use Q style

diff --git a/datatype/Interpreter.hs b/datatype/Interpreter.hs
index 54b50b1..51093e3 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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)