{-# 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 :: [TopBinding] -> Html ()
topBindingsToHtml = (TopBinding -> Html ()) -> [TopBinding] -> Html ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TopBinding -> Html ()
topBindingToHtml

topBindingToHtml :: TopBinding -> Html ()
topBindingToHtml :: TopBinding -> Html ()
topBindingToHtml = ((Binder, CoreStats, Expr) -> Html ())
-> [(Binder, CoreStats, Expr)] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Binder
bndr, CoreStats
_, Expr
rhs) -> Binder -> Expr -> Html ()
bindingToHtml Binder
bndr Expr
rhs) ([(Binder, CoreStats, Expr)] -> Html ())
-> (TopBinding -> [(Binder, CoreStats, Expr)])
-> TopBinding
-> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopBinding -> [(Binder, CoreStats, Expr)]
forall bndr var.
TopBinding' bndr var -> [(bndr, CoreStats, Expr' bndr var)]
topBindings

divClass :: T.Text -> Html a -> Html a
divClass :: Text -> Html a -> Html a
divClass Text
cls Html a
contents = [Attribute] -> Html a -> Html a
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
cls] Html a
contents

spanClass :: T.Text -> Html a -> Html a
spanClass :: Text -> Html a -> Html a
spanClass Text
cls Html a
contents = [Attribute] -> Html a -> Html a
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
cls] Html a
contents

keyword :: Html a -> Html a
keyword :: Html a -> Html a
keyword = Text -> Html a -> Html a
forall a. Text -> Html a -> Html a
divClass Text
"kw"

lambda :: Html ()
lambda :: Html ()
lambda = Html ()
"λ "

rarrow :: Html ()
rarrow :: Html ()
rarrow = Html ()
" → "

spaced :: Html () -> Html ()
spaced :: Html () -> Html ()
spaced Html ()
x = Html ()
" " Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
x Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
" "

exprToHtml :: Expr -> Html ()
exprToHtml :: Expr -> Html ()
exprToHtml (EVar Binder
v) = Binder -> Html ()
bndrToHtml Binder
v
exprToHtml (EVarGlobal ExternalName
v) = ExternalName -> Html ()
externalNameToHtml ExternalName
v
exprToHtml (ELit Lit
lit) = Lit -> Html ()
litToHtml Lit
lit
exprToHtml e :: Expr
e@(EApp Expr
_ Expr
_)
  | (Expr
x, [Expr]
ys) <- Expr -> (Expr, [Expr])
forall bndr var.
Expr' bndr var -> (Expr' bndr var, [Expr' bndr var])
collectArgs Expr
e
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"app" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Expr -> Html ()
exprToHtml Expr
x
    Html ()
" "
    [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat ([Html ()] -> Html ()) -> [Html ()] -> Html ()
forall a b. (a -> b) -> a -> b
$ Html () -> [Html ()] -> [Html ()]
forall a. a -> [a] -> [a]
intersperse Html ()
" " ([Html ()] -> [Html ()]) -> [Html ()] -> [Html ()]
forall a b. (a -> b) -> a -> b
$ (Expr -> Html ()) -> [Expr] -> [Html ()]
forall a b. (a -> b) -> [a] -> [b]
map Expr -> Html ()
exprToHtml [Expr]
ys
exprToHtml e :: Expr
e@(ETyLam Binder
_ Expr
_)
  | ([Binder]
bndrs, Expr
rhs) <- Expr -> ([Binder], Expr)
forall bndr var. Expr' bndr var -> ([bndr], Expr' bndr var)
collectTyBinders Expr
e
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"lam" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html ()
lambda
    [Binder] -> Html ()
bndrsToHtml [Binder]
bndrs
    Html ()
rarrow
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"rhs" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
rhs
exprToHtml e :: Expr
e@(ELam Binder
_ Expr
_)
  | ([Binder]
bndrs, Expr
rhs) <- Expr -> ([Binder], Expr)
forall bndr var. Expr' bndr var -> ([bndr], Expr' bndr var)
collectBinders Expr
e
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"lam" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html ()
lambda
    [Binder] -> Html ()
bndrsToHtml [Binder]
bndrs
    Html ()
rarrow
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"rhs" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
rhs
exprToHtml (ELet [(Binder, Expr)]
bs Expr
e) = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"let" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
"let "
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"binds" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ ((Binder, Expr) -> Html ()) -> [(Binder, Expr)] -> Html ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Binder -> Expr -> Html ()) -> (Binder, Expr) -> Html ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Binder -> Expr -> Html ()
bindingToHtml) [(Binder, Expr)]
bs
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
" in "
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"body" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
e
exprToHtml (ECase Expr
scrut Binder
b [Alt' Binder Binder]
alts) = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"case" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
"case "
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"scrut" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
scrut
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
" of "
    Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"alts" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Alt' Binder Binder -> Html ()) -> [Alt' Binder Binder] -> Html ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Alt' Binder Binder -> Html ()
