ghc-dump-util 0.1.2.0 → 0.2.1.0

raw patch · 4 files changed

+287/−82 lines, 4 filesdep +ansi-terminaldep +luciddep +prettyprinterdep −ansi-wl-pprintdep ~bytestringdep ~ghc-dump-corePVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, lucid, prettyprinter, prettyprinter-ansi-terminal

Dependencies removed: ansi-wl-pprint

Dependency ranges changed: bytestring, ghc-dump-core

API changes (from Hackage documentation)

Files

• Main.hs +56/−30
• ghc-dump-util.cabal +25/−10
• src/GhcDump/Pretty.hs +46/−42
• src/GhcDump/ToHtml.hs +160/−0

@@ -3,35 +3,40 @@ import Control.Monad import Data.Maybe import Data.List (sortBy)-import Data.Monoid import Data.Ord+import System.IO (stdout)  import Options.Applicative-import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))-import qualified Text.PrettyPrint.ANSI.Leijen as PP+import Prettyprinter as PP+import Prettyprinter.Render.Terminal as PP+import qualified System.Console.ANSI  import Text.Regex.TDFA import Text.Regex.TDFA.Common (Regex) import Text.Regex.TDFA.Text () +import GhcDump.ToHtml import GhcDump.Pretty import GhcDump.Util import GhcDump.Ast -data Column a = Col { colWidth :: Int, colHeader :: String, colGet :: (a -> Doc) }+data Column a = Col { colWidth :: Int+                    , colHeader :: String+                    , colGet :: a -> Doc AnsiStyle+                    }  type Table a = [Column a] -renderTable :: forall a. Table a -> [a] -> Doc+renderTable :: forall a. Table a -> [a] -> Doc AnsiStyle renderTable cols xs =-         row (PP.bold . text . colHeader)+         row (PP.annotate PP.bold . pretty . colHeader)     <$$> vcat [ row (flip colGet x) | x <- xs ]   where-    row :: (Column a -> Doc) -> Doc+    row :: (Column a -> Doc AnsiStyle) -> Doc AnsiStyle     row toCell = go cols       where-        go :: [Column a] -> Doc-        go []           = PP.empty+        go :: [Column a] -> Doc AnsiStyle+        go []           = mempty         go [col]        = align $ toCell col         go (col : rest) = fillBreak (colWidth col) (align $ toCell col) PP.<+> go rest @@ -50,6 +55,14 @@     nameMatches :: Binder -> Bool     nameMatches b = matchTest re (binderUniqueName b) +renderIOTerm :: PP.LayoutOptions -> Doc AnsiStyle -> IO ()+renderIOTerm layoutOpts doc = do+    supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout+    let doc' = if supportsANSI+                 then doc+                 else PP.unAnnotate doc+    PP.renderIO stdout $ PP.layoutPretty layoutOpts doc'+ modes :: Parser (IO ()) modes = subparser      $ mode "show" showMode (progDesc "print Core")@@ -69,6 +82,23 @@       where         makeRegexM' = makeRegexM :: String -> ReadM Regex +    bindingsSort :: Parser (Module -> Module)+    bindingsSort =+        option (str >>= readSortField)+               (long "sort" <> short 's' <> value id+                <> help "Sort by (accepted values: none, terms, types, coercions, type)")+      where+        readSortField "none"      = return $ id+        readSortField "terms"     = return $ onBinds $ sortBy (flip $ comparing $ csTerms . getStats)+        readSortField "types"     = return $ onBinds $ sortBy (flip $ comparing $ csTypes . getStats)+        readSortField "coercions" = return $ onBinds $ sortBy (flip $ comparing $ csCoercions . getStats)+        readSortField "type"      = return $ onBinds $ sortBy (comparing $ binderType . unBndr . getBinder)+        readSortField f           = fail $ "unknown sort field "++f++        onBinds :: ([(Binder, CoreStats, Expr)] -> [(Binder, CoreStats, Expr)])+                -> Module -> Module+        onBinds f mod = mod { moduleTopBindings = [RecTopBinding $ f $ moduleBindings mod] }+     prettyOpts :: Parser PrettyOpts     prettyOpts =         PrettyOpts@@ -78,35 +108,31 @@           <*> switch (short 'U' <> long "show-unfoldings" <> help "Show unfolding templates")      showMode =-        run <$> filterCond <*> prettyOpts <*> dumpFile+        run <$> filterCond <*> bindingsSort <*> prettyOpts <*> html <*> dumpFile       where-        run filterFn opts fname = do-            dump <- filterFn <$> GhcDump.Util.readDump fname-            print $ pprModule opts dump+        html = switch (short 'H' <> long "html" <> help "Render to HTML")+        run filterFn sortBindings opts html fname = do+            dump <- sortBindings . filterFn <$> GhcDump.Util.readDump fname+            if html+              then writeFile "out.html" $ show $ topBindingsToHtml (moduleTopBindings dump)+              else renderIOTerm PP.defaultLayoutOptions $ pprModule opts dump      listBindingsMode =-        run <$> filterCond <*> sortField <*> prettyOpts <*> dumpFile+        run <$> filterCond <*> bindingsSort <*> prettyOpts <*> dumpFile       where-        sortField =-            option (str >>= readSortField)-                   (long "sort" <> short 's' <> value id-                    <> help "Sort by (accepted values: terms, types, coercions, type)")-          where-            readSortField "terms"     = return $ sortBy (flip $ comparing $ csTerms . getStats)-            readSortField "types"     = return $ sortBy (flip $ comparing $ csTypes . getStats)-            readSortField "coercions" = return $ sortBy (flip $ comparing $ csCoercions . getStats)-            readSortField "type"      = return $ sortBy (comparing $ binderType . unBndr . getBinder)-            readSortField f           = fail $ "unknown sort field "++f-         run filterFn sortBindings opts fname = do-            dump <- filterFn <$> GhcDump.Util.readDump fname-            let table = [ Col 20 "Name"   (pprBinder opts . getBinder)+            dump <- sortBindings . filterFn <$> GhcDump.Util.readDump fname+            let table = [ Col 30 "Name"   (pprBinder opts . getBinder)                         , Col 6  "Terms"  (pretty . csTerms . getStats)                         , Col 6  "Types"  (pretty . csTypes . getStats)                         , Col 6  "Coerc." (pretty . csCoercions . getStats)-                        , Col 300 "Type"  (pprType opts . binderType . unBndr . getBinder)+                        , Col 3000 "Type"  (pprType opts . binderType . unBndr . getBinder)                         ]-            print $ renderTable table (sortBindings $ moduleBindings dump)+            let layoutOpts = PP.defaultLayoutOptions { layoutPageWidth = Unbounded }+            renderIOTerm layoutOpts $ vcat+              [ pretty (modulePhase dump)+              , renderTable table (moduleBindings dump)+              ]      summarizeMode =         run <$> some dumpFile@@ -116,7 +142,7 @@                                        return (fname, mod)) fnames             let totalSize :: Module -> CoreStats                 totalSize = foldMap getStats . moduleBindings-            let table = [ Col 35 "Name" (text . fst)+            let table = [ Col 35 "Name" (pretty . fst)                         , Col 8  "Terms" (pretty . csTerms . totalSize . snd)                         , Col 8  "Types" (pretty . csTypes . totalSize . snd)                         , Col 8  "Coerc." (pretty . csCoercions . totalSize . snd)

