datatype/Printer.hs

   1 {-# LANGUAGE MultiParamTypeClasses #-}
   2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 module Printer where
   6
   7 import Control.Monad.RWS
   8 import Language
   9
  10 newtype Printer a = P { runPrinter :: RWS PR [String] PS a }
  11   deriving
  12     ( Functor
  13     , Applicative
  14     , Monad
  15     , MonadWriter [String]
  16     , MonadState PS
  17     , MonadReader PR
  18     )
  19 data PS = PS {fresh :: [Int]}
  20 data PR = PR {context :: Ctx, indent :: Int}
  21 data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc}
  22   deriving Eq
  23
  24 localctx :: Ctx -> Printer a -> Printer a
  25 localctx ctx = local $ \r->r { context=ctx }
  26
  27 iindent :: Printer a -> Printer a
  28 iindent p = printIndent >> local (\r->r { indent=indent r + 1 }) p
  29
  30 leftctx,rightctx,nonectx :: Int -> Ctx
  31 leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone}
  32 rightctx p = CtxInfix {assoc=CtxRight, prio=p, branch=CtxNone}
  33 nonectx p = CtxInfix {assoc=CtxNone, prio=p, branch=CtxNone}
  34
  35 setBranch :: Ctx -> CtxAssoc -> Ctx
  36 setBranch ctx@(CtxInfix _ _ _) b = ctx { branch=b }
  37 setBranch ctx _ = ctx
  38
  39 data CtxAssoc = CtxLeft | CtxRight | CtxNone
  40   deriving Eq
  41
  42 runPrint :: Printer a -> String
  43 runPrint p = concat $ snd $ execRWS (runPrinter p) (PR {indent=0, context=CtxNo}) $ PS {fresh=[0..]}
  44
  45 printLit :: String -> Printer a
  46 printLit a = tell [a] *> pure undefined
  47
  48 paren :: Printer a -> Printer a
  49 paren p = printLit "(" *> p <* printLit ")"
  50
  51 accol :: Printer a -> Printer a
  52 accol p = printLit "{" *> p <* printLit "}"
  53
  54 paren' :: Ctx -> Printer a -> Printer a
  55 paren' this p = asks context >>= \outer->if needsParen this outer then paren p else p
  56
  57 needsParen :: Ctx -> Ctx -> Bool
  58 needsParen CtxNo _ = False
  59 needsParen CtxNullary _ = False
  60 needsParen CtxNonfix CtxNo = False
  61 needsParen CtxNonfix CtxNonfix = True
  62 needsParen CtxNonfix (CtxInfix _ _ _) = False
  63 needsParen (CtxInfix _ _ _) CtxNo = False
  64 needsParen (CtxInfix _ _ _) CtxNonfix = True
  65 needsParen (CtxInfix thisassoc thisprio _) (CtxInfix outerassoc outerprio outerbranch)
  66     | outerprio > thisprio = True
  67     | outerprio == thisprio
  68         = thisassoc /= outerassoc || thisassoc /= outerbranch
  69     | otherwise = False
  70 needsParen _ CtxNullary = error "shouldn't occur"
  71
  72 instance DSL Printer
  73 instance Expression Printer where
  74     lit = printLit . show
  75     (+.) = printBinOp (leftctx 6) "+"
  76     (-.) = printBinOp (leftctx 6) "-"
  77     (*.) = printBinOp (leftctx 7) "*"
  78     (/.) = printBinOp (leftctx 7) "/"
  79     neg = printUnOp (nonectx 7) "!"
  80     (&.) = printBinOp (rightctx 3) "&"
  81     (|.) = printBinOp (rightctx 2) "|"
  82     not = printUnOp (nonectx 7) "!"
  83     (==.) = printBinOp (nonectx 4) "=="
  84     (/=.) = printBinOp (nonectx 4) "/="
  85     (<.) = printBinOp (nonectx 4) "<"
  86     (>.) = printBinOp (nonectx 4) ">"
  87     (<=.) = printBinOp (nonectx 4) "<"
  88     (>=.) = printBinOp (nonectx 4) ">"
  89     if' p t e = paren' CtxNonfix
  90         $   printLit "if" >-> p
  91         >^> printLit "then" >^> iindent (localctx CtxNonfix t)
  92         >^> printLit "else" >^> iindent (localctx CtxNonfix e)
  93     bottom msg = printLit $ "error " ++ show msg
  94
  95 freshLabel :: MonadState PS m => String -> m String
  96 freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f)
  97
  98 instance Function () Printer where
  99     fun def = Main $
 100         freshLabel "f" >>= \f->
 101         let g :- m = def $ \()->paren' CtxNonfix $ printLit (f ++ " ()")
 102         in  printLit ("let " ++ f ++ " () = ")
 103         >^> iindent (g ())
 104         >^> printLit "in" >-> unmain m
 105 instance Function (Printer a) Printer where
 106     fun def = Main $
 107         freshLabel "f" >>= \f->freshLabel "a" >>= \a->
 108         let g :- m = def $ \arg->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg
 109         in  printLit (concat ["let ", f, " ", a, " = "])
 110         >^> iindent (g (printLit a))
 111         >^> printLit "in" >-> unmain m
 112 instance Function (Printer a, Printer b) Printer where
 113     fun def = Main $
 114         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->
 115         let g :- m = def $ \(arg1, arg2)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2
 116         in  printLit (concat ["let ", f, " ", a1, " ", a2, " = "])
 117         >^> iindent (g (printLit a1, printLit a2))
 118         >^> printLit "in" >-> unmain m
 119 instance Function (Printer a, Printer b, Printer c) Printer where
 120     fun def = Main $
 121         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3->
 122         let g :- m = def $ \(arg1, arg2, arg3)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3
 123         in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "])
 124         >^> iindent (g (printLit a1, printLit a2, printLit a3))
 125         >^> printLit "in" >-> unmain m
 126 instance Function (Printer a, Printer b, Printer c, Printer d) Printer where
 127     fun def = Main $
 128         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3->freshLabel "a" >>= \a4->
 129         let g :- m = def $ \(arg1, arg2, arg3, arg4)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3 >-> arg4
 130         in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " ", a4, " = "])
 131         >^> iindent (g (printLit a1, printLit a2, printLit a3, printLit a4))
 132         >^> printLit "in" >-> unmain m
 133
 134 (>>>) :: Printer a1 -> Printer a2 -> Printer a3
 135 l >>> r = l >> r >> pure undefined
 136
 137 (>->) :: Printer a1 -> Printer a2 -> Printer a3
 138 l >-> r = l >> printLit " " >>> r
 139
 140 (>^>) :: Printer a1 -> Printer a2 -> Printer a3
 141 l >^> r = l >> printLit "\n" >> printIndent >>> r
 142
 143 printIndent :: Printer a
 144 printIndent = asks (flip replicate '\t' . indent) >>= printLit
 145 infixl 1 >>>, >->, >^>
 146
 147 printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3
 148 printBinOp thisctx op l r = paren' thisctx $
 149         localctx (setBranch thisctx CtxLeft) l
 150     >-> printLit op
 151     >-> localctx (setBranch thisctx CtxRight) r
 152
 153 printUnOp :: Ctx -> String -> Printer a -> Printer a
 154 printUnOp thisctx op l = paren' thisctx $
 155        printLit (' ':op)
 156     >-> localctx (setBranch thisctx CtxRight) l
 157
 158 printCons :: String -> Printer a -> Printer a
 159 printCons cons l = paren' CtxNonfix $ printLit cons >-> l
 160
 161 printRec :: String -> Printer a -> Printer a
 162 printRec op l = printUnOp CtxNo op (accol l)-- (op++" ") (accol l)