uhc-light-1.1.8.7: src/UHC/Light/Compiler/CoreRun/Check.hs
-- UUAGC 0.9.50.2 (build/103/lib-ehc/UHC/Light/Compiler/CoreRun/Check.)
module UHC.Light.Compiler.CoreRun.Check(crmodCheck', Inh_AGItf (..), Syn_AGItf (..)) where
import UHC.Light.Compiler.Base.Common
import UHC.Light.Compiler.Opts
import UHC.Light.Compiler.Error
import UHC.Light.Compiler.CoreRun
import qualified UHC.Util.Rel as Rel
import qualified UHC.Light.Compiler.Module.ImportExport as ModImpExp
crmodCheck'
:: Inh_AGItf
-> Mod
-> Syn_AGItf
crmodCheck' inh crmod
= t
where t = wrap_AGItf
(sem_AGItf (AGItf_AGItf crmod))
inh
-- AGItf -------------------------------------------------------
{-
visit 0:
inherited attributes:
moduleNm : HsName
opts : EHCOpts
synthesized attributes:
hasMain : Bool
impModNmL : [HsName]
mod : ModImpExp.Mod
realModuleNm : HsName
alternatives:
alternative AGItf:
child module : Mod
-}
-- cata
sem_AGItf :: AGItf ->
T_AGItf
sem_AGItf (AGItf_AGItf _module) =
(sem_AGItf_AGItf (sem_Mod _module))
-- semantic domain
type T_AGItf = HsName ->
EHCOpts ->
( Bool,([HsName]),(ModImpExp.Mod),HsName)
data Inh_AGItf = Inh_AGItf {moduleNm_Inh_AGItf :: !(HsName),opts_Inh_AGItf :: !(EHCOpts)}
data Syn_AGItf = Syn_AGItf {hasMain_Syn_AGItf :: !(Bool),impModNmL_Syn_AGItf :: !(([HsName])),mod_Syn_AGItf :: !((ModImpExp.Mod)),realModuleNm_Syn_AGItf :: !(HsName)}
wrap_AGItf :: T_AGItf ->
Inh_AGItf ->
Syn_AGItf
wrap_AGItf sem (Inh_AGItf _lhsImoduleNm _lhsIopts) =
(let ( _lhsOhasMain,_lhsOimpModNmL,_lhsOmod,_lhsOrealModuleNm) = sem _lhsImoduleNm _lhsIopts
in (Syn_AGItf _lhsOhasMain _lhsOimpModNmL _lhsOmod _lhsOrealModuleNm))
sem_AGItf_AGItf :: T_Mod ->
T_AGItf
sem_AGItf_AGItf module_ =
(\ _lhsImoduleNm
_lhsIopts ->
(case (_lhsIopts) of
{ _moduleOopts ->
(case (_lhsImoduleNm) of
{ _moduleOmoduleNm ->
(case (module_ _moduleOmoduleNm _moduleOopts) of
{ ( _moduleIhasMain,_moduleIimpModNmL,_moduleImod,_moduleIrealModuleNm) ->
(case (_moduleIhasMain) of
{ _lhsOhasMain ->
(case (_moduleIimpModNmL) of
{ _lhsOimpModNmL ->
(case (_moduleImod) of
{ _lhsOmod ->
(case (_moduleIrealModuleNm) of
{ _lhsOrealModuleNm ->
( _lhsOhasMain,_lhsOimpModNmL,_lhsOmod,_lhsOrealModuleNm) }) }) }) }) }) }) }))
-- Alt ---------------------------------------------------------
{-
alternatives:
alternative Alt:
child ref2nm : {Ref2Nm}
child expr : Exp
-}
-- cata
sem_Alt :: Alt ->
T_Alt
sem_Alt (Alt_Alt _ref2nm _expr) =
(sem_Alt_Alt _ref2nm (sem_Exp _expr))
-- semantic domain
type T_Alt = ( )
sem_Alt_Alt :: Ref2Nm ->
T_Exp ->
T_Alt
sem_Alt_Alt ref2nm_ expr_ =
( )
-- DataCon -----------------------------------------------------
{-
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 = ( )
sem_DataCon_Con :: HsName ->
Int ->
T_DataCon
sem_DataCon_Con conNm_ tagNr_ =
( )
-- DataConL ----------------------------------------------------
{-
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 = ( )
sem_DataConL_Cons :: T_DataCon ->
T_DataConL ->
T_DataConL
sem_DataConL_Cons hd_ tl_ =
( )
sem_DataConL_Nil :: T_DataConL
sem_DataConL_Nil =
( )
-- Exp ---------------------------------------------------------
{-
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
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
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 = ( )
sem_Exp_SExp :: T_SExp ->
T_Exp
sem_Exp_SExp sexpr_ =
( )
sem_Exp_Tup :: Int ->
(CRArray SExp) ->
T_Exp
sem_Exp_Tup tag_ args_ =
( )
sem_Exp_Let :: Int ->
Ref2Nm ->
(CRArray Bind) ->
T_Exp ->
T_Exp
sem_Exp_Let firstOff_ ref2nm_ binds_ body_ =
( )
sem_Exp_App :: T_Exp ->
(CRArray SExp) ->
T_Exp
sem_Exp_App func_ args_ =
( )
sem_Exp_Lam :: (Maybe HsName) ->
Int ->
Int ->
Ref2Nm ->
T_Exp ->
T_Exp
sem_Exp_Lam mbNm_ nrArgs_ stkDepth_ ref2nm_ body_ =
( )
sem_Exp_Force :: T_Exp ->
T_Exp
sem_Exp_Force expr_ =
( )
sem_Exp_Tail :: T_Exp ->
T_Exp
sem_Exp_Tail expr_ =
( )
sem_Exp_Case :: T_SExp ->
(CRArray Alt) ->
T_Exp
sem_Exp_Case expr_ alts_ =
( )
sem_Exp_FFI :: RunPrim ->
(CRArray SExp) ->
T_Exp
sem_Exp_FFI prim_ args_ =
( )
-- Import ------------------------------------------------------
{-
visit 0:
synthesized attributes:
impModNmL : [HsName]
modImpL : [ModImpExp.ModImp]
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 = ( ([HsName]),([ModImpExp.ModImp]))
sem_Import_Import :: HsName ->
T_Import
sem_Import_Import nm_ =
(case ([nm_]) of
{ _lhsOimpModNmL ->
(case ([ModImpExp.ModImp True nm_ nm_ False [] emptyRange]) of
{ _lhsOmodImpL ->
( _lhsOimpModNmL,_lhsOmodImpL) }) })
-- ImportL -----------------------------------------------------
{-
visit 0:
synthesized attributes:
impModNmL : [HsName]
modImpL : [ModImpExp.ModImp]
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 = ( ([HsName]),([ModImpExp.ModImp]))
sem_ImportL_Cons :: T_Import ->
T_ImportL ->
T_ImportL
sem_ImportL_Cons hd_ tl_ =
(case (tl_) of
{ ( _tlIimpModNmL,_tlImodImpL) ->
(case (hd_) of
{ ( _hdIimpModNmL,_hdImodImpL) ->
(case (_hdIimpModNmL ++ _tlIimpModNmL) of
{ _lhsOimpModNmL ->
(case (_hdImodImpL ++ _tlImodImpL) of
{ _lhsOmodImpL ->
( _lhsOimpModNmL,_lhsOmodImpL) }) }) }) })
sem_ImportL_Nil :: T_ImportL
sem_ImportL_Nil =
(case ([]) of
{ _lhsOimpModNmL ->
(case ([]) of
{ _lhsOmodImpL ->
( _lhsOimpModNmL,_lhsOmodImpL) }) })
-- MbExp -------------------------------------------------------
{-
visit 0:
inherited attribute:
opts : EHCOpts
synthesized attribute:
isJust : Bool
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 = EHCOpts ->
( Bool)
sem_MbExp_Just :: T_Exp ->
T_MbExp
sem_MbExp_Just just_ =
(\ _lhsIopts ->
(case (True) of
{ _lhsOisJust ->
( _lhsOisJust) }))
sem_MbExp_Nothing :: T_MbExp
sem_MbExp_Nothing =
(\ _lhsIopts ->
(case (False) of
{ _lhsOisJust ->
( _lhsOisJust) }))
-- Meta --------------------------------------------------------
{-
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 = ( )
sem_Meta_Data :: HsName ->
T_DataConL ->
T_Meta
sem_Meta_Data tyNm_ dataCons_ =
( )
-- MetaL -------------------------------------------------------
{-
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 = ( )
sem_MetaL_Cons :: T_Meta ->
T_MetaL ->
T_MetaL
sem_MetaL_Cons hd_ tl_ =
( )
sem_MetaL_Nil :: T_MetaL
sem_MetaL_Nil =
( )
-- Mod ---------------------------------------------------------
{-
visit 0:
inherited attributes:
moduleNm : HsName
opts : EHCOpts
synthesized attributes:
hasMain : Bool
impModNmL : [HsName]
mod : ModImpExp.Mod
realModuleNm : HsName
alternatives:
alternative Mod:
child ref2nm : {Ref2Nm}
child moduleNm : {HsName}
child moduleNr : {Int}
child stkDepth : {Int}
child imports : ImportL
child metas : MetaL
child binds : {CRArray Bind}
child mbbody : MbExp
visit 0:
local realModuleNm : _
-}
-- cata
sem_Mod :: Mod ->
T_Mod
sem_Mod (Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth _imports _metas _binds _mbbody) =
(sem_Mod_Mod _ref2nm _moduleNm _moduleNr _stkDepth (sem_ImportL _imports) (sem_MetaL _metas) _binds (sem_MbExp _mbbody))
-- semantic domain
type T_Mod = HsName ->
EHCOpts ->
( Bool,([HsName]),(ModImpExp.Mod),HsName)
sem_Mod_Mod :: Ref2Nm ->
HsName ->
Int ->
Int ->
T_ImportL ->
T_MetaL ->
(CRArray Bind) ->
T_MbExp ->
T_Mod
sem_Mod_Mod ref2nm_ moduleNm_ moduleNr_ stkDepth_ imports_ metas_ binds_ mbbody_ =
(\ _lhsImoduleNm
_lhsIopts ->
(case (_lhsIopts) of
{ _mbbodyOopts ->
(case (mbbody_ _mbbodyOopts) of
{ ( _mbbodyIisJust) ->
(case (_mbbodyIisJust) of
{ _lhsOhasMain ->
(case (imports_) of
{ ( _importsIimpModNmL,_importsImodImpL) ->
(case (_importsIimpModNmL) of
{ _lhsOimpModNmL ->
(case (moduleNm_) of
{ _realModuleNm ->
(case (ModImpExp.Mod
_realModuleNm (Just _realModuleNm) Nothing _importsImodImpL
Rel.empty
Rel.empty
[]) of
{ _lhsOmod ->
(case (_realModuleNm) of
{ _lhsOrealModuleNm ->
( _lhsOhasMain,_lhsOimpModNmL,_lhsOmod,_lhsOrealModuleNm) }) }) }) }) }) }) }) }))
-- Pat ---------------------------------------------------------
{-
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 = ( )
sem_Pat_Con :: Int ->
T_Pat
sem_Pat_Con tag_ =
( )
-- SExp --------------------------------------------------------
{-
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 = ( )
sem_SExp_Var :: RRef ->
T_SExp
sem_SExp_Var ref_ =
( )
sem_SExp_Int :: Int ->
T_SExp
sem_SExp_Int int_ =
( )
sem_SExp_Char :: Char ->
T_SExp
sem_SExp_Char char_ =
( )
sem_SExp_String :: String ->
T_SExp
sem_SExp_String str_ =
( )
sem_SExp_Integer :: Integer ->
T_SExp
sem_SExp_Integer integer_ =
( )
sem_SExp_Dbg :: String ->
T_SExp
sem_SExp_Dbg msg_ =
( )