cleanup compactify, improve

diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs
index adb148f..5669725 100644 (file)
--- a/datatype/Compiler.hs
+++ b/datatype/Compiler.hs
@@ -51,6 +51,7 @@ binop i l r = l >> r >> instr [i]
 unop :: Instr -> Compiler a -> Compiler b
 unop i l = l >> instr [i]
 
+instance DSL Compiler
 instance Expression Compiler where
     lit v = instr [Push $ serialise v]
     (+.) = binop Add

diff --git a/datatype/Language.hs b/datatype/Language.hs
index 3794358..1f0aab2 100644 (file)
--- a/datatype/Language.hs
+++ b/datatype/Language.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Language where
 
 import Serialise
@@ -7,6 +8,14 @@ newtype Main a = Main {unmain :: a}
 data In a b = a :- b
 infix 1 :-
 
+class
+    ( Expression v
+    , Function () v
+    , Function (v Int) v, Function (v Bool) v, Function (v Char) v
+    , Function (v Int, v Int) v
+    , Function (v Int, v Int, v Int) v
+    ) => DSL v
+
 class Expression v where
     lit :: (Serialise a, Show a) => a -> v a
     (+.) :: Num a => v a -> v a -> v a

diff --git a/datatype/Language/GenDSL.hs b/datatype/Language/GenDSL.hs
index 5209e7b..69dff4b 100644 (file)
--- a/datatype/Language/GenDSL.hs
+++ b/datatype/Language/GenDSL.hs
@@ -7,21 +7,25 @@ import Language.Haskell.TH
 import Data.Char
 import Control.Monad
 
-className :: Name -> Name
+className,constructorName,selectorName,predicateName :: Name -> Name
 className = mkName . (++"'") . stringName
-constructorName :: Name -> Name
 constructorName = mkName . map toLower . stringName
-selectorName :: Name -> Name
 selectorName = mkName . map toLower . (++"'") . stringName
+predicateName = mkName . ("is"++) . stringName
+
 stringName :: Name -> String
 stringName (Name occ _) = occString occ
 
-numberedArgs :: [a] -> [Name]
-numberedArgs = zipWith (\i _->mkName $ "f" ++ show i) [0 :: Int ..]
+numberedArgs :: [a] -> Q [Name]
+numberedArgs = zipWithM (\i _->newName $ "f" ++ show i) [0 :: Int ..]
+
+data Field = Field { fname :: Name, ffresh :: Name, ftype :: Type }
 
