-- 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 UHC.Light.Compiler.Base.CfgPP import UHC.Light.Compiler.Scanner.Common 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 ppDifficultNm :: HsName -> PP_Doc ppDifficultNm = pp . show . show -- . ppCoreNm -- ppScanoptsNm corerunScanOpts -- | 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 (show $ "RRef_Dbg: " ++ show n) -- intentionally the same PP as Exp_Dbg so it will parse to Exp_Dbg ppBindItems :: [PP_Doc] -> PP_Doc ppBindItems bs = vlist [ ppSemi b | b <- bs ] ppBinds''' :: InhPP -> (Int -> PP_Doc) -> Int -> AssocL Int PP_Doc -> PP_Doc ppBinds''' inhpp mkr off bs = ppBindItems [ 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) }) }) }) })) -- DataCon ----------------------------------------------------- {- visit 0: synthesized attribute: pp : PP_Doc alternatives: alternative Con: child conNm : {HsName} child tagNr : {Int} -} -- cata sem_DataCon :: DataCon -> T_DataCon sem_DataCon (DataCon_Con _conNm _tagNr) = (sem_DataCon_Con _conNm _tagNr) -- semantic domain type T_DataCon = ( PP_Doc) sem_DataCon_Con :: HsName -> Int -> T_DataCon sem_DataCon_Con conNm_ tagNr_ = (case (ppDifficultNm conNm_ >#< "->" >#< tagNr_) of { _lhsOpp -> ( _lhsOpp) }) -- DataConL ---------------------------------------------------- {- visit 0: synthesized attributes: pp : PP_Doc ppL : [PP_Doc] alternatives: alternative Cons: child hd : DataCon child tl : DataConL alternative Nil: -} -- cata sem_DataConL :: DataConL -> T_DataConL sem_DataConL list = (Prelude.foldr sem_DataConL_Cons sem_DataConL_Nil (Prelude.map sem_DataCon list)) -- semantic domain type T_DataConL = ( PP_Doc,([PP_Doc])) sem_DataConL_Cons :: T_DataCon -> T_DataConL -> T_DataConL sem_DataConL_Cons hd_ tl_ = (case (tl_) of { ( _tlIpp,_tlIppL) -> (case (hd_) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) sem_DataConL_Nil :: T_DataConL sem_DataConL_Nil = (case (empty) of { _lhsOpp -> (case ([]) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) -- 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) })) -- Meta -------------------------------------------------------- {- visit 0: synthesized attribute: pp : PP_Doc alternatives: alternative Data: child tyNm : {HsName} child dataCons : DataConL -} -- cata sem_Meta :: Meta -> T_Meta sem_Meta (Meta_Data _tyNm _dataCons) = (sem_Meta_Data _tyNm (sem_DataConL _dataCons)) -- semantic domain type T_Meta = ( PP_Doc) sem_Meta_Data :: HsName -> T_DataConL -> T_Meta sem_Meta_Data tyNm_ dataCons_ = (case (dataCons_) of { ( _dataConsIpp,_dataConsIppL) -> (case ("data" >#< ppDifficultNm tyNm_ >#< "=" >#< ppBlockWithStringsH "" "" ", " _dataConsIppL) of { _lhsOpp -> ( _lhsOpp) }) }) -- MetaL ------------------------------------------------------- {- visit 0: synthesized attributes: pp : PP_Doc ppL : [PP_Doc] alternatives: alternative Cons: child hd : Meta child tl : MetaL alternative Nil: -} -- cata sem_MetaL :: MetaL -> T_MetaL sem_MetaL list = (Prelude.foldr sem_MetaL_Cons sem_MetaL_Nil (Prelude.map sem_Meta list)) -- semantic domain type T_MetaL = ( PP_Doc,([PP_Doc])) sem_MetaL_Cons :: T_Meta -> T_MetaL -> T_MetaL sem_MetaL_Cons hd_ tl_ = (case (tl_) of { ( _tlIpp,_tlIppL) -> (case (hd_) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) sem_MetaL_Nil :: T_MetaL sem_MetaL_Nil = (case (empty) of { _lhsOpp -> (case ([]) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) -- 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 metas : MetaL 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 _metas _binds _body) = (sem_Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth (sem_MetaL _metas) _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 -> T_MetaL -> (CRArray Bind) -> T_Exp -> T_Mod sem_Mod_Mod ref2nm_ moduleNm_ moduleNr_ stkDepth_ metas_ binds_ body_ = (\ _lhsIinhpp -> (case (r2nAdd ref2nm_ _lhsIinhpp) of { _inhpp -> (case (_inhpp) of { _bodyOinhpp -> (case (body_ _bodyOinhpp) of { ( _bodyIpp) -> (case (metas_) of { ( _metasIpp,_metasIppL) -> (case ((ppSemi $ "module" >#< ppCoreNm moduleNm_ >#< ppCommas [moduleNr_, stkDepth_] >#< "->" >#< _bodyIpp) >-< ppBindItems _metasIppL >-< 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) }))