Commit 95364812 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Tidy up and refactor wildcard handling

When examining #10615, I found the wildcard handling hard
to understand.  This patch refactors quite a bit, but with
no real change in behaviour.

 * Split out TcIdSigInfo from TcSigInfo, as a separate type,
   like TcPatSynInfo.

 * Make TcIdSigInfo express more invariants by pushing the
   wildard info into TcIdSigBndr

 * Remove all special treatment of unification variables that arise
   from wildcards; so the TauTv of TcType.MetaInfo loses its Bool
   argument.

A ton of konck on changes.  The result is significantly simpler, I think.
parent ab988608
This diff is collapsed.
......@@ -9,7 +9,7 @@ Typechecking class declarations
{-# LANGUAGE CPP #-}
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod,
findMethodBind, instantiateMethod,
tcClassMinimalDef,
HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
......@@ -19,7 +19,7 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn
import TcEnv
import TcPat( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
import TcPat( addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv )
import TcEvidence( idHsWrapper )
import TcBinds
import TcUnify
......@@ -207,8 +207,8 @@ tcDefMeth clas tyvars this_dict binds_in
(ptext (sLit "Ignoring SPECIALISE pragmas on default method")
<+> quotes (ppr sel_name))
; let hs_ty = lookupHsSig hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
; let hs_ty = lookupHsSig hs_sig_fn sel_name
`orElse` pprPanic "tc_dm" (ppr sel_name)
-- We need the HsType so that we can bring the right
-- type variables into scope
--
......@@ -225,18 +225,19 @@ tcDefMeth clas tyvars this_dict binds_in
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
ctxt = FunSigCtxt sel_name warn_redundant
; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty Nothing [] local_dm_name
; (ev_binds, (tc_bind, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $
tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
tcPolyCheck NonRecursive no_prag_fn local_dm_sig
(L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id
-- We have created a complete type signature in
-- instTcTySig, hence it is safe to call
-- completeSigPolyId
, abe_mono = completeSigPolyId local_dm_sig'
, abe_mono = completeIdSigPolyId local_dm_sig
, abe_wrap = idHsWrapper
, abe_prags = IsDefaultMethod }
full_bind = AbsBinds { abs_tvs = tyvars
......
......@@ -1701,7 +1701,7 @@ quickFlattenTy (TyConApp tc tys)
| otherwise
= do { let (funtys,resttys) = splitAt (tyConArity tc) tys
-- Ignore the arguments of the type family funtys
; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys))
; v <- newMetaTyVar TauTv (typeKind (TyConApp tc funtys))
; flat_resttys <- mapM quickFlattenTy resttys
; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
......
......@@ -218,9 +218,10 @@ tcExpr e@(HsLamCase _ matches) res_ty
match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
= do { nwc_tvs <- mapM newWildcardVarMetaKind wcs
; tcExtendTyVarEnv nwc_tvs $ do {
sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
= tcWildcardBinders wcs $ \ wc_prs ->
do { addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
emitWildcardHoleConstraints wc_prs
; sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
; (gen_fn, expr')
<- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
......@@ -234,9 +235,7 @@ tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
emitWildcardHoleConstraints (zip wcs nwc_tvs)
; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty } }
; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
tcExpr (HsType ty) _
= failWithTc (text "Can't handle type argument:" <+> ppr ty)
......
......@@ -19,6 +19,7 @@ module TcHsType (
-- Kind-checking types
-- No kind generalisation, no checkValidType
tcWildcardBinders,
kcHsTyVarBndrs, tcHsTyVarBndrs,
tcHsLiftedType, tcHsOpenType,
tcLHsType, tcCheckLHsType, tcCheckLHsTypeAndGen,
......@@ -922,6 +923,19 @@ addTypeCtxt (L _ ty) thing
************************************************************************
-}
tcWildcardBinders :: [Name]
-> ([(Name,TcTyVar)] -> TcM a)
-> TcM a
tcWildcardBinders wcs thing_inside
= do { wc_prs <- mapM new_wildcard wcs
; tcExtendTyVarEnv2 wc_prs $
thing_inside wc_prs }
where
new_wildcard :: Name -> TcM (Name, TcTyVar)
new_wildcard name = do { kind <- newMetaKindVar
; tv <- newFlexiTyVar kind
; return (name, tv) }
mkKindSigVar :: Name -> TcM KindVar
-- Use the specified name; don't clone it
mkKindSigVar n
......@@ -1266,16 +1280,15 @@ tcHsPatSigType :: UserTypeCtxt
tcHsPatSigType ctxt (HsWB { hswb_cts = hs_ty, hswb_kvs = sig_kvs,
hswb_tvs = sig_tvs, hswb_wcs = sig_wcs })
= addErrCtxt (pprSigCtxt ctxt empty (ppr hs_ty)) $
do { kvs <- mapM new_kv sig_kvs
tcWildcardBinders sig_wcs $ \ nwc_binds ->
do { emitWildcardHoleConstraints nwc_binds
; kvs <- mapM new_kv sig_kvs
; tvs <- mapM new_tv sig_tvs
; nwc_tvs <- mapM newWildcardVarMetaKind sig_wcs
; let nwc_binds = sig_wcs `zip` nwc_tvs
ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs)
; sig_ty <- tcExtendTyVarEnv2 (ktv_binds ++ nwc_binds) $
; let ktv_binds = (sig_kvs `zip` kvs) ++ (sig_tvs `zip` tvs)
; sig_ty <- tcExtendTyVarEnv2 ktv_binds $
tcHsLiftedType hs_ty
; sig_ty <- zonkSigType sig_ty
; checkValidType ctxt sig_ty
; emitWildcardHoleConstraints (zip sig_wcs nwc_tvs)
; return (sig_ty, ktv_binds, nwc_binds) }
where
new_kv name = new_tkv name superKind
......
......@@ -18,7 +18,7 @@ import TcTyClsDecls
import TcClassDcl( tcClassDecl2,
HsSigFun, lookupHsSig, mkHsSigFun,
findMethodBind, instantiateMethod )
import TcPat ( addInlinePrags, completeSigPolyId, lookupPragEnv, emptyPragEnv )
import TcPat ( TcIdSigInfo, addInlinePrags, completeIdSigPolyId, lookupPragEnv, emptyPragEnv )
import TcRnMonad
import TcValidity
import TcMType
......@@ -1328,8 +1328,8 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
HsVar dm_id
-- A method always has a complete type signature,
-- hence it is safe to call completeSigPolyId
local_meth_id = completeSigPolyId local_meth_sig
-- hence it is safe to call completeIdSigPolyId
local_meth_id = completeIdSigPolyId local_meth_sig
meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
meth_id1 = meth_id `setInlinePragma` dm_inline_prag
-- Copy the inline pragma (if any) from the default
......@@ -1377,9 +1377,9 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
inst_tys sel_id
; let prags = lookupPragEnv prag_fn (idName sel_id)
-- A method always has a complete type signature, hence
-- it is safe to call completeSigPolyId
local_meth_id = completeSigPolyId local_meth_sig
-- A method always has a complete type signature,
-- so it is safe to call cmpleteIdSigPolyId
local_meth_id = completeIdSigPolyId local_meth_sig
lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
......@@ -1419,7 +1419,7 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
------------------------
mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
-> [TcType] -> Id -> TcM (TcId, TcIdSigInfo, HsWrapper)
mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
= do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
; local_meth_name <- newName sel_occ
......@@ -1434,11 +1434,12 @@ mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
-> setSrcSpan (getLoc lhs_ty) $
do { inst_sigs <- xoptM Opt_InstanceSigs
; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
; sig_ty <- tcHsSigType (FunSigCtxt sel_name True) lhs_ty
; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) lhs_ty
; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name
ctxt = FunSigCtxt sel_name True
; tc_sig <- instTcTySig ctxt lhs_ty sig_ty Nothing [] local_meth_name
; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
tcSubType (FunSigCtxt sel_name False) poly_sig_ty poly_meth_ty
tcSubType ctxt poly_sig_ty poly_meth_ty
; return (poly_meth_id, tc_sig, hs_wrap) }
Nothing -- No type signature
......
......@@ -54,11 +54,7 @@ module TcMType (
zonkTcKind, defaultKindVarToStar,
zonkEvVar, zonkWC, zonkSimples, zonkId, zonkCt, zonkSkolemInfo,
tcGetGlobalTyVars,
--------------------------------
-- (Named) Wildcards
newWildcardVar, newWildcardVarMetaKind
tcGetGlobalTyVars
) where
#include "HsVersions.h"
......@@ -104,7 +100,7 @@ kind_var_occ = mkOccName tvName "k"
newMetaKindVar :: TcM TcKind
newMetaKindVar = do { uniq <- newUnique
; details <- newMetaDetails (TauTv False)
; details <- newMetaDetails TauTv
; let kv = mkTcTyVar (mkKindName uniq) superKind details
; return (mkTyVarTy kv) }
......@@ -288,19 +284,12 @@ newMetaTyVar meta_info kind
; let name = mkTcTyVarName uniq s
s = case meta_info of
ReturnTv -> fsLit "r"
TauTv True -> fsLit "w"
TauTv False -> fsLit "t"
TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv"
SigTv -> fsLit "a"
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
newNamedMetaTyVar :: Name -> MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newNamedMetaTyVar name meta_info kind
= do { details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { uniq <- newUnique
......@@ -418,7 +407,7 @@ writeMetaTyVarRef tyvar ref ty
-}
newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar kind = newMetaTyVar (TauTv False) kind
newFlexiTyVar kind = newMetaTyVar TauTv kind
newFlexiTyVarTy :: Kind -> TcM TcType
newFlexiTyVarTy kind = do
......@@ -449,7 +438,7 @@ tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar)
-- an existing TyVar. We substitute kind variables in the kind.
tcInstTyVarX subst tyvar
= do { uniq <- newUnique
; details <- newMetaDetails (TauTv False)
; details <- newMetaDetails TauTv
; let name = mkSystemName uniq (getOccName tyvar)
-- See Note [Name of an instantiated type variable]
kind = substTy subst (tyVarKind tyvar)
......@@ -577,22 +566,13 @@ skolemiseUnboundMetaTyVar tv details
; uniq <- newUnique -- Remove it from TcMetaTyVar unique land
; kind <- zonkTcKind (tyVarKind tv)
; let tv_name = getOccName tv
new_tv_name = if isWildcardVar tv
then generaliseWildcardVarName tv_name
else tv_name
final_name = mkInternalName uniq new_tv_name span
final_name = mkInternalName uniq tv_name span
final_kind = defaultKind kind
final_tv = mkTcTyVar final_name final_kind details
; traceTc "Skolemising" (ppr tv <+> ptext (sLit ":=") <+> ppr final_tv)
; writeMetaTyVar tv (mkTyVarTy final_tv)
; return final_tv }
where
-- If a wildcard type called _a is generalised, we rename it to w_a
generaliseWildcardVarName :: OccName -> OccName
generaliseWildcardVarName name | startsWithUnderscore name
= mkOccNameFS (occNameSpace name) (appendFS (fsLit "w") (occNameFS name))
generaliseWildcardVarName name = name
{-
Note [Zonking to Skolem]
......@@ -969,31 +949,3 @@ tidySkolemInfo env (UnifyForAllSkol skol_tvs ty)
ty' = tidyType env2 ty
tidySkolemInfo env info = (env, info)
{-
************************************************************************
* *
(Named) Wildcards
* *
************************************************************************
-}
-- | Create a new meta var with the given kind. This meta var should be used
-- to replace a wildcard in a type. Such a wildcard meta var can be
-- distinguished from other meta vars with the 'isWildcardVar' function.
newWildcardVar :: Name -> Kind -> TcM TcTyVar
newWildcardVar name kind = newNamedMetaTyVar name (TauTv True) kind
-- | Create a new meta var (which can unify with a type of any kind). This
-- meta var should be used to replace a wildcard in a type. Such a wildcard
-- meta var can be distinguished from other meta vars with the 'isWildcardVar'
-- function.
newWildcardVarMetaKind :: Name -> TcM TcTyVar
newWildcardVarMetaKind name = do kind <- newMetaKindVar
newWildcardVar name kind
-- | Return 'True' if the argument is a meta var created for a wildcard (by
-- 'newWildcardVar' or 'newWildcardVarMetaKind').
isWildcardVar :: TcTyVar -> Bool
isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True
isWildcardVar _ = False
......@@ -10,9 +10,9 @@ TcPat: Typechecking patterns
module TcPat ( tcLetPat, TcSigFun
, TcPragEnv, lookupPragEnv, emptyPragEnv
, TcSigInfo(..), TcPatSynInfo(..)
, findScopedTyVars, isPartialSig
, completeSigPolyId, completeSigPolyId_maybe
, TcSigInfo(..), TcIdSigInfo(..), TcPatSynInfo(..), TcIdSigBndr(..)
, findScopedTyVars, isPartialSig, noCompleteSig
, completeIdSigPolyId, completeSigPolyId_maybe, completeIdSigPolyId_maybe
, LetBndrSpec(..), addInlinePrags
, tcPat, tcPats, newNoSigLetBndr
, addDataConStupidTheta, badFieldCon, polyPatSig ) where
......@@ -145,56 +145,43 @@ emptyPragEnv = emptyNameEnv
lookupPragEnv :: TcPragEnv -> Name -> [LSig Name]
lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
data TcSigInfo
= TcSigInfo {
sig_name :: Name, -- The binder name of the type signature. When
-- sig_id = Just id, then sig_name = idName id.
data TcSigInfo = TcIdSig TcIdSigInfo
| TcPatSynSig TcPatSynInfo
sig_poly_id :: Maybe TcId,
-- Just f <=> the type signature had no wildcards, so the precise,
-- complete polymorphic type is known. In that case,
-- f is the polymorphic Id, with that type
-- Nothing <=> the type signature is partial (i.e. includes one or more
-- wildcards). In this case it doesn't make sense to give
-- the polymorphic Id, because we are going to /infer/ its
-- type, so we can't make the polymorphic Id ab-initio
--
-- See Note [Complete and partial type signatures]
data TcIdSigInfo
= TISI {
sig_bndr :: TcIdSigBndr,
sig_tvs :: [(Maybe Name, TcTyVar)],
-- Instantiated type and kind variables
-- Just n <=> this skolem is lexically in scope with name n
-- See Note [Binding scoped type variables]
sig_nwcs :: [(Name, TcTyVar)],
-- Instantiated wildcard variables
-- If sig_poly_id = Just f, then sig_nwcs must be empty
sig_extra_cts :: Maybe SrcSpan,
-- Just loc <=> An extra-constraints wildcard was present
-- at location loc
-- e.g. f :: (Eq a, _) => a -> a
-- Any extra constraints inferred during
-- type-checking will be added to the sig_theta.
-- If sig_poly_id = Just f, sig_extra_cts must be Nothing
sig_theta :: TcThetaType, -- Instantiated theta
sig_tau :: TcSigmaType, -- Instantiated tau
-- See Note [sig_tau may be polymorphic]
sig_loc :: SrcSpan, -- The location of the signature
sig_warn_redundant :: Bool -- True <=> report redundant constraints
-- when typechecking the value binding
-- for this type signature
-- This is usually True, but False for
-- * Record selectors (not important here)
-- * Class and instance methods. Here the code may legitimately
-- be more polymorphic than the signature generated from the
-- class declaration
sig_ctxt :: UserTypeCtxt, -- FunSigCtxt or CheckSigCtxt
sig_loc :: SrcSpan -- Location of the type signature
}
| TcPatSynInfo TcPatSynInfo
data TcIdSigBndr -- See Note [Complete and partial type signatures]
= CompleteSig -- A complete signature with no wildards,
-- so the complete polymorphic type is known.
TcId -- The polymoprhic Id with that type
| PartialSig -- A partial type signature (i.e. includes one or more
-- wildcards). In this case it doesn't make sense to give
-- the polymorphic Id, because we are going to /infer/ its
-- type, so we can't make the polymorphic Id ab-initio
{ sig_name :: Name -- Name of the function
, sig_hs_ty :: LHsType Name -- The original partial signatur
, sig_nwcs :: [(Name, TcTyVar)] -- Instantiated wildcard variables
, sig_cts :: Maybe SrcSpan -- Just loc <=> An extra-constraints wildcard was present
} -- at location loc
-- e.g. f :: (Eq a, _) => a -> a
-- Any extra constraints inferred during
-- type-checking will be added to the sig_theta.
data TcPatSynInfo
= TPSI {
......@@ -224,35 +211,56 @@ findScopedTyVars hs_ty sig_ty inst_tvs
scoped_names = mkNameSet (hsExplicitTvs hs_ty)
(sig_tvs,_) = tcSplitForAllTys sig_ty
instance NamedThing TcSigInfo where
getName TcSigInfo{ sig_name = name } = name
getName (TcPatSynInfo tpsi) = patsig_name tpsi
instance NamedThing TcIdSigInfo where
getName (TISI { sig_bndr = bndr }) = getName bndr
instance NamedThing TcIdSigBndr where
getName (CompleteSig id) = idName id
getName (PartialSig { sig_name = n }) = n
instance NamedThing TcSigInfo where
getName (TcIdSig idsi) = getName idsi
getName (TcPatSynSig tpsi) = patsig_name tpsi
instance Outputable TcSigInfo where
ppr (TcSigInfo { sig_name = name, sig_poly_id = mb_poly_id, sig_tvs = tyvars
, sig_theta = theta, sig_tau = tau })
= maybe (ppr name) ppr mb_poly_id <+> dcolon <+>
ppr (TcIdSig idsi) = ppr idsi
ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi
instance Outputable TcIdSigInfo where
ppr (TISI { sig_bndr = bndr, sig_tvs = tyvars
, sig_theta = theta, sig_tau = tau })
= ppr bndr <+> dcolon <+>
vcat [ pprSigmaType (mkSigmaTy (map snd tyvars) theta tau)
, ppr (map fst tyvars) ]
ppr (TcPatSynInfo tpsi) = text "TcPatSynInfo" <+> ppr tpsi
instance Outputable TcIdSigBndr where
ppr s_bndr = ppr (getName s_bndr)
instance Outputable TcPatSynInfo where
ppr (TPSI{ patsig_name = name}) = ppr name
isPartialSig :: TcSigInfo -> Bool
isPartialSig (TcSigInfo { sig_poly_id = Nothing }) = True
isPartialSig _ = False
isPartialSig :: TcIdSigInfo -> Bool
isPartialSig (TISI { sig_bndr = PartialSig {} }) = True
isPartialSig _ = False
-- | No signature or a partial signature
noCompleteSig :: Maybe TcSigInfo -> Bool
noCompleteSig (Just (TcIdSig sig)) = isPartialSig sig
noCompleteSig _ = True
-- Helper for cases when we know for sure we have a complete type
-- signature, e.g. class methods.
completeSigPolyId :: TcSigInfo -> TcId
completeSigPolyId (TcSigInfo { sig_poly_id = Just id }) = id
completeSigPolyId _ = panic "completeSigPolyId"
completeIdSigPolyId :: TcIdSigInfo -> TcId
completeIdSigPolyId (TISI { sig_bndr = CompleteSig id }) = id
completeIdSigPolyId _ = panic "completeSigPolyId"
completeIdSigPolyId_maybe :: TcIdSigInfo -> Maybe TcId
completeIdSigPolyId_maybe (TISI { sig_bndr = CompleteSig id }) = Just id
completeIdSigPolyId_maybe _ = Nothing
completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
completeSigPolyId_maybe (TcSigInfo { sig_poly_id = mb_id }) = mb_id
completeSigPolyId_maybe (TcPatSynInfo {}) = Nothing
completeSigPolyId_maybe (TcIdSig sig) = completeIdSigPolyId_maybe sig
completeSigPolyId_maybe (TcPatSynSig {}) = Nothing
{-
Note [Binding scoped type variables]
......@@ -314,7 +322,7 @@ A type signature is partial when it contains one or more wildcards
stored in sig_nwcs.
f :: Bool -> _
g :: Eq _a => _a -> _a -> Bool
* Or an extra-constraints wildcard, stored in sig_extra_cts:
* Or an extra-constraints wildcard, stored in sig_cts:
h :: (Num a, _) => a -> a
A type signature is a complete type signature when there are no
......@@ -334,9 +342,9 @@ tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercion, TcId)
--
tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
-- See Note [Typing patterns in pattern bindings]
| LetGblBndr prags <- no_gen
, Just sig <- lookup_sig bndr_name
, Just poly_id <- sig_poly_id sig
| LetGblBndr prags <- no_gen
, Just (TcIdSig sig) <- lookup_sig bndr_name
, Just poly_id <- completeIdSigPolyId_maybe sig
= do { bndr_id <- addInlinePrags poly_id (lookupPragEnv prags bndr_name)
; traceTc "tcPatBndr(gbl,sig)" (ppr bndr_id $$ ppr (idType bndr_id))
; co <- unifyPatType (idType bndr_id) pat_ty
......
......@@ -76,7 +76,7 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args
; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False named_taus wanted
; (qtvs, req_dicts, _mr_bites, ev_binds) <- simplifyInfer tclvl False [] named_taus wanted
; (ex_vars, prov_dicts) <- tcCollectEx lpat'
; let univ_tvs = filter (not . (`elemVarSet` ex_vars)) qtvs
......@@ -119,7 +119,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
; req_dicts <- newEvVars req_theta
-- TODO: find a better SkolInfo
; let skol_info = SigSkol (FunSigCtxt name True) (mkFunTys arg_tys pat_ty)
; let skol_info = SigSkol (PatSynCtxt name) (mkFunTys arg_tys pat_ty)
; let (arg_names, is_infix) = case details of
PrefixPatSyn names -> (map unLoc names, False)
......
......@@ -1846,8 +1846,7 @@ tcRnType hsc_env normalise rdr_type
-- Now kind-check the type
-- It can have any rank or kind
; nwc_tvs <- mapM newWildcardVarMetaKind wcs
; (ty, kind) <- tcExtendTyVarEnv nwc_tvs $
; (ty, kind) <- tcWildcardBinders wcs $ \_ ->
tcLHsType rn_type
-- Do kind generalisation; see Note [Kind-generalise in tcRnType]
......
......@@ -2149,8 +2149,8 @@ pprSigSkolInfo ctxt ty
_ -> hang (pprUserTypeCtxt ctxt <> colon)
2 (ppr ty)
where
pp_sig f = sep [ ptext (sLit "the type signature for:")
, pprPrefixOcc f <+> dcolon <+> ppr ty ]
pp_sig f = vcat [ ptext (sLit "the type signature for:")
, nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ]
pprPatSkolInfo :: ConLike -> SDoc
pprPatSkolInfo (RealDataCon dc)
......
......@@ -2650,7 +2650,7 @@ instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
instFlexiTcSHelper :: Name -> Kind -> TcM TcType
instFlexiTcSHelper tvname kind
= do { uniq <- TcM.newUnique
; details <- TcM.newMetaDetails (TauTv False)
; details <- TcM.newMetaDetails TauTv
; let name = setNameUnique tvname uniq
; return (mkTyVarTy (mkTcTyVar name kind details)) }
......
......@@ -346,11 +346,9 @@ instance Outputable MetaDetails where
ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
data MetaInfo
= TauTv Bool -- This MetaTv is an ordinary unification variable
= TauTv -- This MetaTv is an ordinary unification variable
-- A TauTv is always filled in with a tau-type, which
-- never contains any ForAlls.
-- The boolean is true when the meta var originates
-- from a wildcard.
| ReturnTv -- Can unify with *anything*. Used to convert a
-- type "checking" algorithm into a type inference algorithm.
......@@ -372,16 +370,25 @@ data MetaInfo
-- in the places where we need to an expression has that type
data UserTypeCtxt
= FunSigCtxt Name Bool -- Function type signature, when checking the type
-- Also used for types in SPECIALISE pragmas
-- Bool = True <=> report redundant class constraints
-- False <=> do not
-- See Note [Tracking redundant constraints] in TcSimplify
= FunSigCtxt -- Function type signature, when checking the type
-- Also used for types in SPECIALISE pragmas
Name -- Name of the function
Bool -- True <=> report redundant constraints
-- This is usually True, but False for
-- * Record selectors (not important here)
-- * Class and instance methods. Here
-- the code may legitimately be more
-- polymorphic than the signature
-- generated from the class
-- declaration
| InfSigCtxt Name -- Inferred type for function
| ExprSigCtxt -- Expression type signature
| ConArgCtxt Name -- Data constructor argument
| TySynCtxt Name -- RHS of a type synonym decl
| PatSynCtxt Name -- Type sig for a pattern synonym
-- eg pattern C :: Int -> T
| PatSigCtxt -- Type sig in pattern
-- eg f (x::t) = ...
-- or (x::t, y) = e
......@@ -530,11 +537,10 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
= pp_info <> colon <> ppr tclvl
where
pp_info = case info of
ReturnTv -> ptext (sLit "ret")
TauTv True -> ptext (sLit "twc")
TauTv False -> ptext (sLit "tau")
SigTv -> ptext (sLit "sig")
FlatMetaTv -> ptext (sLit "fuv")
ReturnTv -> ptext (sLit "ret")
TauTv -> ptext (sLit "tau")
SigTv -> ptext (sLit "sig")
FlatMetaTv -> ptext (sLit "fuv")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n _) = ptext (sLit "the type signature for") <+> quotes (ppr n)
......@@ -543,6 +549,7 @@ pprUserTypeCtxt (RuleSigCtxt n) = ptext (sLit "a RULE 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 (PatSynCtxt c) = ptext (sLit "the type signature for pattern synonym") <+> quotes (ppr c)
pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]")
pprUserTypeCtxt PatSigCtxt = ptext (sLit "a pattern type signature")
pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature")
......@@ -568,6 +575,7 @@ pprSigCtxt ctxt extra pp_ty
pp_sig (FunSigCtxt n _) = pp_n_colon n
pp_sig (ConArgCtxt n) = pp_n_colon n
pp_sig (ForSigCtxt n) = pp_n_colon n
pp_sig (PatSynCtxt n) = pp_n_colon n
pp_sig _ = pp_ty
pp_n_colon n = pprPrefixOcc n <+> dcolon <+> pp_ty
......@@ -1265,7 +1273,7 @@ canUnifyWithPolyType dflags details kind
= case details of
MetaTv { mtv_info = ReturnTv } -> True -- See Note [ReturnTv]
MetaTv { mtv_info = SigTv } -> False
MetaTv { mtv_info = TauTv _ } -> xopt Opt_ImpredicativeTypes dflags
MetaTv { mtv_info = TauTv } -> xopt Opt_ImpredicativeTypes dflags
|| isOpenTypeKind kind
-- Note [OpenTypeKind accepts foralls]
_other -> True
......
......@@ -282,10 +282,10 @@ checkValidType ctxt ty
RuleSigCtxt _ -> rank1
TySynCtxt _ -> rank0
ExprSigCtxt -> rank1
FunSigCtxt _ _ -> rank1
InfSigCtxt _ -> ArbitraryRank -- Inferred type
ConArgCtxt _ -> rank1 -- We are given the type of the entire
ExprSigCtxt -> rank1
FunSigCtxt {} -> rank1
InfSigCtxt _ -> ArbitraryRank -- Inferred type
ConArgCtxt _ -> rank1 -- We are given the type of the entire
-- constructor, hence rank 1
ForSigCtxt _ -> rank1
......@@ -739,6 +739,7 @@ okIPCtxt ThBrackCtxt = True
okIPCtxt GhciCtxt = True
okIPCtxt SigmaCtxt = True
okIPCtxt (DataTyCtxt {}) = True
okIPCtxt (PatSynCtxt {}) = True
okIPCtxt (ClassSCCtxt {}) = False
okIPCtxt (InstDeclCtxt {}) = False
......
......@@ -131,7 +131,7 @@ module Type (
pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon,
TyPrec(..), maybeParen, pprSigmaTypeExtraCts,
TyPrec(..), maybeParen,
-- * Tidying type related things up for printing
tidyType, tidyTypes,
......
......@@ -32,7 +32,7 @@ module TypeRep (
-- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory, pprSigmaType, pprSigmaTypeExtraCts,
pprTyThing, pprTyThingCategory, pprSigmaType,
pprTheta, pprForAll, pprUserForAll,
pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit, suppressKinds,
......@@ -562,10 +562,6 @@ pprThetaArrowTy preds = parens (fsep (punctuate comma (map (ppr_type TopPrec) p
-- Eq j, Eq k, Eq l) =>
-- Eq (a, b, c, d, e, f, g, h, i, j, k, l)
pprThetaArrowTyExtra :: ThetaType -> SDoc
pprThetaArrowTyExtra [] = text "_" <+> darrow
pprThetaArrowTyExtra preds = parens (fsep (punctuate comma xs)) <+> darrow
where xs = (map (ppr_type TopPrec) preds) ++ [text "_"]
------------------
instance Outputable Type where
ppr ty = pprType ty
......@@ -599,7 +595,7 @@ ppr_type p fun_ty@(FunTy ty1 ty2)
ppr_forall_type :: TyPrec -> Type -> SDoc