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 = local (\r->r { indent=indent r + 1 }) $ printIndent >> 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 Expression Printer where
  73     lit = printLit . show
  74     (+.) = printBinOp (leftctx 6) "+"
  75     (-.) = printBinOp (leftctx 6) "-"
  76     (*.) = printBinOp (leftctx 7) "*"
  77     (/.) = printBinOp (leftctx 7) "/"
  78     neg = printUnOp (nonectx 7) "!"
  79     (&.) = printBinOp (rightctx 3) "&"
  80     (|.) = printBinOp (rightctx 2) "|"
  81     not = printUnOp (nonectx 7) "!"
  82     (==.) = printBinOp (nonectx 4) "=="
  83     (/=.) = printBinOp (nonectx 4) "/="
  84     (<.) = printBinOp (nonectx 4) "<"
  85     (>.) = printBinOp (nonectx 4) ">"
  86     (<=.) = printBinOp (nonectx 4) "<"
  87     (>=.) = printBinOp (nonectx 4) ">"
  88     if' p t e = paren' CtxNonfix
  89         $   printLit "if" >-> p
  90         >^> printLit "then" >^> iindent (localctx CtxNonfix t)
  91         >^> printLit "else" >^> iindent (localctx CtxNonfix e)
  92     bottom msg = printLit $ "error " ++ show msg
  93
  94 freshLabel :: MonadState PS m => String -> m String
  95 freshLabel prefix = gets fresh >>= \(f:fs)->modify (\s->s {fresh=fs}) >> pure (prefix ++ show f)
  96
  97 instance Function () Printer where
  98     fun def = Main $
  99         freshLabel "f" >>= \f->
 100         let g :- m = def $ \()->paren' CtxNonfix $ printLit (f ++ " ()")
 101         in  printLit ("let " ++ f ++ " () = ")
 102         >^> iindent (g ())
 103         >^> printLit "in" >-> unmain m
 104 instance Function (Printer a) Printer where
 105     fun def = Main $
 106         freshLabel "f" >>= \f->freshLabel "a" >>= \a->
 107         let g :- m = def $ \arg->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg
 108         in  printLit (concat ["let ", f, " ", a, " = "])
 109         >^> iindent (g (printLit a))
 110         >^> printLit "in" >-> unmain m
 111 instance Function (Printer a, Printer b) Printer where
 112     fun def = Main $
 113         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->
 114         let g :- m = def $ \(arg1, arg2)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2
 115         in  printLit (concat ["let ", f, " ", a1, " ", a2, " = "])
 116         >^> iindent (g (printLit a1, printLit a2))
 117         >^> printLit "in" >-> unmain m
 118 instance Function (Printer a, Printer b, Printer c) Printer where
 119     fun def = Main $
 120         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3->
 121         let g :- m = def $ \(arg1, arg2, arg3)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3
 122         in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "])
 123         >^> iindent (g (printLit a1, printLit a2, printLit a3))
 124         >^> printLit "in" >-> unmain m
 125 instance Function (Printer a, Printer b, Printer c, Printer d) Printer where
 126     fun def = Main $
 127         freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->freshLabel "a" >>= \a3->freshLabel "a" >>= \a4->
 128         let g :- m = def $ \(arg1, arg2, arg3, arg4)->paren' CtxNonfix $ localctx CtxNonfix $ printLit f >-> arg1 >-> arg2 >-> arg3 >-> arg4
 129         in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " ", a4, " = "])
 130         >^> iindent (g (printLit a1, printLit a2, printLit a3, printLit a4))
 131         >^> printLit "in" >-> unmain m
 132
 133 (>>>) :: Printer a1 -> Printer a2 -> Printer a3
 134 l >>> r = l >> r >> pure undefined
 135
 136 (>->) :: Printer a1 -> Printer a2 -> Printer a3
 137 l >-> r = l >> printLit " " >>> r
 138
 139 (>^>) :: Printer a1 -> Printer a2 -> Printer a3
 140 l >^> r = l >> printLit "\n" >> printIndent >>> r
 141
 142 printIndent :: Printer a
 143 printIndent = asks (flip replicate '\t' . indent) >>= printLit
 144 infixl 1 >>>, >->, >^>
 145
 146 printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3
 147 printBinOp thisctx op l r = paren' thisctx $
 148         localctx (setBranch thisctx CtxLeft) l
 149     >-> printLit op
 150     >-> localctx (setBranch thisctx CtxRight) r
 151
 152 printUnOp :: Ctx -> String -> Printer a -> Printer a
 153 printUnOp thisctx op l = paren' thisctx $
 154        printLit (' ':op)
 155     >-> localctx (setBranch thisctx CtxRight) l
 156
 157 printCons :: String -> Printer a -> Printer a
 158 printCons = printUnOp CtxNonfix-- . (++" ")
 159
 160 printRec :: String -> Printer a -> Printer a
 161 printRec op l = printUnOp CtxNo op (accol l)-- (op++" ") (accol l)