uhc-light-1.1.9.1: src/UHC/Light/Compiler/Foreign/Extract.hs
-- 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) })