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 Ctx [String] PS a }
  11   deriving
  12     ( Functor
  13     , Applicative
  14     , Monad
  15     , MonadWriter [String]
  16     , MonadState PS
  17     , MonadReader Ctx
  18     )
  19 data PS = PS {fresh :: [Int]}
  20 data Ctx = CtxNo | CtxNullary | CtxNonfix | CtxInfix {assoc :: CtxAssoc, prio :: Int, branch :: CtxAssoc}
  21   deriving Eq
  22
  23 leftctx,rightctx,nonectx :: Int -> Ctx
  24 leftctx p = CtxInfix {assoc=CtxLeft, prio=p, branch=CtxNone}
  25 rightctx p = CtxInfix {assoc=CtxRight, prio=p, branch=CtxNone}
  26 nonectx p = CtxInfix {assoc=CtxNone, prio=p, branch=CtxNone}
  27
  28 setBranch :: Ctx -> CtxAssoc -> Ctx
  29 setBranch ctx@(CtxInfix _ _ _) b = ctx { branch=b }
  30 setBranch ctx _ = ctx
  31
  32 data CtxAssoc = CtxLeft | CtxRight | CtxNone
  33   deriving Eq
  34
  35 runPrint :: Printer a -> String
  36 runPrint p = concat $ snd $ execRWS (runPrinter p) CtxNo $ PS {fresh=[0..]}
  37
  38 --printString :: Show a => a -> Printer a
  39 --printString = pure . shows
  40 --
  41 printLit :: String -> Printer a
  42 printLit a = tell [a] *> pure undefined
  43 --
  44 --printcc :: Printer a -> Printer b -> Printer c
  45 --printcc a b = a >>= bkkkkkkkkkkP $ \ps->runPrinter a ps . runPrinter b ps
  46 --
  47 --printcs :: Printer a -> Printer b -> Printer c
  48 --printcs a b = P $ \ps->runPrinter a ps . (' ':) . runPrinter b ps
  49
  50 paren :: Printer a -> Printer a
  51 paren p = printLit "(" *> p <* printLit ")"
  52
  53 accol :: Printer a -> Printer a
  54 accol p = printLit "{" *> p <* printLit "}"
  55
  56 paren' :: Ctx -> Printer a -> Printer a
  57 paren' this p = ask >>= \outer->if needsParen this outer then paren p else p
  58
  59 needsParen :: Ctx -> Ctx -> Bool
  60 needsParen CtxNo _ = False
  61 needsParen CtxNullary _ = False
  62 needsParen CtxNonfix CtxNo = False
  63 needsParen CtxNonfix CtxNonfix = True
  64 needsParen CtxNonfix (CtxInfix _ _ _) = False
  65 needsParen (CtxInfix _ _ _) CtxNo = False
  66 needsParen (CtxInfix _ _ _) CtxNonfix = True
  67 needsParen (CtxInfix thisassoc thisprio _) (CtxInfix outerassoc outerprio outerbranch)
  68     | outerprio > thisprio = True
  69     | outerprio == thisprio
  70         = thisassoc /= outerassoc || thisassoc /= outerbranch
  71     | otherwise = False
  72 needsParen _ CtxNullary = error "shouldn't occur"
  73
  74 instance Expression Printer where
  75     lit = printLit . show
  76     (+.) = printBinOp (leftctx 6) "+"
  77     (-.) = printBinOp (leftctx 6) "-"
  78     (*.) = printBinOp (leftctx 7) "*"
  79     (/.) = printBinOp (leftctx 7) "/"
  80     (^.) = printBinOp (rightctx 8) "^"
  81     neg = printUnOp (nonectx 7) "!"
  82     (&.) = printBinOp (rightctx 3) "&"
  83     (|.) = printBinOp (rightctx 2) "|"
  84     not = printUnOp (nonectx 7) "!"
  85     (==.) = printBinOp (nonectx 4) "=="
  86     (/=.) = printBinOp (nonectx 4) "/="
  87     (<.) = printBinOp (nonectx 4) "<"
  88     (>.) = printBinOp (nonectx 4) ">"
  89     (<=.) = printBinOp (nonectx 4) "<"
  90     (>=.) = printBinOp (nonectx 4) ">"
  91     if' p t e = paren' CtxNonfix $ printLit "if " >> p >> printLit " then " >> local (\_->CtxNonfix) t >> printLit " else " >> local (\_->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 $ freshLabel "f" >>= \f->
  99         let g :- m = def (\()->paren' CtxNonfix $ printLit (f ++ " ()"))
 100         in  printLit ("let " ++ f ++ " () = ") >> g () >> printLit "\n in " >> unmain m
 101 instance Function (Printer a) Printer where
 102     fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a->
 103         let g :- m = def (\arg->paren' CtxNonfix $ printLit (f ++ " ") >>> arg)
 104         in  printLit (concat ["let ", f, " ", a, " = "]) >> g (printLit a) >> printLit " in\n" >> unmain m
 105 instance Function (Printer a, Printer b) Printer where
 106     fun def = Main $ freshLabel "f" >>= \f->freshLabel "a" >>= \a1->freshLabel "a" >>= \a2->
 107         let g :- m = def (\(arg1, arg2)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >>> arg2)
 108         in  printLit (concat ["let ", f, " ", a1, " ", a2, " = "]) >> g (printLit a1, printLit a2) >> printLit " in\n" >> unmain m
 109 instance Function (Printer a, Printer b, Printer c) Printer where
 110     fun def = Main $
 111         freshLabel "f" >>= \f->
 112         freshLabel "a" >>= \a1->
 113         freshLabel "a" >>= \a2->
 114         freshLabel "a" >>= \a3->
 115         let g :- m = def (\(arg1, arg2, arg3)->paren' CtxNonfix $ printLit (f ++ " ") >> arg1 >> printLit " " >> arg2 >> printLit " " >>> arg3)
 116         in  printLit (concat ["let ", f, " ", a1, " ", a2, " ", a3, " = "]) >> g (printLit a1, printLit a2, printLit a3) >> printLit " in\n" >> unmain m
 117
 118 (>>>) :: Printer a1 -> Printer a2 -> Printer a3
 119 l >>> r = l >> r >> pure undefined
 120
 121 printBinOp :: Ctx -> String -> Printer a1 -> Printer a2 -> Printer a3
 122 printBinOp thisctx op l r = paren' thisctx $
 123        local (\_->setBranch thisctx CtxLeft) l
 124     >> printLit (' ':op ++ " ")
 125     >>> local (\_->setBranch thisctx CtxRight) r
 126
 127 printUnOp :: Ctx -> String -> Printer a -> Printer a
 128 printUnOp thisctx op l = paren' thisctx $
 129        printLit (' ':op ++ " ")
 130     >> local (\_->setBranch thisctx CtxRight) l
 131
 132 printCons :: String -> Printer a -> Printer a
 133 printCons = printUnOp CtxNonfix . (++" ")
 134
 135 printRec :: String -> Printer a -> Printer a
 136 printRec op l = printUnOp CtxNo (op++" ") (accol l)