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

import SSTG.Core

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 = (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)  -- names_str
               , "----- [Path Constraint] -----"
               , pcons_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 addr = show (memAddrInt addr)

-- | 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 = injNewLineSeps10 acc_strs
  where
    frame_strs = map pprFrameStr (stackToList 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 `Heap`'s redirection.
pprMemRedirStr :: (MemAddr, MemAddr) -> String
pprMemRedirStr (addr, redir) = sub (addr_str ++ ", " ++ redir_str)
  where
    addr_str = pprMemAddrStr addr
    redir_str = pprMemAddrStr redir

-- | Print `Heap`'s`HeapObj`.
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)

-- | Print `Heap`.
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

-- | Print `Globals`.
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

-- | Print `Locals`.
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

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

-- | 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 `DataCon`.
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]

-- | 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 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"

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

-- | 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)@.
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]

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

-- | 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 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]

-- | 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__", show 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 = pprValStr val
    acc_strs = [header, val_str]

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

-- | Print `PathCons`.
pprPathConsStr :: PathCons -> String
pprPathConsStr pathcons = injNewLineSeps5 strs
  where
    strs = map pprConstraintStr (pathConsToList pathcons)

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