% 
% (c) sof 1999-
%
% @(#) $Docid: Sep. 18th 2001  09:28  Sigbjorn Finne $
% @(#) $Contactid: sof@galconn.com $
%

The 'Renamer' monad - carrying around the environments needed to
turn a set of IDL decls into a set of uniquely named Haskell decls.

\begin{code}
module RnMonad 
	(
	  RnM
	, runRnM           -- :: TypeEnv -> TagEnv -> SourceEnv 
		           -- -> RnM a -> (a, IsoEnv, IfaceNukeEnv)
	, lookupTypeId     -- :: Name -> RnM (Maybe (Maybe String, Type))
	, lookupIface      -- :: Name -> RnM (Maybe Decl)
	, lookupTag        -- :: Name -> RnM (Maybe (Maybe String, String))

	, getMethOffset    -- :: RnM (Maybe Int)
	, setMethOffset    -- :: Maybe Int -> RnM a -> RnM a
	, incMethOffset    -- :: RnM ()

	, withNewVarIdEnv  -- :: RnM a -> RnM a
	, inNewModule      -- :: RnM a -> RnM a

	, isSourceIface           -- :: Name  -> RnM Bool

        , lookupVarIdAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
        , lookupTypeIdAndAddEnv   -- :: String -> (String -> RnM a) -> RnM a
        , lookupTyConAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
        , lookupModIdAndAddEnv    -- :: String -> (String -> RnM a) -> RnM a
        , lookupClassIdAndAddEnv  -- :: String -> (String -> RnM a) -> RnM a

        , lookupTyConEnv    -- :: String -> (String -> RnM a) -> RnM a
        , lookupTypeIdEnv   -- :: String -> (String -> RnM a) -> RnM a
        , lookupVarIdEnv    -- :: String -> (String -> RnM a) -> RnM a
	, varIdInScope      -- :: String -> RnM Bool

        , addIface          -- :: String -> Decl -> RnM ()
        , addNukeIface      -- :: String -> Id -> RnM ()
        , addMethod         -- :: String -> (Maybe Int, Result, [Param]) -> RnM ()
        , addIsoMethod      -- :: String -> (Result,[Param]) -> RnM ()
        , lookupMethod      -- :: String -> RnM (Maybe [(Maybe Int, Result, [Param])])

        , setIfaceName      -- :: String -> RnM a -> RnM a
        , setModuleName     -- :: String -> RnM a -> RnM a
        , withDependers     -- :: [String] -> RnM a -> RnM a
        , getIfaceName      -- :: (String -> RnM a) -> RnM a
        , getModuleName     -- :: (String -> RnM a) -> RnM a
        , getDependers      -- :: ([String] -> RnM a) -> RnM a

	, IsoEnv
	, IfaceNukeEnv
	) where

import qualified Env
import DsMonad   ( TypeEnv, SourceEnv, TagEnv, IfaceEnv )
import CoreIDL
import CoreUtils
import BasicTypes
import Maybe ( isJust )
import Utils
\end{code}

\begin{code}
newtype RnM a  = RnM (RnEnv -> RnState -> (a, RnState))

type RnEnv = ( String    -- current interface name
             , String    -- current Haskell module name
	     , [String]  -- list of interface/modules depending on
	    		 -- iface/module being currently processed.
			 -- (Need to record this when fighting Haskell modules
			 -- in one-module-per-interface mode.)
	     )

  -- name environments are used to map from the name that occurred
  -- in the IDL input to the unique name&module to use when generating Haskell.
  -- 
  -- while renaming, when a name is encountered, we first check to see whether
  -- it has got a mapping in the NameEnv. If so, reuse it.
type NameEnv       = Env.Env String String

  -- UniqueNameEnvs are used to record how many defns of a name N there has been
  -- /in the current scope/. 
type UniqueNameEnv = Env.Env String Int

  -- the renaming pass will optionally also spot isomorphic methods, that is,
  -- methods with the same name, same method table offset (if any -- IDispatch
  -- methods doesn't have any), result and parameter types.
  -- 
  -- The underlying idea is that in many cases interfaces mapped to the same Haskell
  -- module have identical methods. Spotting the ones that are shared allows us to later
  -- generate just the one stub, rather than N. 
type MethodEnv = Env.Env String [(Maybe Int,Result,[Param])]
type IsoEnv    = Env.Env String [(Result,[Param])]

  -- the 'nuke' interface environment is used for two purposes:
  --   * some interfaces we may simply want to ignore. Period.
  --   * sometimes you see IDL input of the form 
  --            "interface _A {....}; coclass A { interface A; }"
  --     If you've got the one-module-per-iface/class option turned on,
  --     you really don't want to generate two modules for this (assuming
  --     the _A isn't used by anyone else, of course.) We support this by
  --     slurping the interface into the class' Haskell module, and dropping
  --     the generation of the interface's module alltogether.
type IfaceNukeEnv = Env.Env String (Maybe Id)
			    -- True => don't bother generating code for this iface.
			    -- False (or not in env) => do generate.
\end{code}

Carry around a set of environments that keep the various namespaces clean.
The n-spaces are:

 + typedef'ed names      (turns into type names in Haskell)
 + constructed tag names (turns into data cons in Haskell)
 + field labels	    
	IDL mimics C's rules for overloading field labels, they
	only have to be unique within a constructed type declaration, not
	across all definitions in scope. 
	    
	Since we're mapping field labels to Haskell record field
	labels, we have to ensure that a label is unique within the scope
	of one module (best we can do.)

         => Field labels, method names and constants are all in the same
            Haskell namespace, so we rename all of these wrt. to one environment.

 + A method's parameter labels is also renamed, although we can assume that
   they by this stage have been checked to have unique (IDL) names. Why? Because
   of the potential clash with Haskell keywords, e.g.,

       void foo([in]int _data, [in]int __data);

   should turn into 

       void foo([in]int data0, [in]int data1);


   To this, we use a per-method name mapping environment for these.

\begin{code}

type NameSpaceEnv = 
  ( NameEnv        -- current set of forward/unbound IDL names.
  , NameEnv        -- mapping from IDL names to (unique) Haskell name
  , UniqueNameEnv  -- mapping from Haskell names to next unique tag.
  )

-- big,fat&ugly state:
data RnState
 = RnState 
     { type_env		:: TypeEnv
     , tg_env		:: TagEnv
     , src_env		:: SourceEnv
     , tycon_env        :: NameSpaceEnv
     , modid_env        :: NameSpaceEnv
     , varid_env        :: NameSpaceEnv
     , clsid_env        :: NameSpaceEnv  -- a class' scope is essentially global in Haskell
     , tyid_env         :: NameSpaceEnv
     , meth_env		:: MethodEnv
     , iso_meths	:: IsoEnv
     , meth_offset	:: Maybe Int
     , iface_env	:: IfaceEnv
     , iface_nuke_env   :: IfaceNukeEnv
     }

runRnM :: TypeEnv
       -> TagEnv
       -> SourceEnv
       -> IfaceEnv
       -> RnM a -> (a, IsoEnv, IfaceNukeEnv)
runRnM tenv tgenv senv ienv (RnM act) = 
  case (act ("","",[]) envs) of 
    (v, RnState{iso_meths=i,iface_nuke_env=e}) -> (v, i, e)
 where
  n_env = (newINameEnv, newINameEnv, newNameEnv)
  envs = RnState
            { type_env   = tenv
	    , tg_env     = tgenv
	    , src_env    = senv
	    , tycon_env  = n_env
	    , modid_env  = n_env
	    , varid_env  = n_env
	    , clsid_env  = n_env
	    , tyid_env   = n_env
	    , meth_env   = Env.newEnv
	    , iso_meths  = Env.newEnv
	    , meth_offset = Nothing
	    , iface_env  = ienv
	    , iface_nuke_env = Env.newEnv
	    }

\end{code}

\begin{code}
lookupTypeId :: Name -> RnM (Maybe (Maybe String, Type))
lookupTypeId nm = RnM $ \ _ st -> 
  ( mapMb (\ (mod,t,_) -> (mod,t))
          (Env.lookupEnv (type_env st) nm)
  , st
  )

lookupIface :: Name -> RnM (Maybe Decl)
lookupIface nm = RnM ( \ _ st -> (Env.lookupEnv (iface_env st) nm, st))

lookupTag :: Name -> RnM (Maybe (Maybe String, String))
lookupTag nm = RnM ( \ _ st -> (Env.lookupEnv (tg_env st) nm, st))

getMethOffset :: RnM (Maybe Int)
getMethOffset = RnM ( \ _ st -> (meth_offset st, st))

setMethOffset :: Maybe Int -> RnM a -> RnM a
setMethOffset no (RnM a) = RnM ( \ env st -> a env (st{meth_offset=no}))

incMethOffset :: RnM ()
incMethOffset = RnM $ \ _ st -> 
	    let
	      st' =
	       case meth_offset st of
	         Nothing -> st
		 Just x  -> st{meth_offset=Just (x+1)}
	    in
	    ((), st')

withNewVarIdEnv :: RnM a -> RnM a
withNewVarIdEnv (RnM act) = RnM $ \ env st -> 
     let old = varid_env st in
     case act env st of
       (v, st') -> (v, st'{varid_env=old})

inNewModule :: RnM a -> RnM a
inNewModule (RnM act) = RnM $ \ env st ->
   let
    ds   = tycon_env st
    vs   = varid_env st
    ts   = tyid_env st
   in
   case act env st of
     (v, new_st) -> (v, new_st{tycon_env=ds,varid_env=vs,tyid_env=ts})

isSourceIface :: Name -> RnM Bool
isSourceIface nm =
  RnM ( \ _ st -> (isJust (Env.lookupEnv (src_env st) nm), st))

newINameEnv :: NameEnv
newINameEnv = Env.newEnv

newNameEnv :: UniqueNameEnv
newNameEnv = Env.addListToEnv Env.newEnv builtins
 where
  builtins = zip builtin_names (repeat 0)
  
  builtin_names = haskellKeywords

haskellKeywords :: [String]
haskellKeywords =
 [ "case", "class", "data", "default", "deriving", "do"
 , "else", "if", "import", "in", "infix", "infixl", "infixr"
 , "instance", "let", "module", "newtype", "of", "then", "type", "where"
 , "do"
 , "as", "qualified", "hiding" -- special ids the last three, so strictly not necessary to include them.
 ]

lookupAndAddEnv2 :: (RnState -> NameSpaceEnv)
		 -> (RnState -> NameSpaceEnv -> RnState)
		 -> String 
		 -> String
		 -> (String -> RnM a) 
		 -> RnM a
lookupAndAddEnv2 get upd nm nm_to_use cont = RnM $ \ rn_env st ->
        let (fwdMap, idlMap, env) = get st in
	case Env.lookupEnv fwdMap nm of
	  Just x -> -- a mention has already been made of this IDL name in
	  	    -- this scope, just reuse it.
		let
		 (RnM act) = cont x
		in
		act rn_env st
          Nothing -> -- no forward mention, try the IDL->HS map.
	     case Env.lookupEnv idlMap nm of
	       Just x -> -- IDL name in scope, use it's unique name. 
	       		let
	                 (RnM act) = cont x
			in
			act rn_env st
	       Nothing ->
	           -- Not seen, add it to the 'forward map', allocating
		   -- a unique name for it.
		case Env.lookupEnv env nm_to_use of
	          Nothing -> 
	            let env'      = Env.addToEnv env nm_to_use 0
		    	fwdMap'   = Env.addToEnv fwdMap nm nm_to_use
	                (RnM act) = cont nm_to_use
		    in
		    act rn_env (upd st (fwdMap', idlMap, env'))
	          Just i -> 
		    -- Find a new unique and use it.
	           let 
		       (env',nm') = addNewName env nm_to_use i
		       fwdMap'    = Env.addToEnv fwdMap nm nm'
	               (RnM act)  = cont nm'
		   in
		   act rn_env (upd st (fwdMap',idlMap,env'))

lookupAndAddEnv :: (RnState -> NameSpaceEnv)
		 -> (RnState -> NameSpaceEnv -> RnState)
		 -> String 
		 -> String
		 -> (String -> RnM a) 
		 -> RnM a
lookupAndAddEnv get upd nm nm_to_use cont = RnM $ \ rn_env st ->
        let (fwdMap,idlMap, env) = get st in
	case Env.lookupEnv fwdMap nm of
	  Just x -> -- a mention has been made of this IDL name in
	  	    -- this scope, incorporate it in the 'IDL map'
		    -- and remove it from the 'forward map'.
		case Env.lookupEnv env x of
		    -- This case could should never happen, as the
		    -- addition of a name to the 'forward map' will
		    -- have allocated a unique name using 'env'. (It's
		    -- no problem to handle it correctly though.)
		  Nothing -> let
		              env'      = Env.addToEnv env x 0
			      fwdMap'   = Env.delFromEnv fwdMap nm
			      idlMap'   = Env.addToEnv idlMap nm x
			      (RnM act) = cont x
			     in
			     act rn_env (upd st (fwdMap',idlMap', env'))
		  Just _ -> 
		    -- 
	           let 
		       fwdMap'   = Env.delFromEnv fwdMap nm
		       idlMap'   = Env.addToEnv idlMap nm x
	               (RnM act) = cont x
		   in
		   act rn_env (upd st (fwdMap',idlMap',env))
          Nothing -> -- there's been no forward reference, 
	  	     -- 'simply' find a unique name and upd. the IDL map.
	     case Env.lookupEnv env nm_to_use of
	        Nothing -> 
	          let env'       = Env.addToEnv env nm_to_use 0
		      idlMap'    = Env.addToEnv idlMap nm nm_to_use
	              (RnM act)  = cont nm_to_use
		  in
		  act rn_env (upd st (fwdMap, idlMap', env'))
	        Just i -> 
	           let (env',nm') = addNewName env nm_to_use i
		       idlMap'    = Env.addToEnv idlMap nm nm'
	               (RnM act)  = cont nm'
		   in
		   act rn_env (upd st (fwdMap,idlMap',env'))

addNewName :: Env.Env String Int
           -> String
	   -> Int
	   -> (Env.Env String Int, String)
addNewName env nm v =
  let nm' = nm ++ show v in
  case Env.lookupEnv env nm' of
   Nothing -> 
	      let env'     = Env.addToEnv env  nm  (v+1)
	          env''    = Env.addToEnv env' nm' 0
              in
	      (env'', nm')
   Just _  -> addNewName env nm (v+1)


lookupVarIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
lookupVarIdAndAddEnv nm cont = 
    lookupAndAddEnv (varid_env) (\ st env' -> st{varid_env=env'}) nm (mkHaskellVarName nm) cont

lookupTypeIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
lookupTypeIdAndAddEnv nm cont = 
    lookupAndAddEnv (tyid_env) (\ st env' -> st{tyid_env=env'}) nm (mkHaskellTyConName nm) cont

lookupTyConAndAddEnv :: String -> (String -> RnM a) -> RnM a
lookupTyConAndAddEnv nm cont = 
    lookupAndAddEnv (tycon_env) (\ st env' -> st{tycon_env=env'}) nm (mkHaskellTyConName nm) cont

lookupModIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
lookupModIdAndAddEnv nm cont = 
    lookupAndAddEnv (modid_env) (\ st env' -> st{modid_env=env'}) nm (mkHaskellTyConName nm) cont

lookupClassIdAndAddEnv :: String -> (String -> RnM a) -> RnM a
lookupClassIdAndAddEnv nm cont = 
    lookupAndAddEnv (clsid_env) (\ st env' -> st{clsid_env=env'}) nm (mkHaskellTyConName nm) cont

lookupTyConEnv :: String -> (String -> RnM a) -> RnM a
lookupTyConEnv nm cont = 
    lookupAndAddEnv2 (tycon_env) (\ st env' -> st{tycon_env=env'}) nm (mkHaskellTyConName nm) cont

lookupTypeIdEnv :: String -> (String -> RnM a) -> RnM a
lookupTypeIdEnv nm cont = 
    lookupAndAddEnv2 (tyid_env) (\ st env' -> st{tyid_env=env'}) nm (mkHaskellTyConName nm) cont

