{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module DumpCore(plugin) where

import GhcPlugins hiding (TB)
import Unique(unpkUnique)
import Demand
import Outputable
import CoreStats
import CoreMonad(getHscEnv)
import HscTypes(CgGuts(..))


import qualified Data.Aeson as JS
import qualified Data.Aeson.Types as JS
import           Data.Aeson ((.=), ToJSON(toJSON))
import           Data.Text(Text)
import qualified Data.Text as Text
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Char8 as BS8
import           Data.Maybe(mapMaybe)
import           MonadLib
import           Data.Map ( Map )
import qualified Data.Map as Map
import           Control.Monad(unless)
import           System.FilePath
import           System.Directory

import Paths_dump_core

plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin { installCoreToDos :: CorePlugin
installCoreToDos = CorePlugin
install }

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: CorePlugin
install [CommandLineOption]
opts [CoreToDo]
todo =
  [CoreToDo] -> CoreM [CoreToDo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([CoreToDo]
todo [CoreToDo] -> [CoreToDo] -> [CoreToDo]
forall a. [a] -> [a] -> [a]
++ [ CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
"DumpCore" (IO ModGuts -> CoreM ModGuts
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ModGuts -> CoreM ModGuts)
-> (ModGuts -> IO ModGuts) -> CorePluginPass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CommandLineOption] -> ModGuts -> IO ModGuts
dumpIn [CommandLineOption]
opts) ])

dumpIn :: [CommandLineOption] -> ModGuts -> IO ModGuts
dumpIn :: [CommandLineOption] -> ModGuts -> IO ModGuts
dumpIn [CommandLineOption]
opts ModGuts
guts =
  do let mod :: M
mod        = ModGuts -> M
cvtM ModGuts
guts
         file :: CommandLineOption
file       = ModuleName -> CommandLineOption
moduleNameString (Module -> ModuleName
moduleName (ModGuts -> Module
mg_module ModGuts
guts))
         htmlDir :: CommandLineOption
htmlDir    = case [CommandLineOption]
opts of
                        []    -> CommandLineOption
"dump-core"
                        CommandLineOption
x : [CommandLineOption]
_ -> CommandLineOption
x

     CommandLineOption -> IO ()
installLibFiles CommandLineOption
htmlDir

     let jsDir :: CommandLineOption
jsDir = CommandLineOption
htmlDir CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
"js"
     Bool -> CommandLineOption -> IO ()
createDirectoryIfMissing Bool
True CommandLineOption
jsDir

     let js_file :: CommandLineOption
js_file = CommandLineOption
jsDir CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
file CommandLineOption -> CommandLineOption -> CommandLineOption
<.> CommandLineOption
"js"
     CommandLineOption -> ByteString -> IO ()
BS.writeFile CommandLineOption
js_file (ByteString
"var it = " ByteString -> ByteString -> ByteString
`BS.append` M -> ByteString
forall a. ToJSON a => a -> ByteString
JS.encode M
mod)

     -- The wrapper assumes `js` and `lib` as sub-directories of html
     let html_file :: CommandLineOption
html_file  = CommandLineOption
htmlDir CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
file CommandLineOption -> CommandLineOption -> CommandLineOption
<.> CommandLineOption
"html"
     CommandLineOption -> ByteString -> IO ()
BS8.writeFile CommandLineOption
html_file (CommandLineOption -> ByteString
htmlWrapper CommandLineOption
file)

     ModGuts -> IO ModGuts
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts


installLibFiles :: FilePath -> IO ()
installLibFiles :: CommandLineOption -> IO ()
installLibFiles CommandLineOption
libDir =
  (CommandLineOption -> IO ()) -> [CommandLineOption] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (CommandLineOption -> CommandLineOption -> IO ()
copyLibFile CommandLineOption
libDir) [ CommandLineOption
"ui/see.js"
                             , CommandLineOption
"ui/see.css"
                             , CommandLineOption
"ui/jquery.js"
                             , CommandLineOption
"ui/fonts/FiraMono-Regular.ttf"
                             , CommandLineOption
"ui/fonts/FiraMono-Bold.ttf" ]

copyLibFile :: FilePath -> FilePath -> IO ()
copyLibFile :: CommandLineOption -> CommandLineOption -> IO ()
copyLibFile CommandLineOption
outDir CommandLineOption
file =
  do CommandLineOption
path <- CommandLineOption -> IO CommandLineOption
getDataFileName CommandLineOption
file
     let outFile :: CommandLineOption
outFile = CommandLineOption
outDir CommandLineOption -> CommandLineOption -> CommandLineOption
</> CommandLineOption
file
     Bool
