module UHC.Light.Compiler.Foreign(ForeignEnt (..), CCall (..), PlainCall (..), PrimCall (..), JavaScriptCall (..)
, ForeignExpr (..), ForeignExprs
, ForeignExprAGItf (..), ForeignAGItf (..)
, foreignexprEval
, ForeignDirection (..)) where
import UHC.Light.Compiler.Base.Common
import qualified Data.Map as Map
import qualified Data.Set as Set
import UHC.Util.Utils
import Control.Monad
import UHC.Util.Binary
import UHC.Util.Serialize
data IE e
= IE { ieArgs :: [e]
}
data OE e
= OE { oeEL :: [e]
, oeUsed :: Set.Set Int
}
mkOE :: e -> Set.Set Int -> OE e
mkOE e s = OE [e] s
oeE :: OE e -> e
oeE = head . oeEL
foreignexprEval
::
( e -> e -> e
, e -> e -> e
, e -> [e] -> e
, e -> e
, [e] -> e
, e -> e
, String -> e
, String -> e
)
-> ForeignExpr
-> e
-> [e]
-> e
foreignexprEval
(mkSel,mkInx,mkCall,mkPtr,mkObj,mkNewObj,mkNm,mkStr)
fexpr ent args
= oeE oe
where argl = zip [1..] args
env = Map.fromList argl
oe = ev fexpr (IE [a | (i,a) <- argl, not $ i `Set.member` oeUsed oe])
ev (ForeignExpr_Ent ) ie = let
in mkOE ent
( Set.empty )
ev (ForeignExpr_EntNm n) ie = let
in mkOE ( mkNm n )
( Set.empty )
ev (ForeignExpr_Str s) ie = let
in mkOE ( mkStr s )
( Set.empty )
ev (ForeignExpr_Arg a ) ie = let
in mkOE ( Map.findWithDefault (panic "foreignexprEval.Arg") a env )
( Set.singleton a )
ev (ForeignExpr_AllArg ) ie = let
in OE ( ieArgs ie )
( Set.empty )
ev (ForeignExpr_Sel e s) ie = let eo = ev e ie
so = ev s ie
in mkOE ( mkSel (oeE eo) (oeE so) )
( oeUsed eo `Set.union` oeUsed so )
ev (ForeignExpr_Inx e i) ie = let eo = ev e ie
io = ev i ie
in mkOE ( mkInx (oeE eo) (oeE io) )
( oeUsed eo `Set.union` oeUsed io )
ev (ForeignExpr_Ptr e ) ie = let eo = ev e ie
in eo {oeEL = [mkPtr $ oeE eo]}
ev (ForeignExpr_Call e ) ie = let eo = ev e ie
in eo {oeEL = [mkCall (oeE eo) (ieArgs ie)]}
ev (ForeignExpr_CallArgs f a)
ie = let fo = ev f ie
ao = evs a ie
in mkOE ( mkCall (oeE fo) (concatMap oeEL ao) )
( Set.unions $ oeUsed fo : map oeUsed ao )
ev (ForeignExpr_ObjData) ie = let
in mkOE ( mkObj (ieArgs ie) )
( Set.empty )
ev (ForeignExpr_NewObj e) ie = let eo = ev e ie
in eo { oeEL = [mkNewObj $ oeE eo] }
evs feL ie = map (\e -> ev e ie) feL
data ForeignDirection
= ForeignDirection_Import
| ForeignDirection_Export
deriving (Eq,Ord)
instance Serialize ForeignExpr where
sput (ForeignExpr_Ent ) = sputWord8 0
sput (ForeignExpr_EntNm a ) = sputWord8 1 >> sput a
sput (ForeignExpr_Arg a ) = sputWord8 2 >> sput a
sput (ForeignExpr_Sel a b) = sputWord8 3 >> sput a >> sput b
sput (ForeignExpr_Inx a b) = sputWord8 4 >> sput a >> sput b
sput (ForeignExpr_Ptr a ) = sputWord8 5 >> sput a
sput (ForeignExpr_Call a ) = sputWord8 6 >> sput a
sput (ForeignExpr_CallArgs a b) = sputWord8 7 >> sput a >> sput b
sput (ForeignExpr_AllArg ) = sputWord8 8
sput (ForeignExpr_Str a ) = sputWord8 9 >> sput a
sput (ForeignExpr_ObjData ) = sputWord8 10
sput (ForeignExpr_NewObj a ) = sputWord8 11 >> sput a
sget = do
t <- sgetWord8
case t of
0 -> return ForeignExpr_Ent
1 -> liftM ForeignExpr_EntNm sget
2 -> liftM ForeignExpr_Arg sget
3 -> liftM2 ForeignExpr_Sel sget sget
4 -> liftM2 ForeignExpr_Inx sget sget
5 -> liftM ForeignExpr_Ptr sget
6 -> liftM ForeignExpr_Call sget
7 -> liftM2 ForeignExpr_CallArgs sget sget
8 -> return ForeignExpr_AllArg
9 -> liftM ForeignExpr_Str sget
10 -> return ForeignExpr_ObjData
11 -> liftM ForeignExpr_NewObj sget
instance Serialize ForeignEnt where
sput (ForeignEnt_CCall a) = sputWord8 0 >> sput a
sput (ForeignEnt_PlainCall a) = sputWord8 1 >> sput a
sput (ForeignEnt_PrimCall a) = sputWord8 2 >> sput a
sput (ForeignEnt_JavaScriptCall a) = sputWord8 3 >> sput a
sget = do t <- sgetWord8
case t of
0 -> liftM ForeignEnt_CCall sget
1 -> liftM ForeignEnt_PlainCall sget
2 -> liftM ForeignEnt_PrimCall sget
3 -> liftM ForeignEnt_JavaScriptCall sget
instance Serialize CCall where
sput (CCall_Id a b c d) = sputWord8 0 >> sput a >> sput b >> sput c >> sput d
sput (CCall_Dynamic ) = sputWord8 1
sput (CCall_Wrapper ) = sputWord8 2
sget = do t <- sgetWord8
case t of
0 -> liftM4 CCall_Id sget sget sget sget
1 -> return CCall_Dynamic
2 -> return CCall_Wrapper
instance Serialize PlainCall where
sput (PlainCall_Id a) = sputWord8 0 >> sput a
sget = do t <- sgetWord8
case t of
0 -> liftM PlainCall_Id sget
instance Serialize PrimCall where
sput (PrimCall_Id a b) = sputWord8 0 >> sput a >> sput b
sget = do t <- sgetWord8
case t of
0 -> liftM2 PrimCall_Id sget sget
instance Serialize JavaScriptCall where
sput (JavaScriptCall_Id a b c) = sputWord8 0 >> sput a >> sput b >> sput c
sput (JavaScriptCall_Dynamic ) = sputWord8 1
sput (JavaScriptCall_Wrapper ) = sputWord8 2
sget = do t <- sgetWord8
case t of
0 -> liftM3 JavaScriptCall_Id sget sget sget
1 -> return JavaScriptCall_Dynamic
2 -> return JavaScriptCall_Wrapper
data CCall = CCall_Id {isStatic_CCall_Id :: !(Bool),mbInclude_CCall_Id :: !((Maybe String)),asPointer_CCall_Id :: !(Bool),nm_CCall_Id :: !(String)}
| CCall_Dynamic {}
| CCall_Wrapper {}
deriving ( Eq,Show,Typeable)
data ForeignAGItf = ForeignAGItf_AGItf {ent_ForeignAGItf_AGItf :: !(ForeignEnt)}
data ForeignEnt = ForeignEnt_CCall {ent_ForeignEnt_CCall :: !(CCall)}
| ForeignEnt_PlainCall {ent_ForeignEnt_PlainCall :: !(PlainCall)}
| ForeignEnt_PrimCall {ent_ForeignEnt_PrimCall :: !(PrimCall)}
| ForeignEnt_JavaScriptCall {ent_ForeignEnt_JavaScriptCall :: !(JavaScriptCall)}
deriving ( Eq,Show,Typeable)
data ForeignExpr = ForeignExpr_Call {expr_ForeignExpr_Call :: !(ForeignExpr)}
| ForeignExpr_CallArgs {expr_ForeignExpr_CallArgs :: !(ForeignExpr),args_ForeignExpr_CallArgs :: !(ForeignExprs)}
| ForeignExpr_Ptr {expr_ForeignExpr_Ptr :: !(ForeignExpr)}
| ForeignExpr_Sel {expr_ForeignExpr_Sel :: !(ForeignExpr),sel_ForeignExpr_Sel :: !(ForeignExpr)}
| ForeignExpr_Inx {expr_ForeignExpr_Inx :: !(ForeignExpr),inx_ForeignExpr_Inx :: !(ForeignExpr)}
| ForeignExpr_Ent {}
| ForeignExpr_EntNm {nm_ForeignExpr_EntNm :: !(String)}
| ForeignExpr_Arg {nr_ForeignExpr_Arg :: !(Int)}
| ForeignExpr_AllArg {}
| ForeignExpr_Empty {}
| ForeignExpr_Str {str_ForeignExpr_Str :: !(String)}
| ForeignExpr_ObjData {}
| ForeignExpr_NewObj {expr_ForeignExpr_NewObj :: !(ForeignExpr)}
deriving ( Eq,Show,Typeable)
data ForeignExprAGItf = ForeignExprAGItf_AGItf {expr_ForeignExprAGItf_AGItf :: !(ForeignExpr)}
type ForeignExprs = [ForeignExpr]
data JavaScriptCall = JavaScriptCall_Id {nm_JavaScriptCall_Id :: !(String),mbInclude_JavaScriptCall_Id :: !((Maybe String)),mbForeignExpr_JavaScriptCall_Id :: !((Maybe ForeignExpr))}
| JavaScriptCall_Dynamic {}
| JavaScriptCall_Wrapper {}
deriving ( Eq,Show,Typeable)
data PlainCall = PlainCall_Id {nm_PlainCall_Id :: !(String)}
deriving ( Eq,Show,Typeable)
data PrimCall = PrimCall_Id {nm_PrimCall_Id :: !(String),mbKnownPrim_PrimCall_Id :: !((Maybe KnownPrim))}
deriving ( Eq,Show,Typeable)