-- | Pretty Printing
module SSTG.Utils.Printing
    ( pprStateStr
    , pprLivesDeadsStr
    , pprBindingStr
    ) where

import SSTG.Core

import qualified Data.Map  as M
import qualified Data.List as L

-- | Print `LiveState` and `DeadState` that yield from execution snapshots.
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]

-- | Print `LiveState`.
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]

-- | Print `DeadState`.
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]

-- | Print `Rule`.
pprRuleStr :: Rule -> String
pprRuleStr rule = show rule

pprRulesStr :: [Rule] -> String
pprRulesStr rules = injIntoList (map pprRuleStr rules)

-- | Print `State`.
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   = (pprPConsStr    . state_paths)   state
        links_str   = (pprLinksStr    . state_links)   state
        acc_strs    = [ ">>>>> [State] >>>>>>>>>>>>>>>"
                      , status_str
                      , "----- [Stack] ---------------"
                      , stack_str
                      , "----- [Heap] ----------------"
                      , heap_str
                      , "----- [Globals] -------------"
                      , globals_str
                      , "----- [Expression] ----------"
                      , expr_str
                      , "----- [All Names] -------"
                      , fst ("", names_str)  -- names_str
                      , "----- [Path Constraint] -----"
                      , pcons_str
                      , "----- [Symbolic Links] ------"
                      , links_str
                      , "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" ]

-- | Inject `String` into parantheses.
sub :: String -> String
sub str = "(" ++ str ++ ")"

-- | Inject a list of `String`s with space.
injSpace :: [String] -> String
injSpace strs = L.intercalate " " strs

-- | Inject a list of `String`s with commas.
injComma :: [String] -> String
injComma strs = L.intercalate "," strs

-- | Inject a list of `String`s with newlines.
injNewLine :: [String] -> String
injNewLine strs = L.intercalate "\n" strs

-- | Inject a list of `String`s into a single string with commas and brackets.
injIntoList :: [String] -> String
injIntoList strs = "[" ++ (injComma strs) ++ "]"

-- | Inject a list of `String`s with newline separators of dashes length 5.
injNewLineSeps5 :: [String] -> String
injNewLineSeps5 strs = L.intercalate seps strs
  where seps = "\n-----\n"

-- | Inject a list of `String`s wit hnewline separators of dashes length 10.
injNewLineSeps10 :: [String] -> String
injNewLineSeps10 strs = L.intercalate seps strs
  where seps = "\n----------\n"

-- | Print `MemAddr`.
pprMemAddrStr :: MemAddr -> String
pprMemAddrStr (MemAddr int) = show int

-- | Print `Name`.
pprNameStr :: Name -> String
pprNameStr name = show name

-- | Print `Lit`.
pprLitStr :: Lit -> String
pprLitStr lit = show lit

-- | Print `Status`.
pprStatusStr :: Status -> String
pprStatusStr status = show status

-- | Print `Stack`.
pprStackStr :: Stack -> String
pprStackStr (Stack stack) = injNewLineSeps10 acc_strs
  where frame_strs = map pprFrameStr stack
        acc_strs   = "Stack" : frame_strs

-- | Print `Frame`.
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]

-- | Print the @Maybe (Expr, Locals)@.
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]]

-- | Print `HeapObj`.
pprHeapObjStr :: HeapObj -> String
pprHeapObjStr (Blackhole) = "Blackhole!!!"
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]

-- | Print `Heap`.
pprHeapStr :: Heap -> String
pprHeapStr (Heap hmap addr) = injNewLine (map (\k -> ">" ++ k) acc_strs)
  where kvs  = M.toList hmap
        addr_strs = map (pprMemAddrStr . fst) kvs
        hobj_strs = map (pprHeapObjStr . snd) kvs
        zipd_strs = zip addr_strs hobj_strs
        addr_str  = pprMemAddrStr addr
        kvs_strs  = map (\(m, o) -> sub (m ++ "," ++ o)) zipd_strs
        acc_strs  = addr_str : kvs_strs

