.

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

diff --git a/datatype/Printer.hs b/datatype/Printer.hs
index 9e25c5b..d19a314 100644 (file)
--- a/datatype/Printer.hs
+++ b/datatype/Printer.hs
@@ -16,7 +16,7 @@ newtype Printer a = P { runPrinter :: RWS PR [String] PS a }
     , MonadState PS
     , MonadReader PR
     )
-data PS = PS {fresh :: [Int]}
+newtype 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
@@ -72,20 +72,20 @@ needsParen _ CtxNullary = error "shouldn't occur"
 instance DSL Printer
 instance Expression Printer where
     lit = printLit . show
-    (+.) = printBinOp (leftctx 6) "+"
-    (-.) = printBinOp (leftctx 6) "-"
-    (*.) = printBinOp (leftctx 7) "*"
-    (/.) = printBinOp (leftctx 7) "/"
-    neg = printUnOp (nonectx 7) "!"
-    (&.) = printBinOp (rightctx 3) "&"
-    (|.) = printBinOp (rightctx 2) "|"
-    not = printUnOp (nonectx 7) "!"
-    (==.) = printBinOp (nonectx 4) "=="
-    (/=.) = printBinOp (nonectx 4) "/="
-    (<.) = printBinOp (nonectx 4) "<"
-    (>.) = printBinOp (nonectx 4) ">"
-    (<=.) = printBinOp (nonectx 4) "<"
-    (>=.) = printBinOp (nonectx 4) ">"
+    (+.) = printBinOp "+" (leftctx 6)
+    (-.) = printBinOp "-" (leftctx 6)
+    (*.) = printBinOp "*" (leftctx 7)
+    (/.) = printBinOp "/" (leftctx 7)
+    neg = printUnOp "!" (nonectx 7)
+    (&.) = printBinOp "&" (rightctx 3)
+    (|.) = printBinOp "|" (rightctx 2)
+    not = printUnOp "!" (nonectx 7)
+    (==.) = printBinOp "==" (nonectx 4)
+    (/=.) = printBinOp "/=" (nonectx 4)
+    (<.) = printBinOp "<" (nonectx 4)
+    (>.) = printBinOp ">" (nonectx 4)
+    (<=.) = printBinOp "<" (nonectx 4)
+    (>=.) = printBinOp ">" (nonectx 4)
     if' p t e = paren' CtxNonfix
         $   printLit "if" >-> p
         >^> printLit "then" >^> iindent (localctx CtxNonfix t)
@@ -144,14 +144,14 @@ 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 $
+printBinOp :: String -> Ctx -> Printer a1 -> Printer a2 -> Printer a3
+printBinOp op thisctx l r = paren' thisctx $
         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 $
+printUnOp :: String -> Ctx -> Printer a -> Printer a
+printUnOp op thisctx l = paren' thisctx $
         printLit (' ':op)
     >-> localctx (setBranch thisctx CtxRight) l
 
@@ -159,4 +159,4 @@ printCons :: String -> Printer a -> Printer a
 printCons cons l = paren' CtxNonfix $ printLit cons >-> l
 
 printRec :: String -> Printer a -> Printer a
-printRec op l = printUnOp CtxNo op $ accol l
+printRec op l = printUnOp op CtxNo $ accol l