[project @ 2006-01-18 11:13:06 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnTypes.lhs
index ed1fb86..e8b0b48 100644 (file)
@@ -9,7 +9,7 @@ module TcRnTypes(
        -- The environment types
        Env(..), 
        TcGblEnv(..), TcLclEnv(..), 
-       IfGblEnv(..), IfLclEnv(..),
+       IfGblEnv(..), IfLclEnv(..), 
 
        -- Ranamer types
        ErrCtxt,
@@ -20,14 +20,14 @@ module TcRnTypes(
        WhereFrom(..), mkModDeps,
 
        -- Typechecker types
-       TcTyThing(..), GadtRefinement,
+       TcTyThing(..), pprTcTyThingCategory, GadtRefinement,
 
        -- Template Haskell
        ThStage(..), topStage, topSpliceStage,
        ThLevel, impLevel, topLevel,
 
        -- Arrows
-       ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel, 
+       ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
        -- Insts
        Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, 
@@ -42,16 +42,16 @@ module TcRnTypes(
 #include "HsVersions.h"
 
 import HsSyn           ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl,
-                         ArithSeqInfo, DictBinds, LHsBinds )
+                         ArithSeqInfo, DictBinds, LHsBinds, HsGroup )
 import HscTypes                ( FixityEnv,
                          HscEnv, TypeEnv, TyThing, 
-                         GenAvailInfo(..), AvailInfo,
+                         GenAvailInfo(..), AvailInfo, HscSource(..),
                          availName, IsBootInterface, Deprecations )
-import Packages                ( PackageId )
-import Type            ( Type, TvSubstEnv, pprParendType )
+import Packages                ( PackageId, HomeModules )
+import Type            ( Type, TvSubstEnv, pprParendType, pprTyThingCategory )
 import TcType          ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo,
-                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes )
-import InstEnv         ( DFunId, InstEnv )
+                         TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
+import InstEnv         ( Instance, InstEnv )
 import IOEnv
 import RdrName         ( GlobalRdrEnv, LocalRdrEnv )
 import Name            ( Name )
@@ -129,6 +129,9 @@ data Env gbl lcl    -- Changes as we move into an expression
 data TcGblEnv
   = TcGblEnv {
        tcg_mod     :: Module,          -- Module being compiled
+       tcg_src     :: HscSource,       -- What kind of module 
+                                       -- (regular Haskell, hs-boot, ext-core)
+
        tcg_rdr_env :: GlobalRdrEnv,    -- Top level envt; used during renaming
        tcg_default :: Maybe [Type],    -- Types used for defaulting
                                        -- Nothing => no 'default' decl
@@ -159,6 +162,10 @@ data TcGblEnv
                                        --    from where, including things bound
                                        --    in this module
 
+       tcg_home_mods :: HomeModules,
+                               -- Calculated from ImportAvails, allows us to
+                               -- call Packages.isHomeModule
+
        tcg_dus :: DefUses,     -- What is defined in this module and what is used.
                                -- The latter is used to generate 
                                --      (a) version tracking; no need to recompile if these
@@ -193,12 +200,28 @@ data TcGblEnv
                -- tcg_inst_uses; the reference is implicit rather than explicit,
                -- so we have to zap a mutable variable.
 
+       tcg_dfun_n  :: TcRef Int,       -- Allows us to number off the names of DFuns
+               -- It's convenient to allocate an External Name for a DFun, with
+               -- a permanently-fixed unique, just like other top-level functions
+               -- defined in this module.  But that means we need a canonical 
+               -- occurrence name, distinct from all other dfuns in this module,
+               -- and this name supply serves that purpose (df1, df2, etc).
+
                -- 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
+
+               -- 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_rn_decls :: Maybe (HsGroup Name),   -- renamed decls, maybe
+               -- Nothing <=> Don't retain renamed decls
+
        tcg_binds   :: LHsBinds Id,             -- Value bindings in this module
        tcg_deprecs :: Deprecations,            -- ...Deprecations 
-       tcg_insts   :: [DFunId],                -- ...Instances
+       tcg_insts   :: [Instance],              -- ...Instances
        tcg_rules   :: [LRuleDecl Id],          -- ...Rules
        tcg_fords   :: [LForeignDecl Id]        -- ...Foreign import & exports
     }
@@ -232,6 +255,13 @@ data IfLclEnv
        -- it means M.f = \x -> x, where M is the if_mod
        if_mod :: Module,
 
+       -- The field is used only for error reporting
+       -- if (say) there's a Lint error in it
+       if_loc :: SDoc,
+               -- Where the interface came from:
+               --      .hi file, or GHCi state, or ext core
+               -- plus which bit is currently being examined
+
        if_tv_env  :: OccEnv TyVar,     -- Nested tyvar bindings
        if_id_env  :: OccEnv Id         -- Nested id binding
     }