altToHtml [Alt' Binder Binder]
alts
exprToHtml (ETick Tick
tick Expr
e) = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"tick" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
"tick "
    Expr -> Html ()
exprToHtml Expr
e
exprToHtml (EType Type' Binder Binder
ty) = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"type" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Type' Binder Binder -> Html ()
typeToHtml Type' Binder Binder
ty
exprToHtml (Expr
ECoercion) = Html ()
"$co"

bndrToHtml :: Binder -> Html ()
bndrToHtml :: Binder -> Html ()
bndrToHtml Binder
bndr =
    Html ()
sigil Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"bndr" (Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Binder -> Text
binderUniqueName Binder
bndr))
  where
    sigil :: Html ()
sigil
      | Binder -> Bool
isTyBinder Binder
bndr = Html ()
"@"
      | Bool
otherwise = Html ()
forall a. Monoid a => a
mempty

bndrsToHtml :: [Binder] -> Html ()
bndrsToHtml :: [Binder] -> Html ()
bndrsToHtml [Binder]
bndrs =
  Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"bndrs" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ (Binder -> Html ()) -> [Binder] -> Html ()
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Html () -> Html ()
spaced (Html () -> Html ()) -> (Binder -> Html ()) -> Binder -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder -> Html ()
bndrToHtml) [Binder]
bndrs

typeSigToHtml :: Binder -> Type -> Html ()
typeSigToHtml :: Binder -> Type' Binder Binder -> Html ()
typeSigToHtml Binder
bndr Type' Binder Binder
ty = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"sig" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
  Binder -> Html ()
bndrToHtml Binder
bndr
  Html ()
" :: "
  Type' Binder Binder -> Html ()
typeToHtml Type' Binder Binder
ty

bindingToHtml :: Binder -> Expr -> Html ()
bindingToHtml :: Binder -> Expr -> Html ()
bindingToHtml Binder
bndr Expr
rhs = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"bind" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
  Binder -> Html ()
bndrToHtml Binder
bndr
  Html ()
" = "
  Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"rhs" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
rhs

moduleNameToHtml :: ModuleName -> Html ()
moduleNameToHtml :: ModuleName -> Html ()
moduleNameToHtml ModuleName
m =
  Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"mod" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (Text -> Html ()) -> Text -> Html ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> Text
getModuleName ModuleName
m

externalNameToHtml :: ExternalName -> Html ()
externalNameToHtml :: ExternalName -> Html ()
externalNameToHtml (ExternalName ModuleName
mod Text
nam Unique
_) =
  Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"ext-name" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ ModuleName -> Html ()
moduleNameToHtml ModuleName
mod Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"." Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
nam
externalNameToHtml (ExternalName
ForeignCall) =
  Html ()
"$foreign-call"

