module Language.HERMIT.PrettyPrinter.GHC where
import Control.Arrow hiding ((<+>))
import Data.Char (isSpace)
import qualified GhcPlugins as GHC
import Language.HERMIT.Kure
import Language.HERMIT.Core
import Language.HERMIT.PrettyPrinter
import Text.PrettyPrint.MarkedHughesPJ as PP
listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a
listify _ [] = text "[]"
listify op (d:ds) = op (text "[ " <> d) (foldr (\e es -> op (text ", " <> e) es) (text "]") ds)
vlist, hlist :: [MDoc a] -> MDoc a
vlist = listify ($$)
hlist = listify (<+>)
corePrettyH :: PrettyOptions -> PrettyH Core
corePrettyH opts = do
dynFlags <- constT GHC.getDynFlags
let hideNotes = po_notes opts
ppSDoc :: (GHC.Outputable a) => a -> MDoc b
ppSDoc = toDoc . (if hideNotes then id else ("showSDoc: " ++)) . GHC.showSDoc dynFlags . GHC.ppr
where toDoc s | any isSpace s = parens (text s)
| otherwise = text s
ppModGuts :: PrettyH GHC.ModGuts
ppModGuts = arr (ppSDoc . GHC.mg_binds)
ppCoreProg :: PrettyH CoreProg
ppCoreProg = arr (ppSDoc . progToBinds)
ppCoreExpr :: PrettyH GHC.CoreExpr
ppCoreExpr = arr ppSDoc
ppCoreBind :: PrettyH GHC.CoreBind
ppCoreBind = arr ppSDoc
ppCoreAlt :: PrettyH GHC.CoreAlt
ppCoreAlt = arr ppSDoc
ppCoreDef :: PrettyH CoreDef
ppCoreDef = defT ppCoreExpr $ \ i e -> ppSDoc i <> text "=" <> e
promoteT (ppCoreExpr :: PrettyH GHC.CoreExpr)
<+ promoteT (ppCoreProg :: PrettyH CoreProg)
<+ promoteT (ppCoreBind :: PrettyH GHC.CoreBind)
<+ promoteT (ppCoreDef :: PrettyH CoreDef)
<+ promoteT (ppModGuts :: PrettyH GHC.ModGuts)
<+ promoteT (ppCoreAlt :: PrettyH GHC.CoreAlt)