[project @ 2003-03-27 08:18:21 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnTypes.lhs

diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs
index beff457..f61115a 100644 (file)
--- a/ghc/compiler/typecheck/TcRnTypes.lhs
+++ b/ghc/compiler/typecheck/TcRnTypes.lhs
@@ -11,7 +11,7 @@ module TcRnTypes(
        -- Non-standard operations
        runTcRn, fixM, tryM, ioToTcRn,
        newMutVar, readMutVar, writeMutVar,
        -- Non-standard operations
        runTcRn, fixM, tryM, ioToTcRn,
        newMutVar, readMutVar, writeMutVar,

-       getEnv, setEnv, updEnv, unsafeInterleaveM, 
+       getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv,

                
        -- The environment types
        Env(..), TopEnv(..), TcGblEnv(..), 
                
        -- The environment types
        Env(..), TopEnv(..), TcGblEnv(..), 

@@ -23,7 +23,7 @@ module TcRnTypes(
        ImportAvails(..), emptyImportAvails, plusImportAvails, 
        plusAvail, pruneAvails,  
        AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, 
        ImportAvails(..), emptyImportAvails, plusImportAvails, 
        plusAvail, pruneAvails,  
        AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv, 

-       mkAvailEnv, lookupAvailEnv, availEnvElts, addAvail,
+       mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail,

        WhereFrom(..),
 
        -- Typechecker types
        WhereFrom(..),
 
        -- Typechecker types

@@ -34,7 +34,7 @@ module TcRnTypes(
        Level, impLevel, topLevel,
 
        -- Insts
        Level, impLevel, topLevel,
 
        -- Insts

-       Inst(..), InstOrigin(..), InstLoc, pprInstLoc,
+       Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc,

        LIE, emptyLIE, unitLIE, plusLIE, consLIE, 
        plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
 
        LIE, emptyLIE, unitLIE, plusLIE, consLIE, 
        plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
 

@@ -46,13 +46,14 @@ module TcRnTypes(
 
 import HsSyn           ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl )
 import RnHsSyn         ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo )
 
 import HsSyn           ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl )
 import RnHsSyn         ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo )

-import HscTypes                ( GhciMode, ExternalPackageState, HomePackageTable, NameCache,
-                         GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing, 
-                         Avails, GenAvailInfo(..), AvailInfo, availName,
-                         IsBootInterface, Deprecations, WhetherHasOrphans )
+import HscTypes                ( GhciMode, ExternalPackageState, HomePackageTable, 
+                         NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv,
+                         TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo,
+                          availName, IsBootInterface, Deprecations,
+                          ExternalPackageState(..), emptyExternalPackageState )

 import Packages                ( PackageName )
 import Packages                ( PackageName )

-import TcType          ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind,
-                         tcCmpPred, tcCmpType, tcCmpTypes )
+import TcType          ( TcTyVarSet, TcType, TcTauType, TcThetaType, 
+                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes )

 import InstEnv         ( DFunId, InstEnv )
 import Name            ( Name )
 import NameEnv
 import InstEnv         ( DFunId, InstEnv )
 import Name            ( Name )
 import NameEnv

@@ -74,10 +75,11 @@ import Outputable
 import DATA_IOREF      ( IORef, newIORef, readIORef, writeIORef )
 import UNSAFE_IO       ( unsafeInterleaveIO )
 import FIX_IO          ( fixIO )
 import DATA_IOREF      ( IORef, newIORef, readIORef, writeIORef )
 import UNSAFE_IO       ( unsafeInterleaveIO )
 import FIX_IO          ( fixIO )

-import EXCEPTION       ( Exception )
+import EXCEPTION       ( Exception(..) )
+import IO              ( isUserError )

 import Maybe           ( mapMaybe )
 import Maybe           ( mapMaybe )

-import List            ( nub )
-import Panic           ( tryMost )
+import ListSetOps      ( unionLists )
+import Panic           ( tryJust )

 \end{code}
 
 
 \end{code}
 
 

@@ -157,7 +159,15 @@ Error recovery
 \begin{code}
 tryM :: TcRn m r -> TcRn m (Either Exception r)
 -- Reflect exception into TcRn monad
 \begin{code}
 tryM :: TcRn m r -> TcRn m (Either Exception r)
 -- Reflect exception into TcRn monad