done <- CommandLineOption -> IO Bool
doesFileExist CommandLineOption
outFile
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
done (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Bool -> CommandLineOption -> IO ()
createDirectoryIfMissing Bool
True (CommandLineOption -> CommandLineOption
takeDirectory CommandLineOption
outFile)
                      CommandLineOption -> CommandLineOption -> IO ()
copyFile CommandLineOption
path CommandLineOption
outFile


--------------------------------------------------------------------------------

type CvtM = ReaderT RO (StateT Int Maybe)

data RO = RO
  { RO -> Map Var V
roVars :: Map Var V    -- ^ Mapping from GHC vars to V
  , RO -> Map Text Int
roTxt  :: Map Text Int -- ^ how many times is this string in scope
  }


data M = M Module [TB]

data E = EVar V
       | EGlob Var
       | ELit Literal
       | EApp E [E]
       | ELam [BindVar] E
       | ELet B E
       | ECase E BindVar [A]

data V       = V Int Var Text
data BindVar = BindVar Int BindingSite Var Text

data A  = A AltCon [BindVar] E
data B  = B Bool [(BindVar,E)]
data TB = TB Bool [(BindVar,CoreStats,E)]

cvtM :: ModGuts -> M
cvtM :: ModGuts -> M
cvtM ModGuts
gs = Module -> [TB] -> M
M (ModGuts -> Module
mg_module ModGuts
gs) ((TB -> [TB] -> [TB]) -> [TB] -> [TB] -> [TB]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TB -> [TB] -> [TB]
jn [] [TB]
bs)
  where
  jn :: TB -> [TB] -> [TB]
jn (TB Bool
False [(BindVar, CoreStats, E)]
xs) (TB Bool
False [(BindVar, CoreStats, E)]
ys : [TB]
more) = Bool -> [(BindVar, CoreStats, E)] -> TB
TB Bool
False ([(BindVar, CoreStats, E)]
xs [(BindVar, CoreStats, E)]
-> [(BindVar, CoreStats, E)] -> [(BindVar, CoreStats, E)]
forall a. [a] -> [a] -> [a]
++ [(BindVar, CoreStats, E)]
ys) TB -> [TB] -> [TB]
forall a. a -> [a] -> [a]
: [TB]
more
  jn TB
x [TB]
y                                = TB
x TB -> [TB] -> [TB]
forall a. a -> [a] -> [a]
: [TB]
y

  mkBV :: Var -> BindVar
mkBV Var
x = Int -> BindingSite -> Var -> Text -> BindVar
BindVar Int
0 BindingSite
LetBind Var
x (Var -> Text
txtName Var
x)

  mkBind :: Bind Var -> [BindVar]
mkBind (NonRec Var
x Expr Var
_) = [Var -> BindVar
mkBV Var
x]
  mkBind (Rec [(Var, Expr Var)]
xs)     = ((Var, Expr Var) -> BindVar) -> [(Var, Expr Var)] -> [BindVar]
forall a b. (a -> b) -> [a] -> [b]
map (Var -> BindVar
mkBV (Var -> BindVar)
-> ((Var, Expr Var) -> Var) -> (Var, Expr Var) -> BindVar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst) [(Var, Expr Var)]
xs

  act :: CvtM [TB]
act = let bs :: [[BindVar]]
bs = (Bind Var -> [BindVar]) -> [Bind Var] -> [[BindVar]]
forall a b. (a -> b) -> [a] -> [b]
map Bind Var -> [BindVar]
mkBind (ModGuts -> [Bind Var]
mg_binds ModGuts
gs)
        in [BindVar] -> ([BindVar] -> CvtM [TB]) -> CvtM [TB]
forall a. [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars ([[BindVar]] -> [BindVar]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BindVar]]
bs) (([BindVar] -> CvtM [TB]) -> CvtM [TB])
-> ([BindVar] -> CvtM [TB]) -> CvtM [TB]
forall a b. (a -> b) -> a -> b
$ \[BindVar]
_ -> (Bind Var -> ReaderT RO (StateT Int Maybe) TB)
-> [Bind Var] -> CvtM [TB]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Bind Var -> ReaderT RO (StateT Int Maybe) TB
cvtTB (ModGuts -> [Bind Var]
mg_binds ModGuts
gs)

  ro0 :: RO
ro0 = RO :: Map Var V -> Map Text Int -> RO
RO { roVars :: Map Var V
roVars = Map Var V
forall k a. Map k a
Map.empty, roTxt :: Map Text Int
roTxt = Map Text Int
forall k a. Map k a
Map.empty }
  bs :: [TB]
bs  = case Int -> StateT Int Maybe [TB] -> Maybe ([TB], Int)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT Int
1 (RO -> CvtM [TB] -> StateT Int Maybe [TB]
forall i (m :: * -> *) a. i -> ReaderT i m a -> m a
runReaderT RO
ro0 CvtM [TB]
act) of
               Maybe ([TB], Int)
Nothing    -> []
               Just ([TB]
a,Int
_) -> [TB]
a

txtName :: Var -> Text
txtName :: Var -> Text
txtName = CommandLineOption -> Text
Text.pack (CommandLineOption -> Text)
-> (Var -> CommandLineOption) -> Var -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> CommandLineOption
occNameString (OccName -> CommandLineOption)
-> (Var -> OccName) -> Var -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName (Name -> OccName) -> (Var -> Name) -> Var -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Var -> Name
varName



newBindVar :: BindingSite -> Var -> CvtM BindVar
newBindVar :: BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
bs Var
v =
  do Int
i <- (Int -> (Int, Int)) -> ReaderT RO (StateT Int Maybe) Int
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets ((Int -> (Int, Int)) -> ReaderT RO (StateT Int Maybe) Int)
-> (Int -> (Int, Int)) -> ReaderT RO (StateT Int Maybe) Int
forall a b. (a -> b) -> a -> b
$ \Int
i -> (Int
i,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
     BindVar -> CvtM BindVar
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> BindingSite -> Var -> Text -> BindVar
BindVar Int
i BindingSite
bs Var
v Text
"")

