-- UUAGC 0.9.52.1 (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 UHC.Util.RelMap as RelMap 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 (ref2nmLookup r $ r2nInhPP inhpp) r -- ppRRef inhpp r = {- ppMbPost ppCurly (ref2nmLookup r $ r2nInhPP inhpp) -} pp r ppRRef inhpp r -- = ppCmtExtra inhpp (maybe (pp "?") pp $ ref2nmLookup r $ r2nInhPP inhpp) $ pp r = maybe r' (\i -> ppCmtExtra inhpp (pp i) r') $ ref2nmLookup r $ r2nInhPP inhpp where r' = pp 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_Imp m e) = ppDots [pp "i", pp m, pp e] pp (RRef_Exp m e) = ppDots [pp "e", ppDifficultNm m, pp e] pp (RRef_Unr n ) = ppDots [pp "u", ppDifficultNm n] pp (RRef_Mod e ) = ppDots [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 ] -- AGItf ------------------------------------------------------- {- visit 0: synthesized attribute: nm2refGath : Nm2RefMp alternatives: alternative AGItf: child module : Mod visit 0: local inhpp : _ -} -- cata sem_AGItf :: AGItf -> T_AGItf sem_AGItf (AGItf_AGItf _module) = (sem_AGItf_AGItf (sem_Mod _module)) -- semantic domain type T_AGItf = ( Nm2RefMp) sem_AGItf_AGItf :: T_Mod -> T_AGItf sem_AGItf_AGItf module_ = (case (mkEmptyInhPP defaultEHCOpts) of { _inhpp -> (case (_inhpp) of { _moduleOinhpp -> (case (module_ _moduleOinhpp) of { ( _moduleInm2refGath,_moduleIpp) -> (case (_moduleInm2refGath) of { _lhsOnm2refGath -> ( _lhsOnm2refGath) }) }) }) }) -- 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: inherited attribute: inhpp : InhPP 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 = InhPP -> ( PP_Doc) sem_DataCon_Con :: HsName -> Int -> T_DataCon sem_DataCon_Con conNm_ tagNr_ = (\ _lhsIinhpp -> (case (ppDifficultNm conNm_ >#< "->" >#< tagNr_) of { _lhsOpp -> ( _lhsOpp) })) -- DataConL ---------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP 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 = InhPP -> ( PP_Doc,([PP_Doc])) sem_DataConL_Cons :: T_DataCon -> T_DataConL -> T_DataConL sem_DataConL_Cons hd_ tl_ = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _tlOinhpp -> (case (tl_ _tlOinhpp) of { ( _tlIpp,_tlIppL) -> (case (_lhsIinhpp) of { _hdOinhpp -> (case (hd_ _hdOinhpp) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) }) })) sem_DataConL_Nil :: T_DataConL sem_DataConL_Nil = (\ _lhsIinhpp -> (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) })) -- Export ------------------------------------------------------ {- visit 0: synthesized attribute: nm2refGath : Nm2RefMp visit 1: inherited attribute: inhpp : InhPP synthesized attribute: pp : PP_Doc alternatives: alternative Export: child nm : {HsName} child offset : {Int} -} -- cata sem_Export :: Export -> T_Export sem_Export (Export_Export _nm _offset) = (sem_Export_Export _nm _offset) -- semantic domain type T_Export = ( Nm2RefMp,T_Export_1) type T_Export_1 = InhPP -> ( PP_Doc) sem_Export_Export :: HsName -> Int -> T_Export sem_Export_Export nm_ offset_ = (case (RelMap.singleton nm_ (RRef_Mod offset_)) of { _lhsOnm2refGath -> (case ((let sem_Export_Export_1 :: T_Export_1 sem_Export_Export_1 = (\ _lhsIinhpp -> (case ("export" >#< ppDifficultNm nm_ >#< "=" >#< offset_) of { _lhsOpp -> ( _lhsOpp) })) in sem_Export_Export_1)) of { ( sem_Export_1) -> ( _lhsOnm2refGath,sem_Export_1) }) }) -- ExportL ----------------------------------------------------- {- visit 0: synthesized attribute: nm2refGath : Nm2RefMp visit 1: inherited attribute: inhpp : InhPP synthesized attributes: pp : PP_Doc ppL : [PP_Doc] alternatives: alternative Cons: child hd : Export child tl : ExportL alternative Nil: -} -- cata sem_ExportL :: ExportL -> T_ExportL sem_ExportL list = (Prelude.foldr sem_ExportL_Cons sem_ExportL_Nil (Prelude.map sem_Export list)) -- semantic domain type T_ExportL = ( Nm2RefMp,T_ExportL_1) type T_ExportL_1 = InhPP -> ( PP_Doc,([PP_Doc])) sem_ExportL_Cons :: T_Export -> T_ExportL -> T_ExportL sem_ExportL_Cons hd_ tl_ = (case (tl_) of { ( _tlInm2refGath,tl_1) -> (case (hd_) of { ( _hdInm2refGath,hd_1) -> (case (_hdInm2refGath `nm2refUnion` _tlInm2refGath) of { _lhsOnm2refGath -> (case ((let sem_ExportL_Cons_1 :: T_ExportL_1 sem_ExportL_Cons_1 = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _tlOinhpp -> (case (tl_1 _tlOinhpp) of { ( _tlIpp,_tlIppL) -> (case (_lhsIinhpp) of { _hdOinhpp -> (case (hd_1 _hdOinhpp) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) }) })) in sem_ExportL_Cons_1)) of { ( sem_ExportL_1) -> ( _lhsOnm2refGath,sem_ExportL_1) }) }) }) }) sem_ExportL_Nil :: T_ExportL sem_ExportL_Nil = (case (emptyNm2RefMp) of { _lhsOnm2refGath -> (case ((let sem_ExportL_Nil_1 :: T_ExportL_1 sem_ExportL_Nil_1 = (\ _lhsIinhpp -> (case (empty) of { _lhsOpp -> (case ([]) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) })) in sem_ExportL_Nil_1)) of { ( sem_ExportL_1) -> ( _lhsOnm2refGath,sem_ExportL_1) }) }) -- Import ------------------------------------------------------ {- visit 0: inherited attribute: inhpp : InhPP synthesized attribute: pp : PP_Doc alternatives: alternative Import: child nm : {HsName} -} -- cata sem_Import :: Import -> T_Import sem_Import (Import_Import _nm) = (sem_Import_Import _nm) -- semantic domain type T_Import = InhPP -> ( PP_Doc) sem_Import_Import :: HsName -> T_Import sem_Import_Import nm_ = (\ _lhsIinhpp -> (case ("import" >#< ppDifficultNm nm_) of { _lhsOpp -> ( _lhsOpp) })) -- ImportL ----------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP synthesized attributes: pp : PP_Doc ppL : [PP_Doc] alternatives: alternative Cons: child hd : Import child tl : ImportL alternative Nil: -} -- cata sem_ImportL :: ImportL -> T_ImportL sem_ImportL list = (Prelude.foldr sem_ImportL_Cons sem_ImportL_Nil (Prelude.map sem_Import list)) -- semantic domain type T_ImportL = InhPP -> ( PP_Doc,([PP_Doc])) sem_ImportL_Cons :: T_Import -> T_ImportL -> T_ImportL sem_ImportL_Cons hd_ tl_ = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _tlOinhpp -> (case (tl_ _tlOinhpp) of { ( _tlIpp,_tlIppL) -> (case (_lhsIinhpp) of { _hdOinhpp -> (case (hd_ _hdOinhpp) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) }) })) sem_ImportL_Nil :: T_ImportL sem_ImportL_Nil = (\ _lhsIinhpp -> (case (empty) of { _lhsOpp -> (case ([]) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) })) -- MbExp ------------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP synthesized attributes: pp : PP_Doc ppMb : Maybe PP_Doc alternatives: alternative Just: child just : Exp alternative Nothing: -} -- cata sem_MbExp :: MbExp -> T_MbExp sem_MbExp (Prelude.Just x) = (sem_MbExp_Just (sem_Exp x)) sem_MbExp Prelude.Nothing = sem_MbExp_Nothing -- semantic domain type T_MbExp = InhPP -> ( PP_Doc,(Maybe PP_Doc)) sem_MbExp_Just :: T_Exp -> T_MbExp sem_MbExp_Just just_ = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _justOinhpp -> (case (just_ _justOinhpp) of { ( _justIpp) -> (case (_justIpp) of { _lhsOpp -> (case (Just _justIpp) of { _lhsOppMb -> ( _lhsOpp,_lhsOppMb) }) }) }) })) sem_MbExp_Nothing :: T_MbExp sem_MbExp_Nothing = (\ _lhsIinhpp -> (case (empty) of { _lhsOpp -> (case (Nothing) of { _lhsOppMb -> ( _lhsOpp,_lhsOppMb) }) })) -- Meta -------------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP 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 = InhPP -> ( PP_Doc) sem_Meta_Data :: HsName -> T_DataConL -> T_Meta sem_Meta_Data tyNm_ dataCons_ = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _dataConsOinhpp -> (case (dataCons_ _dataConsOinhpp) of { ( _dataConsIpp,_dataConsIppL) -> (case ("data" >#< ppDifficultNm tyNm_ >#< "=" >#< ppBlockWithStringsH "" "" ", " _dataConsIppL) of { _lhsOpp -> ( _lhsOpp) }) }) })) -- MetaL ------------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP 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 = InhPP -> ( PP_Doc,([PP_Doc])) sem_MetaL_Cons :: T_Meta -> T_MetaL -> T_MetaL sem_MetaL_Cons hd_ tl_ = (\ _lhsIinhpp -> (case (_lhsIinhpp) of { _tlOinhpp -> (case (tl_ _tlOinhpp) of { ( _tlIpp,_tlIppL) -> (case (_lhsIinhpp) of { _hdOinhpp -> (case (hd_ _hdOinhpp) of { ( _hdIpp) -> (case (_hdIpp >-< _tlIpp) of { _lhsOpp -> (case (_hdIpp : _tlIppL) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) }) }) }) }) })) sem_MetaL_Nil :: T_MetaL sem_MetaL_Nil = (\ _lhsIinhpp -> (case (empty) of { _lhsOpp -> (case ([]) of { _lhsOppL -> ( _lhsOpp,_lhsOppL) }) })) -- Mod --------------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP synthesized attributes: nm2refGath : Nm2RefMp pp : PP_Doc alternatives: alternative Mod: child ref2nm : {Ref2Nm} child moduleNm : {HsName} child moduleNr : {Maybe Int} child stkDepth : {Int} child imports : ImportL child exports : ExportL child metas : MetaL child binds : {CRArray Bind} child mbbody : MbExp visit 0: local inhpp : _ -} -- cata sem_Mod :: Mod -> T_Mod sem_Mod (Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth _imports _exports _metas _binds _mbbody) = (sem_Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth (sem_ImportL _imports) (sem_ExportL _exports) (sem_MetaL _metas) _binds (sem_MbExp _mbbody)) -- semantic domain type T_Mod = InhPP -> ( Nm2RefMp,PP_Doc) data Inh_Mod = Inh_Mod {inhpp_Inh_Mod :: !(InhPP)} data Syn_Mod = Syn_Mod {nm2refGath_Syn_Mod :: !(Nm2RefMp),pp_Syn_Mod :: !(PP_Doc)} wrap_Mod :: T_Mod -> Inh_Mod -> Syn_Mod wrap_Mod sem (Inh_Mod _lhsIinhpp) = (let ( _lhsOnm2refGath,_lhsOpp) = sem _lhsIinhpp in (Syn_Mod _lhsOnm2refGath _lhsOpp)) sem_Mod_Mod :: Ref2Nm -> HsName -> (Maybe Int) -> Int -> T_ImportL -> T_ExportL -> T_MetaL -> (CRArray Bind) -> T_MbExp -> T_Mod sem_Mod_Mod ref2nm_ moduleNm_ moduleNr_ stkDepth_ imports_ exports_ metas_ binds_ mbbody_ = (\ _lhsIinhpp -> (case (exports_) of { ( _exportsInm2refGath,exports_1) -> (case (_exportsInm2refGath) of { _lhsOnm2refGath -> (case (r2nAdd _exportsInm2refGath _lhsIinhpp) of { _inhpp -> (case (_inhpp) of { _mbbodyOinhpp -> (case (mbbody_ _mbbodyOinhpp) of { ( _mbbodyIpp,_mbbodyIppMb) -> (case (_inhpp) of { _metasOinhpp -> (case (metas_ _metasOinhpp) of { ( _metasIpp,_metasIppL) -> (case (_inhpp) of { _exportsOinhpp -> (case (exports_1 _exportsOinhpp) of { ( _exportsIpp,_exportsIppL) -> (case (_inhpp) of { _importsOinhpp -> (case (imports_ _importsOinhpp) of { ( _importsIpp,_importsIppL) -> (case ((ppSemi $ "module" >#< ppCoreNm moduleNm_ >#< stkDepth_ >|< maybe empty (" ->" >#<) _mbbodyIppMb) >-< ppBindItems _importsIppL >-< ppBindItems _exportsIppL >-< ppBindItems _metasIppL >-< ppBinds'' _inhpp RRef_Mod 0 binds_) of { _lhsOpp -> ( _lhsOnm2refGath,_lhsOpp) }) }) }) }) }) }) }) }) }) }) }) })) -- Pat --------------------------------------------------------- {- visit 0: inherited attribute: inhpp : InhPP synthesized attribute: pp : PP_Doc alternatives: alternative Con: child tag : {Int} -} -- cata sem_Pat :: Pat -> T_Pat sem_Pat (Pat_Con _tag) = (sem_Pat_Con _tag) -- 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) })) -- 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) }))