-- UUAGC 0.9.50.2 (build/103/lib-ehc/UHC/Light/Compiler/CoreRun/Pretty)
module UHC.Light.Compiler.CoreRun.Pretty(ppMod', ppExp') where

import UHC.Util.Pretty
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Base.Target
import UHC.Light.Compiler.Ty
import UHC.Light.Compiler.CoreRun
import UHC.Light.Compiler.CoreRun.Prim
import UHC.Light.Compiler.Ty.Pretty
import qualified Data.Vector as V
import UHC.Light.Compiler.Foreign
import UHC.Light.Compiler.Foreign.Pretty










-- | Not all AST datatypes are expressed as AG, inherited info therefore implemented manually
data InhPP
  = InhPP
      { r2nInhPP	:: Ref2Nm		-- ^ ref to name mapping
      , optsInhPP	:: EHCOpts		-- ^ global options
      , letoffInhPP	:: Int			-- ^ offset of first binding for next let
      }

mkEmptyInhPP :: EHCOpts -> InhPP
mkEmptyInhPP opts = InhPP ref2nmEmpty opts 0

-- | Add new
r2nAdd :: Ref2Nm -> InhPP -> InhPP
r2nAdd r2n i@(InhPP {r2nInhPP=r2n', optsInhPP=opts})
  | CoreOpt_RunPPNames `elem` ehcOptCoreOpts opts = i {r2nInhPP = ref2nmUnion r2n r2n'}
  | otherwise                                     = i

-- | Update let offset
letoffUpd :: (Int -> Int) -> InhPP -> InhPP
letoffUpd upd i@(InhPP {letoffInhPP=o}) = i {letoffInhPP = upd o}

-- | PP using InhPP
ppRRef :: InhPP -> RRef -> PP_Doc
ppRRef inhpp r = ppMbPost ppCurly (r2nInhPP inhpp r) r



-- | Print extra/verbose info in cmt
ppCmtExtra' :: (PP_Doc -> PP_Doc -> PP_Doc) -> InhPP -> PP_Doc -> (PP_Doc -> PP_Doc)
ppCmtExtra' align (InhPP {optsInhPP=opts}) x
  | CoreOpt_RunPPVerbose `elem` ehcOptCoreOpts opts = (ppCmt x `align`)
  | otherwise                                       = id

-- | Print extra/verbose info in cmt
ppCmtExtra :: InhPP -> PP_Doc -> (PP_Doc -> PP_Doc)
ppCmtExtra = ppCmtExtra' (>#<)



ppMod'' :: InhPP -> Mod -> PP_Doc
ppMod'' inhpp x = pp_Syn_Mod $ wrap_Mod (sem_Mod x) (Inh_Mod {inhpp_Inh_Mod=inhpp})

ppExp'' :: InhPP -> Exp -> PP_Doc
ppExp'' inhpp x = pp_Syn_Exp $ wrap_Exp (sem_Exp x) (Inh_Exp {inhpp_Inh_Exp=inhpp})

ppSExp'' :: InhPP -> SExp -> PP_Doc
ppSExp'' inhpp x = ppExp'' inhpp (Exp_SExp x)

ppAlt'' :: InhPP -> Alt -> PP_Doc
ppAlt'' inhpp x = pp_Syn_Alt $ wrap_Alt (sem_Alt x) (Inh_Alt {inhpp_Inh_Alt=inhpp})



ppMod' :: EHCOpts -> Mod -> PP_Doc
ppMod' opts = ppMod'' (mkEmptyInhPP opts)

ppExp' :: EHCOpts -> Exp -> PP_Doc
ppExp' opts = ppExp'' (mkEmptyInhPP opts)

ppSExp' :: EHCOpts -> SExp -> PP_Doc
ppSExp' opts = ppSExp'' (mkEmptyInhPP opts)

ppAlt' :: EHCOpts -> Alt -> PP_Doc
ppAlt' opts = ppAlt'' (mkEmptyInhPP opts)



instance Show Mod where
  show _ = "Mod"

instance Show Exp where
  show _ = "Exp"

instance Show SExp where
  show _ = "SExp"

instance Show Alt where
  show _ = "Alt"



instance PP Mod where
  pp = ppMod' defaultEHCOpts

instance PP Exp where
  pp = ppExp' defaultEHCOpts

instance PP SExp where
  pp = ppSExp' defaultEHCOpts

instance PP Alt where
  pp = ppAlt' defaultEHCOpts



instance PP RRef where
  pp (RRef_Glb m e) = ppDots [pp "g", pp m, pp e]
  pp (RRef_Loc l e) = ppDots [pp "l", pp l, pp e]
  pp (RRef_LDf l e) = ppDots [pp "d", pp l, pp e]
  pp (RRef_Tag r  ) = ppDots [pp r, pp "tag"]
  pp (RRef_Fld r e) = ppDots [pp r, pp e]
  pp (RRef_Dbg n  ) = "dbg" >#< pp ("RRef_Dbg: " ++ show n)				-- intentionally the same PP as Exp_Dbg so it will parse to Exp_Dbg



ppBinds''' :: InhPP -> (Int -> PP_Doc) -> Int -> AssocL Int PP_Doc -> PP_Doc
ppBinds''' inhpp mkr off bs = vlist [ ppSemi $ ppCmtExtra inhpp ((mkr $ off+i)) e | (i,e) <- bs ]

ppBinds'' :: InhPP -> (Int -> RRef) -> Int -> CRArray Bind -> PP_Doc
ppBinds'' inhpp mkr off bs = ppBinds''' inhpp (ppRRef inhpp . mkr) off [ (i, ppExp'' inhpp e) | (i,e) <- craAssocs bs ]

-- Alt ---------------------------------------------------------
{-
   visit 0:
      inherited attribute:
         inhpp                : InhPP
      synthesized attribute:
         pp                   : PP_Doc
   alternatives:
      alternative Alt:
         child ref2nm         : {Ref2Nm}
         child expr           : Exp 
         visit 0:
            local inhpp       : _
-}
-- cata
sem_Alt :: Alt ->
           T_Alt
sem_Alt (Alt_Alt _ref2nm _expr) =
    (sem_Alt_Alt _ref2nm (sem_Exp _expr))
-- semantic domain
type T_Alt = InhPP ->
             ( PP_Doc)
data Inh_Alt = Inh_Alt {inhpp_Inh_Alt :: !(InhPP)}
data Syn_Alt = Syn_Alt {pp_Syn_Alt :: !(PP_Doc)}
wrap_Alt :: T_Alt ->
            Inh_Alt ->
            Syn_Alt
wrap_Alt sem (Inh_Alt _lhsIinhpp) =
    (let ( _lhsOpp) = sem _lhsIinhpp
     in  (Syn_Alt _lhsOpp))
sem_Alt_Alt :: Ref2Nm ->
               T_Exp ->
               T_Alt
sem_Alt_Alt ref2nm_ expr_ =
    (\ _lhsIinhpp ->
         (case (r2nAdd ref2nm_ _lhsIinhpp) of
          { _inhpp ->
          (case (_inhpp) of
           { _exprOinhpp ->
           (case (expr_ _exprOinhpp) of
            { ( _exprIpp) ->
                (case ("->" >#< _exprIpp) of
                 { _lhsOpp ->
                 ( _lhsOpp) }) }) }) }))
-- Exp ---------------------------------------------------------
{-
   visit 0:
      inherited attribute:
         inhpp                : InhPP
      synthesized attribute:
         pp                   : PP_Doc
   alternatives:
      alternative SExp:
         child sexpr          : SExp 
      alternative Tup:
         child tag            : {Int}
         child args           : {CRArray SExp}
      alternative Let:
         child firstOff       : {Int}
         child ref2nm         : {Ref2Nm}
         child binds          : {CRArray Bind}
         child body           : Exp 
         visit 0:
            local inhpp       : _
      alternative App:
         child func           : Exp 
         child args           : {CRArray SExp}
      alternative Lam:
         child mbNm           : {Maybe HsName}
         child nrArgs         : {Int}
         child stkDepth       : {Int}
         child ref2nm         : {Ref2Nm}
         child body           : Exp 
         visit 0:
            local inhpp       : _
      alternative Force:
         child expr           : Exp 
      alternative Tail:
         child expr           : Exp 
      alternative Case:
         child expr           : SExp 
         child alts           : {CRArray Alt}
      alternative FFI:
         child prim           : {RunPrim}
         child args           : {CRArray SExp}
-}
-- cata
sem_Exp :: Exp ->
           T_Exp
sem_Exp (Exp_SExp _sexpr) =
    (sem_Exp_SExp (sem_SExp _sexpr))
sem_Exp (Exp_Tup _tag _args) =
    (sem_Exp_Tup _tag _args)
sem_Exp (Exp_Let _firstOff _ref2nm _binds _body) =
    (sem_Exp_Let _firstOff _ref2nm _binds (sem_Exp _body))
sem_Exp (Exp_App _func _args) =
    (sem_Exp_App (sem_Exp _func) _args)
sem_Exp (Exp_Lam _mbNm _nrArgs _stkDepth _ref2nm _body) =
    (sem_Exp_Lam _mbNm _nrArgs _stkDepth _ref2nm (sem_Exp _body))
sem_Exp (Exp_Force _expr) =
    (sem_Exp_Force (sem_Exp _expr))
sem_Exp (Exp_Tail _expr) =
    (sem_Exp_Tail (sem_Exp _expr))
sem_Exp (Exp_Case _expr _alts) =
    (sem_Exp_Case (sem_SExp _expr) _alts)
sem_Exp (Exp_FFI _prim _args) =
    (sem_Exp_FFI _prim _args)
-- semantic domain
type T_Exp = InhPP ->
             ( PP_Doc)
data Inh_Exp = Inh_Exp {inhpp_Inh_Exp :: !(InhPP)}
data Syn_Exp = Syn_Exp {pp_Syn_Exp :: !(PP_Doc)}
wrap_Exp :: T_Exp ->
            Inh_Exp ->
            Syn_Exp
wrap_Exp sem (Inh_Exp _lhsIinhpp) =
    (let ( _lhsOpp) = sem _lhsIinhpp
     in  (Syn_Exp _lhsOpp))
sem_Exp_SExp :: T_SExp ->
                T_Exp
sem_Exp_SExp sexpr_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _sexprOinhpp ->
          (case (sexpr_ _sexprOinhpp) of
           { ( _sexprIpp) ->
               (case (_sexprIpp) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
sem_Exp_Tup :: Int ->
               (CRArray SExp) ->
               T_Exp
sem_Exp_Tup tag_ args_ =
    (\ _lhsIinhpp ->
         (case ("alloc" >#< tag_ >|< ppParensCommas (map (ppSExp'' _lhsIinhpp) $ V.toList args_)) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_Exp_Let :: Int ->
               Ref2Nm ->
               (CRArray Bind) ->
               T_Exp ->
               T_Exp
sem_Exp_Let firstOff_ ref2nm_ binds_ body_ =
    (\ _lhsIinhpp ->
         (case (letoffUpd (+ V.length binds_) $ r2nAdd ref2nm_ _lhsIinhpp) of
          { _inhpp ->
          (case (_inhpp) of
           { _bodyOinhpp ->
           (case (body_ _bodyOinhpp) of
            { ( _bodyIpp) ->
                (case ("let" >#< letoffInhPP _lhsIinhpp >#< "->" >#< ppBinds'' _inhpp (RRef_LDf 0) (letoffInhPP _lhsIinhpp) binds_ >#< "in" >-< _bodyIpp) of
                 { _lhsOpp ->
                 ( _lhsOpp) }) }) }) }))
sem_Exp_App :: T_Exp ->
               (CRArray SExp) ->
               T_Exp
sem_Exp_App func_ args_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _funcOinhpp ->
          (case (func_ _funcOinhpp) of
           { ( _funcIpp) ->
               (case ("app" >#< ppParens _funcIpp >|< ppParensCommas (map (ppSExp'' _lhsIinhpp) $ V.toList args_)) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
sem_Exp_Lam :: (Maybe HsName) ->
               Int ->
               Int ->
               Ref2Nm ->
               T_Exp ->
               T_Exp
sem_Exp_Lam mbNm_ nrArgs_ stkDepth_ ref2nm_ body_ =
    (\ _lhsIinhpp ->
         (case (letoffUpd (const nrArgs_) $ r2nAdd ref2nm_ _lhsIinhpp) of
          { _inhpp ->
          (case (_inhpp) of
           { _bodyOinhpp ->
           (case (body_ _bodyOinhpp) of
            { ( _bodyIpp) ->
                (case ("\\" >|<                        ppCommas [                                         pp nrArgs_,                    pp stkDepth_] >#< "->" >#< _bodyIpp) of
                 { _lhsOpp ->
                 ( _lhsOpp) }) }) }) }))
sem_Exp_Force :: T_Exp ->
                 T_Exp
sem_Exp_Force expr_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _exprOinhpp ->
          (case (expr_ _exprOinhpp) of
           { ( _exprIpp) ->
               (case ("eval" >|< ppParens _exprIpp) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
sem_Exp_Tail :: T_Exp ->
                T_Exp
sem_Exp_Tail expr_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _exprOinhpp ->
          (case (expr_ _exprOinhpp) of
           { ( _exprIpp) ->
               (case ("tail" >|< ppParens _exprIpp) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
sem_Exp_Case :: T_SExp ->
                (CRArray Alt) ->
                T_Exp
sem_Exp_Case expr_ alts_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _exprOinhpp ->
          (case (expr_ _exprOinhpp) of
           { ( _exprIpp) ->
               (case ("case" >#< _exprIpp >#< "of" >-< indent 1 (ppBinds''' _lhsIinhpp pp 0 $ zip [0..] $ map (ppAlt'' _lhsIinhpp) $ V.toList alts_)) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
sem_Exp_FFI :: RunPrim ->
               (CRArray SExp) ->
               T_Exp
sem_Exp_FFI prim_ args_ =
    (\ _lhsIinhpp ->
         (case ("ffi" >#< show (showRunPrim prim_) >|< ppParensCommas (map (ppSExp'' _lhsIinhpp) $ V.toList args_)) of
          { _lhsOpp ->
          ( _lhsOpp) }))
-- Mod ---------------------------------------------------------
{-
   visit 0:
      inherited attribute:
         inhpp                : InhPP
      synthesized attribute:
         pp                   : PP_Doc
   alternatives:
      alternative Mod:
         child ref2nm         : {Ref2Nm}
         child moduleNm       : {HsName}
         child moduleNr       : {Int}
         child stkDepth       : {Int}
         child binds          : {CRArray Bind}
         child body           : Exp 
         visit 0:
            local inhpp       : _
-}
-- cata
sem_Mod :: Mod ->
           T_Mod
sem_Mod (Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth _binds _body) =
    (sem_Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth _binds (sem_Exp _body))
-- semantic domain
type T_Mod = InhPP ->
             ( PP_Doc)
data Inh_Mod = Inh_Mod {inhpp_Inh_Mod :: !(InhPP)}
data Syn_Mod = Syn_Mod {pp_Syn_Mod :: !(PP_Doc)}
wrap_Mod :: T_Mod ->
            Inh_Mod ->
            Syn_Mod
wrap_Mod sem (Inh_Mod _lhsIinhpp) =
    (let ( _lhsOpp) = sem _lhsIinhpp
     in  (Syn_Mod _lhsOpp))
sem_Mod_Mod :: Ref2Nm ->
               HsName ->
               Int ->
               Int ->
               (CRArray Bind) ->
               T_Exp ->
               T_Mod
sem_Mod_Mod ref2nm_ moduleNm_ moduleNr_ stkDepth_ binds_ body_ =
    (\ _lhsIinhpp ->
         (case (r2nAdd ref2nm_ _lhsIinhpp) of
          { _inhpp ->
          (case (_inhpp) of
           { _bodyOinhpp ->
           (case (body_ _bodyOinhpp) of
            { ( _bodyIpp) ->
                (case ((ppSemi $ "module" >#< moduleNm_ >#< ppCommas [moduleNr_, stkDepth_] >#< "->" >#< _bodyIpp)
                       >-< ppBinds'' _inhpp (RRef_Glb moduleNr_) 0 binds_) of
                 { _lhsOpp ->
                 ( _lhsOpp) }) }) }) }))
-- Pat ---------------------------------------------------------
{-
   visit 0:
      inherited attribute:
         inhpp                : InhPP
      synthesized attribute:
         pp                   : PP_Doc
   alternatives:
      alternative Con:
         child tag            : {Int}
      alternative BoolExpr:
         child expr           : Exp 
-}
-- cata
sem_Pat :: Pat ->
           T_Pat
sem_Pat (Pat_Con _tag) =
    (sem_Pat_Con _tag)
sem_Pat (Pat_BoolExpr _expr) =
    (sem_Pat_BoolExpr (sem_Exp _expr))
-- semantic domain
type T_Pat = InhPP ->
             ( PP_Doc)
sem_Pat_Con :: Int ->
               T_Pat
sem_Pat_Con tag_ =
    (\ _lhsIinhpp ->
         (case (pp tag_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_Pat_BoolExpr :: T_Exp ->
                    T_Pat
sem_Pat_BoolExpr expr_ =
    (\ _lhsIinhpp ->
         (case (_lhsIinhpp) of
          { _exprOinhpp ->
          (case (expr_ _exprOinhpp) of
           { ( _exprIpp) ->
               (case (_exprIpp) of
                { _lhsOpp ->
                ( _lhsOpp) }) }) }))
-- SExp --------------------------------------------------------
{-
   visit 0:
      inherited attribute:
         inhpp                : InhPP
      synthesized attribute:
         pp                   : PP_Doc
   alternatives:
      alternative Var:
         child ref            : {RRef}
      alternative Int:
         child int            : {Int}
      alternative Char:
         child char           : {Char}
      alternative String:
         child str            : {String}
      alternative Integer:
         child integer        : {Integer}
      alternative Dbg:
         child msg            : {String}
-}
-- cata
sem_SExp :: SExp ->
            T_SExp
sem_SExp (SExp_Var _ref) =
    (sem_SExp_Var _ref)
sem_SExp (SExp_Int _int) =
    (sem_SExp_Int _int)
sem_SExp (SExp_Char _char) =
    (sem_SExp_Char _char)
sem_SExp (SExp_String _str) =
    (sem_SExp_String _str)
sem_SExp (SExp_Integer _integer) =
    (sem_SExp_Integer _integer)
sem_SExp (SExp_Dbg _msg) =
    (sem_SExp_Dbg _msg)
-- semantic domain
type T_SExp = InhPP ->
              ( PP_Doc)
sem_SExp_Var :: RRef ->
                T_SExp
sem_SExp_Var ref_ =
    (\ _lhsIinhpp ->
         (case (ppRRef _lhsIinhpp ref_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_SExp_Int :: Int ->
                T_SExp
sem_SExp_Int int_ =
    (\ _lhsIinhpp ->
         (case (pp int_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_SExp_Char :: Char ->
                 T_SExp
sem_SExp_Char char_ =
    (\ _lhsIinhpp ->
         (case (pp $ show char_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_SExp_String :: String ->
                   T_SExp
sem_SExp_String str_ =
    (\ _lhsIinhpp ->
         (case (pp $ show str_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_SExp_Integer :: Integer ->
                    T_SExp
sem_SExp_Integer integer_ =
    (\ _lhsIinhpp ->
         (case (pp integer_) of
          { _lhsOpp ->
          ( _lhsOpp) }))
sem_SExp_Dbg :: String ->
                T_SExp
sem_SExp_Dbg msg_ =
    (\ _lhsIinhpp ->
         (case (ppParens $ "dbg" >#< show msg_) of
          { _lhsOpp ->
          ( _lhsOpp) }))