Commit 15b9bf4b authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve typechecking of let-bindings

This major commit was initially triggered by #11339, but it spiraled
into a major review of the way in which type signatures for bindings
are handled, especially partial type signatures.  On the way I fixed a
number of other bugs, namely
   #12069
   #12033
   #11700
   #11339
   #11670

The main change is that I completely reorganised the way in which type
signatures in bindings are handled. The new story is in TcSigs
Note [Overview of type signatures].  Some specific:

* Changes in the data types for signatures in TcRnTypes:
  TcIdSigInfo and new TcIdSigInst

* New module TcSigs deals with typechecking type signatures
  and pragmas. It contains code mostly moved from TcBinds,
  which is already too big

* HsTypes: I swapped the nesting of HsWildCardBndrs
  and HsImplicitBndsrs, so that the wildcards are on the
  oustide not the insidde in a LHsSigWcType.  This is just
  a matter of convenient, nothing deep.

There are a host of other changes as knock-on effects, and
it all took FAR longer than I anticipated :-).  But it is
a significant improvement, I think.

Lots of error messages changed slightly, some just variants but
some modest improvements.

New tests

* typecheck/should_compile
    * SigTyVars: a scoped-tyvar test
    * ExPat, ExPatFail: existential pattern bindings
    * T12069
    * T11700
    * T11339

* partial-sigs/should_compile
    * T12033
    * T11339a
    * T11670

One thing to check:

* Small change to output from ghc-api/landmines.
  Need to check with Alan Zimmerman