-toNameType :: Con -> Q [(Name, Type)]
-toNameType (NormalC consName fs) = pure [(mkName $ map toLower (stringName consName) ++ "f" ++ show i, t) | (_, t)<-fs | i <- [0 :: Int ..]]
-toNameType (RecC consName fs) = pure [(n, t) | (n, _, t)<-fs]
+toNameType :: Con -> Q [Field]
+toNameType (NormalC consName fs) = numberedArgs fs
+    >>= \nfs->pure [Field (mkName $ map toLower (stringName consName) ++ "f" ++ show 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 c = fail $ "Unsupported constructor type: " ++ show c
 
 getConsName :: Con -> Q Name
@@ -29,195 +33,84 @@ getConsName (NormalC consName _) = pure consName
 getConsName (RecC consName _) = pure consName
 getConsName c = fail $ "Unsupported constructor type: " ++ show c
 
-mkConsClass :: Name -> DecsQ
-mkConsClass typename = reify typename >>= \info->case info of
-    TyConI dec
-        -> case dec of
-        DataD _ _ tyvars _ constructors _
-            -> sequence 
-                [ mkConstructorClasses tyvars constructors
-                , mkPrinterInstances constructors
-                , mkCompilerInstances constructors
-                ]
-        _
-            -> fail "mkConsClass only supports data types"
-    _
-        -> fail "mkConsClass only supports types"
+ifx :: String -> Exp -> Exp -> Exp
+ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+
+getNameTyVarBndr :: TyVarBndr -> Name
+getNameTyVarBndr (PlainTV name) = name
+getNameTyVarBndr (KindedTV name _) = name
+
+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
+    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 ]
   where
-    mkConstructorClasses :: [TyVarBndr] -> [Con] -> Q Dec
-    mkConstructorClasses tyvars constructors
-        =   ClassD [] (className typename) [PlainTV view] []
-        <$> (genClassMembers <$> mapM getConsName constructors <*> mapM toNameType constructors)
+    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
       where
-        genClassMembers consNames fieldTypes = mkPredicates $ mkSelectors $ mkConstructors
-            where
-                mkConstructors = zipWith mkConstructorClassMember consNames fieldTypes
-                mkSelectors ds = foldl (foldr $ uncurry mkSelectorClassMember) ds fieldTypes
-                mkPredicates ds = foldr mkPredicateClassMember ds consNames
- 
-        view = mkName "m"
-
-        mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
-        mkConstructorClassMember consName fs
-            = SigD (constructorName consName)
-                $ foldr (AppT . AppT ArrowT) resultT
-                $ map ((AppT $ VarT view) . snd) fs
-
-        mkSelectorClassMember :: Name -> Type -> [Dec] -> [Dec]
-        mkSelectorClassMember n t = (:)
-            $ SigD (className n)
-            $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` t)
-
-        mkPredicateClassMember :: Name -> [Dec] -> [Dec]
-        mkPredicateClassMember n = (:)
-            $ SigD (mkName $ "is" ++ stringName n)
-            $ ArrowT `AppT` resultT `AppT` (VarT view `AppT` ConT (mkName "Bool"))
-
-        resultT = VarT view `AppT` (foldl AppT (ConT typename) $ map (VarT . getNameTyVarBndr) $ tyvars)
-
-    mkPrinterInstances :: [Con] -> DecQ
-    mkPrinterInstances constructors
-        =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Printer"))
-        <$> (genInstances <$> mapM getConsName constructors <*> mapM toNameType constructors)
+        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
+
+        mkSelector :: Integer -> Field -> Dec
+        mkSelector _ f = SigD (selectorName (fname f)) $ resultT `arrow` view (ftype f)
+
+        mkPredicate :: Integer -> Name -> Dec
+        mkPredicate _ n = SigD (predicateName n) $ resultT `arrow` view (ConT (mkName "Bool"))
+
+        resultT = view $ foldl AppT (ConT typeName) $ map (VarT . getNameTyVarBndr) $ typeVars
+
+    fun name args body = FunD name [Clause args (NormalB body) []]
+
+    mkPrinter :: Dec
+    mkPrinter = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Printer")) $ mkDecls mkConstructor mkSelector mkPredicate
       where
-        genInstances consNames fieldTypes = mkConstructors
-          where
-            mkConstructors = zipWith mkPrinterConstructor consNames fieldTypes
-        --concat <$> ( (:) <$> mapM mkPrinterPredicate constructors <*> mapM mkPrinterInstance constructors)
-
-        mkPrinterConstructor :: Name -> [(Name, Type)] -> Dec
-        mkPrinterConstructor consName fs
-            = FunD (constructorName consName)
-                [Clause
-                    (map VarP $ numberedArgs fs)
-                    (NormalB $
-                        (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
-                            (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE $ numberedArgs fs)
-                        )
-                    )
-                    []
-                ]
-        --mkConstructorClassMember :: Name -> [(Name, Type)] -> Dec
-        --mkConstructorClassMember consName fs
-        --    = SigD (constructorName consName)
-        --        $ foldr (AppT . AppT ArrowT) resultT
-        --        $ map ((AppT $ VarT view) . snd) fs
-
-
---        mkPrinterInstance :: Con -> DecsQ
---        mkPrinterInstance (NormalC consName fs)
---            | null fs = pure [FunD (constructorName consName)
---                    [Clause [] (NormalB $ VarE (mkName "printLit") `AppE` LitE (StringL $ stringName consName)) [] ]]
---            | otherwise =
---                let args = map mkName $ numberedArgs fs
---                in (:) <$> pure (FunD (constructorName consName)
---                    [Clause
---                        (map VarP args)
---                        (NormalB $
---                            (AppE (VarE (mkName "printCons") `AppE` LitE (StringL $ stringName consName))
---                                (foldl (\x y->x `pc` pl " " `pc` y) (pl "") $ map VarE args)
---                            )
---                        )
---                        []
---                    ])
---                <*> mapM mkPrinterSelector
---                    (zipWith (\_ i->map toLower (stringName consName) ++ "f" ++ show i) fs [0 :: Int ..])
---        mkPrinterInstance (RecC consName fs)
---            = let args = map mkName $ numberedArgs fs
---            in (:) <$> pure (FunD (constructorName consName)
---                [Clause
---                    (map VarP args)
---                    (NormalB $
---                        (AppE (VarE (mkName "printRec") `AppE` LitE (StringL $ stringName typename))
---                            (foldl1 (\x y->x `pc` pl ", " `pc` y)
---                                $ zipWith (\x ((Name occ'' _), _, _)->pl (occString occ'') `pc` pl "=" `pc` VarE x) args 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
---        mkPrinterSelector n' = do
---            body <- [|\d->d >> printLit $(pure $ LitE $ StringL ('.':n'))|]
---            pure $ FunD (selectorName $ mkName n') [Clause [] (NormalB body) []]
---
---        mkPrinterPredicate :: Con -> Q Dec
---        mkPrinterPredicate (NormalC consName _)
---            = mkPrinterPredicateForName consName
---        mkPrinterPredicate (RecC consName _)
---            = mkPrinterPredicateForName consName
---        mkPrinterPredicate t = fail $ "mkConsClass not supported for types such as: " ++ show t
---
---        mkPrinterPredicateForName :: Name -> Q Dec
---        mkPrinterPredicateForName consName = do
---            body <- [| \d->printLit $(pure $ LitE $ StringL $ "is" ++ stringName consName ++ " ") >>> d|]
---            pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
-
-    mkCompilerInstances :: [Con] -> DecQ
-    mkCompilerInstances constructors
-        =   InstanceD Nothing [] (AppT (ConT $ className typename) (ConT $ mkName "Compiler")) . concat
-        <$> pure []--((:) <$> mapM (uncurry mkCompilerPredicate) (zip [0..] constructors) <*> mapM (uncurry mkCompilerInstance) (zip constructors [0..]))
---      where
---        mkCompilerInstance :: Con -> Int -> DecsQ
---        mkCompilerInstance (NormalC consName fs) consnum = (:)
---            <$> mkCompilerInstanceForName consName consnum (numberedArgs fs)
---            <*> 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..] [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
---        mkCompilerInstanceForName name consnum fs =
---            let args = map mkName $ numberedArgs fs
---            in do
---                body <- [|instr [Push $(pure $ LitE $ IntegerL $ toInteger $ consnum)] *> $(mkBody $ map VarE args) <* instr [Sth $ $(pure $ LitE $ IntegerL $ toInteger $ length fs) + 1] |]
---                pure $ FunD (constructorName name)
---                    [Clause (map VarP args) (NormalB body) [] ]
---          where
---            mkBody :: [Exp] -> Q Exp
---            mkBody [] = pure $ VarE (mkName "pure") `AppE` ConE name
---            mkBody (a:as) = foldM (\x y->pure $ ifx "<*>" x y) (ifx "<$>" (ConE name) a) as
---
---        mkCompilerSelector :: Int -> String -> DecQ
---        mkCompilerSelector idx n' = do
---            body <- [|\d->d >> instr [Ldh $(pure $ LitE (IntegerL (toInteger idx)))] |]
---            pure $ FunD (selectorName $ mkName n')
---                [Clause [] (NormalB body) [] ]
---
---        mkCompilerPredicate :: Int -> Con -> Q Dec
---        mkCompilerPredicate idx (NormalC consName _)
---            = mkCompilerPredicateForName idx consName
---        mkCompilerPredicate idx (RecC consName _)
---            = mkCompilerPredicateForName idx consName
---        mkCompilerPredicate _ t = fail $ "mkConsClass not supported for types such as: " ++ show t
---
---        mkCompilerPredicateForName :: Int -> Name -> Q Dec
---        mkCompilerPredicateForName i consName = do
---            body <- [| \d->d >> instr [Ldh (-1), Push $(pure $ LitE $ IntegerL $ toInteger i), Eq] |]
---            pure $ FunD (mkName $ "is" ++ stringName consName) [Clause [] (NormalB body) []]
-
-instrE :: Exp -> Exp
-instrE e = VarE (mkName "instr") `AppE` ListE [e]
+        pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
 
-ifx :: String -> Exp -> Exp -> Exp
-ifx op a b = InfixE (Just a) (VarE $ mkName op) (Just b)
+        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
 
-pc :: Exp -> Exp -> Exp
-pc l r = VarE (mkName ">>>") `AppE` l `AppE` r
+        mkSelector :: Integer -> Field -> Dec
+        mkSelector _ Field{fname=n} = fun (selectorName n) [VarP argName] (ifx ">>" (VarE argName) $ pl ('.':stringName n))
 
-pl :: String -> Exp
-pl s = VarE (mkName "printLit") `AppE` LitE (StringL s)
+        mkPredicate :: Integer -> Name -> Dec
+        mkPredicate _ n = fun (predicateName n) [VarP argName] (ifx ">->" (pl $ stringName $ predicateName n) $ VarE argName)
 
-getNameTyVarBndr :: TyVarBndr -> Name
-getNameTyVarBndr (PlainTV name) = name
-getNameTyVarBndr (KindedTV name _) = name
+    mkCompiler :: Dec
+    mkCompiler = InstanceD Nothing [] (AppT (ConT $ className typeName) (ConT $ mkName "Compiler")) $ mkDecls mkConstructor mkSelector mkPredicate
+      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")
+                ]

diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs
index c6b94bc..8682f0e 100644 (file)
--- a/datatype/Language/Quote.hs
+++ b/datatype/Language/Quote.hs
@@ -73,8 +73,12 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
       where
         mkCaseMatch :: Pat -> Exp -> Exp -> Exp
         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
+            Nothing -> mkCaseLets (mkCaseBinding name a []) e
+            Just p -> VarE (mkName "if'") `AppE` p `AppE` (mkCaseLets (mkCaseBinding name a []) e) `AppE` rest
+
+        mkCaseLets :: [Dec] -> Exp -> Exp
+        mkCaseLets [] e = e
+        mkCaseLets defs e = LetE defs e
 
         mkCasePred :: Exp -> Pat -> Maybe Exp
         mkCasePred objName (ConP consName fields) = Just $ foldl (ifx "&.")
@@ -93,7 +97,7 @@ pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch
         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 objName (RecP _ 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
@@ -148,12 +152,12 @@ pPat
 parseCP :: MonadFail m => [Char] -> m Exp
 --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
+    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
+    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
@@ -182,6 +186,12 @@ lexer (')':rest) = BClose:lexer rest
 lexer ('_':rest) = Underscore:lexer rest
 lexer (';':rest) = SColon:lexer rest
 lexer ('@':rest) = At:lexer rest
+lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
+lexer ('{':'-':rest) = gobble rest
+  where
+    gobble [] = []
+    gobble ('-':'}':xs) = lexer xs
+    gobble (_:xs) = gobble xs
 lexer ('{':rest) = COpen:lexer rest
 lexer ('}':rest) = CClose:lexer rest
 lexer ('=':rest) = Equal:lexer rest
@@ -199,12 +209,6 @@ lexer ('\'':'\\':x:'\'':rest) = case x of
         _ -> error $ "Unknown character escape: " ++ show x
 lexer ('\'':x:'\'':rest)
     | x /= '\'' && x /= '\\'= Lit (CharL x):lexer rest
-lexer ('-':'-':rest) = lexer $ dropWhile (/='\n') rest
-lexer ('{':'-':rest) = gobble rest
-  where
-    gobble [] = []
-    gobble ('-':'}':xs) = lexer xs
-    gobble (_:xs) = gobble xs
 lexer (d:rest)
     | isAlpha d && isUpper d = case span isAlpha rest of
         (s, rest') -> Con (d:s):lexer rest'

diff --git a/datatype/Main.hs b/datatype/Main.hs
index 72dede0..bccc35d 100644 (file)
--- a/datatype/Main.hs
+++ b/datatype/Main.hs
@@ -35,6 +35,12 @@ main
 --  >> putStrLn (show $ runInterpreter (unmain f4))
   >> putStrLn (runPrint $ unmain f5)
   >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f5))
+  >> putStrLn (runPrint $ unmain f6)
+  >> 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'))
 
 e0 :: Expression v => v Int
 e0 = lit 2 -. lit 8
@@ -103,3 +109,26 @@ f6
 --    :- Main {unmain=sumf $ lit (1 :: Int) `cons` (lit 2 `cons` (lit 3 `cons` nil))}
     :- Main {unmain=firstfun $ tupler (lit 1) (lit 'c')}
     )
+
+f7 :: (Expression v, Function (v Int) v) => Main (v Int)
+f7
+    = fun ( \ffac->(\l->[cp|case l of
+                0 -> 1;
+                n -> n *. ffac (n -. 1);
+            |])
+    :- Main {unmain=ffac (lit 10)}
+    )
+
+f7' :: (DSL v, List' v, Function (v (List Int)) v) => Main (v Int)
+f7'
+    =    fun ( \fromto->(
+            \(from, to)->if' (from >. to) nil (from `cons` fromto (from +. lit 1, to))
+    ) :- fun ( \mullist->(
+            \l->[cp|case l of
+                Cons e rest -> e *. mullist rest
+                Nil -> 1
+            |]
+    ) :- fun ( \fac->(
+            \n->mullist (fromto (lit 1, n))
+    ) :- Main {unmain=fac (lit 10)}
+    )))

diff --git a/datatype/Printer.hs b/datatype/Printer.hs
index 1a7b1d1..f200b15 100644 (file)
--- a/datatype/Printer.hs
+++ b/datatype/Printer.hs
@@ -25,7 +25,7 @@ localctx :: Ctx -> Printer a -> Printer a
 localctx ctx = local $ \r->r { context=ctx }
 
 iindent :: Printer a -> Printer a
-iindent p = local (\r->r { indent=indent r + 1 }) $ printIndent >> p
+iindent p = printIndent >> local (\r->r { indent=indent r + 1 }) p
 
 leftctx,rightctx,nonectx :: Int -> Ctx
 leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone}
@@ -69,6 +69,7 @@ needsParen (CtxInfix thisassoc thisprio _) (CtxInfix outerassoc outerprio outerb
     | otherwise = False
 needsParen _ CtxNullary = error "shouldn't occur"
 
+instance DSL Printer
 instance Expression Printer where
     lit = printLit . show
     (+.) = printBinOp (leftctx 6) "+"
@@ -155,7 +156,7 @@ printUnOp thisctx op l = paren' thisctx $
     >-> localctx (setBranch thisctx CtxRight) l
 
 printCons :: String -> Printer a -> Printer a
-printCons = printUnOp CtxNonfix-- . (++" ")
+printCons cons l = paren' CtxNonfix $ printLit cons >-> l
 
 printRec :: String -> Printer a -> Printer a
 printRec op l = printUnOp CtxNo op (accol l)-- (op++" ") (accol l)

diff --git a/datatype/Tuple.hs b/datatype/Tuple.hs
index 4a3fb10..40ede4e 100644 (file)
--- a/datatype/Tuple.hs
+++ b/datatype/Tuple.hs
@@ -6,21 +6,20 @@ import GHC.Generics
 
 import Printer
 import Compiler
-import Serialise
 import Language.GenDSL
 
 data Tuple a b = Tuple a b
   deriving Generic
-$(mkConsClass ''Tuple)
+$(genDSL ''Tuple)
 
 data Tuple3 a c = Tuple3 a Int c
   deriving Generic
-$(mkConsClass ''Tuple3)
+$(genDSL ''Tuple3)
 
 data TupleR a b = TupleR {first :: a, second :: b}
   deriving Generic
-$(mkConsClass ''TupleR)
+$(genDSL ''TupleR)
 
 data List a = Nil | Cons a (List a)
   deriving (Generic, Show)
-$(mkConsClass ''List)
+$(genDSL ''List)