dump-core-0.1.4: DumpCore.hs
{-# 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 = defaultPlugin { installCoreToDos = install }
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install opts todo =
return (todo ++ [ CoreDoPluginPass "DumpCore" (liftIO . dumpIn opts) ])
dumpIn :: [CommandLineOption] -> ModGuts -> IO ModGuts
dumpIn opts guts =
do let mod = cvtM guts
file = moduleNameString (moduleName (mg_module guts))
htmlDir = case opts of
[] -> "dump-core"
x : _ -> x
installLibFiles htmlDir
let jsDir = htmlDir </> "js"
createDirectoryIfMissing True jsDir
let js_file = jsDir </> file <.> "js"
BS.writeFile js_file ("var it = " `BS.append` JS.encode mod)
-- The wrapper assumes `js` and `lib` as sub-directories of html
let html_file = htmlDir </> file <.> "html"
BS8.writeFile html_file (htmlWrapper file)
return guts
installLibFiles :: FilePath -> IO ()
installLibFiles libDir =
mapM_ (copyLibFile libDir) [ "ui/see.js"
, "ui/see.css"
, "ui/jquery.js"
, "ui/fonts/FiraMono-Regular.ttf"
, "ui/fonts/FiraMono-Bold.ttf" ]
copyLibFile :: FilePath -> FilePath -> IO ()
copyLibFile outDir file =
do path <- getDataFileName file
let outFile = outDir </> file
done <- doesFileExist outFile
unless done $ do createDirectoryIfMissing True (takeDirectory outFile)
copyFile path outFile
--------------------------------------------------------------------------------
type CvtM = ReaderT RO (StateT Int Maybe)
data RO = RO
{ roVars :: Map Var V -- ^ Mapping from GHC vars to V
, 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 gs = M (mg_module gs) (foldr jn [] bs)
where
jn (TB False xs) (TB False ys : more) = TB False (xs ++ ys) : more
jn x y = x : y
mkBV x = BindVar 0 LetBind x (txtName x)
mkBind (NonRec x _) = [mkBV x]
mkBind (Rec xs) = map (mkBV . fst) xs
act = let bs = map mkBind (mg_binds gs)
in withBindVars (concat bs) $ \_ -> mapM cvtTB (mg_binds gs)
ro0 = RO { roVars = Map.empty, roTxt = Map.empty }
bs = case runStateT 1 (runReaderT ro0 act) of
Nothing -> []
Just (a,_) -> a
txtName :: Var -> Text
txtName = Text.pack . occNameString . nameOccName . varName
newBindVar :: BindingSite -> Var -> CvtM BindVar
newBindVar bs v =
do i <- sets $ \i -> (i,i+1)
return (BindVar i bs v "")
withBindVar :: BindVar -> (BindVar -> CvtM a) -> CvtM a
withBindVar b@(BindVar i s v _) m =
do scope <- ask
let txt = txtName v
nm = case mp Map.! txt of
1 -> txt
n -> txt `Text.append` Text.pack ("_" ++ show n)
mp = Map.insertWith (+) txt 1 (roTxt scope)
ro = RO { roVars = Map.insert v (V i v nm) (roVars scope)
, roTxt = mp
}
local ro (m (BindVar i s v nm))
withBindVars :: [BindVar] -> ([BindVar] -> CvtM a) -> CvtM a
withBindVars bs m =
case bs of
[] -> m []
x : xs -> withBindVar x $ \x1 ->
withBindVars xs $ \xs1 -> m (x1:xs1)
cvtE :: CoreExpr -> CvtM E
cvtE expr =
case expr of
Var x ->
do scope <- ask
case Map.lookup x (roVars scope) of
Nothing -> return (EGlob x)
Just v -> return (EVar v)
Lit l -> return (ELit l)
App {} -> cvtApp expr []
Lam x e
| isTyVar x -> cvtE e
| otherwise ->
do b <- newBindVar LambdaBind x
withBindVar b $ \b1 ->
do e' <- cvtE e
case e' of
ELam xs e'' -> return (ELam (b1:xs) e'')
_ -> return (ELam [b1] e')
Let b e ->
do B isRec defs <- cvtB b
withBindVars (map fst defs) $ \defs1 ->
do let newDefs = zip defs1 (map snd defs)
e' <- cvtE e
case e' of
ELet (B False moreDefs) e'' | not isRec ->
return (ELet (B False (newDefs ++ moreDefs)) e'')
_ -> return (ELet (B isRec newDefs) e')
Case e x _ as ->
do e' <- cvtE e
x' <- newBindVar CaseBind x
withBindVar x' $ \x1 -> do as' <- mapM cvtA as
return (ECase e' x1 as')
Cast x _ -> cvtE x
Tick _ e -> cvtE e
Type _ -> inBase Nothing
Coercion _ -> inBase Nothing
cath :: CvtM a -> CvtM (Maybe a)
cath m =
do r <- ask
s <- get
case runStateT s (runReaderT r m) of
Nothing -> return Nothing
Just (a,s1) -> set s1 >> return (Just a)
cvtTB :: CoreBind -> CvtM TB
cvtTB b =
case b of
NonRec x e -> do b' <- cvtSE (x,e)
return (TB False [b'])
Rec cs -> do bs' <- mapM cvtSE cs
return (TB True bs')
where
cvtSE (x,e) = do scope <- ask
let V i v t = roVars scope Map.! x
e' <- cvtE e
return (BindVar i LetBind v t, exprStats e, e')
cvtB :: CoreBind -> CvtM B
cvtB bnd =
case bnd of
NonRec x e -> do x' <- newBindVar LetBind x
e' <- cvtE e
return (B False [(x',e')])
Rec xs ->
do bs <- mapM (newBindVar LetBind) (map fst xs)
withBindVars bs $ \bs1 ->
do es' <- mapM (cvtE . snd) xs
return (B True (zip bs1 es'))
cvtA :: CoreAlt -> CvtM A
cvtA (con,bs,e) =
do xs <- mapM (newBindVar CaseBind) bs
withBindVars xs $ \xs1 -> do e' <- cvtE e
return (A con xs1 e')
cvtApp :: CoreExpr -> [E] -> CvtM E
cvtApp (App x y) rest =
do mb <- cath (cvtE y)
case mb of
Nothing -> cvtApp x rest
Just y' -> cvtApp x (y' : rest)
cvtApp e rest =
do e' <- cvtE e
case rest of
[] -> return e'
_ -> return (EApp e' rest)
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
tag :: Text -> [JS.Pair] -> JS.Value
tag x xs = JS.object ("tag" .= x : xs)
jsText :: Text -> JS.Value
jsText = toJSON
jsOut :: Outputable a => a -> JS.Value
jsOut = toJSON . showSDocUnsafe . ppr
jsBinder :: Var -> JS.Value
jsBinder v =
JS.object
[ "poly" .= map jsOut qVars
, "args" .= zipWith jsArg args sArgs
, "term" .= jsOut sRes
, "result" .= jsOut
#if !MIN_VERSION_ghc(8,10,0)
(mkFunTys otherArgs rest)
#else
(mkVisFunTys otherArgs rest)
#endif
, "usage" .= JS.object
[ "demand" .= jsOut (demandInfo info)
, "occ" .= jsOut (occInfo info)
, "callAr" .= callArityInfo info
, "oneShot" .= jsOut (oneShotInfo info)
]
]
where
ty = idType v
(qVars,tyBody) = splitForAllTys ty
(allArgs,rest) = splitFunTys tyBody
(args,otherArgs) = splitAt (arityInfo info) allArgs
info = idInfo v
(sArgs,sRes) = splitStrictSig (strictnessInfo info)
jsArg t i = JS.object [ "type" .= jsOut t
, "strict" .= jsOut (getStrDmd i) -- XXX
, "use" .= jsOut (getUseDmd i) -- XXX
]
instance ToJSON OccInfo where
toJSON = jsOut
instance ToJSON StrictSig where
toJSON = jsOut
instance ToJSON M where
toJSON (M m bs) = JS.object [ "mod" .= m, "binds" .= bs ]
instance ToJSON Module where
toJSON = toJSON . moduleNameString . moduleName
instance ToJSON TB where
toJSON (TB rec xs) = JS.object [ "rec" .= rec
, "binds" .= map js xs ]
where js (x,s,e) = JS.object [ "var" .= x, "def" .= e
, "terms" .= cs_tm s ]
instance ToJSON B where
toJSON (B rec xs) = JS.object [ "rec" .= rec
, "binds" .= map js xs ]
where js (x,e) = JS.object [ "var" .= x, "def" .= e ]
instance ToJSON Var where
toJSON v = JS.object [ "name" .= varName v
, "id" .= (x : '-' : show y)
, "info" .= jsOut v
, "module" .= nameModule_maybe (varName v)
]
where (x,y) = unpkUnique (varUnique v)
instance ToJSON V where
toJSON (V i v t) = JS.object [ "name" .= t, "id" .= mkId i v ]
instance ToJSON BindVar where
toJSON (BindVar i s v t) =
JS.object (j ++
[ "name" .= t
, "id" .= mkId i v
, "info" .= if isId v then jsBinder v else JS.Null
])
where j = if isJoinId v then [ "join" .= True ] else []
mkId :: Int -> Var -> String
mkId i v = x : '-' : show i ++ ['-'] ++ show y
where
(x,y) = unpkUnique (varUnique v)
instance ToJSON Name where
toJSON = toJSON . nameOccName
instance ToJSON OccName where
toJSON = toJSON . Text.pack . occNameString
instance ToJSON E where
toJSON expr =
case expr of
EVar i -> tag "Var" [ "var" .= i ]
EGlob i -> tag "Glob" [ "var" .= i ]
ELit l -> tag "Lit" [ "lit" .= l ]
EApp e as -> tag "App" [ "fun" .= e, "args" .= as ]
ELam xs e -> tag "Lam" [ "args" .= xs, "body" .= e ]
ELet x e -> tag "Let" [ "defs" .= x, "body" .= e ]
ECase e x as -> tag "Case" [ "expr" .= e , "val" .= x
, "alts" .= as ]
instance ToJSON A where
toJSON (A c bs e) = JS.object [ "con" .= c
, "binds" .= bs, "rhs" .= e ]
instance ToJSON AltCon where
toJSON con =
case con of
DataAlt x -> tag "DataAlt" [ "con" .= x ]
LitAlt x -> tag "LitAlt" [ "lit" .= x ]
DEFAULT -> tag "DEFAULT" []
instance ToJSON Literal where
toJSON lit =
case 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 c -> mk "char" (show c)
LitString bs -> mk "string" (show bs)
LitNullAddr -> mk "null" ""
LitRubbish -> mk "rubbish" ""
LitFloat r -> mk "float" (show r)
LitDouble r -> mk "double" (show r)
LitLabel fs _ _ -> mk "label" (show 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 num_type i _t ->
case num_type of
LitNumInteger -> mk "integer" (show i)
LitNumNatural -> mk "natural" (show i)
LitNumInt -> mk "int" (show i)
LitNumInt64 -> mk "int64" (show i)
LitNumWord -> mk "word" (show i)
#endif
where
mk :: Text -> String -> JS.Value
mk x s = JS.object [ "lit" .= s, "type" .= x ]
instance ToJSON DataCon where
toJSON x = JS.object [ "name" .= nm, "module" .= nameModule_maybe nm ]
where nm = dataConName x
-------------------------------------------------------------------------------
htmlWrapper :: String -> BS8.ByteString
htmlWrapper name = BS8.unlines
[ "<!DOCTYPE html>"
, "<html>"
, "<head>"
, "<script src=\"ui/jquery.js\"></script>"
, BS8.concat [ "<script src=\"js/", BS8.pack name, ".js\"></script>" ]
, "<script src=\"ui/see.js\"></script>"
, "<link href=\"ui/see.css\" rel=\"stylesheet\">"
, "<script>"
, "$(document).ready(function() {"
, " var b = $('body')"
, " b.append(seeMod(it))"
, "})"
, "</script>"
, "</head>"
, "<body>"
, "<div id=\"all-details\">"
, "<div id=\"details-short\"></div>"
, "<div id=\"details-long\"></div>"
, "</div>"
, "</body>"
, "</html>"
]