From: Mart Lubbers Date: Tue, 7 Sep 2021 13:21:54 +0000 (+0200) Subject: use Q style X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=619da9e0448ed91161d1f9a0ad9ddb23353155e8;p=clean-tests.git use Q style --- diff --git a/datatype/Interpreter.hs b/datatype/Interpreter.hs index 54b50b1..51093e3 100644 --- a/datatype/Interpreter.hs +++ b/datatype/Interpreter.hs @@ -6,8 +6,9 @@ module Interpreter where import Language import Control.Monad +--newtype Interpreter a = I {runInterpreter :: Maybe a} newtype Interpreter a = I {runInterpreter :: Maybe a} - deriving (Functor, Applicative, Monad) + deriving (Functor, Applicative, Monad, MonadFail) instance Expression Interpreter where lit = pure @@ -26,6 +27,9 @@ instance Expression Interpreter where (<=.) = liftM2 (<=) (>=.) = liftM2 (>=) if' p t e = p >>= \b->if b then t else e + bottom = fail instance Function a Interpreter where fun def = Main $ let g :- m = def g in unmain m + +instance DSL Interpreter diff --git a/datatype/Language.hs b/datatype/Language.hs index bc7c73f..c2909f1 100644 --- a/datatype/Language.hs +++ b/datatype/Language.hs @@ -20,7 +20,7 @@ class Expression v where lit :: (Serialise a, Show a) => a -> v a (+.) :: Num a => v a -> v a -> v a (-.) :: Num a => v a -> v a -> v a - (/.) :: Num a => v a -> v a -> v a + (/.) :: Fractional a => v a -> v a -> v a (*.) :: Num a => v a -> v a -> v a neg :: Num a => v a -> v a (&.) :: v Bool -> v Bool -> v Bool diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs index 47a6b29..df227cb 100644 --- a/datatype/Language/GenDSL.hs +++ b/datatype/Language/GenDSL.hs @@ -19,101 +19,159 @@ stringName (Name occ _) = occString occ numberedArgs :: [a] -> Q [Name] numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..] -adtFieldName :: Name -> Int -> Name +adtFieldName :: Name -> Integer -> Name adtFieldName consName idx = mkName $ map toLower (stringName consName) ++ "f" ++ show idx -data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type } +data Field = Field { fcons :: Name, ftotal :: Integer, fnum :: Integer, fname :: Name, ftype :: Type } -toNameType :: Con -> Q [Field] -toNameType (NormalC consName fs) = numberedArgs fs - >>= \nfs->pure [Field (adtFieldName consName i) nf t | (_, t) <- fs | nf <- nfs | i <- [0 :: Int ..]] -toNameType (RecC _ fs) = numberedArgs fs - >>= \nfs->pure [Field n nf t | (n, _, t)<-fs | nf <- nfs] +toNameType :: Con -> [Field] +toNameType (NormalC consName fs) = [Field {fcons=consName, ftotal=toInteger $ length fs, fnum=i, fname=adtFieldName consName i, ftype=t} | (_, t) <- fs | i <- [0..]] +toNameType (RecC consName fs) = [Field consName (toInteger $ length fs) i n t | (n, _, t)<-fs | i <- [0..]] toNameType c = fail $ "Unsupported constructor type: " ++ show c getConsName :: Con -> Q Name -getConsName (NormalC consName _) = pure consName +getConsName (NormalC consName _) + | head (stringName consName) == ':' = fail "Infix constructors are not supported" + | otherwise = pure consName getConsName (RecC consName _) = pure consName getConsName c = fail $ "Unsupported constructor type: " ++ show c -ifx :: String -> Exp -> Exp -> Exp -ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b) +int :: Integral a => a -> ExpQ +int = litE . integerL . toInteger + +string :: String -> ExpQ +string = litE . stringL + +ifx :: String -> ExpQ -> ExpQ -> ExpQ +ifx op a b = infixE (Just a) (varE $ mkName op) (Just b) getNameTyVarBndr :: TyVarBndr -> Name getNameTyVarBndr (PlainTV name) = name getNameTyVarBndr (KindedTV name _) = name +fun :: Name -> [PatQ] -> ExpQ -> DecQ +fun name args body = funD name [clause args (normalB body) []] + genDSL :: Name -> DecsQ genDSL typename = reify typename >>= \info->case info of TyConI (DataD _ _ tyvars _ constructors _) - -> mkDSL typename tyvars <$> newName "view" <*> newName "d" <*> mapM getConsName constructors <*> mapM toNameType constructors + -> mapM getConsName constructors >>= mkDSL typename tyvars (map toNameType constructors) t -> fail $ "mkConsClass only supports datatypes and not: " ++ show t -mkDSL :: Name -> [TyVarBndr] -> Name -> Name -> [Name] -> [[Field]] -> [Dec] -mkDSL typeName typeVars viewName argName consNames fields = [ mkClass, mkPrinter, mkCompiler ] +mkDSL :: Name -> [TyVarBndr] -> [[Field]] -> [Name] -> DecsQ +mkDSL typeName typeVars fields consNames = sequence [ mkClass, mkPrinter, mkCompiler, mkInterpreter ] where - mkDecls mkConstructor mkSelector mkPredicate - = zipWith3 mkConstructor [0..] consNames fields - ++ concatMap (zipWith mkSelector [0..]) fields - ++ zipWith mkPredicate [0..] consNames - - mkClass :: Dec - mkClass = ClassD [] (className typeName) [PlainTV viewName] [] $ mkDecls mkConstructor mkSelector mkPredicate + mkClass :: DecQ + mkClass = classD (pure []) (className typeName) [PlainTV (mkName "v")] [] + ( zipWith mkConstructor consNames fields + ++ concatMap (map mkSelector) fields + ++ map mkPredicate consNames + ) where - view a = VarT viewName `AppT` a - arrow = AppT . AppT ArrowT - - mkConstructor :: Integer -> Name -> [Field] -> Dec - mkConstructor _ n fs = SigD (constructorName n) $ foldr arrow resultT $ map (view . ftype) fs + view a = varT (mkName "v") `appT` a + arrow = appT . appT arrowT - mkSelector :: Integer -> Field -> Dec - mkSelector _ f = SigD (selectorName (fname f)) $ resultT `arrow` view (ftype f) + mkConstructor :: Name -> [Field] -> DecQ + mkConstructor n fs = sigD (constructorName n) $ foldr arrow resultT $ map (view . pure . ftype) fs - mkPredicate :: Integer -> Name -> Dec - mkPredicate _ n = SigD (predicateName n) $ resultT `arrow` view (ConT (mkName "Bool")) + mkSelector :: Field -> DecQ + mkSelector f = sigD (selectorName (fname f)) $ resultT `arrow` view (pure $ ftype f) - resultT = view $ foldl AppT (ConT typeName) $ map (VarT . getNameTyVarBndr) $ typeVars + mkPredicate :: Name -> DecQ + mkPredicate n = sigD (predicateName n) $ resultT `arrow` view (conT (mkName "Bool")) - fun name args body = FunD name [Clause args (NormalB body) []] + resultT :: TypeQ + resultT = view $ foldl appT (conT typeName) $ map (varT . getNameTyVarBndr) $ typeVars - mkPrinter :: Dec - mkPrinter = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Printer")) $ mkDecls mkConstructor mkSelector mkPredicate + mkPrinter :: DecQ + mkPrinter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Printer")) + $ zipWith mkConstructor consNames fields + ++ concatMap (map mkSelector) fields + ++ map mkPredicate consNames where - pl s = VarE (mkName "printLit") `AppE` LitE (StringL s) - - mkConstructor :: Integer -> Name -> [Field] -> Dec - mkConstructor _ consName fs = fun (constructorName consName) (map (VarP . ffresh) fs) (pcons `AppE` pargs) - where pcons = VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName) - pargs = foldl (ifx ">->") (pl "") $ map (VarE . ffresh) fs - - mkSelector :: Integer -> Field -> Dec - mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n)) - - mkPredicate :: Integer -> Name -> Dec - mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName) - - mkCompiler :: Dec - mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate + pl s = varE (mkName "printLit") `appE` string s + + mkConstructor :: Name -> [Field] -> DecQ + mkConstructor consName fs = do + fresh <- sequence [newName "f" | _<- fs] + fun (constructorName consName) (map varP fresh) (pcons `appE` pargs fresh) + where pcons = varE (mkName "printCons") `appE` string (stringName consName) + pargs fresh = foldl (ifx ">->") (pl "") $ map varE fresh + + mkSelector :: Field -> DecQ + mkSelector Field{fname=n} = do + fresh <- newName "f" + fun (selectorName n) [varP fresh] (ifx ">>" (varE fresh) $ pl ('.':stringName n)) + + mkPredicate :: Name -> DecQ + mkPredicate n = do + fresh <- newName "f" + fun (predicateName n) [varP fresh] (ifx ">->" (pl $ stringName $ predicateName n) $ varE fresh) + + mkCompiler :: DecQ + mkCompiler = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Compiler")) + $ zipWith3 mkConstructor [0..] consNames fields + ++ concat (zipWith (map . mkSelector) [0..] fields) + ++ zipWith mkPredicate [0..] consNames + where + instrE e = varE (mkName "instr") `appE` listE e + + mkConstructor :: Integer -> Name -> [Field] -> DecQ + mkConstructor consNum consName fs = do + fresh <- sequence [newName "f" | _<-fs] + fun (constructorName consName) (map varP fresh) + $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map varE fresh) storeHeap + where storeHeap = instrE [conE (mkName "Sth") `appE` (ifx "+" (int 1) (int $ length fs))] + mkBody = foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName) + pushCons = instrE [conE (mkName "Push") `appE` int consNum] + + mkSelector :: Integer -> Field -> DecQ + mkSelector consNum Field{fname=f} = do + fresh <- newName "f" + fun (selectorName f) [varP fresh] + $ ifx ">>" (varE fresh) $ instrE [conE (mkName "Ldh") `appE` int consNum] + + mkPredicate :: Integer -> Name -> DecQ + mkPredicate consNum consName = do + fresh <- newName "f" + fun (predicateName consName) [varP fresh] + $ ifx ">>" (varE fresh) $ instrE + [ conE (mkName "Ldh") `appE` int (-1) + , conE (mkName "Push") `appE` int consNum + , conE (mkName "Eq") + ] + + mkInterpreter :: DecQ + mkInterpreter = instanceD (pure []) (appT (conT $ className typeName) (conT $ mkName "Interpreter")) + $ zipWith mkConstructor consNames fields + ++ concatMap (map mkSelector) fields + ++ zipWith mkPredicate consNames fields where - instrE e = VarE (mkName "instr") `AppE` ListE e - - mkConstructor :: Integer -> Name -> [Field] -> Dec - mkConstructor consNum consName fs = fun (constructorName consName) (map (VarP . ffresh) fs) - $ ifx "*>" pushCons $ ifx "<*" (mkBody $ map (VarE . ffresh) fs) storeHeap - where storeHeap = instrE [ConE (mkName "Sth") `AppE` (ifx "+" (LitE $ IntegerL 1) (LitE $ IntegerL $ toInteger $ length fs))] - mkBody = foldl (ifx "<*>") (VarE (mkName "pure") `AppE` ConE consName) - pushCons = instrE [ConE (mkName "Push") `AppE` LitE (IntegerL consNum)] - - mkSelector :: Integer -> Field -> Dec - mkSelector consNum Field{fname=f} = fun (selectorName f) [VarP argName] - $ ifx ">>" (VarE argName) $ instrE - [ConE (mkName "Ldh") `AppE` LitE (IntegerL consNum)] - - mkPredicate :: Integer -> Name -> Dec - mkPredicate consNum consName = fun (predicateName consName) [VarP argName] - $ ifx ">>" (VarE argName) $ instrE - [ ConE (mkName "Ldh") `AppE` LitE (IntegerL (-1)) - , ConE (mkName "Push") `AppE` LitE (IntegerL $ toInteger consNum) - , ConE (mkName "Eq") - ] + wildcase e = if length consNames == 1 then [] else + [match wildP (normalB e) []] + + mkConstructor :: Name -> [Field] -> DecQ + mkConstructor consName fs = do + fresh <- sequence [newName "f" | _<-fs] + fun (constructorName consName) (map varP fresh) + $ foldl (ifx "<*>") (varE (mkName "pure") `appE` conE consName) (map varE fresh) + + mkSelector :: Field -> DecQ + mkSelector f = do + fresh <- newName "f" + fun (selectorName $ fname f) [varP fresh] $ + ifx ">>=" (varE fresh) $ lamCaseE $ mkMatch : wilds + where + mkMatch = do + fresh <- newName "e" + match (conP (fcons f) [if fnum f == i then (varP fresh) else wildP | i<-[0..ftotal f-1]]) + (normalB $ varE (mkName "pure") `appE` varE fresh) [] + wilds = wildcase (varE (mkName "fail") `appE` string "Exhausted case") + + mkPredicate :: Name -> [Field] -> DecQ + mkPredicate n fs = do + fresh <- newName "f" + fun (predicateName n) [varP fresh] $ ifx "<$>" (lamCaseE (mkMatch:wilds)) (varE fresh) + where mkMatch = match (conP n [wildP | _<-fs]) (normalB $ conE (mkName "True")) [] + wilds = wildcase (conE $ mkName "False") diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs index 91541f8..60c0d7b 100644 --- a/datatype/Language/Quote.hs +++ b/datatype/Language/Quote.hs @@ -34,7 +34,7 @@ dsl = QuasiQuoter where file = loc_filename loc (line, col) = loc_start loc - p = getPosition >>= setPosition . mPos >> expr <* eof + p = getPosition >>= setPosition . mPos >> whiteSpace *> funOrExpr <* eof mPos = (flip setSourceName) file . (flip setSourceLine) line . (flip setSourceColumn) col @@ -44,9 +44,10 @@ identifier,operator :: Parser String identifier = P.identifier haskell operator = P.operator haskell -parens,braces :: Parser a -> Parser a +parens,braces,lexeme :: Parser a -> Parser a braces = P.braces haskell parens = P.parens haskell +lexeme = P.lexeme haskell commaSep :: Parser a -> Parser [a] commaSep = P.commaSep haskell @@ -58,26 +59,33 @@ reserved,reservedOp :: String -> Parser () reserved = P.reserved haskell reservedOp = P.reservedOp haskell +whiteSpace :: Parser () +whiteSpace = P.whiteSpace haskell + -- Parser -pat :: Parser Pat -pat - = try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat)) - <|> ConP <$> con <*> many pat - <|> try (AsP <$> var <* reservedOp "@" <*> pat) - <|> VarP <$> var - <|> WildP <$ symbol "_" - <|> LitP <$> lit - <|> parens pat +funOrExpr :: Parser Exp +funOrExpr = expr + +func :: Parser Exp +func = many1 ((,) <$> many1 pat <* reservedOp "=" <*> expr) >>= mkFun + where + mkFun :: MonadFail m => [([Pat], Exp)] -> m Exp + mkFun es + | all ((==1) . length . fst) es = pure $ LamE [VarP (mkName "x")] $ mkCase (VarE (mkName "x")) [(p, e)|([p], e)<-es] + mkFun _ = fail "Multiple patterns/entries not supported yet" expr :: Parser Exp expr = buildExpressionParser - [ [bin "^" AssocRight] + --Postfix record selectors + [ [E.Postfix (fmap (\s e->VarE (selectorName (mkName s)) `AppE` e) $ P.lexeme haskell $ char '.' *> identifier)] + , [bin "^" AssocRight] , [bin "*" AssocLeft, bin "/" AssocLeft] , [bin "+" AssocLeft, bin "-" AssocLeft] , [bin o AssocNone | o <- ["==", "/=", "<", ">", "<=", ">="]] , [bin "&&" AssocRight] , [bin "||" AssocRight] - , [E.Infix (fmap ifx $ P.lexeme haskell $ char '`' *> identifier <* char '`') AssocRight] + -- Infix usage of prefix functions + , [E.Infix (fmap ifx $ lexeme $ char '`' *> identifier <* char '`') AssocRight] ] basic where bin :: String -> Assoc -> Operator String () Identity Exp @@ -95,14 +103,24 @@ expr = buildExpressionParser <|> mkLit . ConE . mkName <$> sat identifier ("True"==) ("Expected True but got: "++) <|> mkLit . ConE . mkName <$> sat identifier ("False"==) ("Expected False but got: "++) -sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a -sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a)) +pat :: Parser Pat +pat + = try (RecP <$> con <*> braces (commaSep $ (,) <$> var <* reservedOp "=" <*> pat)) + <|> ConP <$> con <*> many pat + <|> try (AsP <$> var <* reservedOp "@" <*> pat) + <|> VarP <$> var + <|> WildP <$ symbol "_" + <|> LitP <$> lit + <|> parens pat lit :: Parser Lit lit = CharL <$> P.charLiteral haskell <|> IntegerL <$> P.natural haskell +sat :: Parser a -> (a -> Bool) -> (a -> String) -> Parser a +sat p f msg = try (p >>= \a->if f a then pure a else fail (msg a)) + mkLit :: Exp -> Exp mkLit = AppE $ VarE $ mkName "lit" diff --git a/datatype/Main.hs b/datatype/Main.hs index 35d5ae6..ec7c51b 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -8,6 +8,7 @@ import Language import Compiler import Printer +import Interpreter import Language.Quote import Tuple @@ -39,8 +40,9 @@ main -- >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f6)) -- >> putStrLn (runPrint $ unmain f7) -- >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f7)) --- >> putStrLn (runPrint $ unmain f7') --- >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7')) + >> putStrLn (runPrint $ unmain f7') + >> putStrLn (show $ interpret 100 <$> runCompiler (unmain f7')) + >> putStrLn (show $ runInterpreter (unmain f7')) e0 :: Expression v => v Int e0 = lit 2 -. lit 8 @@ -105,6 +107,7 @@ f6 :: (TupleR' v, Expression v, Function (v (TupleR Int Char)) v) => Main (v Int f6 = fun ( \firstfun->(\l->[dsl|case l of TupleR {first=f} -> f + t -> t.first |]) -- :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))} :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')} @@ -124,6 +127,7 @@ f7' = fun ( \fromto->( \(from, to)->[dsl|if from > to then nil else from `cons` fromto (from + 1, to)|] ) :- fun ( \mullist->( +-- \l->if' (isNil l) (lit 1) (consf0' l *. mullist (consf1' l)) \l->[dsl|case l of Cons e rest -> e * mullist(rest) Nil -> 1 diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs index 40ede4e..ab0eff5 100644 --- a/datatype/Tuple.hs +++ b/datatype/Tuple.hs @@ -2,24 +2,19 @@ {-# LANGUAGE DeriveGeneric #-} module Tuple where -import GHC.Generics - import Printer import Compiler +import Interpreter import Language.GenDSL data Tuple a b = Tuple a b - deriving Generic $(genDSL ''Tuple) data Tuple3 a c = Tuple3 a Int c - deriving Generic $(genDSL ''Tuple3) data TupleR a b = TupleR {first :: a, second :: b} - deriving Generic $(genDSL ''TupleR) data List a = Nil | Cons a (List a) - deriving (Generic, Show) $(genDSL ''List)