withBindVar :: BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar :: BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar b :: BindVar
b@(BindVar Int
i BindingSite
s Var
v Text
_) BindVar -> CvtM a
m =
  do RO
scope <- ReaderT RO (StateT Int Maybe) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     let txt :: Text
txt = Var -> Text
txtName Var
v
         nm :: Text
nm = case Map Text Int
mp Map Text Int -> Text -> Int
forall k a. Ord k => Map k a -> k -> a
Map.! Text
txt of
                Int
1 -> Text
txt
                Int
n -> Text
txt Text -> Text -> Text
`Text.append` CommandLineOption -> Text
Text.pack (CommandLineOption
"_" CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Int
n)
         mp :: Map Text Int
mp = (Int -> Int -> Int) -> Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Text
txt Int
1 (RO -> Map Text Int
roTxt RO
scope)
         ro :: RO
ro = RO :: Map Var V -> Map Text Int -> RO
RO { roVars :: Map Var V
roVars = Var -> V -> Map Var V -> Map Var V
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Var
v (Int -> Var -> Text -> V
V Int
i Var
v Text
nm) (RO -> Map Var V
roVars RO
scope)
                 , roTxt :: Map Text Int
roTxt  = Map Text Int
mp
                 }
     RO -> CvtM a -> CvtM a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local RO
ro (BindVar -> CvtM a
m (Int -> BindingSite -> Var -> Text -> BindVar
BindVar Int
i BindingSite
s Var
v Text
nm))

