summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghci/RtClosureInspect.hs8
-rw-r--r--compiler/typecheck/TcErrors.lhs45
-rw-r--r--compiler/typecheck/TcMType.lhs47
-rw-r--r--compiler/typecheck/TcRnTypes.lhs6
-rw-r--r--compiler/typecheck/TcType.lhs24
-rw-r--r--compiler/typecheck/TcUnify.lhs4
6 files changed, 60 insertions, 74 deletions
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index 59f5669e3e..b4068a7aa7 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -569,10 +569,10 @@ newVar = liftTcM . newFlexiTyVarTy
type RttiInstantiation = [(TcTyVar, TyVar)]
-- Associates the typechecker-world meta type variables
-- (which are mutable and may be refined), to their
- -- debugger-world RuntimeUnkSkol counterparts.
+ -- debugger-world RuntimeUnk counterparts.
-- If the TcTyVar has not been refined by the runtime type
-- elaboration, then we want to turn it back into the
- -- original RuntimeUnkSkol
+ -- original RuntimeUnk
-- | Returns the instantiated type scheme ty', and the
-- mapping from new (instantiated) -to- old (skolem) type variables
@@ -1130,9 +1130,9 @@ zonkRttiType = zonkType (mkZonkTcTyVar zonk_unbound_meta)
zonk_unbound_meta tv
= ASSERT( isTcTyVar tv )
do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk
- -- This is where RuntimeUnkSkols are born:
+ -- This is where RuntimeUnks are born:
-- otherwise-unconstrained unification variables are
- -- turned into RuntimeUnkSkols as they leave the
+ -- turned into RuntimeUnks as they leave the
-- typechecker's monad
; return (mkTyVarTy tv') }
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 6d5a52204f..645c43af6d 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -459,12 +459,22 @@ typeExtraInfoMsg :: [Implication] -> Type -> SDoc
-- Shows a bit of extra info about skolem constants
typeExtraInfoMsg implics ty
| Just tv <- tcGetTyVar_maybe ty
- , isTcTyVar tv
- , isSkolemTyVar tv
- = pprSkolTvBinding implics tv
- where
-typeExtraInfoMsg _ _ = empty -- Normal case
-
+ , isTcTyVar tv, isSkolemTyVar tv
+ , let pp_tv = quotes (ppr tv)
+ = case tcTyVarDetails tv of
+ SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv)
+ FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable")
+ RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem")
+ MetaTv {} -> empty
+
+ | otherwise -- Normal case
+ = empty
+
+ where
+ ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful
+ ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"),
+ sep [ppr info, ptext (sLit "at") <+> ppr loc]]
+
--------------------
unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
@@ -660,7 +670,6 @@ mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
-- ASSUMPTION: the Insts are fully zonked
mkMonomorphismMsg ctxt inst_tvs
= do { dflags <- getDOpts
- ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs))
; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
; return (tidy_env, mk_msg dflags docs) }
where
@@ -686,28 +695,6 @@ monomorphism_fix dflags
else empty] -- Only suggest adding "-XNoMonomorphismRestriction"
-- if it is not already set!
-
-pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc
--- Print info about the binding of a skolem tyvar,
--- or nothing if we don't have anything useful to say
-pprSkolTvBinding implics tv
- | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
- | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv)
- where
- ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv)
- ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable")
- ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem")
- ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for")
- <+> quotes (ppr n)
- ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable")
-
-
- ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
- ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
- ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
- sep [ppr info,
- ptext (sLit "at") <+> ppr (getSrcLoc tv)]]
-
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
= WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 74533340f3..1d163aaed4 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -34,8 +34,8 @@ module TcMType (
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars, tcInstSigTyVars,
- tcInstType, instMetaTyVar,
+ tcInstTyVars, tcInstSigTyVars,
+ tcInstType,
tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType,
tcSkolDFunType, tcSuperSkolTyVars,
@@ -258,8 +258,17 @@ tcInstSkolType ty = tcInstType tcInstSkolTyVars ty
tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
-- Make meta SigTv type variables for patten-bound scoped type varaibles
-- We use SigTvs for them, so that they can't unify with arbitrary types
-tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv)
- -- ToDo: the "function binding site is bogus
+tcInstSigTyVars = mapM tcInstSigTyVar
+
+tcInstSigTyVar :: TyVar -> TcM TcTyVar
+tcInstSigTyVar tyvar
+ = do { uniq <- newMetaUnique
+ ; ref <- newMutVar Flexi
+ ; let name = setNameUnique (tyVarName tyvar) uniq
+ -- Use the same OccName so that the tidy-er
+ -- doesn't rename 'a' to 'a0' etc
+ kind = tyVarKind tyvar
+ ; return (mkTcTyVar name kind (MetaTv SigTv ref)) }
\end{code}
@@ -277,9 +286,9 @@ newMetaTyVar meta_info kind
; ref <- newMutVar Flexi
; let name = mkTcTyVarName uniq s
s = case meta_info of
- TauTv -> fsLit "t"
- TcsTv -> fsLit "u"
- SigTv _ -> fsLit "a"
+ TauTv -> fsLit "t"
+ TcsTv -> fsLit "u"
+ SigTv -> fsLit "a"
; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
mkTcTyVarName :: Unique -> FastString -> Name
@@ -287,16 +296,6 @@ mkTcTyVarName :: Unique -> FastString -> Name
-- leaving the un-cluttered names free for user names
mkTcTyVarName uniq str = mkSysTvName uniq str
-instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar
--- Make a new meta tyvar whose Name and Kind
--- come from an existing TyVar
-instMetaTyVar meta_info tyvar
- = do { uniq <- newMetaUnique
- ; ref <- newMutVar Flexi
- ; let name = mkSystemName uniq (getOccName tyvar)
- kind = tyVarKind tyvar
- ; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
-
readMetaTyVar :: TyVar -> TcM MetaDetails
readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
readMutVar (metaTvRef tyvar)
@@ -394,10 +393,6 @@ newFlexiTyVarTy kind = do
newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
-tcInstTyVar :: TyVar -> TcM TcTyVar
--- Instantiate with a META type variable
-tcInstTyVar tyvar = instMetaTyVar TauTv tyvar
-
tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst)
-- Instantiate with META type variables
tcInstTyVars tyvars
@@ -407,6 +402,16 @@ tcInstTyVars tyvars
-- Since the tyvars are freshly made,
-- they cannot possibly be captured by
-- any existing for-alls. Hence zipTopTvSubst
+
+tcInstTyVar :: TyVar -> TcM TcTyVar
+-- Make a new unification variable tyvar whose Name and Kind
+-- come from an existing TyVar
+tcInstTyVar tyvar
+ = do { uniq <- newMetaUnique
+ ; ref <- newMutVar Flexi
+ ; let name = mkSystemName uniq (getOccName tyvar)
+ kind = tyVarKind tyvar
+ ; return (mkTcTyVar name kind (MetaTv TauTv ref)) }
\end{code}
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 3367f06ded..8858c136db 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -1038,9 +1038,6 @@ data SkolemInfo
-- polymorphic Ids, and are now checking that their RHS
-- constraints are satisfied.
- | RuntimeUnkSkol -- a type variable used to represent an unknown
- -- runtime type (used in the GHCi debugger)
-
| BracketSkol -- Template Haskell bracket
| UnkSkol -- Unhelpful info (until I improve it)
@@ -1075,8 +1072,7 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
-- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.
-- For Insts, these cases should not happen
-pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
-pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol")
+pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
\end{code}
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index eab07326b1..d9166d1c58 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -306,14 +306,12 @@ data MetaInfo
-- A TauTv is always filled in with a tau-type, which
-- never contains any ForAlls
- | SigTv Name -- A variant of TauTv, except that it should not be
+ | SigTv -- A variant of TauTv, except that it should not be
-- unified with a type, only with a type variable
-- SigTvs are only distinguished to improve error messages
-- see Note [Signature skolems]
-- The MetaDetails, if filled in, will
-- always be another SigTv or a SkolemTv
- -- The Name is the name of the function from whose
- -- type signature we got this skolem
| TcsTv -- A MetaTv allocated by the constraint solver
-- Its particular property is that it is always "touchable"
@@ -392,12 +390,12 @@ kind_var_occ = mkOccName tvName "k"
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
-pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
-pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
-pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
-pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
-pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
-pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
+pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk")
+pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt")
+pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
+pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n)
@@ -552,8 +550,8 @@ isTyConableTyVar tv
-- not a SigTv
= ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> False
- _ -> True
+ MetaTv SigTv _ -> False
+ _ -> True
isSkolemTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
@@ -583,8 +581,8 @@ isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> True
- _ -> False
+ MetaTv SigTv _ -> True
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index 4fc50b3325..31352e1491 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -899,8 +899,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2
ty1 = mkTyVarTy tv1
ty2 = mkTyVarTy tv2
- nicer_to_update_tv1 _ (SigTv _) = True
- nicer_to_update_tv1 (SigTv _) _ = False
+ nicer_to_update_tv1 _ SigTv = True
+ nicer_to_update_tv1 SigTv _ = False
nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1)
-- Try not to update SigTvs; and try to update sys-y type
-- variables in preference to ones gotten (say) by
View Lorry Controller Status