diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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) diff --git a/ghc-dump-util.cabal b/ghc-dump-util.cabal --- a/ghc-dump-util.cabal +++ b/ghc-dump-util.cabal @@ -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 diff --git a/src/GhcDump/Pretty.hs b/src/GhcDump/Pretty.hs --- a/src/GhcDump/Pretty.hs +++ b/src/GhcDump/Pretty.hs @@ -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 = "" 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 diff --git a/src/GhcDump/ToHtml.hs b/src/GhcDump/ToHtml.hs new file mode 100644 --- /dev/null +++ b/src/GhcDump/ToHtml.hs @@ -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