-- | Print `Globals`.
pprGlobalsStr :: Globals -> String
pprGlobalsStr (Globals gmap) = injNewLine (map (\k -> ">" ++ k) acc_strs)
  where kvs  = M.toList gmap
        name_strs = map (pprNameStr . fst) kvs
        val_strs  = map (pprValueStr . snd) kvs
        zipd_strs = zip name_strs val_strs
        acc_strs  = map (\(n, v) -> sub (n ++ "," ++ v)) zipd_strs

-- | Print `Locals`.
pprLocalsStr :: Locals -> String
pprLocalsStr (Locals lmap) = injIntoList acc_strs
  where kvs  = M.toList lmap
        name_strs = map (pprNameStr . fst) kvs
        val_strs  = map (pprValueStr . snd) kvs
        zipd_strs = zip name_strs val_strs
        acc_strs  = map (\(n, v) -> sub (n ++ "," ++ v)) zipd_strs

-- | Print `Value`.
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]

-- | Print `Var`.
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]

-- | Print `Atom`.
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]

-- | Print `ConTag`.
pprConTagStr :: ConTag -> String
pprConTagStr (ConTag name _) = pprNameStr name

-- | Print `DataCon`.
pprDataConStr :: DataCon -> String
pprDataConStr (DataCon tag ty tys) = injSpace acc_strs
  where header   = "DataCon"
        tag_str  = (sub . pprConTagStr) tag
        ty_str   = (sub . pprTypeStr) ty
        tys_str  = injIntoList (map pprTypeStr tys)
        acc_strs = [header, tag_str, ty_str, tys_str]

-- | Print `PrimFun`.
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]

-- | Print `AltCon`.
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"

-- | Print `Alt`.
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]

-- | Print a list of `Alt`s.
pprAltsStr :: [Alt] -> String
pprAltsStr alts = injIntoList (map pprAltStr alts)

-- | Print `BindRhs`.
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]

-- | Print @(Var, BindRhs)@.
pprBindStr :: (Var, BindRhs) -> String
pprBindStr (var, lamf) = (sub . injComma) acc_strs
  where var_str  = pprVarStr var
        lamf_str = pprBindRhsStr lamf
        acc_strs = [var_str, lamf_str]

-- | Print `Binding`.
pprBindingStr :: Binding -> String
pprBindingStr (Binding rec bnd) = injSpace acc_strs
  where header   = case rec of { Rec -> "Rec"; NonRec -> "NonRec" }
        bnds_str = injIntoList (map pprBindStr bnd)
        acc_strs = [header, bnds_str]

-- | Print `Expr`.
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 . pprBindingStr) bnd
        expr_str = (sub . pprExprStr) expr
        acc_strs = [header, bnd_str, expr_str]

-- | Print `Type`. NOTE: currently only prints @"__TyPE__"@ because there is
-- a lot of `Type` information which makes analysis of dumps hard otherwise.
pprTypeStr :: Type -> String
pprTypeStr ty = fst ("__Type__", ty)

-- | Print `Code`.
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]

-- | Print a list of `Name`s.
pprNamesStr :: [Name] -> String
pprNamesStr names = injIntoList (map pprNameStr names)

-- | Print `PathCons`.
pprPConsStr :: PathCons -> String
pprPConsStr pathcons = injNewLineSeps5 strs
  where strs = map pprPCondStr pathcons

-- | Print `PathCond`.
pprPCondStr :: PathCond -> String
pprPCondStr (PathCond (acon, params) expr locals hold) = injIntoList acc_strs
  where acon_str = pprAltConStr acon
        prms_str = injIntoList (map pprVarStr params)
        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]

-- | Print `SymLinks`.
pprLinksStr :: SymLinks -> String
pprLinksStr (SymLinks links) = injNewLineSeps5 acc_strs
  where kvs      = M.toList links
        acc_strs = map (\(k, v) -> pprNameStr k ++ " -> " ++ pprNameStr v) kvs