From: Mart Lubbers Date: Fri, 27 Aug 2021 11:54:13 +0000 (+0200) Subject: first order simple patterns X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=b75a0f7b97f4c9ee15d43db703e9b3671f8b231d;p=clean-tests.git first order simple patterns --- diff --git a/datatype/Compiler.hs b/datatype/Compiler.hs index 482bcee..4785e94 100644 --- a/datatype/Compiler.hs +++ b/datatype/Compiler.hs @@ -57,26 +57,6 @@ instance Expression Compiler where (-.) = binop Sub (/.) = binop Div (*.) = binop Mul - (^.) = binop Pow --- (^.) l r = freshLabel >>= \lblstart->freshLabel >>= \lblend-> --- l >> r >> instr -- pow (x, y) { --- [ Str 1 --- , Str 0 --- , Push 1 -- res = 1 --- , Lbl lblstart -- while --- , Ldr 1 -- (y == 0) --- , Push 0 -- --- , Neq -- --- , Brf lblend -- --- , Ldr 0 -- res *= x --- , Mul -- --- , Ldr 1 -- y -= 1 --- , Push 1 -- --- , Sub -- --- , Str 1 -- --- , Bra lblstart -- --- , Lbl lblend -- --- ] neg = unop Neg (&.) = binop And (|.) = binop Or @@ -117,6 +97,12 @@ instance Function (Compiler a, Compiler b, Compiler c) Compiler where let g :- m = def (\(a, b, c)->a >> b >> c >> instr [Jsr funlabel]) in liftFunction funlabel 3 (g (instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m +instance Function (Compiler a, Compiler b, Compiler c, Compiler d) Compiler where + fun def = Main $ + freshLabel >>= \funlabel-> + let g :- m = def (\(a, b, c, d)->a >> b >> c >> d >> instr [Jsr funlabel]) + in liftFunction funlabel 4 (g (instr [Arg 3], instr [Arg 2], instr [Arg 1], instr [Arg 0])) >> unmain m + liftFunction :: Int -> Int -> Compiler a -> Compiler () liftFunction lbl nargs body = do is <- snd <$> censor (\_->[]) (listen body) @@ -124,8 +110,8 @@ liftFunction lbl nargs body = do modify (\s->s { functions=DM.insert lbl instructions $ functions s }) data Instr - = Push Int | Pop Int -- | Dup | Roll Int Int - | Add | Sub | Mul | Div | Neg | Pow + = Push Int | Pop Int + | Add | Sub | Mul | Div | Neg | And | Or | Not | Eq | Neq | Le | Ge | Leq | Geq | Lbl Int | Bra Int | Brf Int @@ -191,10 +177,10 @@ 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 +-- 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 +-- 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')} @@ -217,7 +203,6 @@ interpret memsize prog = runSTArray resultStack ! (memsize-1) Mul -> bop (*) memory reg >>= int program memory Div -> bop div memory reg >>= int program memory Neg -> uop negate memory reg >>= int program memory - Pow -> bop (^) memory reg >>= int program memory And -> bop ((b2i .) . on (&&) i2b) memory reg >>= int program memory Or -> bop ((b2i .) . on (||) i2b) memory reg >>= int program memory Not -> uop (b2i . Prelude.not . i2b) memory reg >>= int program memory diff --git a/datatype/Interpreter.hs b/datatype/Interpreter.hs index cf41d9a..54b50b1 100644 --- a/datatype/Interpreter.hs +++ b/datatype/Interpreter.hs @@ -15,7 +15,6 @@ instance Expression Interpreter where (-.) = liftM2 (-) (/.) = liftM2 (/) (*.) = liftM2 (*) - (^.) = liftM2 (^) neg = fmap negate (&.) = liftM2 (&&) (|.) = liftM2 (||) @@ -29,6 +28,4 @@ instance Expression Interpreter where if' p t e = p >>= \b->if b then t else e instance Function a Interpreter where - fun def = Main $ - let g :- m = def g - in unmain m + fun def = Main $ let g :- m = def g in unmain m diff --git a/datatype/Language.hs b/datatype/Language.hs index eaa3703..3794358 100644 --- a/datatype/Language.hs +++ b/datatype/Language.hs @@ -13,7 +13,6 @@ class Expression v where (-.) :: Num a => v a -> v a -> v a (/.) :: Fractional a => v a -> v a -> v a (*.) :: Num a => v a -> v a -> v a - (^.) :: Integral a => v a -> v a -> v a neg :: Num a => v a -> v a (&.) :: v Bool -> v Bool -> v Bool (|.) :: v Bool -> v Bool -> v Bool @@ -35,4 +34,3 @@ infixr 3 &. infix 4 ==., /=., <., >., <=., >=. infixl 6 +., -. infixl 7 *., /. -infixl 8 ^. diff --git a/datatype/Language/Quote.hs b/datatype/Language/Quote.hs index cd464bc..0153eaa 100644 --- a/datatype/Language/Quote.hs +++ b/datatype/Language/Quote.hs @@ -9,12 +9,9 @@ import Data.List import Debug.Trace import Control.Applicative -import Control.Monad import Language.Haskell.TH.Syntax import Language.Haskell.TH.Quote -import Language.Haskell.TH -import Language import Language.GenDSL cp :: QuasiQuoter @@ -25,49 +22,47 @@ cp = QuasiQuoter , quoteDec = undefined } -appFst f (a, b) = (f a, b) - -newtype Parser t a = Parser {runParser :: [t] -> Maybe (a, [t])} -instance Functor (Parser t) where - fmap f m = Parser $ fmap (appFst f) . runParser m -instance Applicative (Parser t) where - pure a = Parser $ Just . (a,) +newtype RParser m t a = Parser {runParser :: [t] -> m (a, [t])} +type Parser t a = RParser Maybe t a +instance Functor m => Functor (RParser m t) where + fmap f m = Parser $ fmap (\(a, b)->(f a, b)) . runParser m +instance Monad m => Applicative (RParser m t) where + pure a = Parser $ pure . (a,) l <*> r = Parser $ \ts->runParser l ts >>= \(a, ts')->runParser r ts' >>= \(b, ts'')->pure (a b, ts'') -instance Monad (Parser t) where +instance Monad m => Monad (RParser m t) where ma >>= a2mb = Parser $ \ts->runParser ma ts >>= \(a, ts')->runParser (a2mb a) ts' -instance Alternative (Parser t) where - empty = Parser $ \_->Nothing +instance (Monad m, Alternative m) => Alternative (RParser m t) where + empty = Parser $ \_->empty l <|> r = Parser $ \ts->runParser l ts <|> runParser r ts +instance (MonadFail m) => MonadFail (RParser m t) where + fail msg = Parser $ \_->fail msg -pTop :: Parser t t -pTop = Parser uncons - -pFail :: Parser t a -pFail = Parser $ \_->Nothing +pTop :: Alternative m => RParser m t t +pTop = Parser $ maybe empty pure . uncons -pSatisfy :: (t -> Bool) -> Parser t t -pSatisfy pred = pTop >>= \v->if pred v then pure v else pFail +pFail :: (MonadFail m, Alternative m) => String -> RParser m t a +pFail msg = Parser $ \_->fail msg -pToken :: Eq t => t -> Parser t t -pToken t = pSatisfy (t==) +pSat :: (Alternative m, MonadFail m, Show t) => (t -> Bool) -> RParser m t t +pSat p = pTop >>= \v->if p v then pure v else pFail ("unexpected: " ++ show v) -pChainl :: Parser t (a -> a -> a) -> Parser t a -> Parser t a +pChainl :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a pChainl op p = foldl (flip ($)) <$> p <*> many (flip <$> op <*> p) -pChainr :: Parser t (a -> a -> a) -> Parser t a -> Parser t a +pChainr :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a pChainr op p = flip ($) <$> p <*> (flip <$> op <*> pChainr op p) <|> p -pNonfix :: Parser t (a -> a -> a) -> Parser t a -> Parser t a -pNonfix op p = (\l op r->l `op` r) <$> p <*> op <*> p <|> p +pNonfix :: (Monad m, Alternative m) => RParser m t (a -> a -> a) -> RParser m t a -> RParser m t a +pNonfix op p = flip id <$> p <*> op <*> p <|> p -pSepBy :: Parser t s -> Parser t a -> Parser t [a] +pSepBy :: (Monad m, Alternative m) => RParser m t s -> RParser m t a -> RParser m t [a] pSepBy sep el = (:) <$> el <*> many (sep *> el) <|> pure [] -pBrack :: Parser String s -> Parser String s -pBrack p = pToken "(" *> p <* pToken ")" +pBrack :: (MonadFail m, Alternative m) => RParser m Token s -> RParser m Token s +pBrack p = pSat (BOpen==) *> p <* pSat (BClose==) -pCase :: Parser String Exp -pCase = mkCase <$ pToken "case" <*> pExp <* pToken "of" <*> some pCaseMatch +pCase :: (MonadFail m, Alternative m) => RParser m Token Exp +pCase = mkCase <$ pSat (==Case) <*> pExp <* pSat (==Of) <*> some pCaseMatch where mkCase :: Exp -> [(Pat, Exp)] -> Exp mkCase name cases = foldr (uncurry mkCaseMatch) (VarE (mkName "bottom") `AppE` LitE (StringL "Exhausted case")) cases @@ -78,15 +73,19 @@ pCase = mkCase <$ pToken "case" <*> pExp <* pToken "of" <*> some pCaseMatch 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..]] e + `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 -pCaseMatch :: Parser String (Pat, Exp) -pCaseMatch = (,) <$> pPat <* pToken "->" <*> pExp +pCaseMatch :: (MonadFail m, Alternative m) => RParser m Token (Pat, Exp) +pCaseMatch = (,) <$> pPat <* pSat (==(Op "->")) <*> pExp -pExp :: Parser String Exp +pExp :: (MonadFail m, Alternative m) => RParser m Token Exp pExp = foldr ($) (pChainl (pure AppE) pBasic) [ pChainr $ parseOps ["^."] @@ -97,73 +96,93 @@ pExp , pChainr $ parseOps ["|."] ] where - parseOps = foldr1 (<|>) . map (\op->ifx op <$ pToken op) + parseOps = foldr1 (<|>) . map (\op->ifx op <$ pSat (==(Op op))) - pBasic :: Parser String Exp pBasic = VarE <$> pVar <|> AppE (VarE (mkName "lit")) . LitE <$> pLit <|> pBrack pExp -pLit :: Parser String Lit -pLit --- = CharL <$ pToken '\'' <*> pTop <* pToken '\'' - = (IntegerL . read) <$> pSatisfy (all isDigit) +pLit :: (MonadFail m, Alternative m) => RParser m Token Lit +pLit = unlit <$> pSat (\x->case x of Lit _ -> True; _ -> False) -pVar :: Parser String Name -pVar = mkName <$> pSatisfy (\x->isLower (head x) && all isAlpha x && Prelude.not (x `elem` kw)) +pVar :: (MonadFail m, Alternative m) => RParser m Token Name +pVar = mkName . unvar <$> pSat (\x->case x of Var _ -> True; _ -> False) -pCon :: Parser String Name -pCon = mkName <$> pSatisfy (\x->isUpper (head x) && all isAlpha x && Prelude.not (x `elem` kw)) +pCon :: (MonadFail m, Alternative m) => RParser m Token Name +pCon = mkName . uncon <$> pSat (\x->case x of Con _ -> True; _ -> False) -kw = ["case", "of"] - -pPat :: Parser String Pat +pPat :: (MonadFail m, Alternative m) => RParser m Token Pat pPat = ConP <$> pCon <*> many pPat <|> VarP <$> pVar - <|> WildP <$ pToken "_" - -parseCP (file, line, col) s = - case runParser pCase (let ts = lexer s in trace (show ts) ts) of - Nothing -> fail "Parsing failed" - Just (_, _:_) -> fail "Non-exhaustive parse found" - Just (e, []) -> pure e - -lexer :: [Char] -> [String] -lexer ('c':'a':'s':'e':rest) = "case":lexer rest -lexer ('o':'f':rest) = "of":lexer rest -lexer ('-':'>':rest) = "->":lexer rest -lexer ('^':'.':rest) = "^.":lexer rest -lexer ('*':'.':rest) = "*.":lexer rest -lexer ('/':'.':rest) = "/.":lexer rest -lexer ('+':'.':rest) = "+.":lexer rest -lexer ('-':'.':rest) = "-.":lexer rest -lexer ('|':'.':rest) = "|.":lexer rest -lexer ('&':'.':rest) = "&.":lexer rest -lexer ('=':'=':'.':rest) = "==.":lexer rest -lexer ('/':'=':'.':rest) = "/=.":lexer rest -lexer ('<':'=':'.':rest) = "<=.":lexer rest -lexer ('>':'=':'.':rest) = ">=.":lexer rest -lexer ('<':'.':rest) = "<.":lexer rest -lexer ('>':'.':rest) = ">.":lexer rest -lexer ('(':rest) = "(":lexer rest -lexer (')':rest) = ")":lexer rest -lexer ('_':rest) = "_":lexer rest + <|> WildP <$ pSat (Underscore==) + <|> pBrack 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 + deriving (Eq, Show) + +lexer :: [Char] -> [Token] +lexer ('c':'a':'s':'e':rest) = Case:lexer rest +lexer ('o':'f':rest) = Of:lexer rest +lexer ('-':'>':rest) = Op "->":lexer rest +lexer ('^':'.':rest) = Op "^.":lexer rest +lexer ('*':'.':rest) = Op "*.":lexer rest +lexer ('/':'.':rest) = Op "/.":lexer rest +lexer ('+':'.':rest) = Op "+.":lexer rest +lexer ('-':'.':rest) = Op "-.":lexer rest +lexer ('|':'.':rest) = Op "|.":lexer rest +lexer ('&':'.':rest) = Op "&.":lexer rest +lexer ('=':'=':'.':rest) = Op "==.":lexer rest +lexer ('/':'=':'.':rest) = Op "/=.":lexer rest +lexer ('<':'=':'.':rest) = Op "<=.":lexer rest +lexer ('>':'=':'.':rest) = Op ">=.":lexer rest +lexer ('<':'.':rest) = Op "<.":lexer rest +lexer ('>':'.':rest) = Op ">.":lexer rest +lexer ('(':rest) = BOpen:lexer rest +lexer (')':rest) = BClose:lexer rest +lexer ('_':rest) = Underscore:lexer rest +lexer ('\'':'\\':x:'\'':rest) = case x of + '\'' -> Lit (CharL '\''):lexer rest + '\\' -> Lit (CharL '\\'):lexer rest + 'a' -> Lit (CharL '\a'):lexer rest + 'b' -> Lit (CharL '\b'):lexer rest + 't' -> Lit (CharL '\t'):lexer rest + 'n' -> Lit (CharL '\n'):lexer rest + 'v' -> Lit (CharL '\v'):lexer rest + 'f' -> Lit (CharL '\f'):lexer rest + 'r' -> Lit (CharL '\r'):lexer rest + _ -> 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 = case span isAlpha (d:rest) of - (s, rest') -> s:lexer rest' - | isDigit d = case span isDigit (d:rest) of - (s, rest') -> s:lexer rest' -lexer (_:rest) = lexer rest - -- | isSpace d = lexer rest + | isAlpha d && isUpper d = case span isAlpha rest of + (s, rest') -> Con (d:s):lexer 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' + | isSpace d = lexer rest + | otherwise = Unknown d:lexer rest lexer [] = [] quoteCPExp :: String -> Q Exp quoteCPExp s = do - loc <- location - let pos = (loc_filename loc, fst (loc_start loc), snd (loc_start loc)) - parseCP pos s +-- loc <- location +-- let pos = (loc_filename loc, fst (loc_start loc), snd (loc_start loc)) + parseCP s quoteCPPat :: String -> Q Pat quoteCPPat _ = undefined diff --git a/datatype/Main b/datatype/Main index 9e7021c..dec37e5 100755 Binary files a/datatype/Main and b/datatype/Main differ diff --git a/datatype/Main.hs b/datatype/Main.hs index a0e9362..42e0473 100644 --- a/datatype/Main.hs +++ b/datatype/Main.hs @@ -7,7 +7,6 @@ import Language import Compiler import Printer -import Interpreter import Language.Quote import Tuple @@ -37,7 +36,7 @@ main >> putStrLn (show $ interpret 50 <$> runCompiler (unmain f5)) e0 :: Expression v => v Int -e0 = lit 2 ^. lit 8 +e0 = lit 2 -. lit 8 e1 :: (Expression v, Tuple' v) => v (Tuple Char Int) e1 = tuple (lit 'c') (lit 42) @@ -87,9 +86,11 @@ f4 f5 :: (List' v, Expression v, Function (v (List Int)) v) => Main (v Int) f5 - = fun ( \sum->(\l->[cp|case l of - Cons e rest -> e +. sum rest + = fun ( \sumf->(\l->[cp|case l of + Cons e rest -> e +. sumf rest _ -> 0 +-- Cons e (Cons f rest) -> e +. f +. sum rest +{-blup-} |]) - :- Main {unmain=sum $ 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))} ) diff --git a/datatype/Printer.hs b/datatype/Printer.hs index 873d381..1a7b1d1 100644 --- a/datatype/Printer.hs +++ b/datatype/Printer.hs @@ -7,19 +7,26 @@ module Printer where import Control.Monad.RWS import Language -newtype Printer a = P { runPrinter :: RWS Ctx [String] PS a } +newtype Printer a = P { runPrinter :: RWS PR [String] PS a } deriving ( Functor , Applicative , Monad , MonadWriter [String] , MonadState PS - , MonadReader Ctx + , MonadReader PR ) data PS = PS {fresh :: [Int]} +data PR = PR {context :: Ctx, indent :: Int} data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc} deriving Eq +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 + leftctx,rightctx,nonectx :: Int -> Ctx leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone} rightctx p = CtxInfix {assoc=CtxRight, prio=p, branch=CtxNone} @@ -33,19 +40,10 @@ data CtxAssoc = CtxLeft | CtxRight | CtxNone deriving Eq runPrint :: Printer a -> String -runPrint p = concat $ snd $ execRWS (runPrinter p) CtxNo $ PS {fresh=[0..]} +runPrint p = concat $ snd $ execRWS (runPrinter p) (PR {indent=0, context=CtxNo}) $ PS {fresh=[0..]} ---printString :: Show a => a -> Printer a ---printString = pure . shows --- printLit :: String -> Printer a printLit a = tell [a] *> pure undefined --- ---printcc :: Printer a -> Printer b -> Printer c ---printcc a b = a >>= bkkkkkkkkkkP $ \ps->runPrinter a ps . runPrinter b ps --- ---printcs :: Printer a -> Printer b -> Printer c ---printcs a b = P $ \ps->runPrinter a ps . (' ':) . runPrinter b ps paren :: Printer a -> Printer a paren p = printLit "(" *> p <* printLit ")" @@ -54,7 +52,7 @@ accol :: Printer a -> Printer a accol p = printLit "{" *> p <* printLit "}" paren' :: Ctx -> Printer a -> Printer a -paren' this p = ask >>= \outer->if needsParen this outer then paren p else p +paren' this p = asks context >>= \outer->if needsParen this outer then paren p else p needsParen :: Ctx -> Ctx -> Bool needsParen CtxNo _ = False @@ -77,7 +75,6 @@ instance Expression Printer where (-.) = printBinOp (leftctx 6) "-" (*.) = printBinOp (leftctx 7) "*" (/.) = printBinOp (leftctx 7) "/" - (^.) = printBinOp (rightctx 8) "^" neg = printUnOp (nonectx 7) "!" (&.) = printBinOp (rightctx 3) "&" (|.) = printBinOp (rightctx 2) "|" @@ -88,49 +85,77 @@ instance Expression Printer where (>.) = printBinOp (nonectx 4) ">" (<=.) = printBinOp (nonectx 4) "<" (>=.) = printBinOp (nonectx 4) ">" - if' p t e = paren' CtxNonfix $ printLit "if " >> p >> printLit " then " >> local (\_->CtxNonfix) t >> printLit " else " >> local (\_->CtxNonfix) e + if' p t e = paren' CtxNonfix + $ printLit "if" >-> p + >^> printLit "then" >^> iindent (localctx CtxNonfix t) + >^> printLit "else" >^> iindent (localctx CtxNonfix e) bottom msg = printLit $ "error " ++ show msg freshLabel :: MonadState PS m => String -> m String freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f) instance Function () Printer where - fun def = Main $ freshLabel "f" >>= \f-> - let g :- m = def (\()->paren' CtxNonfix $ printLit (f ++ " ()")) - in printLit ("let " ++ f ++ " () = ") >> g () >> printLit "\n in " >> unmain m + fun def = Main $ + freshLabel "f" >>= \f-> + let g :- m = def $ \()->paren' CtxNonfix $ printLit (f ++ " ()") + in printLit ("let " ++ f ++ " () = ") + >^> iindent (g ()) + >^> printLit "in" >-> unmain m instance Function (Printer a) Printer where - fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a-> - let g :- m = def (\arg->paren' CtxNonfix $ printLit (f ++ " ") >>> arg) - in printLit (concat ["let ", f, " ", a, " = "]) >> g (printLit a) >> printLit " in\n" >> unmain m + fun def = Main $ + freshLabel "f" >>= \f->freshLabel "a" >>= \a-> + let g :- m = def $ \arg->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg + in printLit (concat ["let ", f, " ", a, " = "]) + >^> iindent (g (printLit a)) + >^> printLit "in" >-> unmain m instance Function (Printer a, Printer b) Printer where - fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2-> - let g :- m = def (\(arg1, arg2)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2) - in printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) >> g (printLit a1, printLit a2) >> printLit " in\n" >> unmain m + fun def = Main $ + freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2-> + let g :- m = def $ \(arg1, arg2)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 + in printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) + >^> iindent (g (printLit a1, printLit a2)) + >^> printLit "in" >-> unmain m instance Function (Printer a, Printer b, Printer c) Printer where fun def = Main $ - freshLabel "f" >>= \f-> - freshLabel "a" >>= \a1-> - freshLabel "a" >>= \a2-> - freshLabel "a" >>= \a3-> - let g :- m = def (\(arg1, arg2, arg3)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3) - in printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) >> g (printLit a1, printLit a2, printLit a3) >> printLit " in\n" >> unmain m + freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3-> + let g :- m = def $ \(arg1, arg2, arg3)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3 + in printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) + >^> iindent (g (printLit a1, printLit a2, printLit a3)) + >^> printLit "in" >-> unmain m +instance Function (Printer a, Printer b, Printer c, Printer d) Printer where + fun def = Main $ + freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3->freshLabel "a" >>= \a4-> + let g :- m = def $ \(arg1, arg2, arg3, arg4)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3 >-> arg4 + in printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " ", a4, " = "]) + >^> iindent (g (printLit a1, printLit a2, printLit a3, printLit a4)) + >^> printLit "in" >-> unmain m (>>>) :: Printer a1 -> Printer a2 -> Printer a3 l >>> r = l >> r >> pure undefined +(>->) :: Printer a1 -> Printer a2 -> Printer a3 +l >-> r = l >> printLit " " >>> r + +(>^>) :: Printer a1 -> Printer a2 -> Printer a3 +l >^> r = l >> printLit "\n" >> printIndent >>> r + +printIndent :: Printer a +printIndent = asks (flip replicate '\t' . indent) >>= printLit +infixl 1 >>>, >->, >^> + printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3 printBinOp thisctx op l r = paren' thisctx $ - local (\_->setBranch thisctx CtxLeft) l - >> printLit (' ':op ++ " ") - >>> local (\_->setBranch thisctx CtxRight) r + localctx (setBranch thisctx CtxLeft) l + >-> printLit op + >-> localctx (setBranch thisctx CtxRight) r printUnOp :: Ctx -> String -> Printer a -> Printer a printUnOp thisctx op l = paren' thisctx $ - printLit (' ':op ++ " ") - >> local (\_->setBranch thisctx CtxRight) l + printLit (' ':op) + >-> localctx (setBranch thisctx CtxRight) l printCons :: String -> Printer a -> Printer a -printCons = printUnOp CtxNonfix . (++" ") +printCons = printUnOp CtxNonfix-- . (++" ") printRec :: String -> Printer a -> Printer a -printRec op l = printUnOp CtxNo (op++" ") (accol l) +printRec op l = printUnOp CtxNo op (accol l)-- (op++" ") (accol l)