From: Mart Lubbers Date: Wed, 1 Sep 2021 13:46:41 +0000 (+0200) Subject: cleanup compactify, improve X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=49f97199ecf42c45ed7680975e2dfb5c5c23d27f;p=clean-tests.git cleanup compactify, improve --- diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs index adb148f..5669725 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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)