-tryM (TcRn thing) = TcRn (\ env -> tryMost (thing env))
+tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env))
+  where 
+#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
+       tc_errors e@(IOException ioe) | isUserError ioe = Just e
+#else
+       tc_errors e | isUserError e = Just e
+#endif
+       tc_errors _other = Nothing
+       -- type checker failures show up as UserErrors only

 \end{code}
 
 Lazy interleave 
 \end{code}
 
 Lazy interleave 

@@ -201,6 +211,47 @@ updEnv :: (Env m -> Env n) -> TcRn n a -> TcRn m a
 updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
 \end{code}
 
 updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
 \end{code}
 

+\begin{code}
+zapEnv :: TcRn m a -> TcRn m a
+zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } ->
+  case top of {
+   TopEnv{ 
+     top_mode    = mode,
+     top_dflags  = dflags,
+     top_hpt     = hpt,
+     top_eps     = eps,
+     top_us      = us
+    } -> do
+
+  eps_snap <- readIORef eps
+  ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap }
+
+  let
+     top' = TopEnv {
+               top_mode   = mode,
+               top_dflags = dflags,
+               top_hpt    = hpt,
+               top_eps    = ref,
+               top_us     = us
+           }
+
+     type_env = tcg_type_env gbl
+     mod = tcg_mod gbl
+     gbl' = TcGblEnv {
+               tcg_mod = mod,
+               tcg_type_env = type_env
+           }
+
+     env' = Env {
+               env_top = top',
+               env_gbl = gbl',
+               env_lcl = lcl
+               -- leave the rest empty
+            }
+
+  case act of { TcRn f -> f env' }
+ }
+\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -235,6 +286,7 @@ data TopEnv -- Built once at top level then does not change
                -- PIT, ImportedModuleInfo
                -- DeclsMap, IfaceRules, IfaceInsts, InstGates
                -- TypeEnv, InstEnv, RuleBase
                -- PIT, ImportedModuleInfo
                -- DeclsMap, IfaceRules, IfaceInsts, InstGates
                -- TypeEnv, InstEnv, RuleBase

+               -- Mutable, because we demand-load declarations that extend the state

 
        top_hpt  :: HomePackageTable,
                -- The home package table that we've accumulated while 
 
        top_hpt  :: HomePackageTable,
                -- The home package table that we've accumulated while 

@@ -273,15 +325,20 @@ data TcGblEnv
                -- (Ids defined in this module start in the local envt, 
                --  though they move to the global envt during zonking)
        
                -- (Ids defined in this module start in the local envt, 
                --  though they move to the global envt during zonking)
        

-               -- Cached things
-       tcg_ist :: Name -> Maybe TyThing,       -- Imported symbol table
-               -- Global type env: a combination of tcg_eps, tcg_hpt
-               --      (but *not* tcg_type_env; no deep reason)
-               -- When the PCS changes this must be refreshed, 
-               -- notably after running some compile-time code
-       
-       tcg_inst_env :: InstEnv,        -- Global instance env: a combination of 
+       tcg_inst_env :: TcRef InstEnv,  -- Global instance env: a combination of 

                                        --      tc_pcs, tc_hpt, *and* tc_insts
                                        --      tc_pcs, tc_hpt, *and* tc_insts

+               -- This field is mutable so that it can be updated inside a
+               -- Template Haskell splice, which might suck in some new
+               -- instance declarations.  This is a slightly different strategy
+               -- than for the type envt, where we look up first in tcg_type_env
+               -- and then in the mutable EPS, because the InstEnv for this module
+               -- is constructed (in principle at least) only from the modules
+               -- 'below' this one, so it's this-module-specific
+               --
+               -- On the other hand, a declaration quote [d| ... |] may introduce
+               -- some new instance declarations that we *don't* want to persist
+               -- outside the quote, so we tiresomely need to revert the InstEnv
+               -- after finishing the quote (see TcSplice.tcBracket)

 
                -- Now a bunch of things about this module that are simply 
                -- accumulated, but never consulted until the end.  
 
                -- Now a bunch of things about this module that are simply 
                -- accumulated, but never consulted until the end.  

