From: Mart Lubbers Date: Mon, 30 Aug 2021 13:50:03 +0000 (+0200) Subject: support all other patterns and nested patterns X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=9d9a5d77da4898ea81ef59fd19540565d9d85292;p=clean-tests.git support all other patterns and nested patterns --- diff --git a/datatype/.gitignore b/datatype/.gitignore new file mode 100644 index 0000000..c098216 --- /dev/null +++ b/datatype/.gitignore @@ -0,0 +1 @@ +Main diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs index 4785e94..adb148f 100644 --- a/datatype/Compiler.hs +++ b/datatype/Compiler.hs @@ -43,7 +43,7 @@ instr :: [Instr] -> Compiler a instr i = tell i >> pure undefined freshLabel :: Compiler Int -freshLabel = get >>= \cs->put (cs { fresh=tail (fresh cs) }) >> pure (head $ fresh cs) +freshLabel = gets fresh >>= \(f:fs)->modify (\s->s { fresh=fs }) >> pure f binop :: Instr -> Compiler a1 -> Compiler a2 -> Compiler b binop i l r = l >> r >> instr [i] @@ -52,7 +52,7 @@ unop :: Instr -> Compiler a -> Compiler b unop i l = l >> instr [i] instance Expression Compiler where - lit v = instr $ map Push $ serialise v [] + lit v = instr [Push $ serialise v] (+.) = binop Add (-.) = binop Sub (/.) = binop Div @@ -177,27 +177,14 @@ interpret memsize prog = runSTArray resultStack ! (memsize-1) int :: STArray s Int Instr -> STArray s Int Int -> Registers -> ST s (STArray s Int Int) int program memory registers = do instruction <- readArray program $ pc registers --- stack <- getElems memory let reg = registers { pc = pc registers + 1 } --- case trace ("Interpret: " ++ show instruction ++ " with registers: " ++ show registers ++ " and stack: " ++ show stack) instruction of case instruction of Str r -> do (reg', v) <- pop memory reg int program memory $ reg' { gp = DM.insert r v (gp reg')} Ldr r -> push memory (DM.findWithDefault 0 r $ gp reg) reg >>= int program memory --- Roll 0 _ -> int program memory reg --- Roll 1 _ -> int program memory reg --- Roll _ 0 -> int program memory reg --- Roll depth num -> do --- (reg', vs) <- popn memory depth reg --- foldM (flip $ push memory) reg' (roll num [] $ reverse vs) >>= int program memory --- where --- roll 0 acc vs = vs ++ reverse acc --- roll n acc [] = roll n [] $ reverse acc --- roll n acc (v:vs) = roll (n-1) (v:acc) vs Pop n -> popn memory n reg >>= int program memory . fst Push v -> push memory v reg >>= int program memory --- Dup -> pop memory reg >>= \(r', v)->push memory v r' >>= push memory v >>= int program memory Add -> bop (+) memory reg >>= int program memory Sub -> bop (-) memory reg >>= int program memory Mul -> bop (*) memory reg >>= int program memory diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs index 374469d..673827f 100644 --- a/datatype/Language/GenDSL.hs +++ b/datatype/Language/GenDSL.hs @@ -24,8 +24,8 @@ mkConsClass typename = reify typename >>= \info->case info of -> case dec of DataD _ _ tyvars _ constructors _ -> sequence - [ mkDerivation tyvars - , mkConstructorClasses tyvars constructors + [ {-mkDerivation tyvars + ,-}mkConstructorClasses tyvars constructors , mkPrinterInstances constructors , mkCompilerInstances constructors ] @@ -34,12 +34,12 @@ mkConsClass typename = reify typename >>= \info->case info of _ -> fail "mkConsClass only supports types" where - mkDerivation :: [TyVarBndr] -> DecQ - mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $ - InstanceD Nothing - [ConT (mkName "Serialise") `AppT` t | t <- names] - (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names) - [] +-- mkDerivation :: [TyVarBndr] -> DecQ +-- mkDerivation tyvars = let names = (map (VarT . getNameTyVarBndr) tyvars) in pure $ +-- InstanceD Nothing +-- [ConT (mkName "Serialise") `AppT` t | t <- names] +-- (ConT (mkName "Serialise") `AppT` foldl AppT (ConT typename) names) +-- [] mkConstructorClasses :: [TyVarBndr] -> [Con] -> DecQ mkConstructorClasses tyvars constructors = do @@ -68,8 +68,11 @@ mkConsClass typename = reify typename >>= \info->case info of mkSelectorClassMember (NormalC consName fs) = mapM (uncurry mkSelectorClassMemberForField) $ zipWith (\(_, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..] - mkSelectorClassMember (RecC _ fs) - = mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs] + mkSelectorClassMember (RecC consName fs) + = (++) <$> mapM (uncurry mkSelectorClassMemberForField) [(n, t)|(n, _, t)<-fs] + <*> mapM (uncurry mkSelectorClassMemberForField) + (zipWith (\(_, _, t) i->(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t)) fs [0 :: Int ..]) + mkSelectorClassMember t = fail $ "mkConsClass not supported for types such as: " ++ show t @@ -118,9 +121,9 @@ mkConsClass typename = reify typename >>= \info->case info of ]) <*> mapM mkPrinterSelector (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..]) - mkPrinterInstance (RecC name fs) + mkPrinterInstance (RecC consName fs) = let args = map mkName $ numberedArgs fs - in (:) <$> pure (FunD (constructorName name) + in (:) <$> pure (FunD (constructorName consName) [Clause (map VarP args) (NormalB $ @@ -131,7 +134,11 @@ mkConsClass typename = reify typename >>= \info->case info of ) [] ]) - <*> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs] + <*> ((++) + <$> mapM mkPrinterSelector [occString occ | (Name occ _, _, _)<-fs] + <*> mapM mkPrinterSelector + (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..]) + ) mkPrinterInstance t = fail $ "mkConsClass not supported for types such as: " ++ show t mkPrinterSelector :: String -> Q Dec @@ -162,7 +169,10 @@ mkConsClass typename = reify typename >>= \info->case info of <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs]) mkCompilerInstance (RecC consName fs) consnum = (:) <$> mkCompilerInstanceForName consName consnum [occString occ | (Name occ _, _, _) <- fs] - <*> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs]) + <*> ((++) + <$> mapM (uncurry mkCompilerSelector) (zip [0..] [occString occ | (Name occ _, _, _) <- fs]) + <*> mapM (uncurry mkCompilerSelector) (zip [0..] [map toLower (stringName consName) ++ f | f<-numberedArgs fs]) + ) mkCompilerInstance t _ = fail $ "mkConsClass not supported for types such as: " ++ show t mkCompilerInstanceForName :: Name -> Int -> [String] -> DecQ diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs index 0153eaa..c6b94bc 100644 --- a/datatype/Language/Quote.hs +++ b/datatype/Language/Quote.hs @@ -6,6 +6,7 @@ module Language.Quote where import Data.Char import Data.List +import Data.Maybe import Debug.Trace import Control.Applicative @@ -61,6 +62,9 @@ pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure [] pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s pBrack p = pSat (BOpen==) *> p <* pSat (BClose==) +pCBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s +pCBrack p = pSat (COpen==) *> p <* pSat (CClose==) + pCase :: (MonadFail m, Alternative m) => RParser m Token Exp pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch where @@ -68,22 +72,38 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases where mkCaseMatch :: Pat -> Exp -> Exp -> Exp - mkCaseMatch (VarP v) e _ = LetE [FunD v [Clause [] (NormalB name) []]] e - mkCaseMatch WildP e _ = e - mkCaseMatch (ConP consName fields) e rest - = VarE (mkName "if'") - `AppE` (VarE (mkName $ "is" ++ stringName consName) `AppE` name) --Predicate - `AppE` LetE [mkFieldMatch idx f | f <- fields | idx <- [0 :: Int ..]] e - `AppE` rest - where - mkFieldMatch idx (VarP v) = FunD v [Clause [] (NormalB $ VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` name) []] --- mkFieldMatch idx p@(ConP consName fields) = FunD (mkName "f0") [Clause [] (NormalB $ mkCaseMatch p e (LitE (StringL "Exhausted case"))) []] - mkFieldMatch _ p = error $ "Unsupported subpat: " ++ show p - - mkCaseMatch p _ _ = error $ "Unsupported pat: " ++ show p + mkCaseMatch a e rest = case mkCasePred name a of + Nothing -> LetE (mkCaseBinding name a []) e + Just p -> VarE (mkName "if'") `AppE` p `AppE` LetE (mkCaseBinding name a []) e `AppE` rest + + mkCasePred :: Exp -> Pat -> Maybe Exp + mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.") + (VarE (mkName $ "is" ++ stringName consName) `AppE` objName) + $ catMaybes $ [mkCasePred (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]] + mkCasePred objName (RecP consName fields) = Just $ foldl (ifx "&.") + (VarE (mkName $ "is" ++ stringName consName) `AppE` objName) + $ catMaybes $ [mkCasePred (VarE (selectorName n) `AppE` objName) p | (n, p) <- fields] + mkCasePred _ (VarP _) = Nothing + mkCasePred _ WildP = Nothing + mkCasePred objName (ParensP p) = mkCasePred objName p + mkCasePred objName (AsP _ p) = mkCasePred objName p + mkCasePred objName (LitP v) = Just (ifx "==." (VarE (mkName "lit") `AppE` LitE v) objName) + mkCasePred _ p = error $ "Unsupported pat: " ++ show p + + mkCaseBinding :: Exp -> Pat -> [Dec] -> [Dec] + mkCaseBinding objName (ConP consName fields) ds = foldr ($) ds $ + [mkCaseBinding (VarE (selectorName $ mkName $ stringName consName ++ "f" ++ show idx) `AppE` objName) f | f <- fields | idx <- [0 :: Int ..]] + mkCaseBinding objName (RecP consName fields) ds = foldr ($) ds $ + [mkCaseBinding (VarE (selectorName n) `AppE` objName) p| (n, p) <- fields] + mkCaseBinding objName (VarP v) ds = FunD v [Clause [] (NormalB $ objName) []]:ds + mkCaseBinding objName (AsP n v) ds = mkCaseBinding objName (VarP n) $ mkCaseBinding objName v ds + mkCaseBinding _ (LitP _) ds = ds + mkCaseBinding _ WildP ds = ds + mkCaseBinding objName (ParensP p) ds = mkCaseBinding objName p ds + mkCaseBinding _ p _ = error $ "Unsupported pat: " ++ show p pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp) -pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp +pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp <* optional (pSat (==SColon)) pExp :: (MonadFail m, Alternative m) => RParser m Token Exp pExp @@ -114,18 +134,30 @@ pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False) pPat :: (MonadFail m, Alternative m) => RParser m Token Pat pPat - = ConP <$> pCon <*> many pPat + = RecP <$> pCon <*> pCBrack pFieldPat + <|> ConP <$> pCon <*> many pPat + <|> AsP <$> pVar <* pSat (At==) <*> pPat <|> VarP <$> pVar <|> WildP <$ pSat (Underscore==) + <|> LitP <$> pLit <|> pBrack pPat + where + pFieldPat = pSepBy (pSat (==Comma)) $ + (,) <$> pVar <* pSat (==Equal) <*> pPat parseCP :: MonadFail m => [Char] -> m Exp -parseCP s = case runParser pCase (lexer s) of - Nothing -> fail "Parsing failed" - Just (_, _:_) -> fail "Non-exhaustive parse found" - Just (e, []) -> pure e - -data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String} | Case | Of | Op String | BOpen | BClose | Underscore | Unknown Char +--parseCP s = case runParser pCase (lexer s) of +parseCP s = case runParser pCase (lexer (trace (show s) s)) of +-- Nothing -> fail $ "Parsing failed for: " ++ show (lexer s) + [] -> fail $ "Parsing failed for: " ++ show (lexer s) +-- Just (_, t@(_:_)) -> fail $ "Non-exhaustive parse found: " ++ show t + (e, []):_ -> pure e +-- x -> fail $ "Multiple parses: " ++ show x +-- Just (e, []) -> pure e + +data Token = Lit {unlit :: Lit} | Con {uncon :: String} | Var {unvar :: String} + | Case | Of | Op String | BOpen | BClose | Underscore | SColon | At | COpen | CClose | Equal | Comma + | Unknown Char deriving (Eq, Show) lexer :: [Char] -> [Token] @@ -148,6 +180,12 @@ lexer ('>':'.':rest) = Op ">.":lexer rest lexer ('(':rest) = BOpen:lexer rest lexer (')':rest) = BClose:lexer rest lexer ('_':rest) = Underscore:lexer rest +lexer (';':rest) = SColon:lexer rest +lexer ('@':rest) = At:lexer rest +lexer ('{':rest) = COpen:lexer rest +lexer ('}':rest) = CClose:lexer rest +lexer ('=':rest) = Equal:lexer rest +lexer (',':rest) = Comma:lexer rest lexer ('\'':'\\':x:'\'':rest) = case x of '\'' -> Lit (CharL '\''):lexer rest '\\' -> Lit (CharL '\\'):lexer rest @@ -173,7 +211,7 @@ lexer (d:rest) | isAlpha d && isLower d = case span isAlpha rest of (s, rest') -> Var (d:s):lexer rest' | isDigit d || d == '-' || d == '+' = case span isDigit rest of - (s, rest') -> Lit (IntegerL $ read (d:s)):lexer rest' + (s, rest') -> trace (show (d:s)) $ Lit (IntegerL $ read (d:s)):lexer rest' | isSpace d = lexer rest | otherwise = Unknown d:lexer rest lexer [] = [] diff --git a/datatype/Main b/datatype/Main deleted file mode 100755 index dec37e5..0000000 Binary files a/datatype/Main and /dev/null differ diff --git a/datatype/Main.hs b/datatype/Main.hs index 42e0473..72dede0 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveGeneric #-} module Main where import Language @@ -88,9 +89,17 @@ f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int) f5 = fun ( \sumf->(\l->[cp|case l of Cons e rest -> e +. sumf rest - _ -> 0 --- Cons e (Cons f rest) -> e +. f +. sum rest -{-blup-} + Nil -> 0 |]) +-- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} ) + +f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int) +f6 + = fun ( \firstfun->(\l->[cp|case l of + TupleR{first=f} -> f + |]) +-- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} + :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')} + ) diff --git a/datatype/Serialise.hs b/datatype/Serialise.hs index 524cdb3..effa82d 100644 --- a/datatype/Serialise.hs +++ b/datatype/Serialise.hs @@ -6,36 +6,39 @@ import Data.Char import GHC.Generics class Serialise a where - serialise :: a -> [Int] -> [Int] - default serialise :: (Generic a, GSerialise (Rep a)) => a -> [Int] -> [Int] - serialise = gserialise . from + serialise :: a -> Int -class GSerialise f where - gserialise :: f a -> [Int] -> [Int] - ---Void -instance GSerialise V1 where - gserialise _ = id ---Unit -instance GSerialise U1 where - gserialise _ = id ---Pair -instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where - gserialise (l :*: r) = gserialise l . gserialise r ---Constants, additional parameters and recursion of kind * -instance Serialise a => GSerialise (K1 i a) where - gserialise (K1 a) = serialise a ---Either not supported because we don't support sumtypes in our stack machine -instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where - gserialise (L1 l) = (0:) . gserialise l - gserialise (R1 r) = (1:) . gserialise r ---Datatype, Constructor or Selector -instance (GSerialise a) => GSerialise (M1 i c a) where - gserialise (M1 l) = gserialise l +--class serialise a where +-- serialise :: a -> int -> [int] -> [int] +-- default serialise :: (generic a, gserialise (rep a)) => a -> int -> [int] -> [int] +-- serialise = gserialise . from +-- +--class GSerialise f where +-- gserialise :: f a -> Int -> [Int] -> [Int] +-- +----Void +--instance GSerialise V1 where +-- gserialise _ _ = id +----Unit +--instance GSerialise U1 where +-- gserialise _ _ = id +----Pair +--instance (GSerialise a, GSerialise b) => GSerialise (a :*: b) where +-- gserialise (l :*: r) _ = gserialise l 0 . gserialise r 0 +----Constants, additional parameters and recursion of kind * +--instance Serialise a => GSerialise (K1 i a) where +-- gserialise (K1 a) i = serialise a i +----Either not supported because we don't support sumtypes in our stack machine +--instance (GSerialise a, GSerialise b) => GSerialise (a :+: b) where +-- gserialise (L1 l) c = gserialise l (c * 2) +-- gserialise (R1 r) c = gserialise r (c + 1) +----Datatype, Constructor or Selector +--instance (GSerialise a) => GSerialise (M1 i c a) where +-- gserialise (M1 l) c = (c:) . gserialise l 0 instance Serialise Int where - serialise i = (i:) + serialise i = i instance Serialise Bool where - serialise b = ((if b then 1 else 0):) + serialise b = if b then 1 else 0 instance Serialise Char where - serialise c = (ord c:) + serialise c = ord c diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs index abd0104..4a3fb10 100644 --- a/datatype/Tuple.hs +++ b/datatype/Tuple.hs @@ -22,5 +22,5 @@ data TupleR a b = TupleR {first :: a, second :: b} $(mkConsClass ''TupleR) data List a = Nil | Cons a (List a) - deriving Generic + deriving (Generic, Show) $(mkConsClass ''List)