(-.) = 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
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)
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
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')}
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
(-.) = liftM2 (-)
(/.) = liftM2 (/)
(*.) = liftM2 (*)
- (^.) = liftM2 (^)
neg = fmap negate
(&.) = liftM2 (&&)
(|.) = liftM2 (||)
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
(-.) :: 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
infix 4 ==., /=., <., >., <=., >=.
infixl 6 +., -.
infixl 7 *., /.
-infixl 8 ^.
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
, 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
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 ["^."]
, 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
import Compiler
import Printer
-import Interpreter
import Language.Quote
import Tuple
>> 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)
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))}
)
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}
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 ")"
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
(-.) = printBinOp (leftctx 6) "-"
(*.) = printBinOp (leftctx 7) "*"
(/.) = printBinOp (leftctx 7) "/"
- (^.) = printBinOp (rightctx 8) "^"
neg = printUnOp (nonectx 7) "!"
(&.) = printBinOp (rightctx 3) "&"
(|.) = printBinOp (rightctx 2) "|"
(>.) = 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)
repositories / clean-tests.git / commitdiff