@@ -291,7 +348,10 @@ data TcGblEnv
        tcg_imports :: ImportAvails,            -- Information about what was imported 
                                                --    from where, including things bound
                                                --    in this module
        tcg_imports :: ImportAvails,            -- Information about what was imported 
                                                --    from where, including things bound
                                                --    in this module

-               -- The next fields are always fully zonked
+
+               -- The next fields accumulate the payload of the module
+               -- The binds, rules and foreign-decl fiels are collected
+               -- initially in un-zonked form and are finally zonked in tcRnSrcDecls

        tcg_binds   :: MonoBinds Id,            -- Value bindings in this module
        tcg_deprecs :: Deprecations,            -- ...Deprecations 
        tcg_insts   :: [DFunId],                -- ...Instances
        tcg_binds   :: MonoBinds Id,            -- Value bindings in this module
        tcg_deprecs :: Deprecations,            -- ...Deprecations 
        tcg_insts   :: [DFunId],                -- ...Instances

@@ -355,7 +415,7 @@ topSpliceStage = Splice (topLevel - 1)      -- Stage for the body of a top-level spli
 
 
 impLevel, topLevel :: Level
 
 
 impLevel, topLevel :: Level

-topLevel = 1   -- Things dedined at top level of this module
+topLevel = 1   -- Things defined at top level of this module

 impLevel = 0   -- Imported things; they can be used inside a top level splice
 --
 -- For example: 
 impLevel = 0   -- Imported things; they can be used inside a top level splice
 --
 -- For example: 

@@ -374,6 +434,12 @@ data TcTyThing
 --     2. Then we kind-check the (T a Int) part.
 --     3. Then we zonk the kind variable.
 --     4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment
 --     2. Then we kind-check the (T a Int) part.
 --     3. Then we zonk the kind variable.
 --     4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment

+
+instance Outputable TcTyThing where    -- Debugging only
+   ppr (AGlobal g) = text "AGlobal" <+> ppr g
+   ppr (ATcId g l) = text "ATcId" <+> ppr g <+> ppr l
+   ppr (ATyVar t)  = text "ATyVar" <+> ppr t
+   ppr (AThing k)  = text "AThing" <+> ppr k

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -449,10 +515,11 @@ emptyUsages = emptyNameSet
 
 ImportAvails summarises what was imported from where, irrespective
 of whether the imported htings are actually used or not
 
 ImportAvails summarises what was imported from where, irrespective
 of whether the imported htings are actually used or not

-It is used     * when porcessing the export list
+It is used     * when processing the export list

                * when constructing usage info for the inteface file
                * to identify the list of directly imported modules
                        for initialisation purposes
                * when constructing usage info for the inteface file
                * to identify the list of directly imported modules
                        for initialisation purposes

+               * when figuring out what things are really unused

 
 \begin{code}
 data ImportAvails 
 
 \begin{code}
 data ImportAvails 

@@ -463,10 +530,18 @@ data ImportAvails
                -- i.e. *excluding* class ops and constructors
                --      (which appear inside their parent AvailTC)
 
                -- i.e. *excluding* class ops and constructors
                --      (which appear inside their parent AvailTC)
 

-       imp_unqual :: ModuleEnv AvailEnv,
+       imp_qual :: ModuleEnv AvailEnv,

                -- Used to figure out "module M" export specifiers
                -- Used to figure out "module M" export specifiers

-               -- Domain is only modules with *unqualified* imports
-               -- (see 1.4 Report Section 5.1.1)
+               -- (see 1.4 Report Section 5.1.1).  Ultimately, we want to find 
+               -- everything that is unambiguously in scope as 'M.x'
+               -- and where plain 'x' is (perhaps ambiguously) in scope.
+               -- So the starting point is all things that are in scope as 'M.x',
+               -- which is what this field tells us.
+               --
+               -- Domain is the *module qualifier* for imports.
+               --   e.g.        import List as Foo
+               -- would add a binding Foo |-> ...stuff from List...
+               -- to imp_qual.

                -- We keep the stuff as an AvailEnv so that it's easy to 
                -- combine stuff coming from different (unqualified) 
                -- imports of the same module
                -- We keep the stuff as an AvailEnv so that it's easy to 
                -- combine stuff coming from different (unqualified) 
                -- imports of the same module

