ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Constraints
- Untouchables,
+ Untouchables(..), inTouchableRange, isNoUntouchables,
WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc,
wantedEvVarToVar, wantedEvVarPred, splitWanteds,
Implication(..),
CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
CtOrigin(..), EqOrigin(..),
- WantedLoc, GivenLoc,
+ WantedLoc, GivenLoc, pushErrCtxt,
SkolemInfo(..),
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
--
-- * 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,
tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings
tcg_binds :: LHsBinds Id, -- Value bindings in this module
tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature
+ tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids
tcg_warns :: Warnings, -- ...Warnings and deprecations
tcg_anns :: [Annotation], -- ...Annotations
tcg_insts :: [Instance], -- ...Instances
-- 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
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
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
| 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
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)]
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