tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
eqKind,
isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
- isDoubleTy, isFloatTy, isIntTy, isStringTy,
+ isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
isOpenSynTyConApp,
import Maybes
import ListSetOps
import Outputable
+import FastString
import Data.List
import Data.IORef
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
-pprTcTyVarDetails (SkolemTv _) = ptext SLIT("sk")
-pprTcTyVarDetails (MetaTv BoxTv _) = ptext SLIT("box")
-pprTcTyVarDetails (MetaTv TauTv _) = ptext SLIT("tau")
-pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig")
+pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk")
+pprTcTyVarDetails (MetaTv BoxTv _) = ptext (sLit "box")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
-pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
-pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature")
-pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of the constructor") <+> quotes (ppr c)
-pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c)
-pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition")
-pprUserTypeCtxt LamPatSigCtxt = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt BindPatSigCtxt = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
-pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign declaration for") <+> quotes (ppr n)
-pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration")
-pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma")
+pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n)
+pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature")
+pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
+pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
+pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition")
+pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature")
+pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature")
+pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature")
+pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
+pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
+pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma")
--------------------------------
= ASSERT ( isTcTyVar tv )
quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
where
- ppr_details (MetaTv TauTv _) = ptext SLIT("is a meta type variable")
- ppr_details (MetaTv BoxTv _) = ptext SLIT("is a boxy type variable")
+ ppr_details (MetaTv TauTv _) = ptext (sLit "is a meta type variable")
+ ppr_details (MetaTv BoxTv _) = ptext (sLit "is a boxy type variable")
ppr_details (MetaTv (SigTv info) _) = ppr_skol info
ppr_details (SkolemTv info) = ppr_skol info
- ppr_skol UnkSkol = empty -- Unhelpful; omit
- ppr_skol RuntimeUnkSkol = ptext SLIT("is an unknown runtime type")
- ppr_skol info = sep [ptext SLIT("is a rigid type variable bound by"),
+ 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 [pprSkolInfo info,
- nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]]
+ nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]]
pprSkolInfo :: SkolemInfo -> SDoc
pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt
-pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo InstSkol = ptext SLIT("the instance declaration")
-pprSkolInfo FamInstSkol = ptext SLIT("the family instance declaration")
-pprSkolInfo (RuleSkol name) = ptext SLIT("the RULE") <+> doubleQuotes (ftext name)
-pprSkolInfo ArrowSkol = ptext SLIT("the arrow form")
-pprSkolInfo (PatSkol dc) = sep [ptext SLIT("the constructor") <+> quotes (ppr dc)]
-pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"),
+pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo InstSkol = ptext (sLit "the instance declaration")
+pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration")
+pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
+pprSkolInfo ArrowSkol = ptext (sLit "the arrow form")
+pprSkolInfo (PatSkol dc) = sep [ptext (sLit "the constructor") <+> quotes (ppr dc)]
+pprSkolInfo (GenSkol tvs ty) = sep [ptext (sLit "the polymorphic type"),
nest 2 (quotes (ppr (mkForAllTys tvs ty)))]
-- UnkSkol
pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol"
instance Outputable MetaDetails where
- ppr Flexi = ptext SLIT("Flexi")
- ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+ ppr Flexi = ptext (sLit "Flexi")
+ ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
\end{code}
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
split orig_ty (ForAllTy tv ty) ts
- | isCoVar tv = split ty ty (eq_pred:ts)
- where
- PredTy eq_pred = tyVarKind tv
+ | isCoVar tv = split ty ty (coVarPred tv : ts)
split orig_ty (FunTy arg res) ts
| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
split orig_ty ty ts = (reverse ts, orig_ty)
-- are transparent, so we need a special function here
tcInstHeadTyNotSynonym ty
= case ty of
- NoteTy _ ty -> tcInstHeadTyNotSynonym ty
TyConApp tc tys -> not (isSynTyCon tc)
_ -> True
-- These must be a constructor applied to type variable arguments
tcInstHeadTyAppAllTyVars ty
= case ty of
- NoteTy _ ty -> tcInstHeadTyAppAllTyVars ty
TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
other -> False
where
tvs = mapCatMaybes get_tv tys
- get_tv (NoteTy _ ty) = get_tv ty -- Again, do not look
get_tv (TyVarTy tv) = Just tv -- through synonyms
get_tv other = Nothing
\end{code}
isDoubleTy = is_tc doubleTyConKey
isIntegerTy = is_tc integerTyConKey
isIntTy = is_tc intTyConKey
+isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
isCharTy = is_tc charTyConKey
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
-tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty
tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
which type variables are mentioned in a type. It's also used in the
smart-app checking code --- see TcExpr.tcIdApp
+On the other hand, consider a *top-level* definition
+ f = (\x -> x) :: T a -> T a
+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
+if we have an application like (f "x") we get a confusing error message
+involving Any. So the conclusion is this: when generalising
+ - at top level use tyVarsOfType
+ - in nested bindings use exactTyVarsOfType
+See Trac #1813 for example.
+
\begin{code}
exactTyVarsOfType :: TcType -> TyVarSet
-- Find the free type variables (of any kind)
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
`unionVarSet` go_tv tyvar
- go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView
go_pred (IParam _ ty) = go ty
go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
tyClsNamesOfType :: Type -> NameSet
tyClsNamesOfType (TyVarTy tv) = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2
tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
projects / ghc-hetmet.git / blobdiff