%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Jun. 8th 2001 21:45 Sigbjorn Finne $
% @(#) $Contactid: sof@galconn.com $
%
\begin{code}
module MarshallMonad
( Mm
, runMm
, getMethodName
, addCode
, addToEnv
, lookupName
, MarshallInfo(..)
, proxyMarshallInfo
, stubMarshallInfo
, structMarshallInfo
) where
import AbstractH ( Expr(..), Pat(..) )
import qualified Env
import BasicTypes
import LibUtils ( prelReturn )
data Mm a = Mm (Maybe String -> NameEnv -> (a, Cont, NameEnv))
type NameEnv = Env.Env String String
type Cont = Expr -> Expr
\end{code}
\begin{code}
runMm :: Maybe String -> [String] -> Expr -> Mm a -> Expr
runMm methName orig_names hole (Mm act) =
case act methName env of
(_, econt, _) -> peepHoleTop (econt hole)
where
env = Env.addListToEnv (Env.newEnv) (zip orig_names orig_names)
peepHoleTop :: Expr -> Expr
peepHoleTop e =
case e of
Apply f [a] -> Apply f [(peepHole a)]
x -> peepHole x
peepHole :: Expr -> Expr
peepHole e =
case e of
Let bndrs e1 -> Let bndrs (peepHole e1)
Bind (Apply (Var x) [Var y]) (PatVar z) e2
| x == prelReturn && qName y == qName z -> peepHole e2
Bind_ e1 e2 -> Bind_ (peepHole e1) (peepHole e2)
Bind e1 p e2 ->
let
p_e1 = peepHole e1
p_e2 = peepHole e2
p_e = Bind p_e1 p p_e2
in
case p of
PatVar x ->
case p_e1 of
Return (Var y) | qName x == qName y -> p_e2
_ ->
case p_e2 of
Return (Var y) | qName x == qName y -> p_e1
_ -> p_e
_ -> p_e
_ -> e
thenMm :: Mm a -> (a -> Mm b) -> Mm b
thenMm (Mm act) cont =
Mm ( \ env s ->
case (act env s) of
(v,cont1, s') ->
let (Mm b) = cont v in
case b env s' of
(x, cont2, s'') ->
(x, cont1.cont2, s''))
returnMm :: a -> Mm a
returnMm v = Mm ( \ _ s -> (v,id,s))
instance Monad Mm where
(>>=) = thenMm
return = returnMm
getMethodName :: Mm (Maybe String)
getMethodName = Mm (\ nm env -> (nm, id, env))
addCode :: (Expr -> Expr) -> Mm ()
addCode cont1 = Mm ( \ _ s -> ((), cont1, s))
lookupName :: String -> Mm (Maybe String)
lookupName nm = Mm ( \ _ env ->
case (Env.lookupEnv env nm) of
Just n -> (Just n, id, env)
Nothing -> (Nothing, id, env))
addToEnv :: String -> String -> Mm ()
addToEnv src_nm new_nm =
Mm (\ _ env ->
((), id, Env.addToEnv env src_nm new_nm))
\end{code}
Marshalling IDL types isn't merely type-directed, it also needs to take
into account the context, are we generating proxy or stub marshallers,
for a struct etc. The @MarshallInfo@ encapsulates the context and
is passed to the functions which implements the marshalling rules.
\begin{code}
data MarshallInfo
= MarshallInfo
{ forProxy :: Bool
, forStruct :: Bool
, forInOut :: Bool
, forRef :: Bool
, doFree :: Bool
}
proxyMarshallInfo :: MarshallInfo
proxyMarshallInfo =
MarshallInfo
{ forProxy = True
, forStruct = False
, forInOut = False
, forRef = False
, doFree = False
}
stubMarshallInfo :: MarshallInfo
stubMarshallInfo =
MarshallInfo
{ forProxy = False
, forStruct = False
, forInOut = False
, forRef = False
, doFree = False
}
structMarshallInfo :: MarshallInfo
structMarshallInfo =
MarshallInfo
{ forProxy = False
, forStruct = True
, forInOut = False
, forRef = True
, doFree = False
}
\end{code}