@@ -345,40 +375,45 @@ topStage, topSpliceStage :: ThStage
 topStage       = Comp
 topSpliceStage = Splice (topLevel - 1) -- Stage for the body of a top-level splice
 
-
 ---------------------------
--- Arrow-notation stages
+-- Arrow-notation context
 ---------------------------
 
--- In arrow notation, a variable bound by a proc (or enclosed let/kappa)
--- is not in scope to the left of an arrow tail (-<).  For example
---
---     proc x -> (e1 -< e2)
---
--- Here, x is not in scope in e1, but it is in scope in e2.  This can get 
--- a bit complicated:
---
---     let x = 3 in
---     prox y -> (proc z -> e1) -< e2
---
--- Here, x and z are in scope in e1, but y is not.  Here's how we track this:
---     a) Assign an "proc level" to each proc, being the number of
---        lexically-enclosing procs + 1.  
---     b) Assign to each local variable the proc-level of its lexically
---        enclosing proc.
---     c) Keep a list of out-of-scope procs.  When moving to the left of
---        an arrow-tail, add the proc-level of the immediately enclosing
---        proc to the list.
---     d) When looking up a variable, complain if its proc-level is in
---        the banned list
+{-
+In arrow notation, a variable bound by a proc (or enclosed let/kappa)
+is not in scope to the left of an arrow tail (-<) or the head of (|..|).
+For example
+
+       proc x -> (e1 -< e2)
 
-type ProcLevel = Int   -- Always >= 0
-topProcLevel = 0       -- Not inside any proc
+Here, x is not in scope in e1, but it is in scope in e2.  This can get
+a bit complicated:
 
-data ArrowCtxt = ArrCtxt { proc_level :: ProcLevel,    -- Current level
-                          proc_banned :: [ProcLevel] } -- Out of scope proc-levels
+       let x = 3 in
+       proc y -> (proc z -> e1) -< e2
+
+Here, x and z are in scope in e1, but y is not.  We implement this by
+recording the environment when passing a proc (using newArrowScope),
+and returning to that (using escapeArrowScope) on the left of -< and the
+head of (|..|).
+-}
 
-topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
+data ArrowCtxt
+  = NoArrowCtxt
+  | ArrowCtxt (Env TcGblEnv TcLclEnv)
+
+-- Record the current environment (outside a proc)
+newArrowScope :: TcM a -> TcM a
+newArrowScope
+  = updEnv $ \env ->
+       env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } }
+
+-- Return to the stored environment (from the enclosing proc)
+escapeArrowScope :: TcM a -> TcM a
+escapeArrowScope
+  = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of
+       NoArrowCtxt -> env
+       ArrowCtxt env' -> env'
 
 ---------------------------
 -- TcTyThing
@@ -387,9 +422,9 @@ topArrowCtxt = ArrCtxt { proc_level = topProcLevel, proc_banned = [] }
 data TcTyThing
   = AGlobal TyThing                    -- Used only in the return type of a lookup
 
-  | ATcId   TcId ThLevel ProcLevel     -- Ids defined in this module; may not be fully zonked
+  | ATcId   TcId ThLevel               -- Ids defined in this module; may not be fully zonked
 
-  | ATyVar  TyVar TcType               -- Type variables; tv -> type.  It can't just be a TyVar
+  | ATyVar  Name TcType                        -- Type variables; tv -> type.  It can't just be a TyVar
                                        -- that is mutated to point to the type it is bound to,
                                        -- because that would make it a wobbly type, and we
                                        -- want pattern-bound lexically-scoped type variables to
@@ -399,10 +434,17 @@ data TcTyThing
                                        --      tycons and clases in this recursive group
 
 instance Outputable TcTyThing where    -- Debugging only
-   ppr (AGlobal g)      = text "AGlobal" <+> ppr g
-   ppr (ATcId g tl pl)  = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl
-   ppr (ATyVar tv ty)   = text "ATyVar" <+> ppr tv <+> pprParendType ty
+   ppr (AGlobal g)      = ppr g
+   ppr (ATcId g tl)     = text "Identifier" <> 
+                         ifPprDebug (brackets (ppr g <> comma <> ppr tl))
+   ppr (ATyVar tv ty)   = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty
    ppr (AThing k)       = text "AThing" <+> ppr k
