X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnTypes.lhs;h=721f0782812ef604d358937db4051d848d8a90c8;hb=03edcb58482b016a8ee019a06e114c8e8c996400;hp=17f8d63012de7038d2b8e09cc4c12e8988a70e44;hpb=92267aa26adb1ab5a6d8004a80fdf6aa06ea4e44;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 17f8d63..721f078 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -28,7 +28,7 @@ module TcRnTypes(
 	ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
 	-- Constraints
-        Untouchables,
+        Untouchables(..), inTouchableRange, isNoUntouchables,
   	WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
 	WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc, 
         wantedEvVarToVar, wantedEvVarPred, splitWanteds,
@@ -37,7 +37,7 @@ module TcRnTypes(
 	Implication(..), 
         CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
 	CtOrigin(..), EqOrigin(..), 
-	WantedLoc, GivenLoc,
+        WantedLoc, GivenLoc, pushErrCtxt,
 
 	SkolemInfo(..),
 
@@ -68,11 +68,12 @@ import NameSet
 import Var
 import VarEnv
 import Module
-import UniqFM
 import SrcLoc
 import VarSet
 import ErrUtils
+import UniqFM
 import UniqSupply
+import Unique
 import BasicTypes
 import Bag
 import Outputable
@@ -216,22 +217,13 @@ data TcGblEnv
           --
           --   * Top-level variables appearing free in a TH bracket
 
-	tcg_inst_uses :: TcRef NameSet,
-          -- ^ Home-package Dfuns actually used.
-          --
-          -- Used to generate version dependencies This records usages, rather
-          -- like tcg_dus, but it has to be a mutable variable so it can be
-          -- augmented when we look up an instance.  These uses of dfuns are
-          -- rather like the free variables of the program, but are implicit
-          -- instead of explicit.
-
-	tcg_th_used :: TcRef Bool,
+        tcg_th_used :: TcRef Bool,
           -- ^ @True@ <=> Template Haskell syntax used.
           --
-          -- We need this so that we can generate a dependency on the Template
-          -- Haskell package, becuase the desugarer is going to emit loads of
-          -- references to TH symbols.  It's rather like tcg_inst_uses; the
-          -- reference is implicit rather than explicit, so we have to zap a
+          -- We need this so that we can generate a dependency on the
+          -- Template Haskell package, becuase the desugarer is going
+          -- to emit loads of references to TH symbols.  The reference
+          -- is implicit rather than explicit, so we have to zap a
           -- mutable variable.
 
 	tcg_dfun_n  :: TcRef OccSet,
@@ -383,7 +375,13 @@ data TcLclEnv		-- Changes as we move inside an expression
                         -- Why mutable? see notes with tcGetGlobalTyVars
 
 	tcl_lie   :: TcRef WantedConstraints,    -- Place to accumulate type constraints
-	tcl_untch :: Untouchables		 -- Untouchables
+
+	-- TcMetaTyVars have 
+	tcl_meta  :: TcRef Unique,  -- The next free unique for TcMetaTyVars
+		     		    -- Guaranteed to be allocated linearly
+	tcl_untch :: Unique	    -- Any TcMetaTyVar with 
+		     		    --     unique >= tcl_untch is touchable
+		     		    --     unique <  tcl_untch is untouchable
     }
 
 type TcTypeEnv = NameEnv TcTyThing
@@ -678,7 +676,29 @@ instance Outputable WhereFrom where
 v%************************************************************************
 
 \begin{code}
-type Untouchables = TcTyVarSet	-- All MetaTyVars
+data Untouchables = NoUntouchables
+                  | TouchableRange
+                          Unique  -- Low end
+                          Unique  -- High end
+ -- A TcMetaTyvar is *touchable* iff its unique u satisfies
+ --   u >= low
+ --   u < high
+
+instance Outputable Untouchables where
+  ppr NoUntouchables = ptext (sLit "No untouchables")
+  ppr (TouchableRange low high) = ptext (sLit "Touchable range:") <+> 
+                                  ppr low <+> char '-' <+> ppr high
+
+isNoUntouchables :: Untouchables -> Bool
+isNoUntouchables NoUntouchables      = True
+isNoUntouchables (TouchableRange {}) = False
+
+inTouchableRange :: Untouchables -> TcTyVar -> Bool
+inTouchableRange NoUntouchables _ = True
+inTouchableRange (TouchableRange low high) tv 
+  = uniq >= low && uniq < high
+  where
+    uniq = varUnique tv
 
 type WantedConstraints = Bag WantedConstraint
 
@@ -850,12 +870,19 @@ ctLocOrigin (CtLoc o _ _) = o
 setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
 setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
 
+pushErrCtxt :: orig -> ErrCtxt -> CtLoc orig -> CtLoc orig
+pushErrCtxt o err (CtLoc _ s errs) = CtLoc o s (err:errs)
+
 pprArising :: CtOrigin -> SDoc
+-- Used for the main, top-level error message
+-- We've done special processing for TypeEq and FunDep origins
 pprArising (TypeEqOrigin {}) = empty
+pprArising FunDepOrigin      = empty
 pprArising orig              = text "arising from" <+> ppr orig
 
-pprArisingAt :: CtLoc CtOrigin -> SDoc
-pprArisingAt (CtLoc o s _) = sep [pprArising o, text "at" <+> ppr s]
+pprArisingAt :: Outputable o => CtLoc o -> SDoc
+pprArisingAt (CtLoc o s _) = sep [ text "arising from" <+> ppr o
+                                 , text "at" <+> ppr s]
 
 -------------------------------------------
 -- CtOrigin gives the origin of *wanted* constraints
@@ -887,8 +914,10 @@ data CtOrigin
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin	-- Typechecking a default decl
   | DoOrigin		-- Arising from a do expression
+  | IfOrigin            -- Arising from an if statement
   | ProcOrigin		-- Arising from a proc expression
   | AnnOrigin           -- An annotation
+  | FunDepOrigin
 
 data EqOrigin 
   = UnifyOrigin 
@@ -908,6 +937,7 @@ pprO ExprSigOrigin         = ptext (sLit "an expression type signature")
 pprO PatSigOrigin          = ptext (sLit "a pattern type signature")
 pprO PatOrigin             = ptext (sLit "a pattern")
 pprO ViewPatOrigin         = ptext (sLit "a view pattern")
+pprO IfOrigin              = ptext (sLit "an if statement")
 pprO (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
 pprO (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
 pprO (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
@@ -922,6 +952,7 @@ pprO DoOrigin	           = ptext (sLit "a do statement")
 pprO ProcOrigin	           = ptext (sLit "a proc expression")
 pprO (TypeEqOrigin eq)     = ptext (sLit "an equality") <+> ppr eq
 pprO AnnOrigin             = ptext (sLit "an annotation")
+pprO FunDepOrigin          = ptext (sLit "a functional dependency")
 
 instance Outputable EqOrigin where
   ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2