parent d25cb61a
...@@ -189,8 +189,8 @@ hsSigTvBinders binds ...@@ -189,8 +189,8 @@ hsSigTvBinders binds
-- here 'k' scopes too -- here 'k' scopes too
get_scoped_tvs (L _ (TypeSig _ sig)) get_scoped_tvs (L _ (TypeSig _ sig))
| HsIB { hsib_vars = implicit_vars | HsIB { hsib_vars = implicit_vars
, hsib_body = sig1 } <- sig , hsib_body = hs_ty } <- hswc_body sig
, (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1) , (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars = implicit_vars ++ map hsLTyVarName explicit_vars
get_scoped_tvs _ = [] get_scoped_tvs _ = []
...@@ -567,7 +567,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _)) ...@@ -567,7 +567,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
ruleBndrNames :: LRuleBndr Name -> [Name] ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n] ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n sig)) ruleBndrNames (L _ (RuleBndrSig n sig))
| HsIB { hsib_vars = vars } <- sig | HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
= unLoc n : vars = unLoc n : vars
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ) repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
...@@ -735,8 +735,8 @@ rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name ...@@ -735,8 +735,8 @@ rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name
-- We must special-case the top-level explicit for-all of a TypeSig -- We must special-case the top-level explicit for-all of a TypeSig
-- See Note [Scoped type variables in bindings] -- See Note [Scoped type variables in bindings]
rep_wc_ty_sig mk_sig loc sig_ty nm rep_wc_ty_sig mk_sig loc sig_ty nm
| HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty | HsIB { hsib_vars = implicit_tvs, hsib_body = hs_ty } <- hswc_body sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1) , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
= do { nm1 <- lookupLOcc nm = do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name } ; repTyVarBndrWithKind tv name }
...@@ -917,8 +917,8 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs ...@@ -917,8 +917,8 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
(univs, reqs, exis, provs, ty) = splitLHsPatSynTy body (univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ) repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 }) repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType (ib_ty { hsib_body = hswc_body sig1 }) = repHsSigType sig1
-- yield the representation of a list of types -- yield the representation of a list of types
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
......
...@@ -15,7 +15,6 @@ module DsMonad ( ...@@ -15,7 +15,6 @@ module DsMonad (
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
Applicative(..),(<$>), Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs, newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs, getSrcSpanDs, putSrcSpanDs,
......
...@@ -399,6 +399,7 @@ Library ...@@ -399,6 +399,7 @@ Library
TcAnnotations TcAnnotations
TcArrows TcArrows
TcBinds TcBinds
TcSigs
TcClassDcl TcClassDcl
TcDefaults TcDefaults
TcDeriv TcDeriv
......
...@@ -288,16 +288,12 @@ data HsWildCardBndrs name thing ...@@ -288,16 +288,12 @@ data HsWildCardBndrs name thing
-- See Note [The wildcard story for types] -- See Note [The wildcard story for types]
= HsWC { hswc_wcs :: PostRn name [Name] = HsWC { hswc_wcs :: PostRn name [Name]
-- Wild cards, both named and anonymous -- Wild cards, both named and anonymous
-- after the renamer
, hswc_ctx :: Maybe SrcSpan , hswc_body :: thing
-- Indicates whether hswc_body has an -- Main payload (type or list of types)
-- extra-constraint wildcard, and if so where -- If there is an extra-constraints wildcard,
-- e.g. (Eq a, _) => a -> a -- it's still there in the hsc_body.
-- NB: the wildcard stays in HsQualTy inside the type!
-- So for pretty printing purposes you can ignore
-- hswc_ctx
, hswc_body :: thing -- Main payload (type or list of types)
} }
deriving instance (Data name, Data thing, Data (PostRn name [Name])) deriving instance (Data name, Data thing, Data (PostRn name [Name]))
...@@ -308,7 +304,7 @@ deriving instance (Data name, Data thing, Data (PostRn name [Name])) ...@@ -308,7 +304,7 @@ deriving instance (Data name, Data thing, Data (PostRn name [Name]))
type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only
type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only
type LHsSigWcType name = HsImplicitBndrs name (LHsWcType name) -- Both type LHsSigWcType name = HsWildCardBndrs name (LHsSigType name) -- Both
-- See Note [Representing type signatures] -- See Note [Representing type signatures]
...@@ -319,11 +315,11 @@ hsSigType :: LHsSigType name -> LHsType name ...@@ -319,11 +315,11 @@ hsSigType :: LHsSigType name -> LHsType name
hsSigType = hsImplicitBody hsSigType = hsImplicitBody
hsSigWcType :: LHsSigWcType name -> LHsType name hsSigWcType :: LHsSigWcType name -> LHsType name
hsSigWcType sig_ty = hswc_body (hsib_body sig_ty) hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)
dropWildCards :: LHsSigWcType name -> LHsSigType name dropWildCards :: LHsSigWcType name -> LHsSigType name
-- Drop the wildcard part of a LHsSigWcType -- Drop the wildcard part of a LHsSigWcType
dropWildCards sig_ty = sig_ty { hsib_body = hsSigWcType sig_ty } dropWildCards sig_ty = hswc_body sig_ty
{- Note [Representing type signatures] {- Note [Representing type signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -351,8 +347,7 @@ mkHsImplicitBndrs x = HsIB { hsib_body = x ...@@ -351,8 +347,7 @@ mkHsImplicitBndrs x = HsIB { hsib_body = x
mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing
mkHsWildCardBndrs x = HsWC { hswc_body = x mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = PlaceHolder , hswc_wcs = PlaceHolder }
, hswc_ctx = Nothing }
-- Add empty binders. This is a bit suspicious; what if -- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables? -- the wrapped thing had free type variables?
...@@ -362,8 +357,7 @@ mkEmptyImplicitBndrs x = HsIB { hsib_body = x ...@@ -362,8 +357,7 @@ mkEmptyImplicitBndrs x = HsIB { hsib_body = x
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x mkEmptyWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = [] , hswc_wcs = [] }
, hswc_ctx = Nothing }
-------------------------------------------------- --------------------------------------------------
...@@ -789,8 +783,8 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name] ...@@ -789,8 +783,8 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name]
-- - the named wildcars; see Note [Scoping of named wildcards] -- - the named wildcars; see Note [Scoping of named wildcards]
-- because they scope in the same way -- because they scope in the same way
hsWcScopedTvs sig_ty hsWcScopedTvs sig_ty
| HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty | HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1 , HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of = case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs map hsLTyVarName tvs
...@@ -1237,10 +1231,10 @@ ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty) ...@@ -1237,10 +1231,10 @@ ppr_mono_ty _ (HsPArrTy ty) = paBrackets (ppr_mono_lty TopPrec ty)
ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty) ppr_mono_ty prec (HsIParamTy n ty) = maybeParen prec FunPrec (ppr n <+> dcolon <+> ppr_mono_lty TopPrec ty)
ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s ppr_mono_ty _ (HsSpliceTy s _) = pprSplice s
ppr_mono_ty _ (HsCoreTy ty) = ppr ty ppr_mono_ty _ (HsCoreTy ty) = ppr ty
ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys) ppr_mono_ty _ (HsExplicitListTy _ tys) = quote $ brackets (interpp'SP tys)
ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys) ppr_mono_ty _ (HsExplicitTupleTy _ tys) = quote $ parens (interpp'SP tys)
ppr_mono_ty _ (HsTyLit t) = ppr_tylit t ppr_mono_ty _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) = char '_' ppr_mono_ty _ (HsWildCardTy {}) = char '_'
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
= maybeParen ctxt_prec TyOpPrec $ = maybeParen ctxt_prec TyOpPrec $
......
...@@ -564,7 +564,7 @@ mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName ...@@ -564,7 +564,7 @@ mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty) mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName] mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig -- Convert TypeSig to ClassOpSig
......
...@@ -103,100 +103,95 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs ...@@ -103,100 +103,95 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures -- rn_hs_sig_wc_type is used for source-language type signatures
rn_hs_sig_wc_type no_implicit_if_forall ctxt rn_hs_sig_wc_type no_implicit_if_forall ctxt
(HsIB { hsib_body = wc_ty }) thing_inside (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
= do { let hs_ty = hswc_body wc_ty thing_inside
; free_vars <- extractFilteredRdrTyVars hs_ty = do { free_vars <- extractFilteredRdrTyVars hs_ty
; (free_vars', nwc_rdrs) <- partition_nwcs free_vars ; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
; rnImplicitBndrs no_implicit_if_forall free_vars' hs_ty $ \ vars -> ; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->
do { rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
thing_inside (HsIB { hsib_vars = vars ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_ty' }
, hsib_body = wc_ty' }) } } ib_ty' = HsIB { hsib_vars = vars, hsib_body = hs_ty' }
; (res, fvs2) <- thing_inside sig_ty'
; return (res, fvs1 `plusFV` fvs2) } }
rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
rnHsWcType ctxt wc_ty@(HsWC { hswc_body = hs_ty }) rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- extractFilteredRdrTyVars hs_ty = do { free_vars <- extractFilteredRdrTyVars hs_ty
; (_, nwc_rdrs) <- partition_nwcs free_vars ; (_, nwc_rdrs) <- partition_nwcs free_vars
; rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' -> ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
return (wc_ty', emptyFVs) } ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
-- | Renames a type with wild card binders.
-- Expects a list of names of type variables that should be replaced with rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName
-- named wild cards. (See Note [Renaming named wild cards]) -> RnM ([Name], LHsType Name, FreeVars)
-- Although the parser does not create named wild cards, it is possible to find rnWcBody ctxt nwc_rdrs hs_ty
-- them in declaration splices, so the function tries to collect them.
rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName
-> [Located RdrName] -- Named wildcards
-> (LHsWcType Name -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) nwc_rdrs thing_inside
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
; bindLocalNamesFV nwcs $ ; let env = RTKE { rtke_level = TypeLevel
do { let env = RTKE { rtke_level = TypeLevel
, rtke_what = RnTypeBody , rtke_what = RnTypeBody
, rtke_nwcs = mkNameSet nwcs , rtke_nwcs = mkNameSet nwcs
, rtke_ctxt = ctxt } , rtke_ctxt = ctxt }
; (wc_ty, fvs1) <- rnWcSigTy env hs_ty ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
; let wc_ty' :: HsWildCardBndrs Name (LHsType Name) rn_lty env hs_ty
wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty } ; let awcs = collectAnonWildCards hs_ty'
; (res, fvs2) <- thing_inside wc_ty' ; return (nwcs ++ awcs, hs_ty', fvs) }
; return (res, fvs1 `plusFV` fvs2) } } where
rn_lty env (L loc hs_ty)
= setSrcSpan loc $
do { (hs_ty', fvs) <- rn_ty env hs_ty
; return (L loc hs_ty', fvs) }
rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
-- A lot of faff just to allow the extra-constraints wildcard to appear
rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
= bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
Nothing [] tvs $ \ _ tvs' _ _ ->
do { (hs_body', fvs) <- rn_lty env hs_body
; return (HsForAllTy { hst_bndrs = tvs', hst_body = hs_body' }, fvs) }
rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
, L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
; wc' <- setSrcSpan lx $
do { checkExtraConstraintWildCard env wc
; rnAnonWildCard wc }
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
| otherwise
= do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
; return (HsQualTy { hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
, fvs1 `plusFV` fvs2) }
rn_ty env hs_ty = rnHsTyKi env hs_ty
rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
rnWcSigTy :: RnTyKiEnv -> LHsType RdrName
-> RnM (LHsWcType Name, FreeVars)
-- ^ Renames just the top level of a type signature
-- It's exactly like rnHsTyKi, except that it uses rnWcSigContext
-- on a qualified type, and return info on any extra-constraints
-- wildcard. Some code duplication, but no big deal.
rnWcSigTy env (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
= bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty)
Nothing [] tvs $ \ _ tvs' _ _ ->
do { (hs_tau', fvs) <- rnWcSigTy env hs_tau
; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
awcs_bndrs = collectAnonWildCardsBndrs tvs'
; return ( hs_tau' { hswc_wcs = hswc_wcs hs_tau' ++ awcs_bndrs
, hswc_body = L loc hs_ty' }, fvs) }
rnWcSigTy env (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
= do { (hs_ctxt', fvs1) <- rnWcSigContext env hs_ctxt
; (tau', fvs2) <- rnLHsTyKi env tau
; let awcs_tau = collectAnonWildCards tau'
hs_ty' = HsQualTy { hst_ctxt = hswc_body hs_ctxt'
, hst_body = tau' }
; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau
, hswc_ctx = hswc_ctx hs_ctxt'
, hswc_body = L loc hs_ty' }
, fvs1 `plusFV` fvs2) }
rnWcSigTy env hs_ty checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName
= do { (hs_ty', fvs) <- rnLHsTyKi env hs_ty -> RnM ()
; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty' -- Rename the extra-constraint spot in a type signature
, hswc_ctx = Nothing -- (blah, _) => type
, hswc_body = hs_ty' } -- Check that extra-constraints are allowed at all, and
, fvs) } -- if so that it's an anonymous wildcard
checkExtraConstraintWildCard env wc
rnWcSigContext :: RnTyKiEnv -> LHsContext RdrName = checkWildCard env mb_bad
-> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars)
rnWcSigContext env (L loc hs_ctxt)
| Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
, L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
= do { (hs_ctxt1', fvs) <- mapFvRn rn_top_constraint hs_ctxt1
; setSrcSpan lx $ checkExtraConstraintWildCard env wc
; wc' <- rnAnonWildCard wc
; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
awcs = concatMap collectAnonWildCards hs_ctxt1'
-- NB: *not* including the extra-constraint wildcard
; return ( HsWC { hswc_wcs = awcs
, hswc_ctx = Just lx
, hswc_body = L loc hs_ctxt' }
, fvs ) }
| otherwise
= do { (hs_ctxt', fvs) <- mapFvRn rn_top_constraint hs_ctxt
; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt'
, hswc_ctx = Nothing
, hswc_body = L loc hs_ctxt' }, fvs) }
where where
rn_top_constraint = rnLHsTyKi (env { rtke_what = RnTopConstraint }) mb_bad | not (extraConstraintWildCardsAllowed env)
= Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
<+> text "not allowed")
| otherwise
= Nothing
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
_ -> False
-- | Finds free type and kind variables in a type, -- | Finds free type and kind variables in a type,
-- without duplicates, and -- without duplicates, and
...@@ -736,27 +731,6 @@ checkNamedWildCard env name ...@@ -736,27 +731,6 @@ checkNamedWildCard env name
RnConstraint -> Just constraint_msg RnConstraint -> Just constraint_msg
constraint_msg = notAllowed (ppr name) <+> text "in a constraint" constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName
-> RnM ()
-- Rename the extra-constraint spot in a type signature
-- (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
checkExtraConstraintWildCard env wc
= checkWildCard env mb_bad
where
mb_bad | not (extraConstraintWildCardsAllowed env)
= Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
<+> text "not allowed")
| otherwise
= Nothing
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
= case rtke_ctxt env of
TypeSigCtx {} -> True
_ -> False
wildCardsAllowed :: RnTyKiEnv -> Bool wildCardsAllowed :: RnTyKiEnv -> Bool
-- ^ In what contexts are wildcards permitted -- ^ In what contexts are wildcards permitted
wildCardsAllowed env wildCardsAllowed env
...@@ -1052,7 +1026,9 @@ collectAnonWildCards lty = go lty ...@@ -1052,7 +1026,9 @@ collectAnonWildCards lty = go lty
HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
HsExplicitListTy _ tys -> gos tys HsExplicitListTy _ tys -> gos tys
HsExplicitTupleTy _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys
HsForAllTy { hst_body = ty } -> go ty HsForAllTy { hst_bndrs = bndrs
, hst_body = ty } -> collectAnonWildCardsBndrs bndrs
`mappend` go ty
HsQualTy { hst_ctxt = L _ ctxt HsQualTy { hst_ctxt = L _ ctxt
, hst_body = ty } -> gos ctxt `mappend` go ty , hst_body = ty } -> gos ctxt `mappend` go ty
-- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
......
This diff is collapsed.
...@@ -20,8 +20,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, ...@@ -20,8 +20,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
import HsSyn import HsSyn
import TcEnv import TcEnv
import TcPat( addInlinePrags, lookupPragEnv, emptyPragEnv ) import TcSigs
import TcEvidence( idHsWrapper ) import TcEvidence ( idHsWrapper )
import TcBinds import TcBinds
import TcUnify import TcUnify
import TcHsType import TcHsType
...@@ -152,10 +152,10 @@ tcClassSigs clas sigs def_methods ...@@ -152,10 +152,10 @@ tcClassSigs clas sigs def_methods
tcClassDecl2 :: LTyClDecl Name -- The class declaration tcClassDecl2 :: LTyClDecl Name -- The class declaration
-> TcM (LHsBinds Id) -> TcM (LHsBinds Id)
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds})) tcdMeths = default_binds}))
= recoverM (return emptyLHsBinds) $ = recoverM (return emptyLHsBinds) $
setSrcSpan loc $ setSrcSpan (getLoc class_name) $
do { clas <- tcLookupLocatedClass class_name do { clas <- tcLookupLocatedClass class_name
-- We make a separate binding for each default method. -- We make a separate binding for each default method.
...@@ -203,7 +203,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ...@@ -203,7 +203,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
= do { -- First look up the default method -- It should be there! = do { -- First look up the default method -- It should be there!
global_dm_id <- tcLookupId dm_name global_dm_id <- tcLookupId dm_name
; global_dm_id <- addInlinePrags global_dm_id prags ; global_dm_id <- addInlinePrags global_dm_id prags
; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name) ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
-- Base the local_dm_name on the selector name, because -- Base the local_dm_name on the selector name, because
-- type errors from tcInstanceMethodBody come from here -- type errors from tcInstanceMethodBody come from here
...@@ -241,26 +241,27 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn ...@@ -241,26 +241,27 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
ctxt = FunSigCtxt sel_name warn_redundant ctxt = FunSigCtxt sel_name warn_redundant
; local_dm_sig <- instTcTySig ctxt hs_ty local_dm_ty local_dm_name ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
; (ev_binds, (tc_bind, _)) local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
, sig_loc = getLoc (hsSigType hs_ty) }
; (ev_binds, (tc_bind, _))
<- checkConstraints (ClsSkol clas) tyvars [this_dict] $ <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
tcPolyCheck NonRecursive no_prag_fn local_dm_sig tcPolyCheck no_prag_fn local_dm_sig
(L bind_loc lm_bind) (L bind_loc lm_bind)
; let export = ABE { abe_poly = global_dm_id ; let export = ABE { abe_poly = global_dm_id
-- We have created a complete type signature in , abe_mono = local_dm_id
-- instTcTySig, hence it is safe to call , abe_wrap = idHsWrapper
-- completeSigPolyId , abe_prags = IsDefaultMethod }
, abe_mono = completeIdSigPolyId local_dm_sig full_bind = AbsBinds { abs_tvs = tyvars
, abe_wrap = idHsWrapper , abs_ev_vars = [this_dict]
, abe_prags = IsDefaultMethod } , abs_exports = [export]
full_bind = AbsBinds { abs_tvs = tyvars , abs_ev_binds = [ev_binds]
, abs_ev_vars = [this_dict] , abs_binds = tc_bind }