fix haddock submodule pointer

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

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index fc82729..d94ecd7 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -40,11 +40,13 @@ module TcRnTypes(
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
        CtOrigin(..), EqOrigin(..), 
         Implication(..),
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
        CtOrigin(..), EqOrigin(..), 

-        WantedLoc, GivenLoc, pushErrCtxt,
+        WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt,

 
 

-        SkolemInfo(..),
+       SkolemInfo(..),

 
 

-        CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived,
+        CtFlavor(..), pprFlavorArising, isWanted, 
+        isGivenOrSolved, isGiven_maybe,
+        isDerived,

         FlavoredEvVar,
 
        -- Pretty printing
         FlavoredEvVar,
 
        -- Pretty printing

@@ -62,6 +64,7 @@ module TcRnTypes(
 import HsSyn
 import HscTypes
 import Type
 import HsSyn
 import HscTypes
 import Type

+import Id      ( evVarPred )

 import Class    ( Class )
 import DataCon  ( DataCon, dataConUserType )
 import TcType
 import Class    ( Class )
 import DataCon  ( DataCon, dataConUserType )
 import TcType

@@ -324,6 +327,7 @@ data IfLclEnv
                -- plus which bit is currently being examined
 
        if_tv_env  :: UniqFM TyVar,     -- Nested tyvar bindings
                -- plus which bit is currently being examined
 
        if_tv_env  :: UniqFM TyVar,     -- Nested tyvar bindings

+                                       -- (and coercions)

        if_id_env  :: UniqFM Id         -- Nested id binding
     }
 \end{code}
        if_id_env  :: UniqFM Id         -- Nested id binding
     }
 \end{code}

@@ -373,6 +377,7 @@ data TcLclEnv               -- Changes as we move inside an expression
                -- We still need the unsullied global name env so that
                --   we can look up record field names
 
                -- We still need the unsullied global name env so that
                --   we can look up record field names
 

+        tcl_hetMetLevel  :: [TyVar],    -- The current environment classifier level (list-of-names)

        tcl_env  :: TcTypeEnv,    -- The local type environment: Ids and
                                  -- TyVars defined in this module
                                        
        tcl_env  :: TcTypeEnv,    -- The local type environment: Ids and
                                  -- TyVars defined in this module
                                        

@@ -509,7 +514,9 @@ data TcTyThing
 
   | ATcId   {          -- Ids defined in this module; may not be fully zonked
        tct_id    :: TcId,              
 
   | ATcId   {          -- Ids defined in this module; may not be fully zonked
        tct_id    :: TcId,              

-       tct_level :: ThLevel }
+       tct_level :: ThLevel,
+       tct_hetMetLevel :: [TyVar]
+    }

 
   | ATyVar  Name TcType                -- The type to which the lexically scoped type vaiable
                                -- is currently refined. We only need the Name
 
   | ATyVar  Name TcType                -- The type to which the lexically scoped type vaiable
                                -- is currently refined. We only need the Name

@@ -524,7 +531,8 @@ instance Outputable TcTyThing where -- Debugging only
    ppr elt@(ATcId {})   = text "Identifier" <> 
                          brackets (ppr (tct_id elt) <> dcolon 
                                  <> ppr (varType (tct_id elt)) <> comma
    ppr elt@(ATcId {})   = text "Identifier" <> 
                          brackets (ppr (tct_id elt) <> dcolon 
                                  <> ppr (varType (tct_id elt)) <> comma

-                                <+> ppr (tct_level elt))
+                                <+> ppr (tct_level elt)
+                                <+> ppr (tct_hetMetLevel elt))

    ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
    ppr (AThing k)       = text "AThing" <+> ppr k
 
    ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
    ppr (AThing k)       = text "AThing" <+> ppr k
 

@@ -674,7 +682,6 @@ instance Outputable WhereFrom where
 %************************************************************************
 %*                                                                     *
                Wanted constraints
 %************************************************************************
 %*                                                                     *
                Wanted constraints

-

      These are forced to be in TcRnTypes because
           TcLclEnv mentions WantedConstraints
           WantedConstraint mentions CtLoc
      These are forced to be in TcRnTypes because
           TcLclEnv mentions WantedConstraints
           WantedConstraint mentions CtLoc

@@ -901,7 +908,7 @@ pprEvVarTheta :: [EvVar] -> SDoc
 pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
                               
 pprEvVarWithType :: EvVar -> SDoc
 pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
                               
 pprEvVarWithType :: EvVar -> SDoc

-pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v)

 
 pprWantedsWithLocs :: WantedConstraints -> SDoc
 pprWantedsWithLocs wcs
 
 pprWantedsWithLocs :: WantedConstraints -> SDoc
 pprWantedsWithLocs wcs

@@ -923,35 +930,37 @@ pprWantedEvVar        (EvVarX v _)   = pprEvVarWithType v
 
 \begin{code}
 data CtFlavor
 
 \begin{code}
 data CtFlavor

-  = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
-  | Derived WantedLoc 
-                      -- We have evidence for this constraint in TcEvBinds;
-                      --   *however* this evidence can contain wanteds, so 
-                      --   it's valid only provisionally to the solution of
-                      --   these wanteds 
-  | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
-
--- data DerivedOrig = DerSC | DerInst | DerSelf
--- Deriveds are either superclasses of other wanteds or deriveds, or partially
--- solved wanteds from instances, or 'self' dictionaries containing yet wanted
--- superclasses. 
+  = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds
+  | Derived WantedLoc        -- Derived's are just hints for unifications 
+  | Wanted WantedLoc         -- We have no evidence bindings for this constraint. 
+
+data GivenKind
+  = GivenOrig   -- Originates in some given, such as signature or pattern match
+  | GivenSolved -- Is given as result of being solved, maybe provisionally on
+                -- some other wanted constraints. 

 
 instance Outputable CtFlavor where
 
 instance Outputable CtFlavor where

-  ppr (Given {})   = ptext (sLit "[G]")
-  ppr (Wanted {})  = ptext (sLit "[W]")
-  ppr (Derived {}) = ptext (sLit "[D]") 
+  ppr (Given _ GivenOrig)   = ptext (sLit "[G]")
+  ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's
+  ppr (Wanted {})           = ptext (sLit "[W]")
+  ppr (Derived {})          = ptext (sLit "[D]") 
+

 pprFlavorArising :: CtFlavor -> SDoc
 pprFlavorArising :: CtFlavor -> SDoc

-pprFlavorArising (Derived wl )  = pprArisingAt wl
+pprFlavorArising (Derived wl)   = pprArisingAt wl

 pprFlavorArising (Wanted  wl)   = pprArisingAt wl
 pprFlavorArising (Wanted  wl)   = pprArisingAt wl

-pprFlavorArising (Given gl)     = pprArisingAt gl
+pprFlavorArising (Given gl _)   = pprArisingAt gl

 
 isWanted :: CtFlavor -> Bool
 isWanted (Wanted {}) = True
 isWanted _           = False
 
 
 isWanted :: CtFlavor -> Bool
 isWanted (Wanted {}) = True
 isWanted _           = False
 

-isGiven :: CtFlavor -> Bool 
-isGiven (Given {}) = True 
-isGiven _          = False 
+isGivenOrSolved :: CtFlavor -> Bool
+isGivenOrSolved (Given {}) = True
+isGivenOrSolved _ = False
+
+isGiven_maybe :: CtFlavor -> Maybe GivenKind 
+isGiven_maybe (Given _ gk) = Just gk
+isGiven_maybe _            = Nothing

 
 isDerived :: CtFlavor -> Bool 
 isDerived (Derived {}) = True
 
 isDerived :: CtFlavor -> Bool 
 isDerived (Derived {}) = True

@@ -1112,6 +1121,7 @@ data CtOrigin
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin      -- Typechecking a default decl
   | DoOrigin           -- Arising from a do expression
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin      -- Typechecking a default decl
   | DoOrigin           -- Arising from a do expression

+  | MCompOrigin         -- Arising from a monad comprehension

   | IfOrigin            -- Arising from an if statement
   | ProcOrigin         -- Arising from a proc expression
   | AnnOrigin           -- An annotation
   | IfOrigin            -- Arising from an if statement
   | ProcOrigin         -- Arising from a proc expression
   | AnnOrigin           -- An annotation

@@ -1147,6 +1157,7 @@ pprO DerivOrigin     = ptext (sLit "the 'deriving' clause of a data type declarat
 pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin        = ptext (sLit "a 'default' declaration")
 pprO DoOrigin             = ptext (sLit "a do statement")
 pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
 pprO DefaultOrigin        = ptext (sLit "a 'default' declaration")
 pprO DoOrigin             = ptext (sLit "a do statement")

+pprO MCompOrigin           = ptext (sLit "a statement in a monad comprehension")

 pprO ProcOrigin                   = ptext (sLit "a proc expression")
 pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
 pprO AnnOrigin             = ptext (sLit "an annotation")
 pprO ProcOrigin                   = ptext (sLit "a proc expression")
 pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
 pprO AnnOrigin             = ptext (sLit "an annotation")