-- UUAGC 0.9.50.2 (build/103/lib-ehc/UHC/Light/Compiler/Foreign.ag) 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 -- | evaluation of a ForeignExpr has arguments, known by index [1..], and a foreign entity 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 :: -- the (partial) algebra for constructing an e ( e -> e -> e -- select , e -> e -> e -- index , e -> [e] -> e -- call , e -> e -- as var/ptr , [e] -> e -- object , e -> e -- new object , String -> e -- name , String -> e -- string ) -> ForeignExpr -> e -- ent -> [e] -- args -> 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 d) = sputWord8 0 >> sput a >> sput b >> sput c >> sput d sget = do t <- sgetWord8 case t of 0 -> liftM4 JavaScriptCall_Id sget sget 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 -- CCall ------------------------------------------------------- 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 ( Data,Eq,Show,Typeable) -- ForeignAGItf ------------------------------------------------ data ForeignAGItf = ForeignAGItf_AGItf {ent_ForeignAGItf_AGItf :: !(ForeignEnt)} -- 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 ( Data,Eq,Show,Typeable) -- ForeignExpr ------------------------------------------------- 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 ( Data,Eq,Show,Typeable) -- ForeignExprAGItf -------------------------------------------- data ForeignExprAGItf = ForeignExprAGItf_AGItf {expr_ForeignExprAGItf_AGItf :: !(ForeignExpr)} -- ForeignExprs ------------------------------------------------ type ForeignExprs = [ForeignExpr] -- JavaScriptCall ---------------------------------------------- data JavaScriptCall = JavaScriptCall_Id {nm_JavaScriptCall_Id :: !(String),mbInclude_JavaScriptCall_Id :: !((Maybe String)),mbForeignExpr_JavaScriptCall_Id :: !((Maybe ForeignExpr))} | JavaScriptCall_Dynamic {} | JavaScriptCall_Wrapper {} deriving ( Data,Eq,Show,Typeable) -- PlainCall --------------------------------------------------- data PlainCall = PlainCall_Id {nm_PlainCall_Id :: !(String)} deriving ( Data,Eq,Show,Typeable) -- PrimCall ---------------------------------------------------- data PrimCall = PrimCall_Id {nm_PrimCall_Id :: !(String),mbKnownPrim_PrimCall_Id :: !((Maybe KnownPrim))} deriving ( Data,Eq,Show,Typeable)