module SSTG.Utils.Printing
( pprStateStr
, pprLivesDeadsStr
, pprBindsStr
) 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_path) 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 (memAddrInt 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]]
pprMemRedirStr :: (MemAddr, MemAddr) -> String
pprMemRedirStr (addr, redir) = sub (addr_str ++ ", " ++ redir_str)
where
addr_str = pprMemAddrStr addr
redir_str = pprMemAddrStr redir
pprMemHeapObjStr :: (MemAddr, HeapObj) -> String
pprMemHeapObjStr (addr, Blackhole) = sub (pprMemAddrStr addr ++ ", Blackhole")
pprMemHeapObjStr (addr, LitObj lit) = acc_str
where
header = "LitObj"
addr_str = pprMemAddrStr addr
lit_str = pprLitStr lit
acc_str = sub (addr_str ++ ", " ++ injSpace [header, lit_str])
pprMemHeapObjStr (addr, SymObj (Symbol sym mb_scls)) = acc_str
where
header = "SymObj"
addr_str = pprMemAddrStr addr
var_str = pprVarStr sym
scls_str = (sub . pprSymClosureStr) mb_scls
acc_str = sub (addr_str ++ ", " ++ injSpace [header, var_str, scls_str])
pprMemHeapObjStr (addr, ConObj dcon vals) = acc_str
where
header = "ConObj"
addr_str = pprMemAddrStr addr
dcon_str = pprDataConStr dcon
vals_str = injIntoList (map pprValStr vals)
acc_str = sub (addr_str ++ ", " ++ injSpace [header, dcon_str, vals_str])
pprMemHeapObjStr (addr, FunObj params expr locals) = acc_str
where
header = "FunObj"
addr_str = pprMemAddrStr addr
prms_str = injIntoList (map pprVarStr params)
expr_str = pprExprStr expr
locs_str = pprLocalsStr locals
funobj_str = injSpace [header, prms_str, expr_str, locs_str]
acc_str = sub (addr_str ++ ", " ++ funobj_str)
pprHeapStr :: Heap -> String
pprHeapStr heap = injNewLine acc_strs
where
hlist = heapToList heap
addr_redirs = [(addr, r) | (addr, HeapRedir r) <- hlist]
addr_hobjs = [(addr, o) | (addr, HeapObj o) <- hlist]
addr_redir_strs = map pprMemRedirStr addr_redirs
addr_hobj_strs = map pprMemHeapObjStr addr_hobjs
acc_strs = addr_redir_strs ++ addr_hobj_strs
pprGlobalsStr :: Globals -> String
pprGlobalsStr globals = injNewLine acc_strs
where
glist = globalsToList globals
name_strs = map (pprNameStr . fst) glist
val_strs = map (pprValStr . 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 (pprValStr . snd) llist
zipd_strs = zip name_strs val_strs
acc_strs = map (\(n, v) -> sub (n ++ ", " ++ v)) zipd_strs
pprValStr :: Val -> String
pprValStr (LitVal lit) = injSpace acc_strs
where
header = "LitVal"
lit_str = pprLitStr lit
acc_strs = [header, lit_str]
pprValStr (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 params) = injSpace acc_strs
where
header = "DataAlt"
dcon_str = (sub . pprDataConStr) dcon
ps_str = injIntoList (map pprVarStr params)
acc_strs = [header, dcon_str, ps_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 expr) = injSpace acc_strs
where
header = "Alt"
acon_str = (sub . pprAltConStr) acon
expr_str = (sub . pprExprStr) expr
acc_strs = [header, acon_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, rhs) = (sub . injComma) acc_strs
where
var_str = pprVarStr var
rhs_str = pprBindRhsStr rhs
acc_strs = [var_str, rhs_str]
pprBindsStr :: Binds -> String
pprBindsStr (Binds rec kvs) = injSpace acc_strs
where
header = case rec of { Rec -> "Rec"; NonRec -> "NonRec" }
kvs_str = injIntoList (map pprBindKVStr kvs)
acc_strs = [header, kvs_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 binds expr) = injSpace acc_strs
where
header = "Let"
binds_str = (sub . pprBindsStr) binds
expr_str = (sub . pprExprStr) expr
acc_strs = [header, binds_str, expr_str]
pprTypeStr :: Type -> String
pprTypeStr ty = fst ("__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 = pprValStr 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 acon expr locals hold) = injIntoList acc_strs
where
acon_str = pprAltConStr acon
expr_str = pprExprStr expr
locs_str = pprLocalsStr locals
hold_str = if hold then "Positive" else "Negative"
acc_strs = [acon_str, expr_str, locs_str, hold_str]