altToHtml :: Alt -> Html ()
altToHtml :: Alt' Binder Binder -> Html ()
altToHtml Alt{[Binder]
Expr
AltCon
altCon :: forall bndr var. Alt' bndr var -> AltCon
altBinders :: forall bndr var. Alt' bndr var -> [bndr]
altRHS :: forall bndr var. Alt' bndr var -> Expr' bndr var
altRHS :: Expr
altBinders :: [Binder]
altCon :: AltCon
..} = Html () -> Html ()
forall arg result. Term arg result => arg -> result
div_ (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
  case AltCon
altCon of
    AltDataCon Text
dc -> Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"datacon" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
dc
    AltLit Lit
lit -> Lit -> Html ()
litToHtml Lit
lit
    AltCon
AltDefault -> Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"kw" Html ()
"DEFAULT"
  [Binder] -> Html ()
bndrsToHtml [Binder]
altBinders
  Html ()
rarrow
  Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"rhs" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Expr -> Html ()
exprToHtml Expr
altRHS

typeToHtml :: Type -> Html ()
typeToHtml :: Type' Binder Binder -> Html ()
typeToHtml (VarTy Binder
v) = Binder -> Html ()
bndrToHtml Binder
v
typeToHtml t :: Type' Binder Binder
t@(FunTy Type' Binder Binder
_ Type' Binder Binder
_)
  | [Type' Binder Binder]
ts <- Type' Binder Binder -> [Type' Binder Binder]
forall bndr var. Type' bndr var -> [Type' bndr var]
splitFunTys Type' Binder Binder
t
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"funty" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat ([Html ()] -> Html ()) -> [Html ()] -> Html ()
forall a b. (a -> b) -> a -> b
$ Html () -> [Html ()] -> [Html ()]
forall a. a -> [a] -> [a]
intersperse Html ()
rarrow ([Html ()] -> [Html ()]) -> [Html ()] -> [Html ()]
forall a b. (a -> b) -> a -> b
$ (Type' Binder Binder -> Html ())
-> [Type' Binder Binder] -> [Html ()]
forall a b. (a -> b) -> [a] -> [b]
map Type' Binder Binder -> Html ()
typeToHtml [Type' Binder Binder]
ts
typeToHtml (TyConApp TyCon
tc [Type' Binder Binder]
tys)
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"tyconapp" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ TyCon -> Html ()
tyConToHtml TyCon
tc Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
" " Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> [Html ()] -> Html ()
forall a. Monoid a => [a] -> a
mconcat (Html () -> [Html ()] -> [Html ()]
forall a. a -> [a] -> [a]
intersperse Html ()
" " ((Type' Binder Binder -> Html ())
-> [Type' Binder Binder] -> [Html ()]
forall a b. (a -> b) -> [a] -> [b]
map Type' Binder Binder -> Html ()
typeToHtml [Type' Binder Binder]
tys))
typeToHtml (AppTy Type' Binder Binder
a Type' Binder Binder
b)
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"appty" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Type' Binder Binder -> Html ()
typeToHtml Type' Binder Binder
a Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Type' Binder Binder -> Html ()
typeToHtml Type' Binder Binder
b
typeToHtml t :: Type' Binder Binder
t@(ForAllTy Binder
_ Type' Binder Binder
_)
  | ([Binder]
bndrs, Type' Binder Binder
ty) <- Type' Binder Binder -> ([Binder], Type' Binder Binder)
forall bndr var. Type' bndr var -> ([bndr], Type' bndr var)
splitForAlls Type' Binder Binder
t
  = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"forallty" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ do
    Html () -> Html ()
forall a. Html a -> Html a
keyword Html ()
"forall "
    [Binder] -> Html ()
bndrsToHtml [Binder]
bndrs
    Html ()
". "
    Type' Binder Binder -> Html ()
typeToHtml Type' Binder Binder
t
typeToHtml (Type' Binder Binder
LitTy) = Html ()
"LIT"
typeToHtml (Type' Binder Binder
CoercionTy) = Html ()
"COERCION"

tyConToHtml :: TyCon -> Html ()
tyConToHtml :: TyCon -> Html ()
tyConToHtml (TyCon Text
name Unique
_) = Text -> Html () -> Html ()
forall a. Text -> Html a -> Html a
divClass Text
"tycon" (Html () -> Html ()) -> Html () -> Html ()
forall a b. (a -> b) -> a -> b
$ Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
name

litToHtml :: Lit -> Html ()
litToHtml :: Lit -> Html ()
litToHtml (MachChar Char
c) = Html ()
"'" Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> [Char] -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml [Char
c] Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"'"
litToHtml (MachStr ByteString
s) = Html ()
"'" Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> [Char] -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml (ByteString -> [Char]
BS.unpack ByteString
s) Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"'"
litToHtml (Lit
MachNullAddr) = Html ()
"$nullAddr"
litToHtml (MachInt Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"#"
litToHtml (MachInt64 Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"#"
litToHtml (MachWord Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"##"
litToHtml (MachWord64 Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"##64"
litToHtml (MachFloat Rational
n) = Double -> Html ()
forall a. Show a => a -> Html ()
showHtml (Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
n :: Double) Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"##"
litToHtml (MachDouble Rational
n) = Double -> Html ()
forall a. Show a => a -> Html ()
showHtml (Rational -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac Rational
n :: Double) Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Html ()
"##"
litToHtml (MachLabel Text
s) = Html ()
"&" Html () -> Html () -> Html ()
forall a. Semigroup a => a -> a -> a
<> Text -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml Text
s
litToHtml (LitInteger Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n
litToHtml (LitNatural Integer
n) = Integer -> Html ()
forall a. Show a => a -> Html ()
showHtml Integer
n

showHtml :: Show a => a -> Html ()
showHtml :: a -> Html ()
showHtml = [Char] -> Html ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
toHtml ([Char] -> Html ()) -> (a -> [Char]) -> a -> Html ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Char]
forall a. Show a => a -> [Char]
show