module HERMIT.PrettyPrinter.Common
(
DocH
, Attr(..)
, attrP
, HTML(..)
, ASCII(..)
, coercionColor
, idColor
, keywordColor
, syntaxColor
, markBindingSite
, markColor
, typeColor
, ShowOption(..)
, specialFont
, SpecialSymbol(..)
, SyntaxForColor(..)
, coreRenders
, renderCode
, RenderCode(..)
, renderSpecial
, RenderSpecial
, Unicode(..)
, PrettyPrinter(..)
, PrettyH
, PrettyHLCoreBox(..)
, PrettyHLCoreTCBox(..)
, TransformLCoreDocHBox(..)
, TransformLCoreTCDocHBox(..)
, liftPrettyH
, PrettyC(..)
, initPrettyC
, liftPrettyC
, PrettyOptions(..)
, updateCoShowOption
, updateTypeShowOption
, updateWidthOption
, pad
, hlist
, vlist
, showRole
) where
import Data.Char
import Data.Default.Class
import Data.Monoid hiding ((<>))
import qualified Data.Map as M
import Data.Typeable
import HERMIT.Context
import HERMIT.Core
import HERMIT.External
import HERMIT.GHC hiding (($$), (<>), (<+>), char)
import HERMIT.Kure
import HERMIT.Monad
import Text.PrettyPrint.MarkedHughesPJ as PP
showRole :: Role -> String
showRole Nominal = "N"
showRole Representational = "R"
showRole Phantom = "P"
type DocH = MDoc HermitMark
data HermitMark
= PushAttr Attr
| PopAttr
deriving Show
data Attr = BndrAttr AbsolutePathH
| Color SyntaxForColor
| PathAttr AbsolutePathH
| SpecialFont
deriving (Eq, Show)
data SyntaxForColor
= KeywordColor
| SyntaxColor
| IdColor
| CoercionColor
| TypeColor
| LitColor
| WarningColor
deriving (Eq, Show)
attr :: Attr -> DocH -> DocH
attr a p = mark (PushAttr a) <> p <> mark PopAttr
attrP :: AbsolutePathH -> DocH -> DocH
attrP = attr . PathAttr
idColor :: DocH -> DocH
idColor = markColor IdColor
typeColor :: DocH -> DocH
typeColor = markColor TypeColor
coercionColor :: DocH -> DocH
coercionColor = markColor CoercionColor
keywordColor :: DocH -> DocH
keywordColor = markColor KeywordColor
syntaxColor :: DocH -> DocH
syntaxColor = markColor SyntaxColor
markColor :: SyntaxForColor -> DocH -> DocH
markColor = attr . Color
specialFont :: DocH -> DocH
specialFont = attr SpecialFont
data PrettyPrinter = PP { pForall :: PrettyH [Var]
, pCoreTC :: PrettyH CoreTC
, pOptions :: PrettyOptions
}
deriving Typeable
instance Extern PrettyPrinter where
type Box PrettyPrinter = PrettyPrinter
box i = i
unbox i = i
type PrettyH a = Transform PrettyC HermitM a DocH
data PrettyHLCoreBox = PrettyHLCoreBox (PrettyH LCore) deriving Typeable
instance Extern (PrettyH LCore) where
type Box (PrettyH LCore) = PrettyHLCoreBox
box = PrettyHLCoreBox
unbox (PrettyHLCoreBox i) = i
data TransformLCoreDocHBox = TransformLCoreDocHBox (TransformH LCore DocH) deriving Typeable
instance Extern (TransformH LCore DocH) where
type Box (TransformH LCore DocH) = TransformLCoreDocHBox
box = TransformLCoreDocHBox
unbox (TransformLCoreDocHBox i) = i
data PrettyHLCoreTCBox = PrettyHLCoreTCBox (PrettyH LCoreTC) deriving Typeable
instance Extern (PrettyH LCoreTC) where
type Box (PrettyH LCoreTC) = PrettyHLCoreTCBox
box = PrettyHLCoreTCBox
unbox (PrettyHLCoreTCBox i) = i
data TransformLCoreTCDocHBox = TransformLCoreTCDocHBox (TransformH LCoreTC DocH) deriving Typeable
instance Extern (TransformH LCoreTC DocH) where
type Box (TransformH LCoreTC DocH) = TransformLCoreTCDocHBox
box = TransformLCoreTCDocHBox
unbox (TransformLCoreTCDocHBox i) = i
data PrettyC = PrettyC { prettyC_path :: AbsolutePathH
, prettyC_vars :: M.Map Var AbsolutePathH
, prettyC_options :: PrettyOptions
}
markBindingSite :: Var -> PrettyC -> DocH -> DocH
markBindingSite i c d = case M.lookup i (prettyC_vars c) of
Nothing -> d
Just p -> attr (BndrAttr p) d
instance ReadPath PrettyC Crumb where
absPath :: PrettyC -> AbsolutePath Crumb
absPath = prettyC_path
instance ExtendPath PrettyC Crumb where
(@@) :: PrettyC -> Crumb -> PrettyC
c @@ n = c { prettyC_path = prettyC_path c @@ n }
instance AddBindings PrettyC where
addHermitBindings :: [(Var,HermitBindingSite,AbsolutePathH)] -> PrettyC -> PrettyC
addHermitBindings vbs c = c { prettyC_vars = M.union (prettyC_vars c) (M.fromList [ (i,p) | (i,_,p) <- vbs ]) }
instance BoundVars PrettyC where
boundVars :: PrettyC -> VarSet
boundVars = mkVarSet . M.keys . prettyC_vars
instance HasEmptyContext PrettyC where
setEmptyContext :: PrettyC -> PrettyC
setEmptyContext c = c { prettyC_path = mempty
, prettyC_vars = M.empty}
liftPrettyH :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> Transform PrettyC HermitM a b -> Transform c HermitM a b
liftPrettyH = liftContext . liftPrettyC
liftPrettyC :: (ReadBindings c, ReadPath c Crumb) => PrettyOptions -> c -> PrettyC
liftPrettyC opts c = PrettyC { prettyC_path = absPath c
, prettyC_vars = M.fromList [ (i,hbPath b) | (i,b) <- M.toList (hermitBindings c) ]
, prettyC_options = opts}
initPrettyC :: PrettyOptions -> PrettyC
initPrettyC opts = PrettyC
{ prettyC_path = mempty
, prettyC_vars = M.empty
, prettyC_options = opts
}
data PrettyOptions = PrettyOptions
{ po_fullyQualified :: Bool
, po_exprTypes :: ShowOption
, po_coercions :: ShowOption
, po_typesForBinders :: ShowOption
, po_showUniques :: Bool
, po_focus :: Maybe PathH
, po_depth :: Maybe Int
, po_notes :: Bool
, po_ribbon :: Float
, po_width :: Int
} deriving Show
data ShowOption = Show | Abstract | Detailed | Omit | Kind deriving (Eq, Ord, Show, Read)
updateTypeShowOption :: ShowOption -> PrettyOptions -> PrettyOptions
updateTypeShowOption Kind po = po
updateTypeShowOption opt po = po { po_exprTypes = opt }
updateCoShowOption :: ShowOption -> PrettyOptions -> PrettyOptions
updateCoShowOption opt po = po { po_coercions = opt }
updateWidthOption :: Int -> PrettyOptions -> PrettyOptions
updateWidthOption w po = po { po_width = w }
instance Default PrettyOptions where
def = PrettyOptions
{ po_fullyQualified = False
, po_exprTypes = Abstract
, po_coercions = Kind
, po_typesForBinders = Omit
, po_showUniques = False
, po_focus = Nothing
, po_depth = Nothing
, po_notes = False
, po_ribbon = 1.2
, po_width = 80
}
data SpecialSymbol
= LambdaSymbol
| TypeOfSymbol
| RightArrowSymbol
| CastSymbol
| CoercionSymbol
| CoercionBindSymbol
| TypeSymbol
| TypeBindSymbol
| ForallSymbol
deriving (Show, Eq, Ord, Bounded, Enum)
class RenderSpecial a where
renderSpecial :: SpecialSymbol -> a
instance RenderSpecial Char where
renderSpecial LambdaSymbol = '\\'
renderSpecial TypeOfSymbol = ':'
renderSpecial RightArrowSymbol = '>'
renderSpecial CastSymbol = '#'
renderSpecial CoercionSymbol = 'C'
renderSpecial CoercionBindSymbol = 'c'
renderSpecial TypeSymbol = 'T'
renderSpecial TypeBindSymbol = 't'
renderSpecial ForallSymbol = 'F'
newtype ASCII = ASCII String
instance Monoid ASCII where
mempty = ASCII ""
mappend (ASCII xs) (ASCII ys) = ASCII (xs ++ ys)
instance RenderSpecial ASCII where
renderSpecial LambdaSymbol = ASCII "\\"
renderSpecial TypeOfSymbol = ASCII "::"
renderSpecial RightArrowSymbol = ASCII "->"
renderSpecial CastSymbol = ASCII "|>"
renderSpecial CoercionSymbol = ASCII "~#"
renderSpecial CoercionBindSymbol = ASCII "~#"
renderSpecial TypeSymbol = ASCII "*"
renderSpecial TypeBindSymbol = ASCII "*"
renderSpecial ForallSymbol = ASCII "forall"
newtype Unicode = Unicode Char
instance RenderSpecial Unicode where
renderSpecial LambdaSymbol = Unicode '\x03BB'
renderSpecial TypeOfSymbol = Unicode '\x2237'
renderSpecial RightArrowSymbol = Unicode '\x2192'
renderSpecial CastSymbol = Unicode '\x25B9'
renderSpecial CoercionSymbol = Unicode '\x25A0'
renderSpecial CoercionBindSymbol = Unicode '\x25A1'
renderSpecial TypeSymbol = Unicode '\x25b2'
renderSpecial TypeBindSymbol = Unicode '\x25b3'
renderSpecial ForallSymbol = Unicode '\x2200'
newtype LaTeX = LaTeX String
instance Monoid LaTeX where
mempty = LaTeX ""
mappend (LaTeX xs) (LaTeX ys) = LaTeX (xs ++ ys)
instance RenderSpecial LaTeX where
renderSpecial LambdaSymbol = LaTeX "\\ensuremath{\\lambda}"
renderSpecial TypeOfSymbol = LaTeX ":\\!:"
renderSpecial RightArrowSymbol = LaTeX "\\ensuremath{\\shortrightarrow}"
renderSpecial CastSymbol = LaTeX "\\ensuremath{\\triangleright}"
renderSpecial CoercionSymbol = LaTeX "\\ensuremath{\\blacksquare}"
renderSpecial CoercionBindSymbol = LaTeX "\\ensuremath{\\square}"
renderSpecial TypeSymbol = LaTeX "\\ensuremath{\\blacktriangle}"
renderSpecial TypeBindSymbol = LaTeX "\\ensuremath{\\vartriangle}"
renderSpecial ForallSymbol = LaTeX "\\ensuremath{\\forall}"
newtype HTML = HTML String
instance Monoid HTML where
mempty = HTML ""
mappend (HTML xs) (HTML ys) = HTML (xs ++ ys)
instance RenderSpecial HTML where
renderSpecial LambdaSymbol = HTML "λ"
renderSpecial TypeOfSymbol = HTML "∷"
renderSpecial RightArrowSymbol = HTML "→"
renderSpecial CastSymbol = HTML "▹"
renderSpecial CoercionSymbol = HTML "■"
renderSpecial CoercionBindSymbol = HTML "□"
renderSpecial TypeSymbol = HTML "▲"
renderSpecial TypeBindSymbol = HTML "△"
renderSpecial ForallSymbol = HTML "∀"
renderSpecialFont :: RenderSpecial a => Char -> Maybe a
renderSpecialFont = fmap renderSpecial . flip M.lookup specialFontMap
specialFontMap :: M.Map Char SpecialSymbol
specialFontMap = M.fromList
[ (renderSpecial s,s)
| s <- [minBound..maxBound]
]
class (RenderSpecial a, Monoid a) => RenderCode a where
rStart :: a
rStart = mempty
rEnd :: a
rEnd = mempty
rDoHighlight :: Maybe Attr
-> [Attr]
-> a
rPutStr :: String -> a
renderCode :: RenderCode a => PrettyOptions -> DocH -> a
renderCode opts doc = rStart `mappend` PP.fullRender PP.PageMode w rib marker (\ _ -> rEnd) doc []
where
w = po_width opts
rib = po_ribbon opts
marker :: RenderCode a => PP.TextDetails HermitMark -> ([Attr] -> a) -> ([Attr]-> a)
marker m rest as@(SpecialFont:_) = case m of
PP.Chr ch -> special [ch] `mappend` rest as
PP.Str str -> special str `mappend` rest as
PP.PStr str -> special str `mappend` rest as
PP.Mark PopAttr ->
let (a:as') = as in rDoHighlight (Just a) as' `mappend` rest as'
PP.Mark (PushAttr _) -> error "renderCode: can not have marks inside special symbols"
marker m rest as = case m of
PP.Chr ch -> rPutStr [ch] `mappend` rest as
PP.Str str -> rPutStr str `mappend` rest as
PP.PStr str -> rPutStr str `mappend` rest as
PP.Mark (PushAttr a) ->
let as' = a : as in rDoHighlight Nothing as' `mappend` rest as'
PP.Mark PopAttr -> do
let (a:as') = as in rDoHighlight (Just a) as' `mappend` rest as'
special txt = mconcat [ code | Just code <- map renderSpecialFont txt ]
coreRenders :: [(String, PrettyOptions -> DocH -> String)]
coreRenders =
[ ("latex", \ opts doc -> latexToString $ renderCode opts doc)
, ("html", \ opts doc -> let HTML str = renderCode opts doc in str)
, ("ascii", \ opts doc -> let ASCII str = renderCode opts doc in str)
, ("debug", \ opts doc -> let DebugPretty str = renderCode opts doc in str)
]
latexToString :: LaTeX -> String
latexToString (LaTeX orig) = unlines $ map trunkSpaces $ lines orig where
trunkSpaces txt = case span isSpace txt of
([],rest) -> rest
(pre,rest) -> "\\hspace{" ++ show (length pre) ++ "\\hermitspace}" ++ rest
instance RenderCode LaTeX where
rPutStr txt = LaTeX txt
rDoHighlight (Just _) _ = LaTeX "}"
rDoHighlight _ [] = LaTeX $ "{"
rDoHighlight _ (Color col:_) = LaTeX $ "{" ++ case col of
KeywordColor -> "\\color{hermit:keyword}"
SyntaxColor -> "\\color{hermit:syntax}"
IdColor -> ""
CoercionColor -> "\\color{hermit:coercion}"
TypeColor -> "\\color{hermit:type}"
LitColor -> "\\color{hermit:lit}"
WarningColor -> "\\color{hermit:warning}"
rDoHighlight o (_:rest) = rDoHighlight o rest
rEnd = LaTeX "\n"
instance RenderCode HTML where
rPutStr txt = HTML txt
rDoHighlight (Just _) _ = HTML "</span>"
rDoHighlight _ [] = HTML $ "<span>"
rDoHighlight _ (Color col:_) = HTML $ case col of
KeywordColor -> "<span class=\"hermit-keyword\">"
SyntaxColor -> "<span class=\"hermit-syntax\">"
IdColor -> "<span>"
CoercionColor -> "<span class=\"hermit-coercion\">"
TypeColor -> "<span class=\"hermit-type\">"
LitColor -> "<span class=\"hermit-lit\">"
WarningColor -> "<span class=\"hermit-warning\">"
rDoHighlight o (_:rest) = rDoHighlight o rest
rEnd = HTML "\n"
instance RenderCode ASCII where
rPutStr txt = ASCII txt
rDoHighlight _ _ = ASCII ""
rEnd = ASCII "\n"
data DebugPretty = DebugPretty String
instance RenderSpecial DebugPretty where
renderSpecial sym = DebugPretty ("{" ++ show sym ++ "}")
instance Monoid DebugPretty where
mempty = DebugPretty ""
mappend (DebugPretty xs) (DebugPretty ys) = DebugPretty $ xs ++ ys
instance RenderCode DebugPretty where
rStart = DebugPretty "(START)\n"
rPutStr txt = DebugPretty txt
rDoHighlight Nothing stk = DebugPretty $ show (True,stk)
rDoHighlight (Just _) stk = DebugPretty $ show (False,stk)
rEnd = DebugPretty "(END)\n"
listify :: (MDoc a -> MDoc a -> MDoc a) -> [MDoc a] -> MDoc a
listify _ [] = PP.text "[]"
listify op (d:ds) = op (PP.text "[ " <> d) (foldr (\e es -> op (PP.text ", " <> e) es) (PP.text "]") ds)
vlist, hlist :: [MDoc a] -> MDoc a
vlist = listify ($$)
hlist = listify (<+>)
pad :: MDoc a -> MDoc a
pad d = char ' ' <> d <> char ' '