+
+pprTcTyThingCategory :: TcTyThing -> SDoc
+pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
+pprTcTyThingCategory (ATyVar _ _)    = ptext SLIT("Type variable")
+pprTcTyThingCategory (ATcId _ _)     = ptext SLIT("Local identifier")
+pprTcTyThingCategory (AThing _)             = ptext SLIT("Kinded thing")
 \end{code}
 
 \begin{code}
@@ -445,22 +487,18 @@ data ImportAvails
                -- So the starting point is all things that are in scope as 'M.x',
                -- which is what this field tells us.
 
-       imp_mods :: ModuleEnv (Module, Maybe Bool, SrcSpan),
+       imp_mods :: ModuleEnv (Module, Bool, SrcSpan),
                -- Domain is all directly-imported modules
-               -- Maybe value answers the question "is the import restricted?"
-               --   Nothing    => unrestricted import (e.g., "import Foo")
-               --   Just True  => restricted import, at least one entity (e.g., "import Foo(x)")
-               --   Just False => fully restricted import (e.g., "import Foo ()")
-               --
-               --  A distinction is made between the first and the third in order
-               --  to more precisely emit warnings about unused imports.
+               -- Bool means:
+               --   True => import was "import Foo ()"
+               --   False  => import was some other form
                --
                -- We need the Module in the range because we can't get
                --      the keys of a ModuleEnv
                -- Used 
                --   (a) to help construct the usage information in 
-               --       the interface file; if we import everything we
-               --       need to recompile if the module version changes
+               --       the interface file; if we import somethign we
+               --       need to recompile if the export version changes
                --   (b) to specify what child modules to initialise
 
        imp_dep_mods :: ModuleEnv (Module, IsBootInterface),
@@ -653,10 +691,11 @@ data Inst
 
   | LitInst
        Name
-       HsOverLit       -- The literal from the occurrence site
-                       --      INVARIANT: never a rebindable-syntax literal
-                       --      Reason: tcSyntaxName does unification, and we
-                       --              don't want to deal with that during tcSimplify
+       (HsOverLit Name)        -- The literal from the occurrence site
+                               -- INVARIANT: never a rebindable-syntax literal
+                               -- Reason: tcSyntaxName does unification, and we
+                               --         don't want to deal with that during tcSimplify,
+                               --         when resolving LitInsts
        TcType          -- The type at which the literal is used
        InstLoc
 \end{code}
@@ -744,7 +783,7 @@ data InstOrigin
 
   | IPOccOrigin  (IPName Name) -- Occurrence of an implicit parameter
 
-  | LiteralOrigin HsOverLit    -- Occurrence of a literal
+  | LiteralOrigin (HsOverLit Name)     -- Occurrence of a literal
 
   | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
   | PArrSeqOrigin  (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
@@ -762,8 +801,6 @@ data InstOrigin
 
 \begin{code}
 pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (InstLoc (SigOrigin info) locn _) 
-  = text "arising from" <+> ppr info   -- I don't think this happens much, if at all
 pprInstLoc (InstLoc orig locn _)
   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
   where
@@ -774,11 +811,11 @@ pprInstLoc (InstLoc orig locn _)
     pp_orig (LiteralOrigin lit)         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
     pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
     pp_orig (PArrSeqOrigin seq)         = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
-    pp_orig InstSigOrigin       =  ptext SLIT("instantiating a type signature")
-    pp_orig InstScOrigin        =  ptext SLIT("the superclasses of an instance declaration")
+    pp_orig InstSigOrigin       = ptext SLIT("instantiating a type signature")
+    pp_orig InstScOrigin        = ptext SLIT("the superclasses of an instance declaration")
     pp_orig DerivOrigin                 = ptext SLIT("the 'deriving' clause of a data type declaration")
     pp_orig DefaultOrigin       = ptext SLIT("a 'default' declaration")
-    pp_orig DoOrigin            =  ptext SLIT("a do statement")
-    pp_orig ProcOrigin          =  ptext SLIT("a proc expression")
-    pp_orig (SigOrigin info)    = ppr info
+    pp_orig DoOrigin            = ptext SLIT("a do statement")
+    pp_orig ProcOrigin          = ptext SLIT("a proc expression")
+    pp_orig (SigOrigin info)    = pprSkolInfo info
 \end{code}