module SSTG.Utils.PrettyPrint
    ( pprStateStr
    , pprLivesDeadsStr
    , pprBindingStr
    ) where

import SSTG.Core

import qualified Data.Map  as M
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)

-- | Make String from 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] -------"
                      , "" -- names_str
                      , "----- [Path Constraint] -----"
                      , pcons_str
                      , "----- [Symbolic Links] ------"
                      , links_str
                      , "<<<<<<<<<<<<<<<<<<<<<<<<<<<<<" ]

-- | Sub Member String Wrapping
sub :: String -> String
sub str = "(" ++ str ++ ")"

-- | Inject with " "
injSpace :: [String] -> String
injSpace strs = L.intercalate " " strs

-- | Inject with ","
injComma :: [String] -> String
injComma strs = L.intercalate "," strs

-- | Inject New Line
injNewLine :: [String] -> String
injNewLine strs = L.intercalate "\n" strs

-- | Inj into List
injIntoList :: [String] -> String
injIntoList strs = "[" ++ (injComma strs) ++ "]"

-- | In Newline Separators
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 (MemAddr int) = show int

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 stack) = injNewLineSeps10 acc_strs
  where frame_strs = map pprFrameStr stack
        acc_strs   = "Stack" : frame_strs

pprFrameStr :: Frame -> String
pprFrameStr (AltFrame var alts locals) = injNewLine acc_strs
  where header   = "AltFrame"
        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 = [addr_str]

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)) = injSpace acc_strs
  where header   = "SymObj"
        var_str  = pprVarStr sym
        acc_strs = [header, var_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 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
        acc_strs  = map (\(m, o) -> sub (m ++ "," ++ o)) zipd_strs

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

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

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]

pprConTagStr :: ConTag -> String
pprConTagStr (ConTag name int) = pprNameStr name

pprDataConStr :: DataCon -> String
pprDataConStr (DataCon id ty tys) = injSpace acc_strs
  where header   = "DataCon"
        id_str   = (sub . pprConTagStr) id
        ty_str   = (sub . pprTypeStr) ty
        tys_str  = injIntoList (map pprTypeStr tys)
        acc_strs = [header, id_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]

pprAltCon :: AltCon -> String
pprAltCon (DataAlt dcon) = injSpace acc_strs
  where header   = "DataAlt"
        dcon_str = (sub . pprDataConStr) dcon
        acc_strs = [header, dcon_str]
pprAltCon (LitAlt lit) = injSpace acc_strs
  where header   = "LitAlt"
        lit_str  = (sub . pprLitStr) lit
        acc_strs = [header, lit_str]
pprAltCon Default = "Default"

pprAltStr :: Alt -> String
pprAltStr (Alt acon var expr) = injSpace acc_strs
  where header   = "Alt"
        acon_str = (sub . pprAltCon) 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]

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

pprBindingStr :: Binding -> String
pprBindingStr (Binding rec bnds) = injSpace acc_strs
  where header   = case rec of { Rec -> "Rec-Bind"; NonRec -> "NonRec-Bind" }
        bnds_str = injIntoList (map bindStr bnds)
        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 . pprBindingStr) bnd
        expr_str = (sub . pprExprStr) expr
        acc_strs = [header, bnd_str, expr_str]

pprTypeStr :: Type -> String
pprTypeStr ty = "__Type__"

-- | State Code String
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]

-- | All Names String
pprNamesStr :: [Name] -> String
pprNamesStr names = injIntoList (map pprNameStr names)

-- | Path Constraints String
pprPConsStr :: PathCons -> String
pprPConsStr pathcons = injNewLineSeps5 strs
  where strs = map pprPCondStr pathcons

-- | Path Condition String
pprPCondStr :: PathCond -> String
pprPCondStr (PathCond alt expr locals hold) = injIntoList acc_strs
  where alt_str  = pprAltStr alt
        expr_str = pprExprStr expr
        locs_str = pprLocalsStr locals
        hold_str = case hold of { True -> "Positive"; False -> "Negative" }
        acc_strs = [alt_str, expr_str, locs_str, hold_str]

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