@@ -483,11 +558,8 @@ data ImportAvails
                --       need to recompile if the module version changes
                --   (b) to specify what child modules to initialise
 
                --       need to recompile if the module version changes
                --   (b) to specify what child modules to initialise
 

-       dep_mods :: ModuleEnv (ModuleName, WhetherHasOrphans, IsBootInterface),
-               -- For a given import or set of imports, 
-               -- there's an entry here for
-               -- (a) modules below the one being compiled, in the current package
-               -- (b) orphan modules below the one being compiled, regardless of package
+       imp_dep_mods :: ModuleEnv (ModuleName, IsBootInterface),
+               -- Home-package modules needed by the module being compiled

                --
                -- It doesn't matter whether any of these dependencies are actually
                -- *used* when compiling the module; they are listed if they are below
                --
                -- It doesn't matter whether any of these dependencies are actually
                -- *used* when compiling the module; they are listed if they are below

@@ -495,40 +567,40 @@ data ImportAvails
                -- compiling M might not need to consult X.hi, but X is still listed
                -- in M's dependencies.
 
                -- compiling M might not need to consult X.hi, but X is still listed
                -- in M's dependencies.
 

-       dep_pkgs :: [PackageName]
+       imp_dep_pkgs :: [PackageName],

                -- Packages needed by the module being compiled, whether
                -- directly, or via other modules in this package, or via
                -- modules imported from other packages.
                -- Packages needed by the module being compiled, whether
                -- directly, or via other modules in this package, or via
                -- modules imported from other packages.

+
+       imp_orphs :: [ModuleName]
+               -- Orphan modules below us in the import tree

       }
 
 emptyImportAvails :: ImportAvails
       }
 
 emptyImportAvails :: ImportAvails

-emptyImportAvails = ImportAvails { imp_env    = emptyAvailEnv, 
-                                  imp_unqual = emptyModuleEnv, 
-                                  imp_mods   = emptyModuleEnv,
-                                  dep_mods   = emptyModuleEnv,
-                                  dep_pkgs   = [] }
+emptyImportAvails = ImportAvails { imp_env     = emptyAvailEnv, 
+                                  imp_qual     = emptyModuleEnv, 
+                                  imp_mods     = emptyModuleEnv,
+                                  imp_dep_mods = emptyModuleEnv,
+                                  imp_dep_pkgs = [],
+                                  imp_orphs    = [] }

 
 plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails
 plusImportAvails
 
 plusImportAvails ::  ImportAvails ->  ImportAvails ->  ImportAvails
 plusImportAvails

-  (ImportAvails { imp_env = env1, imp_unqual = unqual1, imp_mods = mods1,
-                 dep_mods = dmods1, dep_pkgs = dpkgs1 })
-  (ImportAvails { imp_env = env2, imp_unqual = unqual2, imp_mods = mods2,
-                 dep_mods = dmods2, dep_pkgs = dpkgs2 })
-  = ImportAvails { imp_env    = env1 `plusAvailEnv` env2, 
-                  imp_unqual = plusModuleEnv_C plusAvailEnv unqual1 unqual2, 
-                  imp_mods   = mods1  `plusModuleEnv` mods2,   
-                  dep_mods   = plusModuleEnv_C plus_mod_dep dmods1 dmods2,     
-                  dep_pkgs   = nub (dpkgs1 ++ dpkgs2)   }
+  (ImportAvails { imp_env = env1, imp_qual = unqual1, imp_mods = mods1,
+                 imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 })
+  (ImportAvails { imp_env = env2, imp_qual = unqual2, imp_mods = mods2,
+                 imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 })
+  = ImportAvails { imp_env      = env1 `plusAvailEnv` env2, 
+                  imp_qual     = plusModuleEnv_C plusAvailEnv unqual1 unqual2, 
+                  imp_mods     = mods1  `plusModuleEnv` mods2, 
+                  imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2,   
+                  imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
+                  imp_orphs    = orphs1 `unionLists` orphs2 }

   where
   where