withBindVars :: [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars :: [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars [BindVar]
bs [BindVar] -> CvtM a
m =
  case [BindVar]
bs of
    []     -> [BindVar] -> CvtM a
m []
    BindVar
x : [BindVar]
xs -> BindVar -> (BindVar -> CvtM a) -> CvtM a
forall a. BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar  BindVar
x  ((BindVar -> CvtM a) -> CvtM a) -> (BindVar -> CvtM a) -> CvtM a
forall a b. (a -> b) -> a -> b
$ \BindVar
x1 ->
              [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
forall a. [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars [BindVar]
xs (([BindVar] -> CvtM a) -> CvtM a)
-> ([BindVar] -> CvtM a) -> CvtM a
forall a b. (a -> b) -> a -> b
$ \[BindVar]
xs1 -> [BindVar] -> CvtM a
m (BindVar
x1BindVar -> [BindVar] -> [BindVar]
forall a. a -> [a] -> [a]
:[BindVar]
xs1)


cvtE :: CoreExpr -> CvtM E
cvtE :: Expr Var -> CvtM E
cvtE Expr Var
expr =
  case Expr Var
expr of

    Var Var
x ->
      do RO
scope <- ReaderT RO (StateT Int Maybe) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
         case Var -> Map Var V -> Maybe V
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Var
x (RO -> Map Var V
roVars RO
scope) of
           Maybe V
Nothing -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> E
EGlob Var
x)
           Just V
v  -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (V -> E
EVar V
v)

    Lit Literal
l -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> E
ELit Literal
l)

    App {} -> Expr Var -> [E] -> CvtM E
cvtApp Expr Var
expr []

    Lam Var
x Expr Var
e
      | Var -> Bool
isTyVar Var
x -> Expr Var -> CvtM E
cvtE Expr Var
e
      | Bool
otherwise ->
        do BindVar
b <- BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
LambdaBind Var
x
           BindVar -> (BindVar -> CvtM E) -> CvtM E
forall a. BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar BindVar
b ((BindVar -> CvtM E) -> CvtM E) -> (BindVar -> CvtM E) -> CvtM E
forall a b. (a -> b) -> a -> b
$ \BindVar
b1 ->
             do E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
                case E
e' of
                  ELam [BindVar]
xs E
e'' -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return ([BindVar] -> E -> E
ELam (BindVar
b1BindVar -> [BindVar] -> [BindVar]
forall a. a -> [a] -> [a]
:[BindVar]
xs) E
e'')
                  E
_ -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return ([BindVar] -> E -> E
ELam [BindVar
b1] E
e')

    Let Bind Var
b Expr Var
e ->
      do B Bool
isRec [(BindVar, E)]
defs <- Bind Var -> CvtM B
cvtB Bind Var
b
         [BindVar] -> ([BindVar] -> CvtM E) -> CvtM E
forall a. [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars (((BindVar, E) -> BindVar) -> [(BindVar, E)] -> [BindVar]
forall a b. (a -> b) -> [a] -> [b]
map (BindVar, E) -> BindVar
forall a b. (a, b) -> a
fst [(BindVar, E)]
defs) (([BindVar] -> CvtM E) -> CvtM E)
-> ([BindVar] -> CvtM E) -> CvtM E
forall a b. (a -> b) -> a -> b
$ \[BindVar]
defs1 ->
            do let newDefs :: [(BindVar, E)]
newDefs = [BindVar] -> [E] -> [(BindVar, E)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BindVar]
defs1 (((BindVar, E) -> E) -> [(BindVar, E)] -> [E]
forall a b. (a -> b) -> [a] -> [b]
map (BindVar, E) -> E
forall a b. (a, b) -> b
snd [(BindVar, E)]
defs)
               E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
               case E
e' of
                 ELet (B Bool
False [(BindVar, E)]
moreDefs) E
e'' | Bool -> Bool
not Bool
isRec ->
                    E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (B -> E -> E
ELet (Bool -> [(BindVar, E)] -> B
B Bool
False ([(BindVar, E)]
newDefs [(BindVar, E)] -> [(BindVar, E)] -> [(BindVar, E)]
forall a. [a] -> [a] -> [a]
++ [(BindVar, E)]
moreDefs)) E
e'')
                 E
_ -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (B -> E -> E
ELet (Bool -> [(BindVar, E)] -> B
B Bool
isRec [(BindVar, E)]
newDefs) E
e')

    Case Expr Var
e Var
x Type
_ [Alt Var]
as ->
      do E
e'  <- Expr Var -> CvtM E
cvtE Expr Var
e
         BindVar
x'  <- BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
CaseBind Var
x
         BindVar -> (BindVar -> CvtM E) -> CvtM E
forall a. BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar BindVar
x' ((BindVar -> CvtM E) -> CvtM E) -> (BindVar -> CvtM E) -> CvtM E
forall a b. (a -> b) -> a -> b
$ \BindVar
x1 -> do [A]
as' <- (Alt Var -> ReaderT RO (StateT Int Maybe) A)
-> [Alt Var] -> ReaderT RO (StateT Int Maybe) [A]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt Var -> ReaderT RO (StateT Int Maybe) A
cvtA [Alt Var]
as
                                    E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> BindVar -> [A] -> E
ECase E
e' BindVar
x1 [A]
as')

    Cast Expr Var
x Coercion
_    -> Expr Var -> CvtM E
cvtE Expr Var
x

    Tick Tickish Var
_ Expr Var
e    -> Expr Var -> CvtM E
cvtE Expr Var
e

    Type Type
_      -> Maybe E -> CvtM E
forall (m :: * -> *) (n :: * -> *) a. BaseM m n => n a -> m a
inBase Maybe E
forall a. Maybe a
Nothing

    Coercion Coercion
_  -> Maybe E -> CvtM E
forall (m :: * -> *) (n :: * -> *) a. BaseM m n => n a -> m a
inBase Maybe E
forall a. Maybe a
Nothing


cath :: CvtM a -> CvtM (Maybe a)
cath :: CvtM a -> CvtM (Maybe a)
cath CvtM a
m =
  do RO
r <- ReaderT RO (StateT Int Maybe) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     Int
s <- ReaderT RO (StateT Int Maybe) Int
forall (m :: * -> *) i. StateM m i => m i
get
     case Int -> StateT Int Maybe a -> Maybe (a, Int)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT Int
s (RO -> CvtM a -> StateT Int Maybe a
forall i (m :: * -> *) a. i -> ReaderT i m a -> m a
runReaderT RO
r CvtM a
m) of
       Maybe (a, Int)
Nothing -> Maybe a -> CvtM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
       Just (a
a,Int
s1) -> Int -> ReaderT RO (StateT Int Maybe) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set Int
s1 ReaderT RO (StateT Int Maybe) ()
-> CvtM (Maybe a) -> CvtM (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> CvtM (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

cvtTB :: CoreBind -> CvtM TB
cvtTB :: Bind Var -> ReaderT RO (StateT Int Maybe) TB
cvtTB Bind Var
b =
  case Bind Var
b of
    NonRec Var
x Expr Var
e -> do (BindVar, CoreStats, E)
b' <- (Var, Expr Var)
-> ReaderT RO (StateT Int Maybe) (BindVar, CoreStats, E)
cvtSE (Var
x,Expr Var
e)
                     TB -> ReaderT RO (StateT Int Maybe) TB
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(BindVar, CoreStats, E)] -> TB
TB Bool
False [(BindVar, CoreStats, E)
b'])
    Rec [(Var, Expr Var)]
cs     -> do [(BindVar, CoreStats, E)]
bs' <- ((Var, Expr Var)
 -> ReaderT RO (StateT Int Maybe) (BindVar, CoreStats, E))
-> [(Var, Expr Var)]
-> ReaderT RO (StateT Int Maybe) [(BindVar, CoreStats, E)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Var, Expr Var)
-> ReaderT RO (StateT Int Maybe) (BindVar, CoreStats, E)
cvtSE [(Var, Expr Var)]
cs
                     TB -> ReaderT RO (StateT Int Maybe) TB
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(BindVar, CoreStats, E)] -> TB
TB Bool
True [(BindVar, CoreStats, E)]
bs')
  where
  cvtSE :: (Var, Expr Var)
-> ReaderT RO (StateT Int Maybe) (BindVar, CoreStats, E)
cvtSE (Var
x,Expr Var
e) = do RO
scope <- ReaderT RO (StateT Int Maybe) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
                   let V Int
i Var
v Text
t = RO -> Map Var V
roVars RO
scope Map Var V -> Var -> V
forall k a. Ord k => Map k a -> k -> a
Map.! Var
x
                   E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
                   (BindVar, CoreStats, E)
-> ReaderT RO (StateT Int Maybe) (BindVar, CoreStats, E)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> BindingSite -> Var -> Text -> BindVar
BindVar Int
i BindingSite
LetBind Var
v Text
t, Expr Var -> CoreStats
exprStats Expr Var
e, E
e')

cvtB :: CoreBind -> CvtM B
cvtB :: Bind Var -> CvtM B
cvtB Bind Var
bnd =
  case Bind Var
bnd of
    NonRec Var
x Expr Var
e -> do BindVar
x' <- BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
LetBind Var
x
                     E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
                     B -> CvtM B
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(BindVar, E)] -> B
B Bool
False [(BindVar
x',E
e')])
    Rec [(Var, Expr Var)]
xs ->
      do [BindVar]
bs <- (Var -> CvtM BindVar)
-> [Var] -> ReaderT RO (StateT Int Maybe) [BindVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
LetBind) (((Var, Expr Var) -> Var) -> [(Var, Expr Var)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, Expr Var) -> Var
forall a b. (a, b) -> a
fst [(Var, Expr Var)]
xs)
         [BindVar] -> ([BindVar] -> CvtM B) -> CvtM B
forall a. [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars [BindVar]
bs (([BindVar] -> CvtM B) -> CvtM B)
-> ([BindVar] -> CvtM B) -> CvtM B
forall a b. (a -> b) -> a -> b
$ \[BindVar]
bs1 ->
           do [E]
es' <- ((Var, Expr Var) -> CvtM E)
-> [(Var, Expr Var)] -> ReaderT RO (StateT Int Maybe) [E]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Expr Var -> CvtM E
cvtE (Expr Var -> CvtM E)
-> ((Var, Expr Var) -> Expr Var) -> (Var, Expr Var) -> CvtM E
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, Expr Var) -> Expr Var
forall a b. (a, b) -> b
snd) [(Var, Expr Var)]
xs
              B -> CvtM B
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> [(BindVar, E)] -> B
B Bool
True ([BindVar] -> [E] -> [(BindVar, E)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BindVar]
bs1 [E]
es'))


cvtA :: CoreAlt -> CvtM A
cvtA :: Alt Var -> ReaderT RO (StateT Int Maybe) A
cvtA (AltCon
con,[Var]
bs,Expr Var
e) =
  do [BindVar]
xs <- (Var -> CvtM BindVar)
-> [Var] -> ReaderT RO (StateT Int Maybe) [BindVar]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (BindingSite -> Var -> CvtM BindVar
newBindVar BindingSite
CaseBind) [Var]
bs
     [BindVar]
-> ([BindVar] -> ReaderT RO (StateT Int Maybe) A)
-> ReaderT RO (StateT Int Maybe) A
forall a. [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars [BindVar]
xs (([BindVar] -> ReaderT RO (StateT Int Maybe) A)
 -> ReaderT RO (StateT Int Maybe) A)
-> ([BindVar] -> ReaderT RO (StateT Int Maybe) A)
-> ReaderT RO (StateT Int Maybe) A
forall a b. (a -> b) -> a -> b
$ \[BindVar]
xs1 -> do E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
                                  A -> ReaderT RO (StateT Int Maybe) A
forall (m :: * -> *) a. Monad m => a -> m a
return (AltCon -> [BindVar] -> E -> A
A AltCon
con [BindVar]
xs1 E
e')

cvtApp :: CoreExpr -> [E] -> CvtM E
cvtApp :: Expr Var -> [E] -> CvtM E
cvtApp (App Expr Var
x Expr Var
y) [E]
rest =
  do Maybe E
mb <- CvtM E -> CvtM (Maybe E)
forall a. CvtM a -> CvtM (Maybe a)
cath (Expr Var -> CvtM E
cvtE Expr Var
y)
     case Maybe E
mb of
       Maybe E
Nothing -> Expr Var -> [E] -> CvtM E
cvtApp Expr Var
x [E]
rest
       Just E
y' -> Expr Var -> [E] -> CvtM E
cvtApp Expr Var
x (E
y' E -> [E] -> [E]
forall a. a -> [a] -> [a]
: [E]
rest)
cvtApp Expr Var
e [E]
rest =
  do E
e' <- Expr Var -> CvtM E
cvtE Expr Var
e
     case [E]
rest of
       [] -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return E
e'
       [E]
_  -> E -> CvtM E
forall (m :: * -> *) a. Monad m => a -> m a
return (E -> [E] -> E
EApp E
e' [E]
rest)

--------------------------------------------------------------------------------


--------------------------------------------------------------------------------

tag :: Text -> [JS.Pair] -> JS.Value
tag :: Text -> [Pair] -> Value
tag Text
x [Pair]
xs = [Pair] -> Value
JS.object (Key
"tag" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
x Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
xs)

jsText :: Text -> JS.Value
jsText :: Text -> Value
jsText = Text -> Value
forall a. ToJSON a => a -> Value
toJSON

jsOut :: Outputable a => a -> JS.Value
jsOut :: a -> Value
jsOut = CommandLineOption -> Value
forall a. ToJSON a => a -> Value
toJSON (CommandLineOption -> Value)
-> (a -> CommandLineOption) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDoc -> CommandLineOption
showSDocUnsafe (SDoc -> CommandLineOption)
-> (a -> SDoc) -> a -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr

jsBinder :: Var -> JS.Value
jsBinder :: Var -> Value
jsBinder Var
v =
  [Pair] -> Value
JS.object
    [ Key
"poly" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Var -> Value) -> [Var] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Var -> Value
forall a. Outputable a => a -> Value
jsOut [Var]
qVars
    , Key
"args" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Type -> JointDmd ArgStr ArgUse -> Value)
-> [Type] -> [JointDmd ArgStr ArgUse] -> [Value]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Type -> JointDmd ArgStr ArgUse -> Value
forall a s a.
(Outputable a, Outputable s, Outputable a) =>
a -> JointDmd s a -> Value
jsArg [Type]
args [JointDmd ArgStr ArgUse]
sArgs
    , Key
"term" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DmdResult -> Value
forall a. Outputable a => a -> Value
jsOut DmdResult
sRes
    , Key
"result" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Type -> Value
forall a. Outputable a => a -> Value
jsOut
#if !MIN_VERSION_ghc(8,10,0)
        (mkFunTys otherArgs rest)
#else
        ([Type] -> Type -> Type
mkVisFunTys [Type]
otherArgs Type
rest)
#endif
    , Key
"usage" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
JS.object
                   [ Key
"demand"  Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= JointDmd ArgStr ArgUse -> Value
forall a. Outputable a => a -> Value
jsOut (IdInfo -> JointDmd ArgStr ArgUse
demandInfo IdInfo
info)
                   , Key
"occ"     Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OccInfo -> Value
forall a. Outputable a => a -> Value
jsOut (IdInfo -> OccInfo
occInfo IdInfo
info)
                   , Key
"callAr"  Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= IdInfo -> Int
callArityInfo IdInfo
info
                   , Key
"oneShot" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OneShotInfo -> Value
forall a. Outputable a => a -> Value
jsOut (IdInfo -> OneShotInfo
oneShotInfo IdInfo
info)
                   ]
    ]

  where
  ty :: Type
ty               = Var -> Type
idType Var
v
  ([Var]
qVars,Type
tyBody)   = Type -> ([Var], Type)
splitForAllTys Type
ty
  ([Type]
allArgs,Type
rest)   = Type -> ([Type], Type)
splitFunTys Type
tyBody

  ([Type]
args,[Type]
otherArgs) = Int -> [Type] -> ([Type], [Type])
forall a. Int -> [a] -> ([a], [a])
splitAt (IdInfo -> Int
arityInfo IdInfo
info) [Type]
allArgs

  info :: IdInfo
info             = HasDebugCallStack => Var -> IdInfo
Var -> IdInfo
idInfo Var
v
  ([JointDmd ArgStr ArgUse]
sArgs,DmdResult
sRes) = StrictSig -> ([JointDmd ArgStr ArgUse], DmdResult)
splitStrictSig (IdInfo -> StrictSig
strictnessInfo IdInfo
info)

  jsArg :: a -> JointDmd s a -> Value
jsArg a
t JointDmd s a
i = [Pair] -> Value
JS.object [ Key
"type"   Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a -> Value
forall a. Outputable a => a -> Value
jsOut a
t
                        , Key
"strict" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= s -> Value
forall a. Outputable a => a -> Value
jsOut (JointDmd s a -> s
forall s u. JointDmd s u -> s
getStrDmd JointDmd s a
i) -- XXX
                        , Key
"use"    Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= a -> Value
forall a. Outputable a => a -> Value
jsOut (JointDmd s a -> a
forall s u. JointDmd s u -> u
getUseDmd JointDmd s a
i) -- XXX
                        ]

instance ToJSON OccInfo where
  toJSON :: OccInfo -> Value
toJSON = OccInfo -> Value
forall a. Outputable a => a -> Value
jsOut

instance ToJSON StrictSig where
  toJSON :: StrictSig -> Value
toJSON = StrictSig -> Value
forall a. Outputable a => a -> Value
jsOut

instance ToJSON M where
  toJSON :: M -> Value
toJSON (M Module
m [TB]
bs) = [Pair] -> Value
JS.object [ Key
"mod" Key -> Module -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Module
m, Key
"binds" Key -> [TB] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [TB]
bs ]

instance ToJSON Module where
  toJSON :: Module -> Value
toJSON = CommandLineOption -> Value
forall a. ToJSON a => a -> Value
toJSON (CommandLineOption -> Value)
-> (Module -> CommandLineOption) -> Module -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> CommandLineOption
moduleNameString (ModuleName -> CommandLineOption)
-> (Module -> ModuleName) -> Module -> CommandLineOption
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> ModuleName
moduleName

instance ToJSON TB where
  toJSON :: TB -> Value
toJSON (TB Bool
rec [(BindVar, CoreStats, E)]
xs) = [Pair] -> Value
JS.object [ Key
"rec"   Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
rec
                                 , Key
"binds"  Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ((BindVar, CoreStats, E) -> Value)
-> [(BindVar, CoreStats, E)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (BindVar, CoreStats, E) -> Value
forall v v. (ToJSON v, ToJSON v) => (v, CoreStats, v) -> Value
js [(BindVar, CoreStats, E)]
xs ]
    where js :: (v, CoreStats, v) -> Value
js (v
x,CoreStats
s,v
e) = [Pair] -> Value
JS.object [ Key
"var" Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
x, Key
"def" Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
e
                                 , Key
"terms" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CoreStats -> Int
cs_tm CoreStats
s ]




instance ToJSON B where
  toJSON :: B -> Value
toJSON (B Bool
rec [(BindVar, E)]
xs) = [Pair] -> Value
JS.object [ Key
"rec"   Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
rec
                              , Key
"binds" Key -> [Value] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ((BindVar, E) -> Value) -> [(BindVar, E)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (BindVar, E) -> Value
forall v v. (ToJSON v, ToJSON v) => (v, v) -> Value
js [(BindVar, E)]
xs ]
    where js :: (v, v) -> Value
js (v
x,v
e) = [Pair] -> Value
JS.object [ Key
"var" Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
x, Key
"def" Key -> v -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= v
e ]

instance ToJSON Var where
  toJSON :: Var -> Value
toJSON Var
v = [Pair] -> Value
JS.object [ Key
"name" Key -> Name -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Var -> Name
varName Var
v
                       , Key
"id" Key -> CommandLineOption -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Char
x Char -> CommandLineOption -> CommandLineOption
forall a. a -> [a] -> [a]
: Char
'-' Char -> CommandLineOption -> CommandLineOption
forall a. a -> [a] -> [a]
: Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Int
y)
                       , Key
"info" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Var -> Value
forall a. Outputable a => a -> Value
jsOut Var
v
                       , Key
"module" Key -> Maybe Module -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Name -> Maybe Module
nameModule_maybe (Var -> Name
varName Var
v)
                       ]
    where (Char
x,Int
y) = Unique -> (Char, Int)
unpkUnique (Var -> Unique
varUnique Var
v)

instance ToJSON V where
  toJSON :: V -> Value
toJSON (V Int
i Var
v Text
t) = [Pair] -> Value
JS.object [ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t, Key
"id" Key -> CommandLineOption -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Var -> CommandLineOption
mkId Int
i Var
v ]

instance ToJSON BindVar where
   toJSON :: BindVar -> Value
toJSON (BindVar Int
i BindingSite
s Var
v Text
t) =
    [Pair] -> Value
JS.object ([Pair]
j [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++
              [ Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t
              , Key
"id" Key -> CommandLineOption -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int -> Var -> CommandLineOption
mkId Int
i Var
v
              , Key
"info" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if Var -> Bool
isId Var
v then Var -> Value
jsBinder Var
v else Value
JS.Null
              ])
    where j :: [Pair]
j = if Var -> Bool
isJoinId Var
v then [ Key
"join" Key -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
True ] else []

mkId :: Int -> Var -> String
mkId :: Int -> Var -> CommandLineOption
mkId Int
i Var
v = Char
x Char -> CommandLineOption -> CommandLineOption
forall a. a -> [a] -> [a]
: Char
'-' Char -> CommandLineOption -> CommandLineOption
forall a. a -> [a] -> [a]
: Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Int
i CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ [Char
'-'] CommandLineOption -> CommandLineOption -> CommandLineOption
forall a. [a] -> [a] -> [a]
++ Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Int
y
  where
  (Char
x,Int
y) = Unique -> (Char, Int)
unpkUnique (Var -> Unique
varUnique Var
v)

instance ToJSON Name where
  toJSON :: Name -> Value
toJSON = OccName -> Value
forall a. ToJSON a => a -> Value
toJSON (OccName -> Value) -> (Name -> OccName) -> Name -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
nameOccName

instance ToJSON OccName where
  toJSON :: OccName -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (OccName -> Text) -> OccName -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CommandLineOption -> Text
Text.pack (CommandLineOption -> Text)
-> (OccName -> CommandLineOption) -> OccName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> CommandLineOption
occNameString

instance ToJSON E where
  toJSON :: E -> Value
toJSON E
expr =
   case E
expr of
     EVar V
i       -> Text -> [Pair] -> Value
tag Text
"Var"  [ Key
"var" Key -> V -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= V
i ]
     EGlob Var
i      -> Text -> [Pair] -> Value
tag Text
"Glob" [ Key
"var" Key -> Var -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Var
i ]
     ELit Literal
l       -> Text -> [Pair] -> Value
tag Text
"Lit" [ Key
"lit" Key -> Literal -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Literal
l ]
     EApp E
e [E]
as    -> Text -> [Pair] -> Value
tag Text
"App" [ Key
"fun" Key -> E -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= E
e, Key
"args" Key -> [E] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [E]
as ]
     ELam [BindVar]
xs E
e    -> Text -> [Pair] -> Value
tag Text
"Lam" [ Key
"args" Key -> [BindVar] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [BindVar]
xs, Key
"body" Key -> E -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= E
e ]
     ELet B
x E
e     -> Text -> [Pair] -> Value
tag Text
"Let" [ Key
"defs" Key -> B -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= B
x, Key
"body" Key -> E -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= E
e ]
     ECase E
e BindVar
x [A]
as -> Text -> [Pair] -> Value
tag Text
"Case" [ Key
"expr" Key -> E -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= E
e , Key
"val" Key -> BindVar -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= BindVar
x
                                , Key
"alts" Key -> [A] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [A]
as ]


instance ToJSON A where
  toJSON :: A -> Value
toJSON (A AltCon
c [BindVar]
bs E
e) = [Pair] -> Value
JS.object [ Key
"con" Key -> AltCon -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AltCon
c
                                , Key
"binds" Key -> [BindVar] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [BindVar]
bs, Key
"rhs" Key -> E -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= E
e ]

instance ToJSON AltCon where
  toJSON :: AltCon -> Value
toJSON AltCon
con =
    case AltCon
con of
      DataAlt DataCon
x -> Text -> [Pair] -> Value
tag Text
"DataAlt" [ Key
"con" Key -> DataCon -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= DataCon
x ]
      LitAlt Literal
x  -> Text -> [Pair] -> Value
tag Text
"LitAlt" [ Key
"lit" Key -> Literal -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Literal
x ]
      AltCon
DEFAULT   -> Text -> [Pair] -> Value
tag Text
"DEFAULT" []

instance ToJSON Literal where
  toJSON :: Literal -> Value
toJSON Literal
lit =
    case Literal
lit of
#if !MIN_VERSION_ghc(8,8,0)
      MachChar c -> mk "char" (show c)
      MachStr bs -> mk "string" (show bs)
      MachNullAddr -> mk "null" ""
      MachFloat r -> mk "float" (show r)
      MachDouble r -> mk "double" (show r)
      MachLabel fs _ _ -> mk "label" (show fs)
#else
      LitChar Char
c -> Text -> CommandLineOption -> Value
mk Text
"char" (Char -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Char
c)
      LitString ByteString
bs -> Text -> CommandLineOption -> Value
mk Text
"string" (ByteString -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show ByteString
bs)
      Literal
LitNullAddr -> Text -> CommandLineOption -> Value
mk Text
"null" CommandLineOption
""
      Literal
LitRubbish -> Text -> CommandLineOption -> Value
mk Text
"rubbish" CommandLineOption
""
      LitFloat Rational
r -> Text -> CommandLineOption -> Value
mk Text
"float" (Rational -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Rational
r)
      LitDouble Rational
r -> Text -> CommandLineOption -> Value
mk Text
"double" (Rational -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Rational
r)
      LitLabel FastString
fs Maybe Int
_ FunctionOrData
_ -> Text -> CommandLineOption -> Value
mk Text
"label" (FastString -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show FastString
fs)
#endif
#if !MIN_VERSION_ghc(8,6,0)
      MachInt i -> mk "int" (show i)
      MachInt64 i -> mk "int64" (show i)
      MachWord i -> mk "word" (show i)
      MachWord64 i -> mk "word64" (show i)
      LitInteger i _t -> mk "integer" (show i)
#else
      LitNumber LitNumType
num_type Integer
i Type
_t ->
        case LitNumType
num_type of
          LitNumType
LitNumInteger -> Text -> CommandLineOption -> Value
mk Text
"integer" (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
i)
          LitNumType
LitNumNatural -> Text -> CommandLineOption -> Value
mk Text
"natural" (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
i)
          LitNumType
LitNumInt -> Text -> CommandLineOption -> Value
mk Text
"int" (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
i)
          LitNumType
LitNumInt64 -> Text -> CommandLineOption -> Value
mk Text
"int64" (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
i)
          LitNumType
LitNumWord -> Text -> CommandLineOption -> Value
mk Text
"word" (Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
i)
#endif

    where
    mk :: Text -> String -> JS.Value
    mk :: Text -> CommandLineOption -> Value
mk Text
x CommandLineOption
s = [Pair] -> Value
JS.object [ Key
"lit" Key -> CommandLineOption -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= CommandLineOption
s, Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
x ]

instance ToJSON DataCon where
  toJSON :: DataCon -> Value
toJSON DataCon
x = [Pair] -> Value
JS.object [ Key
"name" Key -> Name -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Name
nm, Key
"module" Key -> Maybe Module -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Name -> Maybe Module
nameModule_maybe Name
nm ]
    where nm :: Name
nm = DataCon -> Name
dataConName DataCon
x

-------------------------------------------------------------------------------

htmlWrapper :: String -> BS8.ByteString
htmlWrapper :: CommandLineOption -> ByteString
htmlWrapper CommandLineOption
name = [ByteString] -> ByteString
BS8.unlines
  [ ByteString
"<!DOCTYPE html>"
  , ByteString
"<html>"
  , ByteString
"<head>"
  , ByteString
"<script src=\"ui/jquery.js\"></script>"
  , [ByteString] -> ByteString
BS8.concat [ ByteString
"<script src=\"js/", CommandLineOption -> ByteString
BS8.pack CommandLineOption
name, ByteString
".js\"></script>" ]
  , ByteString
"<script src=\"ui/see.js\"></script>"
  , ByteString
"<link href=\"ui/see.css\" rel=\"stylesheet\">"
  , ByteString
"<script>"
  , ByteString
"$(document).ready(function() {"
  , ByteString
"  var b = $('body')"
  , ByteString
"  b.append(seeMod(it))"
  , ByteString
"})"
  , ByteString
"</script>"
  , ByteString
"</head>"
  , ByteString
"<body>"
  , ByteString
"<div id=\"all-details\">"
  , ByteString
"<div id=\"details-short\"></div>"
  , ByteString
"<div id=\"details-long\"></div>"
  , ByteString
"</div>"
  , ByteString
"</body>"
  , ByteString
"</html>"
  ]