lookupVarIdEnv :: String -> (String -> RnM a) -> RnM a
lookupVarIdEnv nm cont = 
    lookupAndAddEnv2 (varid_env) (\ st env' -> st{varid_env=env'}) nm (mkHaskellVarName nm) cont

varIdInScope :: String -> RnM Bool
varIdInScope nm = RnM $ \ _ st ->
   let (_,idlMap, env) = varid_env st in
   case Env.lookupEnv idlMap nm of
     Nothing -> (isJust (Env.lookupEnv env nm), st)
     Just _  -> (True, st)

addIface :: String -> Decl -> RnM ()
addIface nm d = RnM (\ _ st -> ((), st{iface_env=Env.addToEnv (iface_env st) nm d}))

addNukeIface :: String -> Id -> RnM ()
addNukeIface nm i =
    RnM
      (\ _ st ->
	case Env.lookupEnv (iface_nuke_env st) nm of
	   Nothing -> ((), st{iface_nuke_env=Env.addToEnv (iface_nuke_env st) nm (Just i)})
	   Just _  -> ((), st{iface_nuke_env=Env.addToEnv (iface_nuke_env st) nm Nothing}))

addMethod :: String -> (Maybe Int, Result, [Param]) -> RnM ()
addMethod nm it = RnM (\ _ st -> ((), st{meth_env=Env.addToEnv_C (++) (meth_env st) nm [it]}))

