module SSTG.Utils.Printing
( pprStateStr
, pprLivesDeadsStr
, pprBindStr
) where
import SSTG.Core
import qualified Data.List as L
pprLivesDeadsStr :: ([LiveState], [DeadState]) -> String
pprLivesDeadsStr (lives, deads) = injNewLineSeps10 acc_strs
where
header = "(Lives, Deads)"
lv_str = (injNewLineSeps5 . map pprLiveStr) lives
dd_str = (injNewLineSeps5 . map pprDeadStr) deads
acc_strs = [header, lv_str, dd_str]
pprLiveStr :: LiveState -> String
pprLiveStr (rules, state) = injNewLine acc_strs
where
header = "Live"
rule_str = pprRulesStr rules
st_str = pprStateStr state
acc_strs = [header, rule_str, st_str]
pprDeadStr :: LiveState -> String
pprDeadStr (rules, state) = injNewLine acc_strs
where
header = "Dead"
rule_str = pprRulesStr rules
st_str = pprStateStr state
acc_strs = [header, rule_str, st_str]
pprRuleStr :: Rule -> String
pprRuleStr rule = show rule
pprRulesStr :: [Rule] -> String
pprRulesStr rules = injIntoList (map pprRuleStr rules)
pprStateStr :: State -> String
pprStateStr state = injNewLine acc_strs
where
status_str= (pprStatusStr . state_status) state
stack_str = (pprStackStr . state_stack) state
heap_str = (pprHeapStr . state_heap) state
globals_str = (pprGlobalsStr . state_globals) state
expr_str = (pprCodeStr . state_code) state
names_str = (pprNamesStr . state_names) state
pcons_str = (pprPathConsStr . state_paths) state
acc_strs = [ ">>>>> [State] >>>>>>>>>>>>>>>"
, status_str
, "----- [Stack] ---------------"
, stack_str
, "----- [Heap] ----------------"
, heap_str
, "----- [Globals] -------------"
, globals_str
, "----- [Expression] ----------"
, expr_str
, "----- [All Names] -------"
, fst ("", names_str)
, "----- [Path Constraint] -----"
, pcons_str
, "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" ]
sub :: String -> String
sub str = "(" ++ str ++ ")"
injSpace :: [String] -> String
injSpace strs = L.intercalate " " strs
injComma :: [String] -> String
injComma strs = L.intercalate "," strs
injNewLine :: [String] -> String
injNewLine strs = L.intercalate "\n" strs
injIntoList :: [String] -> String
injIntoList strs = "[" ++ (injComma strs) ++ "]"
injNewLineSeps5 :: [String] -> String
injNewLineSeps5 strs = L.intercalate seps strs
where
seps = "\n-----\n"
injNewLineSeps10 :: [String] -> String
injNewLineSeps10 strs = L.intercalate seps strs
where
seps = "\n----------\n"
pprMemAddrStr :: MemAddr -> String
pprMemAddrStr addr = show (addrInt addr)
pprNameStr :: Name -> String
pprNameStr name = show name
pprLitStr :: Lit -> String
pprLitStr lit = show lit
pprStatusStr :: Status -> String
pprStatusStr status = show status
pprStackStr :: Stack -> String
pprStackStr stack = injNewLineSeps10 acc_strs
where
frame_strs = map pprFrameStr (stackToList stack)
acc_strs = "Stack" : frame_strs
pprFrameStr :: Frame -> String
pprFrameStr (CaseFrame var alts locals) = injNewLine acc_strs
where
header = "CaseFrame"
var_str = pprVarStr var
alts_str = pprAltsStr alts
locs_str = pprLocalsStr locals
acc_strs = [header, var_str, alts_str, locs_str]
pprFrameStr (ApplyFrame args locals) = injNewLine acc_strs
where
header = "ApplyFrame"
args_str = injIntoList (map pprAtomStr args)
locs_str = pprLocalsStr locals
acc_strs = [header, args_str, locs_str]
pprFrameStr (UpdateFrame addr) = injNewLine acc_strs
where
header = "UpdateFrame"
addr_str = pprMemAddrStr addr
acc_strs = [header, addr_str]
pprSymClosureStr :: Maybe (Expr, Locals) -> String
pprSymClosureStr (Nothing) = "SymClosure ()"
pprSymClosureStr (Just (expr, locals)) = injSpace acc_strs
where
header = "SymClosure"
expr_str = pprExprStr expr
locs_str = pprLocalsStr locals
acc_strs = [header, injIntoList [expr_str, locs_str]]
pprHeapObjStr :: HeapObj -> String
pprHeapObjStr (Blackhole) = "Blackhole!!!"
pprHeapObjStr (AddrObj addr) = pprMemAddrStr addr
pprHeapObjStr (LitObj lit) = injSpace acc_strs
where
header = "LitObj"
lit_str = pprLitStr lit
acc_strs = [header, lit_str]
pprHeapObjStr (SymObj (Symbol sym mb_scls)) = injSpace acc_strs
where
header = "SymObj"
var_str = pprVarStr sym
scls_str = (sub . pprSymClosureStr) mb_scls
acc_strs = [header, var_str, scls_str]
pprHeapObjStr (ConObj dcon vals) = injSpace acc_strs
where
header = "ConObj"
dcon_str = pprDataConStr dcon
vals_str = injIntoList (map pprValueStr vals)
acc_strs = [header, dcon_str, vals_str]
pprHeapObjStr (FunObj params expr locals) = injSpace acc_strs
where
header = "FunObj"
prms_str = injIntoList (map pprVarStr params)
expr_str = pprExprStr expr
locs_str = pprLocalsStr locals
acc_strs = [header, prms_str, expr_str, locs_str]
pprHeapStr :: Heap -> String
pprHeapStr heap = injNewLine acc_strs
where
hlist = heapToList heap
addr_strs = map (pprMemAddrStr . fst) hlist
hobj_strs = map (pprHeapObjStr . snd) hlist
zipd_strs = zip addr_strs hobj_strs
acc_strs = map (\(m, o) -> sub (m ++ ", " ++ o)) zipd_strs
pprGlobalsStr :: Globals -> String
pprGlobalsStr globals = injNewLine acc_strs
where
glist = globalsToList globals
name_strs = map (pprNameStr . fst) glist
val_strs = map (pprValueStr . snd) glist
zipd_strs = zip name_strs val_strs
acc_strs = map (\(n, v) -> sub (n ++ ", " ++ v)) zipd_strs
pprLocalsStr :: Locals -> String
pprLocalsStr locals = injIntoList acc_strs
where
llist = localsToList locals
name_strs = map (pprNameStr . fst) llist
val_strs = map (pprValueStr . snd) llist
zipd_strs = zip name_strs val_strs
acc_strs = map (\(n, v) -> sub (n ++ ", " ++ v)) zipd_strs
pprValueStr :: Value -> String
pprValueStr (LitVal lit) = injSpace acc_strs
where
header = "LitVal"
lit_str = pprLitStr lit
acc_strs = [header, lit_str]
pprValueStr (MemVal addr) = injSpace acc_strs
where
header = "MemVal"
ptr_str = pprMemAddrStr addr
acc_strs = [header, ptr_str]
pprVarStr :: Var -> String
pprVarStr (Var name ty) = injSpace acc_strs
where
header = "Var"
name_str = (sub . pprNameStr) name
type_str = (sub . pprTypeStr) ty
acc_strs = [header, name_str, type_str]
pprAtomStr :: Atom -> String
pprAtomStr (VarAtom var) = injSpace acc_strs
where
header = "VarAtom"
var_str = (sub . pprVarStr) var
acc_strs = [header, var_str]
pprAtomStr (LitAtom lit) = injSpace acc_strs
where
header = "LitAtom"
lit_str = (sub . pprLitStr) lit
acc_strs = [header, lit_str]
pprDataConStr :: DataCon -> String
pprDataConStr (DataCon name ty tys) = injSpace acc_strs
where
header = "DataCon"
tag_str = (sub . pprNameStr) name
ty_str = (sub . pprTypeStr) ty
tys_str = injIntoList (map pprTypeStr tys)
acc_strs = [header, tag_str, ty_str, tys_str]
pprPrimFunStr :: PrimFun -> String
pprPrimFunStr (PrimFun name ty) = injSpace acc_strs
where
header = "PrimFun"
name_str = (sub . pprNameStr) name
type_str = (sub . pprTypeStr) ty
acc_strs = [header, name_str, type_str]
pprAltConStr :: AltCon -> String
pprAltConStr (DataAlt dcon) = injSpace acc_strs
where
header = "DataAlt"
dcon_str = (sub . pprDataConStr) dcon
acc_strs = [header, dcon_str]
pprAltConStr (LitAlt lit) = injSpace acc_strs
where
header = "LitAlt"
lit_str = (sub . pprLitStr) lit
acc_strs = [header, lit_str]
pprAltConStr (Default) = "Default"
pprAltStr :: Alt -> String
pprAltStr (Alt acon var expr) = injSpace acc_strs
where
header = "Alt"
acon_str = (sub . pprAltConStr) acon
vars_str = injIntoList (map pprVarStr var)
expr_str = (sub . pprExprStr) expr
acc_strs = [header, acon_str, vars_str, expr_str]
pprAltsStr :: [Alt] -> String
pprAltsStr alts = injIntoList (map pprAltStr alts)
pprBindRhsStr :: BindRhs -> String
pprBindRhsStr (FunForm params expr) = injSpace acc_strs
where
header = "FunForm"
prms_str = injIntoList (map pprVarStr params)
expr_str = (sub . pprExprStr) expr
acc_strs = [header, prms_str, expr_str]
pprBindRhsStr (ConForm dcon args) = injSpace acc_strs
where
header = "ConForm"
dcon_str = (sub . pprDataConStr) dcon
args_str = injIntoList (map pprAtomStr args)
acc_strs = [header, dcon_str, args_str]
pprBindKVStr :: (Var, BindRhs) -> String
pprBindKVStr (var, lamf) = (sub . injComma) acc_strs
where
var_str = pprVarStr var
lamf_str = pprBindRhsStr lamf
acc_strs = [var_str, lamf_str]
pprBindStr :: Bind -> String
pprBindStr (Bind rec bnd) = injSpace acc_strs
where
header = case rec of { Rec -> "Rec"; NonRec -> "NonRec" }
bnds_str = injIntoList (map pprBindKVStr bnd)
acc_strs = [header, bnds_str]
pprExprStr :: Expr -> String
pprExprStr (Atom atom) = injSpace acc_strs
where
header = "Atom"
atom_str = (sub . pprAtomStr) atom
acc_strs = [header, atom_str]
pprExprStr (FunApp var args) = injSpace acc_strs
where
header = "FunApp"
var_str = (sub . pprVarStr) var
args_str = injIntoList (map pprAtomStr args)
acc_strs = [header, var_str, args_str]
pprExprStr (PrimApp pfun args) = injSpace acc_strs
where
header = "PrimApp"
pfun_str = (sub . pprPrimFunStr) pfun
args_str = injIntoList (map pprAtomStr args)
acc_strs = [header, pfun_str, args_str]
pprExprStr (ConApp dcon args) = injSpace acc_strs
where
header = "ConApp"
dcon_str = (sub . pprDataConStr) dcon
args_str = injIntoList (map pprAtomStr args)
acc_strs = [header, dcon_str, args_str]
pprExprStr (Case expr var alts) = injSpace acc_strs
where
header = "Case"
expr_str = (sub . pprExprStr) expr
var_str = (sub . pprVarStr) var
alts_str = pprAltsStr alts
acc_strs = [header, expr_str, var_str, alts_str]
pprExprStr (Let bnd expr) = injSpace acc_strs
where
header = "Let"
bnd_str = (sub . pprBindStr) bnd
expr_str = (sub . pprExprStr) expr
acc_strs = [header, bnd_str, expr_str]
pprTypeStr :: Type -> String
pprTypeStr ty = snd ("__Type__", show ty)
pprCodeStr :: Code -> String
pprCodeStr (Evaluate expr locals) = injSpace acc_strs
where
header = "Evaluate"
expr_str = (sub . pprExprStr) expr
loc_str = (sub . pprLocalsStr) locals
acc_strs = [header, expr_str, loc_str]
pprCodeStr (Return val) = injSpace acc_strs
where
header = "Return"
val_str = pprValueStr val
acc_strs = [header, val_str]
pprNamesStr :: [Name] -> String
pprNamesStr names = injIntoList (map pprNameStr names)
pprPathConsStr :: PathCons -> String
pprPathConsStr pathcons = injNewLineSeps5 strs
where
strs = map pprConstraintStr (pathconsToList pathcons)
pprConstraintStr :: Constraint -> String
pprConstraintStr (Constraint (ac, ps) expr locals hold) = injIntoList acc_strs
where
acon_str = pprAltConStr ac
prms_str = injIntoList (map pprVarStr ps)
expr_str = pprExprStr expr
locs_str = pprLocalsStr locals
hold_str = case hold of { True -> "Positive"; False -> "Negative" }
acc_strs = [acon_str, prms_str, expr_str, locs_str, hold_str]