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
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
data Implication
= Implic {
- ic_env_tvs :: Untouchables, -- Untouchables: unification variables
+ ic_untch :: Untouchables, -- Untouchables: unification variables
-- free in the environment
- ic_env :: TcTypeEnv, -- The type environment
+ ic_env :: TcTypeEnv, -- The type environment
-- Used only when generating error messages
- -- Generally, ic_env_tvs = tvsof(ic_env)
+ -- Generally, ic_untch is a superset of tvsof(ic_env)
-- However, we don't zonk ic_env when zonking the Implication
-- Instead we do that when generating a skolem-escape error message
pprWantedEvVar (WantedEvVar v _) = pprEvVarWithType v
instance Outputable Implication where
- ppr (Implic { ic_env_tvs = env_tvs, ic_skols = skols, ic_given = given
+ ppr (Implic { ic_untch = untch, ic_skols = skols, ic_given = given
, ic_wanted = wanted, ic_binds = binds, ic_loc = loc })
= ptext (sLit "Implic") <+> braces
- (sep [ ptext (sLit "Untouchables = ") <+> ppr env_tvs
+ (sep [ ptext (sLit "Untouchables = ") <+> ppr untch
, ptext (sLit "Skolems = ") <+> ppr skols
, ptext (sLit "Given = ") <+> pprEvVars given
, ptext (sLit "Wanted = ") <+> ppr wanted
setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
-pprArising :: CtLoc CtOrigin -> SDoc
-pprArising loc = case ctLocOrigin loc of
- TypeEqOrigin -> empty
- _ -> text "arising from" <+> ppr (ctLocOrigin loc)
+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 loc = sep [pprArising loc, text "at" <+> ppr (ctLocSpan loc)]
+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
| SpecPragOrigin Name -- Specialisation pragma for identifier
- | TypeEqOrigin
+ | TypeEqOrigin EqOrigin
| IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter
| 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 DefaultOrigin = ptext (sLit "a 'default' declaration")
pprO DoOrigin = ptext (sLit "a do statement")
pprO ProcOrigin = ptext (sLit "a proc expression")
-pprO TypeEqOrigin = ptext (sLit "an equality")
+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
projects / ghc-hetmet.git / blobdiff