first order simple patterns

[clean-tests.git] / datatype / Printer.hs

diff --git a/datatype/Printer.hs b/datatype/Printer.hs
index 873d381..1a7b1d1 100644 (file)
--- 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)