X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnTypes.lhs;h=721f0782812ef604d358937db4051d848d8a90c8;hb=ef6d82a4e1d4ba4884c322be85cff291e017f0e6;hp=7357669669d580b6b4733703573106cf588d7826;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 7357669..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, @@ -256,6 +248,8 @@ data TcGblEnv 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 @@ -381,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 @@ -676,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 @@ -702,11 +724,11 @@ type GivenLoc = CtLoc SkolemInfo 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 @@ -812,10 +834,10 @@ pprWantedEvVarWithLoc (WantedEvVar v loc) = hang (pprEvVarWithType v) 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 @@ -848,13 +870,19 @@ ctLocOrigin (CtLoc o _ _) = o 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 @@ -864,7 +892,7 @@ data CtOrigin | SpecPragOrigin Name -- Specialisation pragma for identifier - | TypeEqOrigin + | TypeEqOrigin EqOrigin | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter @@ -886,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 @@ -907,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)] @@ -919,8 +950,9 @@ pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") 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