A (final) re-engineering of the new typechecker

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

diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 8f02da6..387961a 100644 (file)
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -28,7 +28,7 @@ module TcRnTypes(
        ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
        -- Constraints
-        Untouchables(..), inTouchableRange,
+        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(..),
 
@@ -698,6 +698,10 @@ instance Outputable Untouchables where
   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 
@@ -875,12 +879,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
@@ -912,8 +923,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 
@@ -933,6 +946,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)]
@@ -947,6 +961,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