@@ -1,5 +1,6 @@+cabal-version:       3.0 name:                ghc-dump-util-version:             0.1.2.0+version:             0.2.1.0 synopsis:            Handy tools for working with ghc-dump dumps description:   @ghc-dump@ is a library, GHC plugin, and set of tools for recording and@@ -11,39 +12,53 @@   This package provides the AST and compiler plugin. See the @ghc-dump-util@   package for a useful command-line tool for working with dumps produced by this   plugin.-license:             BSD3+license:             BSD-3-Clause license-file:        LICENSE author:              Ben Gamari maintainer:          ben@well-typed.com copyright:           (c) 2017 Ben Gamari category:            Development build-type:          Simple-tested-with:         GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.5, GHC==8.8.3, GHC==8.10.1-cabal-version:       >=1.10+tested-with:         GHC==7.10.3,+                     GHC==8.0.2,+                     GHC==8.2.2,+                     GHC==8.4.4,+                     GHC==8.6.5,+                     GHC==8.8.3,+                     GHC==8.10.4,+                     GHC==9.0.1,+                     GHC==9.2.1,  source-repository head   type: git   location: https://github.com/bgamari/ghc-dump  library-  exposed-modules:     GhcDump.Repl, GhcDump.Util, GhcDump.Pretty, GhcDump.Reconstruct+  exposed-modules:     GhcDump.Repl,+                       GhcDump.Util,+                       GhcDump.Pretty,+                       GhcDump.Reconstruct,+                       GhcDump.ToHtml   hs-source-dirs:      src   build-depends:       base < 5.0,-                       ghc-dump-core >=0.1 && <0.2,-                       bytestring >=0.10 && <0.11,+                       ghc-dump-core >=0.2 && <0.3,+                       bytestring >=0.10 && <0.12,                        unordered-containers >= 0.2,                        hashable >= 1.2,+                       lucid,                        text >= 1.0,-                       ansi-wl-pprint >= 0.6,+                       prettyprinter,                        serialise >=0.2 && <0.3   default-language:    Haskell2010  executable ghc-dump   main-is:             Main.hs   build-depends:       base < 5.0,-                       ghc-dump-core >=0.1 && <0.2,+                       ghc-dump-core,                        ghc-dump-util,-                       ansi-wl-pprint >= 0.6,+                       ansi-terminal,+                       prettyprinter,+                       prettyprinter-ansi-terminal,                        regex-tdfa >= 1.3.1.0,                        optparse-applicative >= 0.13   default-language:    Haskell2010

