-- UUAGC 0.9.52.1 (build/103/lib-ehc/UHC/Light/Compiler/Foreign/Extrac) module UHC.Light.Compiler.Foreign.Extract(ForeignExtraction (..), forextractMbEnt , foreignEntExtract) where import UHC.Light.Compiler.Base.Common import UHC.Light.Compiler.Foreign import Data.Maybe -- | all relevant info for all calling conventions is gathered in one place, for backends to choose from data ForeignExtraction = ForeignExtraction_Plain { forextractIncludes :: ![String] -- ccall: include files , forextractEnt :: !String -- all: name of function/... , forextractMbKnownPrim :: !(Maybe KnownPrim) -- prim: known semantics , forextractMbThisArgNr :: !(Maybe Int) -- javascript: which arg acts as this/receiver of call , forextractMbIndexArgNr :: !(Maybe Int) -- javascript: combination with indexing an array , forextractOptIsStatic :: !Bool -- ccall: static , forextractOptIsPtr :: !Bool -- ccall: pointer , forextractForeignExpr :: !ForeignExpr -- the AST for building the FFI call in terms of the target language (20101020 AD: soon replaces flags above) } | ForeignExtraction_Wrapper | ForeignExtraction_Dynamic instance Show ForeignExtraction where show (ForeignExtraction_Plain {forextractEnt=e}) = show e show ForeignExtraction_Wrapper = "wrapper" show ForeignExtraction_Dynamic = "dynamic" emptyForeignExtraction = ForeignExtraction_Plain [] "??" Nothing Nothing Nothing False False (ForeignExpr_Call ForeignExpr_Ent) forextractMbEnt :: ForeignExtraction -> Maybe String forextractMbEnt (ForeignExtraction_Plain{forextractEnt=e}) = Just e forextractMbEnt _ = Nothing foreignEntExtract :: ForeignEnt -> ForeignExtraction foreignEntExtract ty = let t = wrap_ForeignAGItf (sem_ForeignAGItf (ForeignAGItf_AGItf ty)) Inh_ForeignAGItf in extr_Syn_ForeignAGItf t -- CCall ------------------------------------------------------- {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative Id: child isStatic : {Bool} child mbInclude : {Maybe String} child asPointer : {Bool} child nm : {String} alternative Dynamic: alternative Wrapper: -} -- cata sem_CCall :: CCall -> T_CCall sem_CCall (CCall_Id _isStatic _mbInclude _asPointer _nm) = (sem_CCall_Id _isStatic _mbInclude _asPointer _nm) sem_CCall (CCall_Dynamic) = (sem_CCall_Dynamic) sem_CCall (CCall_Wrapper) = (sem_CCall_Wrapper) -- semantic domain type T_CCall = ( ForeignExtraction) sem_CCall_Id :: Bool -> (Maybe String) -> Bool -> String -> T_CCall sem_CCall_Id isStatic_ mbInclude_ asPointer_ nm_ = (case (emptyForeignExtraction { forextractIncludes = maybeToList mbInclude_ , forextractEnt = nm_ , forextractOptIsStatic = isStatic_ , forextractOptIsPtr = asPointer_ }) of { _lhsOextr -> ( _lhsOextr) }) sem_CCall_Dynamic :: T_CCall sem_CCall_Dynamic = (case (ForeignExtraction_Dynamic) of { _lhsOextr -> ( _lhsOextr) }) sem_CCall_Wrapper :: T_CCall sem_CCall_Wrapper = (case (ForeignExtraction_Wrapper) of { _lhsOextr -> ( _lhsOextr) }) -- ForeignAGItf ------------------------------------------------ {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative AGItf: child ent : ForeignEnt -} -- cata sem_ForeignAGItf :: ForeignAGItf -> T_ForeignAGItf sem_ForeignAGItf (ForeignAGItf_AGItf _ent) = (sem_ForeignAGItf_AGItf (sem_ForeignEnt _ent)) -- semantic domain type T_ForeignAGItf = ( ForeignExtraction) data Inh_ForeignAGItf = Inh_ForeignAGItf {} data Syn_ForeignAGItf = Syn_ForeignAGItf {extr_Syn_ForeignAGItf :: !(ForeignExtraction)} wrap_ForeignAGItf :: T_ForeignAGItf -> Inh_ForeignAGItf -> Syn_ForeignAGItf wrap_ForeignAGItf sem (Inh_ForeignAGItf) = (let ( _lhsOextr) = sem in (Syn_ForeignAGItf _lhsOextr)) sem_ForeignAGItf_AGItf :: T_ForeignEnt -> T_ForeignAGItf sem_ForeignAGItf_AGItf ent_ = (case (ent_) of { ( _entIextr) -> (case (_entIextr) of { _lhsOextr -> ( _lhsOextr) }) }) -- ForeignEnt -------------------------------------------------- {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative CCall: child ent : CCall alternative PlainCall: child ent : PlainCall alternative PrimCall: child ent : PrimCall alternative JavaScriptCall: child ent : JavaScriptCall -} -- cata sem_ForeignEnt :: ForeignEnt -> T_ForeignEnt sem_ForeignEnt (ForeignEnt_CCall _ent) = (sem_ForeignEnt_CCall (sem_CCall _ent)) sem_ForeignEnt (ForeignEnt_PlainCall _ent) = (sem_ForeignEnt_PlainCall (sem_PlainCall _ent)) sem_ForeignEnt (ForeignEnt_PrimCall _ent) = (sem_ForeignEnt_PrimCall (sem_PrimCall _ent)) sem_ForeignEnt (ForeignEnt_JavaScriptCall _ent) = (sem_ForeignEnt_JavaScriptCall (sem_JavaScriptCall _ent)) -- semantic domain type T_ForeignEnt = ( ForeignExtraction) sem_ForeignEnt_CCall :: T_CCall -> T_ForeignEnt sem_ForeignEnt_CCall ent_ = (case (ent_) of { ( _entIextr) -> (case (_entIextr) of { _lhsOextr -> ( _lhsOextr) }) }) sem_ForeignEnt_PlainCall :: T_PlainCall -> T_ForeignEnt sem_ForeignEnt_PlainCall ent_ = (case (ent_) of { ( _entIextr) -> (case (_entIextr) of { _lhsOextr -> ( _lhsOextr) }) }) sem_ForeignEnt_PrimCall :: T_PrimCall -> T_ForeignEnt sem_ForeignEnt_PrimCall ent_ = (case (ent_) of { ( _entIextr) -> (case (_entIextr) of { _lhsOextr -> ( _lhsOextr) }) }) sem_ForeignEnt_JavaScriptCall :: T_JavaScriptCall -> T_ForeignEnt sem_ForeignEnt_JavaScriptCall ent_ = (case (ent_) of { ( _entIextr) -> (case (_entIextr) of { _lhsOextr -> ( _lhsOextr) }) }) -- ForeignExpr ------------------------------------------------- {- alternatives: alternative Call: child expr : ForeignExpr alternative CallArgs: child expr : ForeignExpr child args : ForeignExprs alternative Ptr: child expr : ForeignExpr alternative Sel: child expr : ForeignExpr child sel : ForeignExpr alternative Inx: child expr : ForeignExpr child inx : ForeignExpr alternative Ent: alternative EntNm: child nm : {String} alternative Arg: child nr : {Int} alternative AllArg: alternative Empty: alternative Str: child str : {String} alternative ObjData: alternative NewObj: child expr : ForeignExpr -} -- cata sem_ForeignExpr :: ForeignExpr -> T_ForeignExpr sem_ForeignExpr (ForeignExpr_Call _expr) = (sem_ForeignExpr_Call (sem_ForeignExpr _expr)) sem_ForeignExpr (ForeignExpr_CallArgs _expr _args) = (sem_ForeignExpr_CallArgs (sem_ForeignExpr _expr) (sem_ForeignExprs _args)) sem_ForeignExpr (ForeignExpr_Ptr _expr) = (sem_ForeignExpr_Ptr (sem_ForeignExpr _expr)) sem_ForeignExpr (ForeignExpr_Sel _expr _sel) = (sem_ForeignExpr_Sel (sem_ForeignExpr _expr) (sem_ForeignExpr _sel)) sem_ForeignExpr (ForeignExpr_Inx _expr _inx) = (sem_ForeignExpr_Inx (sem_ForeignExpr _expr) (sem_ForeignExpr _inx)) sem_ForeignExpr (ForeignExpr_Ent) = (sem_ForeignExpr_Ent) sem_ForeignExpr (ForeignExpr_EntNm _nm) = (sem_ForeignExpr_EntNm _nm) sem_ForeignExpr (ForeignExpr_Arg _nr) = (sem_ForeignExpr_Arg _nr) sem_ForeignExpr (ForeignExpr_AllArg) = (sem_ForeignExpr_AllArg) sem_ForeignExpr (ForeignExpr_Empty) = (sem_ForeignExpr_Empty) sem_ForeignExpr (ForeignExpr_Str _str) = (sem_ForeignExpr_Str _str) sem_ForeignExpr (ForeignExpr_ObjData) = (sem_ForeignExpr_ObjData) sem_ForeignExpr (ForeignExpr_NewObj _expr) = (sem_ForeignExpr_NewObj (sem_ForeignExpr _expr)) -- semantic domain type T_ForeignExpr = ( ) sem_ForeignExpr_Call :: T_ForeignExpr -> T_ForeignExpr sem_ForeignExpr_Call expr_ = ( ) sem_ForeignExpr_CallArgs :: T_ForeignExpr -> T_ForeignExprs -> T_ForeignExpr sem_ForeignExpr_CallArgs expr_ args_ = ( ) sem_ForeignExpr_Ptr :: T_ForeignExpr -> T_ForeignExpr sem_ForeignExpr_Ptr expr_ = ( ) sem_ForeignExpr_Sel :: T_ForeignExpr -> T_ForeignExpr -> T_ForeignExpr sem_ForeignExpr_Sel expr_ sel_ = ( ) sem_ForeignExpr_Inx :: T_ForeignExpr -> T_ForeignExpr -> T_ForeignExpr sem_ForeignExpr_Inx expr_ inx_ = ( ) sem_ForeignExpr_Ent :: T_ForeignExpr sem_ForeignExpr_Ent = ( ) sem_ForeignExpr_EntNm :: String -> T_ForeignExpr sem_ForeignExpr_EntNm nm_ = ( ) sem_ForeignExpr_Arg :: Int -> T_ForeignExpr sem_ForeignExpr_Arg nr_ = ( ) sem_ForeignExpr_AllArg :: T_ForeignExpr sem_ForeignExpr_AllArg = ( ) sem_ForeignExpr_Empty :: T_ForeignExpr sem_ForeignExpr_Empty = ( ) sem_ForeignExpr_Str :: String -> T_ForeignExpr sem_ForeignExpr_Str str_ = ( ) sem_ForeignExpr_ObjData :: T_ForeignExpr sem_ForeignExpr_ObjData = ( ) sem_ForeignExpr_NewObj :: T_ForeignExpr -> T_ForeignExpr sem_ForeignExpr_NewObj expr_ = ( ) -- ForeignExprAGItf -------------------------------------------- {- alternatives: alternative AGItf: child expr : ForeignExpr -} -- cata sem_ForeignExprAGItf :: ForeignExprAGItf -> T_ForeignExprAGItf sem_ForeignExprAGItf (ForeignExprAGItf_AGItf _expr) = (sem_ForeignExprAGItf_AGItf (sem_ForeignExpr _expr)) -- semantic domain type T_ForeignExprAGItf = ( ) sem_ForeignExprAGItf_AGItf :: T_ForeignExpr -> T_ForeignExprAGItf sem_ForeignExprAGItf_AGItf expr_ = ( ) -- ForeignExprs ------------------------------------------------ {- alternatives: alternative Cons: child hd : ForeignExpr child tl : ForeignExprs alternative Nil: -} -- cata sem_ForeignExprs :: ForeignExprs -> T_ForeignExprs sem_ForeignExprs list = (Prelude.foldr sem_ForeignExprs_Cons sem_ForeignExprs_Nil (Prelude.map sem_ForeignExpr list)) -- semantic domain type T_ForeignExprs = ( ) sem_ForeignExprs_Cons :: T_ForeignExpr -> T_ForeignExprs -> T_ForeignExprs sem_ForeignExprs_Cons hd_ tl_ = ( ) sem_ForeignExprs_Nil :: T_ForeignExprs sem_ForeignExprs_Nil = ( ) -- JavaScriptCall ---------------------------------------------- {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative Id: child nm : {String} child mbInclude : {Maybe String} child mbForeignExpr : {Maybe ForeignExpr} alternative Dynamic: alternative Wrapper: -} -- cata sem_JavaScriptCall :: JavaScriptCall -> T_JavaScriptCall sem_JavaScriptCall (JavaScriptCall_Id _nm _mbInclude _mbForeignExpr) = (sem_JavaScriptCall_Id _nm _mbInclude _mbForeignExpr) sem_JavaScriptCall (JavaScriptCall_Dynamic) = (sem_JavaScriptCall_Dynamic) sem_JavaScriptCall (JavaScriptCall_Wrapper) = (sem_JavaScriptCall_Wrapper) -- semantic domain type T_JavaScriptCall = ( ForeignExtraction) sem_JavaScriptCall_Id :: String -> (Maybe String) -> (Maybe ForeignExpr) -> T_JavaScriptCall sem_JavaScriptCall_Id nm_ mbInclude_ mbForeignExpr_ = (case (emptyForeignExtraction { forextractEnt = nm_ , forextractIncludes = maybeToList mbInclude_ , forextractForeignExpr = maybe (forextractForeignExpr emptyForeignExtraction) id mbForeignExpr_ }) of { _lhsOextr -> ( _lhsOextr) }) sem_JavaScriptCall_Dynamic :: T_JavaScriptCall sem_JavaScriptCall_Dynamic = (case (ForeignExtraction_Dynamic) of { _lhsOextr -> ( _lhsOextr) }) sem_JavaScriptCall_Wrapper :: T_JavaScriptCall sem_JavaScriptCall_Wrapper = (case (ForeignExtraction_Wrapper) of { _lhsOextr -> ( _lhsOextr) }) -- PlainCall --------------------------------------------------- {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative Id: child nm : {String} -} -- cata sem_PlainCall :: PlainCall -> T_PlainCall sem_PlainCall (PlainCall_Id _nm) = (sem_PlainCall_Id _nm) -- semantic domain type T_PlainCall = ( ForeignExtraction) sem_PlainCall_Id :: String -> T_PlainCall sem_PlainCall_Id nm_ = (case (emptyForeignExtraction { forextractEnt = nm_ }) of { _lhsOextr -> ( _lhsOextr) }) -- PrimCall ---------------------------------------------------- {- visit 0: synthesized attribute: extr : ForeignExtraction alternatives: alternative Id: child nm : {String} child mbKnownPrim : {Maybe KnownPrim} -} -- cata sem_PrimCall :: PrimCall -> T_PrimCall sem_PrimCall (PrimCall_Id _nm _mbKnownPrim) = (sem_PrimCall_Id _nm _mbKnownPrim) -- semantic domain type T_PrimCall = ( ForeignExtraction) sem_PrimCall_Id :: String -> (Maybe KnownPrim) -> T_PrimCall sem_PrimCall_Id nm_ mbKnownPrim_ = (case (emptyForeignExtraction { forextractEnt = nm_ , forextractMbKnownPrim = mbKnownPrim_ }) of { _lhsOextr -> ( _lhsOextr) })