Foreign.hs


-- UUAGC 0.9.52.1 (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
instance Serialize ForeignEnt
instance Serialize CCall
instance Serialize PlainCall
instance Serialize PrimCall
instance Serialize JavaScriptCall

-- 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 ( Eq,Generic,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 ( Eq,Generic,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 ( Eq,Generic,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 ( Eq,Generic,Show,Typeable)
-- PlainCall ---------------------------------------------------
data PlainCall = PlainCall_Id {nm_PlainCall_Id :: !(String)}
               deriving ( Eq,Generic,Show,Typeable)
-- PrimCall ----------------------------------------------------
data PrimCall = PrimCall_Id {nm_PrimCall_Id :: !(String),mbKnownPrim_PrimCall_Id :: !((Maybe KnownPrim))}
              deriving ( Eq,Generic,Show,Typeable)