-    plus_mod_dep (m1, orphan1, boot1) (m2, orphan2, boot2) 
-       = WARN( not (m1 == m2 && (boot1 || boot2 || orphan1 == orphan2)), 
-               (ppr m1 <+> ppr m2) $$ (ppr orphan1 <+> ppr orphan2) $$ (ppr boot1 <+> ppr boot2) )
-               -- Check mod-names match, and orphan-hood matches; but a boot interface
-               -- might not know about orphan hood, so only check the orphan match
-               -- if both are non-boot interfaces
-         (m1, orphan1 || orphan2, boot1 && boot2)
-       -- If either side can "see" a non-hi-boot interface, use that
-       -- Similarly orphan-hood (see note about about why orphan1 and 2 might differ)
+    plus_mod_dep (m1, boot1) (m2, boot2) 
+       = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
+               -- Check mod-names match
+         (m1, boot1 && boot2)  -- If either side can "see" a non-hi-boot interface, use that

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -539,7 +611,7 @@ v%************************************************************************
 
 \begin{code}
 plusAvail (Avail n1)      (Avail n2)       = Avail n1
 
 \begin{code}
 plusAvail (Avail n1)      (Avail n2)       = Avail n1

-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
+plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2)

 -- Added SOF 4/97
 #ifdef DEBUG
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 -- Added SOF 4/97
 #ifdef DEBUG
 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])

@@ -577,7 +649,13 @@ unitAvailEnv a = unitNameEnv (availName a) a
 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 plusAvailEnv = plusNameEnv_C plusAvail
 
 plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
 plusAvailEnv = plusNameEnv_C plusAvail
 

-lookupAvailEnv = lookupNameEnv
+lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo
+lookupAvailEnv_maybe = lookupNameEnv
+
+lookupAvailEnv :: AvailEnv -> Name -> AvailInfo
+lookupAvailEnv env n = case lookupNameEnv env n of
+                        Just avail -> avail
+                        Nothing    -> pprPanic "lookupAvailEnv" (ppr n)

 
 availEnvElts = nameEnvElts
 
 
 availEnvElts = nameEnvElts
 

@@ -656,13 +734,19 @@ data Inst
        TcThetaType     -- The (types of the) dictionaries to which the function
                        -- must be applied to get the method
 
        TcThetaType     -- The (types of the) dictionaries to which the function
                        -- must be applied to get the method
 

-       TcTauType       -- The type of the method
+       TcTauType       -- The tau-type of the method

 
        InstLoc
 
 
        InstLoc
 

-       -- INVARIANT: in (Method u f tys theta tau loc)
+       -- INVARIANT 1: in (Method u f tys theta tau loc)

        --      type of (f tys dicts(from theta)) = tau
 
        --      type of (f tys dicts(from theta)) = tau
 

+       -- INVARIANT 2: tau must not be of form (Pred -> Tau)
+       --   Reason: two methods are considerd equal if the 
+       --           base Id matches, and the instantiating types
+       --           match.  The TcThetaType should then match too.
+       --   This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
+

   | LitInst
        Id
        HsOverLit       -- The literal from the occurrence site
   | LitInst
        Id
        HsOverLit       -- The literal from the occurrence site

@@ -734,7 +818,10 @@ It appears in TcMonad because there are a couple of error-message-generation
 functions that deal with it.
 
 \begin{code}
 functions that deal with it.
 
 \begin{code}

-type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
+data InstLoc = InstLoc InstOrigin SrcLoc ErrCtxt
+
+instLocSrcLoc :: InstLoc -> SrcLoc
+instLocSrcLoc (InstLoc _ src_loc _) = src_loc

 
 data InstOrigin
   = OccurrenceOf Name          -- Occurrence of an overloaded identifier
 
 data InstOrigin
   = OccurrenceOf Name          -- Occurrence of an overloaded identifier

@@ -789,7 +876,7 @@ data InstOrigin
 
 \begin{code}
 pprInstLoc :: InstLoc -> SDoc
 
 \begin{code}
 pprInstLoc :: InstLoc -> SDoc

-pprInstLoc (orig, locn, ctxt)
+pprInstLoc (InstLoc orig locn ctxt)

   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
   where
     pp_orig (OccurrenceOf name)
   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
   where
     pp_orig (OccurrenceOf name)