%
% (c) The Foo Project, University of Glasgow, 1998
%
% @(#) $Docid: Feb. 9th 2003 15:08 Sigbjorn Finne $
% @(#) $Contactid: sof@galois.com $
%
The desugar monad helps carry around environments
that maps user defined type names to their type and
attributes.
\begin{code}
module DsMonad
(
DsM
, runDsM
, mapDsM
, lookupType
, lookupTypeInfo
, lookupAsf
, lookupConst
, lookupIface
, lookupTag
, getAttributes
, propagateAttributes
, withAttributes
, getSrcFilename
, pushPack
, popPack
, getCurrentPack
, openUpScope
, addToTypeEnv
, addToIfaceEnv
, addToConstEnv
, getConstEnv
, addToTagEnv
, addSourceIface
, getFilename
, setFilename
, getInterface
, withInterface
, addToPath
, getPath
, inLibrary
, isInLibrary
, inImportedContext
, isInImportedContext
, addWarning
, ioToDsM
, TypeEnv
, SourceEnv
, ConstEnv
, TagEnv
, IfaceEnv
, TypeInfo
) where
import CoreIDL
import qualified IDLSyn as IDL ( Attribute )
import CoreUtils ( childAttributes )
import Env
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import IO ( hPutStrLn, stderr )
import Int ( Int32 )
import Monad ( when )
import Opts ( optVerbose, optDebug )
import Maybe ( catMaybes )
import TypeInfo
\end{code}
Lots of stuff being plumbed here...maybe I qualify for a plumber's
diploma on the grounds of this monad?
\begin{code}
type TypeEnv = Env String (Maybe String, Type, [Attribute])
type IfaceEnv = Env String Decl
type ConstEnv = Env String (Either Int32 Expr)
type SourceEnv = Env String ()
type TagEnv = Env String (Maybe String, String)
data EnvChain
= EnvChain
TypeEnv
[DsEnvs]
data DsEnvs
= DsEnvs
{ type_env :: TypeEnv
, if_env :: IfaceEnv
, co_env :: ConstEnv
, tg_env :: TagEnv
, src_env :: SourceEnv
}
freshDsEnv :: DsEnvs
freshDsEnv = DsEnvs newEnv newEnv newEnv newEnv newEnv
data DsMEnv
= DsMEnv
{ env_ref :: IORef EnvChain
, at_ref :: (IORef [Attribute])
, fn_ref :: (IORef (Maybe String))
, current_if :: (IORef (Maybe String))
, in_lib :: (IORef Bool)
, in_import :: (IORef Bool)
, tinfo_env :: Env String TypeInfo
, asf_env :: Env String (Bool,[IDL.Attribute])
, pack_stk :: IORef [(Maybe String, Int)]
, nm_path :: String
, src_name :: String
}
newtype DsM a = DsM (DsMEnv -> IO a)
\end{code}
Types out of the way, here's the big ugly action for performing @DsM@
actions:
\begin{code}
runDsM :: String
-> Env String TypeInfo
-> Env String (Bool,[IDL.Attribute])
-> [(String, Maybe String, Type)]
-> DsM a
-> IO (a, TypeEnv, TagEnv, SourceEnv, IfaceEnv)
runDsM srcFileName tInfo aenv defs (DsM m) = do
at <- newIORef []
pck <- newIORef []
md <- newIORef Nothing
cur_if <- newIORef Nothing
in_l <- newIORef False
in_im <- newIORef False
let tenv = addListToEnv newEnv (map (\(n,mo,t) -> (n, (mo,t,[]))) defs)
cha = EnvChain tenv [freshDsEnv]
chain <- newIORef cha
let denv = DsMEnv chain at md cur_if in_l in_im tInfo
aenv pck "" srcFileName
a <- m denv
cha1 <- readIORef chain
let (EnvChain t ds) = cha1
ty = unionEnvs (t:map type_env ds)
ta = unionEnvs (map tg_env ds)
sr = unionEnvs (map src_env ds)
ir = unionEnvs (map if_env ds)
return (a, ty, ta, sr, ir)
thenDsM :: DsM a -> (a -> DsM b) -> DsM b
thenDsM (DsM m) n =
DsM (\ te -> do
v <- m te
case n v of
DsM k -> k te)
returnDsM :: a -> DsM a
returnDsM v = DsM (\ _ -> return v)
openUpScope :: DsM a -> DsM a
openUpScope (DsM a) = liftDsM $ \ dse -> do
let ref = env_ref dse
cha <- readIORef ref
let (EnvChain t (x:ls)) = cha
writeIORef ref (EnvChain t [freshDsEnv])
v <- a dse
cha1 <- readIORef ref
let (EnvChain t1 nls) = cha1
ls' = x:nls ++ ls
writeIORef ref (EnvChain t1 ls')
return v
liftDsM :: (DsMEnv -> IO a) -> DsM a
liftDsM a = DsM a
lookupType :: String -> DsM (Maybe (Maybe String, Type, [Attribute]))
lookupType str = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain t ds) = chain
case lookupEnv t str of
x@(Just _) -> return x
_ -> case catMaybes (map (\ d -> lookupEnv (type_env d) str) ds) of
[] -> return Nothing
(x:_) -> return (Just x)
lookupTypeInfo :: String -> DsM (Maybe TypeInfo)
lookupTypeInfo str = liftDsM (\ (DsMEnv{tinfo_env=ti}) -> return (lookupEnv ti str))
lookupAsf :: String -> DsM (Maybe (Bool, [IDL.Attribute]))
lookupAsf str = liftDsM (\ (DsMEnv{asf_env=as}) -> return (lookupEnv as str))
lookupConst :: String -> DsM (Maybe (Either Int32 Expr))
lookupConst str = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain _ ls) = chain
case catMaybes (map (\ d -> lookupEnv (co_env d) str) ls) of
[] -> return Nothing
(x:_) -> return (Just x)
lookupIface :: String -> DsM (Maybe Decl)
lookupIface str = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain _ ls) = chain
case catMaybes (map (\ d -> lookupEnv (if_env d) str) ls) of
[] -> return Nothing
(x:_) -> return (Just x)
lookupTag :: String -> DsM (Maybe (Maybe String, String))
lookupTag str = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain _ ls) = chain
case catMaybes (map (\ d -> lookupEnv (tg_env d) str) ls) of
[] -> return Nothing
(x:_) -> return (Just x)
getAttributes :: DsM [Attribute]
getAttributes = liftDsM (\ (DsMEnv{at_ref=at_v}) -> readIORef at_v)
getSrcFilename :: DsM String
getSrcFilename = liftDsM (\ (DsMEnv{src_name=s}) -> return s)
withAttributes :: [Attribute] -> DsM a -> DsM a
withAttributes ats (DsM act) = liftDsM $
\ env@(DsMEnv{at_ref=at_v}) -> do
old_at <- readIORef at_v
writeIORef at_v ats
v <- act env
writeIORef at_v old_at
return v
propagateAttributes :: [Attribute] -> DsM a -> DsM a
propagateAttributes ats (DsM act) = liftDsM $
\ env@(DsMEnv{at_ref=at_v}) -> do
old_at <- readIORef at_v
writeIORef at_v (childAttributes ats)
v <- act env
writeIORef at_v old_at
return v
addToTypeEnv :: String -> Maybe String -> (Type, [Attribute]) -> DsM ()
addToTypeEnv str md (ty,at) = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain t (d:ds)) = chain
ty_env = type_env d
d' =d{type_env=addToEnv ty_env str (md,ty,at)}
writeIORef ref (EnvChain t (d':ds))
addToIfaceEnv :: String -> Decl -> DsM ()
addToIfaceEnv str val = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain t (d:ds)) = chain
ienv = if_env d
d' =d{if_env=addToEnv ienv str val}
writeIORef ref (EnvChain t (d':ds))
addSourceIface :: String -> DsM ()
addSourceIface str = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain t (d:ds)) = chain
senv = src_env d
d' =d{src_env=addToEnv senv str ()}
writeIORef ref (EnvChain t (d':ds))
addToConstEnv :: String -> Either Int32 Expr -> DsM ()
addToConstEnv str val = liftDsM $
\ (DsMEnv{env_ref=ref}) -> do
chain <- readIORef ref
let (EnvChain t (d:ds)) = chain
cenv = co_env d
d' =d{co_env=addToEnv cenv str val}
writeIORef ref (EnvChain t (d':ds))
addToTagEnv :: String -> String -> DsM ()
addToTagEnv str val = liftDsM $
\ (DsMEnv{env_ref=ref,fn_ref=fe}) -> do
chain <- readIORef ref
md <- readIORef fe
let (EnvChain t (d:ds)) = chain
tenv = tg_env d
d' =d{tg_env=addToEnv tenv str (md,val)}
writeIORef ref (EnvChain t (d':ds))
getConstEnv :: DsM ConstEnv
getConstEnv = liftDsM $
\ DsMEnv{env_ref=ref} -> do
chain <- readIORef ref
let (EnvChain _ ds) = chain
return (unionEnvs (map co_env ds))
getFilename :: DsM (Maybe String)
getFilename = liftDsM (\ (DsMEnv{fn_ref=md}) -> readIORef md)
setFilename :: Maybe String -> DsM ()
setFilename nm = liftDsM ( \ (DsMEnv{fn_ref=md}) -> writeIORef md nm)
getInterface :: DsM (Maybe String)
getInterface = liftDsM ( \ (DsMEnv{current_if=cur_i_ref}) -> readIORef cur_i_ref)
getPath :: DsM String
getPath = liftDsM ( \ (DsMEnv{nm_path=nm}) -> return nm)
setInterface :: Maybe String -> DsM ()
setInterface nm = liftDsM ( \ (DsMEnv{current_if=cur_i_ref}) -> writeIORef cur_i_ref nm)
addToPath :: String -> DsM a -> DsM a
addToPath nm (DsM x) =
DsM (\ (env@DsMEnv{nm_path=onm}) ->
let new_nm =
case onm of
"" -> nm
_ -> onm ++ '.':nm
in
x (env{nm_path=new_nm}))
withInterface :: String -> DsM a -> DsM a
withInterface nm act = do
old_nm <- getInterface
setInterface (Just nm)
v <- act
setInterface old_nm
return v
inLibrary :: DsM a -> DsM a
inLibrary (DsM act) = liftDsM $
\ env@(DsMEnv{in_lib=in_lib_ref}) -> do
writeIORef in_lib_ref True
v <- act env
writeIORef in_lib_ref False
return v
isInLibrary :: DsM Bool
isInLibrary = liftDsM (\ (DsMEnv{in_lib=in_lib_ref}) -> readIORef in_lib_ref)
inImportedContext :: DsM a -> DsM a
inImportedContext (DsM act) = liftDsM $
\ env@(DsMEnv{in_import=in_import_ref}) -> do
x <- readIORef in_import_ref
writeIORef in_import_ref True
v <- act env
writeIORef in_import_ref x
return v
isInImportedContext :: DsM Bool
isInImportedContext = liftDsM (\ (DsMEnv{in_import=in_import_ref}) -> readIORef in_import_ref)
pushPack :: Maybe (Maybe (String, Maybe Int)) -> DsM ()
pushPack mb_val = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
ls <- readIORef ps_ref
case mb_val of
Nothing -> writeIORef ps_ref ((Nothing,8):ls)
Just Nothing ->
case ls of
((_,x):_) -> writeIORef ps_ref ((Nothing,x):ls)
[] -> writeIORef ps_ref [(Nothing,8)]
Just (Just ("", Just x)) -> writeIORef ps_ref ((Nothing,x):ls)
Just (Just (nm, Nothing)) ->
case ls of
((_,x):_) -> writeIORef ps_ref ((Just nm,x):ls)
[] -> writeIORef ps_ref [(Just nm,8)]
Just (Just (nm, Just x)) -> writeIORef ps_ref ((Just nm,x):ls)
getCurrentPack :: DsM (Maybe Int)
getCurrentPack = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
ls <- readIORef ps_ref
case ls of
[] -> return Nothing
((_,x):_) -> return (Just x)
popPack :: Maybe (String, Maybe Int) -> DsM ()
popPack mb_i = liftDsM $ \ (DsMEnv{pack_stk=ps_ref}) -> do
ls <- readIORef ps_ref
let ls' =
case mb_i of
Nothing -> case ls of { [] -> [] ; (_:xs) -> xs }
Just ("", Just v) -> case ls of { [] -> [] ; (_:xs) -> ((Nothing,v):xs) }
Just (x,_) -> scramble x ls ls
writeIORef ps_ref ls'
where
scramble _ ls [] = ls
scramble x ls ((Nothing,_):xs) = scramble x ls xs
scramble x ls ((Just y,_):xs)
| x == y = xs
| otherwise = scramble x ls xs
\end{code}
\begin{code}
addWarning :: String -> DsM ()
addWarning msg = liftDsM ( \ _ -> when (optVerbose || optDebug ) (hPutStrLn stderr msg))
ioToDsM :: IO a -> DsM a
ioToDsM act = liftDsM ( \ _ -> act)
instance Monad DsM where
(>>=) = thenDsM
return = returnDsM
mapDsM :: (a -> b) -> DsM a -> DsM b
mapDsM f m = m >>= \ v -> return (f v)
\end{code}