@@ -14,8 +14,11 @@ import Data.Ratio import qualified Data.Text as T import qualified Data.ByteString.Char8 as BS-import Text.PrettyPrint.ANSI.Leijen+import Prettyprinter +(<$$>) :: Doc ann -> Doc ann -> Doc ann+a <$$> b = vcat [a,b]+ data PrettyOpts = PrettyOpts { showUniques    :: Bool                              , showIdInfo     :: Bool                              , showLetTypes   :: Bool@@ -29,19 +32,15 @@                                , showUnfoldings = False                                } --- orphan-instance Pretty T.Text where-    pretty = text . T.unpack- instance Pretty ExternalName where-    pretty n@ExternalName{} = pretty (externalModuleName n) <> "." <> text (T.unpack $ externalName n)+    pretty n@ExternalName{} = pretty (externalModuleName n) <> "." <> pretty (T.unpack $ externalName n)     pretty ForeignCall = "<foreign>"  instance Pretty ModuleName where-    pretty = text . T.unpack . getModuleName+    pretty = pretty . T.unpack . getModuleName  instance Pretty Unique where-    pretty = text . show+    pretty = pretty . show  instance Pretty BinderId where     pretty (BinderId b) = pretty b@@ -49,20 +48,20 @@ instance Pretty Binder where     pretty = pprBinder defaultPrettyOpts -pprBinder :: PrettyOpts -> Binder -> Doc+pprBinder :: PrettyOpts -> Binder -> Doc ann pprBinder opts b   | showUniques opts = pretty $ binderUniqueName b   | otherwise        = pretty $ binderName $ unBndr b  instance Pretty TyCon where-    pretty (TyCon t _) = text $ T.unpack t+    pretty (TyCon t _) = pretty $ T.unpack t -pprRational :: Rational -> Doc+pprRational :: Rational -> Doc ann pprRational r = pretty (numerator r) <> "/" <> pretty (denominator r)  instance Pretty Lit where-    pretty (MachChar x) = "'" <> char x <> "'#"-    pretty (MachStr x) = "\"" <> text (BS.unpack x) <> "\"#"+    pretty (MachChar x) = "'" <> pretty x <> "'#"+    pretty (MachStr x) = "\"" <> pretty (BS.unpack x) <> "\"#"     pretty MachNullAddr = "nullAddr#"     pretty (MachInt x) = pretty x <> "#"     pretty (MachInt64 x) = pretty x <> "#"@@ -76,16 +75,16 @@ instance Pretty CoreStats where     pretty c =         "Core Size"-        <>braces (hsep [ "terms="<>int (csTerms c)-                       , "types="<>int (csTypes c)-                       , "cos="<>int (csCoercions c)-                       , "vbinds="<>int (csValBinds c)-                       , "jbinds="<>int (csJoinBinds c)+        <>braces (hsep [ "terms="<>pretty (csTerms c)+                       , "types="<>pretty (csTypes c)+                       , "cos="<>pretty (csCoercions c)+                       , "vbinds="<>pretty (csValBinds c)+                       , "jbinds="<>pretty (csJoinBinds c)                        ]) -pprIdInfo :: PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc+pprIdInfo :: PrettyOpts -> IdInfo Binder Binder -> IdDetails -> Doc ann pprIdInfo opts i d-  | not $ showIdInfo opts = empty+  | not $ showIdInfo opts = mempty   | otherwise = comment $ "IdInfo:" <+> align doc   where     doc = sep $ punctuate ", "@@ -99,7 +98,7 @@             , "unfolding=" <> pprUnfolding opts (idiUnfolding i)             ] ++ (if idiIsOneShot i then ["one-shot"] else []) -pprUnfolding :: PrettyOpts -> Unfolding Binder Binder -> Doc+pprUnfolding :: PrettyOpts -> Unfolding Binder Binder -> Doc ann pprUnfolding _    NoUnfolding = "NoUnfolding" pprUnfolding _    BootUnfolding = "BootUnfolding" pprUnfolding _    OtherCon{} = "OtherCon"@@ -122,7 +121,7 @@         if strong then "Strong Loopbrk" else "Weak Loopbrk"  instance Pretty IdDetails where-    pretty = text . show+    pretty = pretty . show  data TyPrec   -- See Note [Precedence in types] in TyCoRep.hs   = TopPrec         -- No parens@@ -131,10 +130,10 @@   | TyConPrec       -- Tycon args; no parens for atomic   deriving( Eq, Ord ) -pprType :: PrettyOpts -> Type -> Doc+pprType :: PrettyOpts -> Type -> Doc ann pprType opts = pprType' opts TopPrec -pprType' :: PrettyOpts -> TyPrec -> Type -> Doc+pprType' :: PrettyOpts -> TyPrec -> Type -> Doc ann pprType' opts _ (VarTy b)         = pprBinder opts b pprType' opts p t@(FunTy _ _)     = maybeParens (p >= FunPrec) $ sep $ punctuate " ->" (map (pprType' opts FunPrec) (splitFunTys t)) pprType' opts p (TyConApp tc [])  = pretty tc@@ -146,23 +145,23 @@ pprType' opts _ LitTy             = "LIT" pprType' opts _ CoercionTy        = "Co" -maybeParens :: Bool -> Doc -> Doc+maybeParens :: Bool -> Doc ann -> Doc ann maybeParens True  = parens maybeParens False = id  instance Pretty Type where     pretty = pprType defaultPrettyOpts -pprExpr :: PrettyOpts -> Expr -> Doc+pprExpr :: PrettyOpts -> Expr -> Doc ann pprExpr opts = pprExpr' opts False -pprExpr' :: PrettyOpts -> Bool -> Expr -> Doc+pprExpr' :: PrettyOpts -> Bool -> Expr -> Doc ann pprExpr' opts _parens (EVar v)         = pprBinder opts v pprExpr' opts _parens (EVarGlobal v)   = pretty v pprExpr' opts _parens (ELit l)         = pretty l pprExpr' opts parens  e@(EApp{})       = let (x, ys) = collectArgs e                                          in maybeParens parens $ hang' (pprExpr' opts True x) 2 (sep $ map pprArg ys)-  where pprArg (EType t) = char '@' <> pprType' opts TyConPrec t+  where pprArg (EType t) = pretty '@' <> pprType' opts TyConPrec t         pprArg x         = pprExpr' opts True x pprExpr' opts parens  x@(ETyLam _ _)   = let (bs, x') = collectTyBinders x                                          in maybeParens parens@@ -170,7 +169,7 @@ pprExpr' opts parens  x@(ELam _ _)     = let (bs, x') = collectBinders x                                          in maybeParens parens                                             $ hang' ("λ" <+> sep (map (pprBinder opts) bs) <+> smallRArrow) 2 (pprExpr' opts False x')-pprExpr' opts parens  (ELet xs y)      = maybeParens parens $ "let" <+> (align $ vcat $ map (uncurry (pprBinding opts)) xs)+pprExpr' opts parens  (ELet xs y)      = maybeParens parens $ "let" <> (align $ vcat $ map (uncurry (pprBinding opts)) xs)                                          <$$> "in" <+> align (pprExpr' opts False y)   where pprBind (b, rhs) = pprBinder opts b <+> equals <+> align (pprExpr' opts False rhs) pprExpr' opts parens  (ECase x b alts) = maybeParens parens@@ -180,18 +179,23 @@                                                , "}"                                                ]   where pprAlt (Alt con bndrs rhs) = hang' (hsep (pretty con : map (pprBinder opts) bndrs) <+> smallRArrow) 2 (pprExpr' opts False rhs)+pprExpr' opts parens  (ETick tick e)   = maybeParens parens+                                         $ sep [ "<" <> pprTick tick <> ">", pprExpr' opts parens e ] pprExpr' opts parens  (EType t)        = maybeParens parens $ "TYPE:" <+> pprType opts t pprExpr' opts parens  ECoercion        = "CO" +pprTick :: Tick -> Doc ann+pprTick (SourceNote n) = "srcnote"+ instance Pretty AltCon where-    pretty (AltDataCon t) = text $ T.unpack t+    pretty (AltDataCon t) = pretty $ T.unpack t     pretty (AltLit l) = pretty l-    pretty AltDefault = text "DEFAULT"+    pretty AltDefault = "DEFAULT"  instance Pretty Expr where     pretty = pprExpr defaultPrettyOpts -pprTopBinding :: PrettyOpts -> TopBinding -> Doc+pprTopBinding :: PrettyOpts -> TopBinding -> Doc ann pprTopBinding opts tb =     case tb of       NonRecTopBinding b s rhs -> pprTopBind (b,s,rhs)@@ -204,11 +208,11 @@         <$$> hang' (pprBinder opts b <+> equals) 2 (pprExpr opts rhs)         <> line -pprTypeSig :: PrettyOpts -> Binder -> Doc+pprTypeSig :: PrettyOpts -> Binder -> Doc ann pprTypeSig opts b@(Bndr b') =     pprBinder opts b <+> dcolon <+> align (pprType opts (binderType b')) -pprBinding :: PrettyOpts -> Binder -> Expr -> Doc+pprBinding :: PrettyOpts -> Binder -> Expr -> Doc ann pprBinding opts b@(Bndr b'@Binder{}) rhs =     ppWhen (showLetTypes opts) (pprTypeSig opts b)     <$$> pprIdInfo opts (binderIdInfo b') (binderIdDetails b')@@ -220,27 +224,27 @@ instance Pretty TopBinding where     pretty = pprTopBinding defaultPrettyOpts -pprModule :: PrettyOpts -> Module -> Doc+pprModule :: PrettyOpts -> Module -> Doc ann pprModule opts m =     comment (pretty $ modulePhase m)-    <$$> text "module" <+> pretty (moduleName m) <+> "where" <> line+    <$$> "module" <+> pretty (moduleName m) <+> "where" <> line     <$$> vsep (map (pprTopBinding opts) (moduleTopBindings m))  instance Pretty Module where     pretty = pprModule defaultPrettyOpts -comment :: Doc -> Doc+comment :: Doc ann -> Doc ann comment x = "{-" <+> x <+> "-}" -dcolon :: Doc+dcolon :: Doc ann dcolon = "::" -smallRArrow :: Doc+smallRArrow :: Doc ann smallRArrow = "→" -hang' :: Doc -> Int -> Doc -> Doc+hang' :: Doc ann -> Int -> Doc ann -> Doc ann hang' d1 n d2 = hang n $ sep [d1, d2] -ppWhen :: Bool -> Doc -> Doc+ppWhen :: Bool -> Doc ann -> Doc ann ppWhen True x = x-ppWhen False _ = empty+ppWhen False _ = mempty

@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module GhcDump.ToHtml (topBindingsToHtml, exprToHtml) where++import Data.List+import Lucid+import GhcDump.Ast+import GhcDump.Util+import qualified Data.ByteString.Char8 as BS+import qualified Data.Text as T+import Data.Monoid ((<>))+import Prelude++topBindingsToHtml :: [TopBinding] -> Html ()+topBindingsToHtml = foldMap topBindingToHtml++topBindingToHtml :: TopBinding -> Html ()+topBindingToHtml = mapM_ (\(bndr, _, rhs) -> bindingToHtml bndr rhs) . topBindings++divClass :: T.Text -> Html a -> Html a+divClass cls contents = div_ [class_ cls] contents++spanClass :: T.Text -> Html a -> Html a+spanClass cls contents = span_ [class_ cls] contents++keyword :: Html a -> Html a+keyword = divClass "kw"++lambda :: Html ()+lambda = "λ "++rarrow :: Html ()+rarrow = " → "++spaced :: Html () -> Html ()+spaced x = " " <> x <> " "++exprToHtml :: Expr -> Html ()+exprToHtml (EVar v) = bndrToHtml v+exprToHtml (EVarGlobal v) = externalNameToHtml v+exprToHtml (ELit lit) = litToHtml lit+exprToHtml e@(EApp _ _)+  | (x, ys) <- collectArgs e+  = divClass "app" $ do+    exprToHtml x+    " "+    mconcat $ intersperse " " $ map exprToHtml ys+exprToHtml e@(ETyLam _ _)+  | (bndrs, rhs) <- collectTyBinders e+  = divClass "lam" $ do+    lambda+    bndrsToHtml bndrs+    rarrow+    divClass "rhs" $ exprToHtml rhs+exprToHtml e@(ELam _ _)+  | (bndrs, rhs) <- collectBinders e+  = divClass "lam" $ do+    lambda+    bndrsToHtml bndrs+    rarrow+    divClass "rhs" $ exprToHtml rhs+exprToHtml (ELet bs e) = divClass "let" $ do+    keyword "let "+    divClass "binds" $ foldMap (uncurry bindingToHtml) bs+    keyword " in "+    divClass "body" $ exprToHtml e+exprToHtml (ECase scrut b alts) = divClass "case" $ do+    keyword "case "+    divClass "scrut" $ exprToHtml scrut+    keyword " of "+    divClass "alts" $ mapM_ altToHtml alts+exprToHtml (ETick tick e) = divClass "tick" $ do+    keyword "tick "+    exprToHtml e+exprToHtml (EType ty) = divClass "type" $ typeToHtml ty+exprToHtml (ECoercion) = "$co"++bndrToHtml :: Binder -> Html ()+bndrToHtml bndr =+    sigil <> divClass "bndr" (toHtml (binderUniqueName bndr))+  where+    sigil+      | isTyBinder bndr = "@"+      | otherwise = mempty++bndrsToHtml :: [Binder] -> Html ()+bndrsToHtml bndrs =+  divClass "bndrs" $ foldMap (spaced . bndrToHtml) bndrs++typeSigToHtml :: Binder -> Type -> Html ()+typeSigToHtml bndr ty = divClass "sig" $ do+  bndrToHtml bndr+  " :: "+  typeToHtml ty++bindingToHtml :: Binder -> Expr -> Html ()+bindingToHtml bndr rhs = divClass "bind" $ do+  bndrToHtml bndr+  " = "+  divClass "rhs" $ exprToHtml rhs++moduleNameToHtml :: ModuleName -> Html ()+moduleNameToHtml m =+  divClass "mod" $ toHtml $ getModuleName m++externalNameToHtml :: ExternalName -> Html ()+externalNameToHtml (ExternalName mod nam _) =+  divClass "ext-name" $ moduleNameToHtml mod <> "." <> toHtml nam+externalNameToHtml (ForeignCall) =+  "$foreign-call"++altToHtml :: Alt -> Html ()+altToHtml Alt{..} = div_ $ do+  case altCon of+    AltDataCon dc -> divClass "datacon" $ toHtml dc+    AltLit lit -> litToHtml lit+    AltDefault -> divClass "kw" "DEFAULT"+  bndrsToHtml altBinders+  rarrow+  divClass "rhs" $ exprToHtml altRHS++typeToHtml :: Type -> Html ()+typeToHtml (VarTy v) = bndrToHtml v+typeToHtml t@(FunTy _ _)+  | ts <- splitFunTys t+  = divClass "funty" $ mconcat $ intersperse rarrow $ map typeToHtml ts+typeToHtml (TyConApp tc tys)+  = divClass "tyconapp" $ tyConToHtml tc <> " " <> mconcat (intersperse " " (map typeToHtml tys))+typeToHtml (AppTy a b)+  = divClass "appty" $ typeToHtml a <> typeToHtml b+typeToHtml t@(ForAllTy _ _)+  | (bndrs, ty) <- splitForAlls t+  = divClass "forallty" $ do+    keyword "forall "+    bndrsToHtml bndrs+    ". "+    typeToHtml t+typeToHtml (LitTy) = "LIT"+typeToHtml (CoercionTy) = "COERCION"++tyConToHtml :: TyCon -> Html ()+tyConToHtml (TyCon name _) = divClass "tycon" $ toHtml name++litToHtml :: Lit -> Html ()+litToHtml (MachChar c) = "'" <> toHtml [c] <> "'"+litToHtml (MachStr s) = "'" <> toHtml (BS.unpack s) <> "'"+litToHtml (MachNullAddr) = "$nullAddr"+litToHtml (MachInt n) = showHtml n <> "#"+litToHtml (MachInt64 n) = showHtml n <> "#"+litToHtml (MachWord n) = showHtml n <> "##"+litToHtml (MachWord64 n) = showHtml n <> "##64"+litToHtml (MachFloat n) = showHtml (realToFrac n :: Double) <> "##"+litToHtml (MachDouble n) = showHtml (realToFrac n :: Double) <> "##"+litToHtml (MachLabel s) = "&" <> toHtml s+litToHtml (LitInteger n) = showHtml n+litToHtml (LitNatural n) = showHtml n++showHtml :: Show a => a -> Html ()+showHtml = toHtml . show