addIsoMethod :: String -> (Result,[Param]) -> RnM ()
addIsoMethod nm it =
   RnM (\ _ st -> 
	  ((), st{iso_meths=Env.addToEnv_C (++) (iso_meths st) nm [it]}))

lookupMethod :: String -> RnM (Maybe [(Maybe Int, Result, [Param])])
lookupMethod nm = RnM (\ _ st -> (Env.lookupEnv (meth_env st) nm, st))

setIfaceName :: String -> RnM a -> RnM a
setIfaceName nm (RnM act) = RnM (\ (_,hmod,ls) st -> act (nm,hmod,ls) st)

setModuleName :: String -> RnM a -> RnM a
setModuleName nm (RnM act) = RnM (\ (inm,_,ls) st -> act (inm,nm,ls) st)

withDependers :: [String] -> RnM a -> RnM a
withDependers nms (RnM act) = RnM (\ (inm,nm,_) st -> act (inm,nm,nms) st)

getIfaceName :: (String -> RnM a) -> RnM a
getIfaceName f = RnM (\ env@(nm,_,_) st -> let (RnM act) = f nm in act env st)

getModuleName :: (String -> RnM a) -> RnM a
getModuleName f = RnM (\ env@(_,nm,_) st -> let (RnM act) = f nm in act env st)

getDependers :: ([String] -> RnM a) -> RnM a
getDependers f = RnM (\ env@(_,_,nms) st -> let (RnM act) = f nms in act env st)

\end{code}

And, finally, let's have a look at tomorrow's weather..

\begin{code}
instance Monad RnM where
  (>>=) (RnM m) n =
     RnM (\ env st ->
            case m env st of
	      (v, st') -> let (RnM act) = n v in
	                   act env st')
  return v = RnM (\ _ st -> (v,st))

\end{code}