Commit 35a1ec43 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Tidy up SigTv

This just a refactoring, removing dead code
parent 2b6ba11c
......@@ -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') }
......
......@@ -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 )
......
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment