1 files changed, 268 insertions, 0 deletions
diff --git a/ghc/compiler/envs/E.lhs b/ghc/compiler/envs/E.lhs
new file mode 100644
index 0000000000..c0c8b0f764
--- /dev/null
+++ b/ghc/compiler/envs/E.lhs
@@ -0,0 +1,268 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+\section[E]{Main typechecker environment}
+
+\begin{code}
+#include "HsVersions.h"
+
+module E (
+	E,
+	mkE, nullE,
+	getE_GlobalVals, getE_TCE, getE_CE,
+	plusE_TCE, plusE_CE,
+
+	growE_LVE, plusE_GVE, tvOfE,
+
+	lookupE_Value, lookupE_ValueQuietly,
+	lookupE_ClassOpByKey, lookupE_Binder,
+
+	GVE(..), LVE(..),
+	plusLVE, nullLVE,
+	plusGVE, nullGVE, unitGVE, -- UNUSED: rngGVE,
+
+	-- and to make the interface self-sufficient...
+	CE(..), Id, Name, TCE(..), TyVar, Maybe, UniqFM
+    ) where
+
+import CE
+import TCE
+import UniqFM		-- basic env handling code
+
+import AbsPrel		( PrimOp
+			  IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
+			  IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+			)
+import AbsUniType	( getClassOps, extractTyVarsFromTy,
+			  getClassBigSig, getClassOpString, TyVar,
+			  TyVarTemplate, ClassOp, Class, Arity(..),
+			  TauType(..)
+			  IF_ATTACK_PRAGMAS(COMMA cmpTyVar COMMA cmpClass)
+			)
+import Id		( getIdUniType, Id, IdInfo )
+import Maybes		( MaybeErr(..), Maybe(..) )
+import Name		-- Name(..), etc.
+import Outputable	-- def of ppr, etc.
+import Pretty		-- to pretty-print error messages
+import UniqSet		-- this use of Sets is a HACK (WDP 94/05)
+import Unique		-- *Key stuff
+import Util
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Type declarations}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+data E
+  = MkE	TCE 	    -- type environment                                        
+	GVB	    -- "global" value bindings; no free type vars
+	LVB	    -- "local" value bindings; may have free type vars      
+	CE 	    -- class environment                                       
+
+mkE :: TCE -> CE -> E
+mkE tce ce = MkE tce nullGVB nullLVB ce
+
+nullE :: E
+nullE = MkE nullTCE nullGVB nullLVB nullCE
+\end{code}
+
+The ``local'' and ``global'' bindings, @LVB@ and @GVB@, are
+non-exported synonyms.  The important thing is that @GVB@ doesn't
+contain any free type variables.  This is used (only) in @tvOfE@,
+which extracts free type variables from the environment.  It's quite a
+help to have this separation because there may be quite a large bunch
+of imported things in the @GVB@, all of which are guaranteed
+polymorphic.
+
+\begin{code}
+type LVB = UniqFM Id -- Locals just have a Unique
+type GVB = UniqFM Id -- Globals might be a prelude thing; hence IdKey
+
+nullLVB = (emptyUFM :: LVB)
+nullGVB = (emptyUFM :: GVB)
+\end{code}
+
+The ``local'' and ``global'' value environments are not part of @E@ at
+all, but is used to provide increments to the value bindings.  GVE are
+carries the implication that there are no free type variables.
+
+\begin{code}
+type LVE = [(Name, Id)]	-- Maps Names to Ids
+type GVE = [(Name, Id)]	-- Maps Names to Ids
+
+nullLVE     = ([] :: LVE)
+plusLVE a b = a ++ b
+nullGVE     = ([] :: GVE)
+unitGVE n i = ( [(n, i)] :: GVE )
+-- UNUSED: rngGVE  gve = map snd gve
+plusGVE a b = a ++ b
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Value environment stuff}
+%*									*
+%************************************************************************
+
+Looking up things should mostly succeed, because the renamer should
+have spotted all out-of-scope names.  The exception is instances.
+
+The ``Quietly'' version is for pragmas, where lookups very well may
+fail. @lookup_val@ is the internal function that does the work.
+
+\begin{code}
+lookupE_Value	     :: E -> Name -> Id
+lookupE_ValueQuietly :: E -> Name -> Maybe Id
+
+lookupE_Value e nm
+  = case lookup_val e nm of
+      Succeeded id -> id
+      Failed (should_panic, msg)
+	-> if should_panic then panic msg else error msg
+
+lookupE_ValueQuietly e nm
+  = case lookup_val e nm of
+      Succeeded id -> Just id
+      Failed _	   -> Nothing
+\end{code}
+
+\begin{code}
+lookup_val (MkE _ gvb lvb ce) name
+  = case name of
+
+      WiredInVal id   -> Succeeded id
+      PreludeVal key _ -> case (lookupDirectlyUFM gvb key) of
+			    Just id -> Succeeded id
+			    Nothing -> Failed (False, prelude_err_msg)
+
+      ClassOpName uniq clas_name _ tag -> id_from_env uniq
+
+      -- You might think that top-level ids are guaranteed to have no
+      -- free tyvars, so look only in gvb; but you'd be wrong!  When
+      -- type-checking the RHS of recursive top-level defns, the name
+      -- of the thing is bound to a *monomorphic* type, which is later
+      -- generalised.  So we have to look in the LVE too.
+
+      OtherTopId uniq _ -> id_from_env uniq
+
+      -- Short names could be in either GVB or LVB
+      Short uniq _      -> id_from_env uniq
+
+      funny_name -> pprPanic "lookup_val: funny Name" (ppr PprDebug funny_name)
+  where
+    prelude_err_msg = "ERROR: in looking up a built-in Prelude value!\n(This can happen if you use `-fno-implicit-prelude'\nor you hide the system's Prelude.hi in some way.)"
+
+    id_from_env uniq
+      = case (lookupDirectlyUFM lvb uniq) of
+	  Just id -> Succeeded id
+	  Nothing ->
+	    case (lookupDirectlyUFM gvb uniq) of
+	      Just id -> Succeeded id
+	      Nothing -> Failed (True, -- should panic
+			  ("lookupE_Value: unbound name: "++(ppShow 80 (ppr PprShowAll name))))
+\end{code}
+
+For Prelude things that we reach out and grab, we have only an @Unique@.
+\begin{code}
+lookupE_ClassOpByKey :: E -> Unique{-ClassKey-} -> FAST_STRING -> Id
+
+lookupE_ClassOpByKey (MkE _ gvb lvb ce) clas_key op_str
+  = let
+	clas   = lookupCE ce (PreludeClass clas_key bottom)
+	bottom = pprPanic ("lookupE_ClassOpByKey: "++(_UNPK_ op_str))
+			  (ppAbove (pprUnique clas_key) (ppr PprShowAll (rngCE ce)))
+
+	(clas_tyvar_tmpl, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
+	  = getClassBigSig clas
+    in
+    case [ op_sel_id | (op, op_sel_id) <- ops `zip` op_sel_ids,
+		       op_str == getClassOpString op ] of
+      [op] -> op
+    -- Seems a rather horrible way to do it (ToDo)
+\end{code}
+
+@lookupE_Binder@ is like @lookupE_Value@, but it is used for {\em
+binding} occurrences of a variable, rather than {\em uses}.  The
+difference is that there should always be an entry in the LVE for
+binding occurrences.  Just a sanity check now, really.
+
+\begin{code}
+lookupE_Binder :: E -> Name -> Id
+lookupE_Binder (MkE _ _ lvb _) name
+  = case (lookupDirectlyUFM lvb (name2uniq name)) of
+      Just id -> id
+      Nothing -> pprPanic "lookupE_Binder: unbound name: " (ppr PprShowAll name)
+\end{code}
+
+\begin{code}
+getE_GlobalVals :: E -> [Id]
+getE_GlobalVals  (MkE tce gvb lvb ce)
+  = let
+    	result = eltsUFM gvb ++ eltsUFM lvb
+    in
+    -- pprTrace "Global Ids:" (ppr PprShowAll result)
+    result
+
+plusE_GVE :: E -> GVE -> E
+plusE_GVE (MkE tce gvb lvb ce) gve
+  = let
+	new_stuff = listToUFM_Directly [(name2idkey n, i) | (n,i) <- gve ]
+    in
+    MkE tce (plusUFM gvb new_stuff) lvb ce
+  where
+    name2idkey (PreludeVal k _) = k
+    name2idkey (OtherTopId u _) = u
+    name2idkey (ClassOpName u _ _ _) = u
+
+growE_LVE :: E -> LVE -> E
+growE_LVE (MkE tce gvb lvb ce) lve
+  = let
+	new_stuff = listToUFM_Directly [(name2uniq n, i) | (n,i) <- lve ]
+    in
+    MkE tce gvb (plusUFM lvb new_stuff) ce
+
+-- ToDo: move this elsewhere??
+name2uniq (Short u _)   	= u
+name2uniq (OtherTopId u _)	= u
+name2uniq (ClassOpName u _ _ _) = panic "growE_LVE:name2uniq"
+\end{code}
+
+Return the free type variables of an LVE; there are no duplicates in
+the result---hence all the @Set@ bozo-ery.  The free tyvars can only
+occur in the LVB part.
+
+\begin{code}
+tvOfE :: E -> [TyVar]
+tvOfE (MkE tce gvb lvb ce) 
+  = uniqSetToList (mkUniqSet (
+	foldr ((++) . extractTyVarsFromTy . getIdUniType) [] (eltsUFM lvb)
+    ))
+\end{code}
+
+%************************************************************************
+%*									*
+%*	
+\subsection{Type and class environments}
+%*									*
+%************************************************************************
+
+\begin{code}
+getE_TCE :: E -> TCE
+getE_TCE (MkE tce gvb lvb ce) = tce
+
+getE_CE :: E -> CE
+getE_CE  (MkE tce gvb lvb ce) = ce
+
+plusE_TCE :: E -> TCE -> E
+plusE_TCE (MkE tce gvb lvb ce) tce'
+  = MkE (plusTCE tce' tce) gvb lvb ce
+
+plusE_CE :: E -> CE -> E
+plusE_CE (MkE tce gvb lvb ce) ce'
+  = MkE tce gvb lvb (plusCE ce ce')
+\end{code}