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
-- here 'k' scopes too
get_scoped_tvs (L _ (TypeSig _ sig))
| HsIB { hsib_vars = implicit_vars
, hsib_body = sig1 } <- sig
, (explicit_vars, _) <- splitLHsForAllTy (hswc_body sig1)
, hsib_body = hs_ty } <- hswc_body sig
, (explicit_vars, _) <- splitLHsForAllTy hs_ty
= implicit_vars ++ map hsLTyVarName explicit_vars
get_scoped_tvs _ = []
......@@ -567,7 +567,7 @@ repRuleD (L loc (HsRule n act bndrs lhs _ rhs _))
ruleBndrNames :: LRuleBndr Name -> [Name]
ruleBndrNames (L _ (RuleBndr n)) = [unLoc n]
ruleBndrNames (L _ (RuleBndrSig n sig))
| HsIB { hsib_vars = vars } <- sig
| HsWC { hswc_body = HsIB { hsib_vars = vars }} <- sig
= unLoc n : vars
repRuleBndr :: LRuleBndr Name -> DsM (Core TH.RuleBndrQ)
......@@ -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
-- See Note [Scoped type variables in bindings]
rep_wc_ty_sig mk_sig loc sig_ty nm
| HsIB { hsib_vars = implicit_tvs, hsib_body = sig1 } <- sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy (hswc_body sig1)
| HsIB { hsib_vars = implicit_tvs, hsib_body = hs_ty } <- hswc_body sig_ty
, (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty
= do { nm1 <- lookupLOcc nm
; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name }
......@@ -917,8 +917,8 @@ repHsPatSynSigType (HsIB { hsib_vars = implicit_tvs
(univs, reqs, exis, provs, ty) = splitLHsPatSynTy body
repHsSigWcType :: LHsSigWcType Name -> DsM (Core TH.TypeQ)
repHsSigWcType ib_ty@(HsIB { hsib_body = sig1 })
= repHsSigType (ib_ty { hsib_body = hswc_body sig1 })
repHsSigWcType (HsWC { hswc_body = sig1 })
= repHsSigType sig1
-- yield the representation of a list of types
repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ]
......
......@@ -15,7 +15,6 @@ module DsMonad (
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
Applicative(..),(<$>),
newLocalName,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs, newPredVarDs,
getSrcSpanDs, putSrcSpanDs,
......
......@@ -399,6 +399,7 @@ Library
TcAnnotations
TcArrows
TcBinds
TcSigs
TcClassDcl
TcDefaults
TcDeriv
......
......@@ -288,16 +288,12 @@ data HsWildCardBndrs name thing
-- See Note [The wildcard story for types]
= HsWC { hswc_wcs :: PostRn name [Name]
-- Wild cards, both named and anonymous
-- after the renamer
, hswc_ctx :: Maybe SrcSpan
-- Indicates whether hswc_body has an
-- extra-constraint wildcard, and if so where
-- e.g. (Eq a, _) => a -> a
-- 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)
, hswc_body :: thing
-- Main payload (type or list of types)
-- If there is an extra-constraints wildcard,
-- it's still there in the hsc_body.
}
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 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]
......@@ -319,11 +315,11 @@ hsSigType :: LHsSigType name -> LHsType name
hsSigType = hsImplicitBody
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
-- 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -351,8 +347,7 @@ mkHsImplicitBndrs x = HsIB { hsib_body = x
mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing
mkHsWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = PlaceHolder
, hswc_ctx = Nothing }
, hswc_wcs = PlaceHolder }
-- Add empty binders. This is a bit suspicious; what if
-- the wrapped thing had free type variables?
......@@ -362,8 +357,7 @@ mkEmptyImplicitBndrs x = HsIB { hsib_body = x
mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing
mkEmptyWildCardBndrs x = HsWC { hswc_body = x
, hswc_wcs = []
, hswc_ctx = Nothing }
, hswc_wcs = [] }
--------------------------------------------------
......@@ -789,8 +783,8 @@ hsWcScopedTvs :: LHsSigWcType Name -> [Name]
-- - the named wildcars; see Note [Scoping of named wildcards]
-- because they scope in the same way
hsWcScopedTvs sig_ty
| HsIB { hsib_vars = vars, hsib_body = sig_ty1 } <- sig_ty
, HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1
| HsWC { hswc_wcs = nwcs, hswc_body = sig_ty1 } <- sig_ty
, HsIB { hsib_vars = vars, hsib_body = sig_ty2 } <- sig_ty1
= case sig_ty2 of
L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++
map hsLTyVarName tvs
......@@ -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 _ (HsSpliceTy s _) = pprSplice s
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 _ (HsTyLit t) = ppr_tylit t
ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) = char '_'
ppr_mono_ty _ (HsWildCardTy {}) = char '_'
ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2)
= maybeParen ctxt_prec TyOpPrec $
......
......@@ -564,7 +564,7 @@ mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
-- Convert TypeSig to ClassOpSig
......
......@@ -103,100 +103,95 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs
-> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
rn_hs_sig_wc_type no_implicit_if_forall ctxt
(HsIB { hsib_body = wc_ty }) thing_inside
= do { let hs_ty = hswc_body wc_ty
; free_vars <- extractFilteredRdrTyVars hs_ty
; (free_vars', nwc_rdrs) <- partition_nwcs free_vars
; rnImplicitBndrs no_implicit_if_forall free_vars' hs_ty $ \ vars ->
do { rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
thing_inside (HsIB { hsib_vars = vars
, hsib_body = wc_ty' }) } }
(HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
thing_inside
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (tv_rdrs, nwc_rdrs) <- partition_nwcs free_vars
; rnImplicitBndrs no_implicit_if_forall tv_rdrs hs_ty $ \ vars ->
do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = ib_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 ctxt wc_ty@(HsWC { hswc_body = hs_ty })
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
= do { free_vars <- extractFilteredRdrTyVars hs_ty
; (_, nwc_rdrs) <- partition_nwcs free_vars
; rn_hs_wc_type ctxt wc_ty nwc_rdrs $ \ wc_ty' ->
return (wc_ty', emptyFVs) }
-- | Renames a type with wild card binders.
-- Expects a list of names of type variables that should be replaced with
-- named wild cards. (See Note [Renaming named wild cards])
-- Although the parser does not create named wild cards, it is possible to find
-- 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
; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' }
; return (sig_ty', fvs) }
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName
-> RnM ([Name], LHsType Name, FreeVars)
rnWcBody ctxt nwc_rdrs hs_ty
= do { nwcs <- mapM newLocalBndrRn nwc_rdrs
; bindLocalNamesFV nwcs $
do { let env = RTKE { rtke_level = TypeLevel
; let env = RTKE { rtke_level = TypeLevel
, rtke_what = RnTypeBody
, rtke_nwcs = mkNameSet nwcs
, rtke_ctxt = ctxt }
; (wc_ty, fvs1) <- rnWcSigTy env hs_ty
; let wc_ty' :: HsWildCardBndrs Name (LHsType Name)
wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty }
; (res, fvs2) <- thing_inside wc_ty'
; return (res, fvs1 `plusFV` fvs2) } }
; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
rn_lty env hs_ty
; let awcs = collectAnonWildCards hs_ty'
; return (nwcs ++ awcs, hs_ty', fvs) }
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
= do { (hs_ty', fvs) <- rnLHsTyKi env hs_ty
; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty'
, hswc_ctx = Nothing
, hswc_body = hs_ty' }
, fvs) }
rnWcSigContext :: RnTyKiEnv -> LHsContext RdrName
-> 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) }
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
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,
-- without duplicates, and
......@@ -736,27 +731,6 @@ checkNamedWildCard env name
RnConstraint -> Just constraint_msg
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
-- ^ In what contexts are wildcards permitted
wildCardsAllowed env
......@@ -1052,7 +1026,9 @@ collectAnonWildCards lty = go lty
HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
HsExplicitListTy _ 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
, hst_body = ty } -> gos ctxt `mappend` go ty
-- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
......
......@@ -10,21 +10,18 @@
module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
tcValBinds, tcHsBootSigs, tcPolyCheck,
tcSpecPrags, tcSpecWrapper,
tcVectDecls, addTypecheckedBinds,
TcSigInfo(..), TcSigFun,
TcPragEnv, mkPragEnv,
tcUserTypeSig, instTcTySig, chooseInferredQuantifiers,
instTcTySigFromId, tcExtendTyVarEnvFromSig,
badBootDeclErr) where
chooseInferredQuantifiers,
badBootDeclErr ) where
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
, tcPatSynBuilderBind, tcPatSynSig )
, tcPatSynBuilderBind )
import DynFlags
import HsSyn
import HscTypes( isHsBootOrSig )
import TcSigs
import TcRnMonad
import TcEnv
import TcUnify
......@@ -33,12 +30,13 @@ import TcEvidence
import TcHsType
import TcPat
import TcMType
import Inst( topInstantiate, deeplyInstantiate )
import Inst( deeplyInstantiate )
import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
import TyCon
import TcType
import TysPrim
import TysWiredIn( cTupleTyConName )
import Id
import Var
import VarSet
......@@ -57,7 +55,7 @@ import Util
import BasicTypes
import Outputable
import Type(mkStrLitTy, tidyOpenType)
import PrelNames( mkUnboundName, gHC_PRIM, ipClassName )
import PrelNames( gHC_PRIM, ipClassName )
import TcValidity (checkValidType)
import UniqFM
import qualified GHC.LanguageExtensions as LangExt
......@@ -360,7 +358,7 @@ tcValBinds top_lvl binds sigs thing_inside
{ (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do
{ thing <- thing_inside
-- See Note [Pattern synonym builders don't yield dependencies]
; patsyn_builders <- mapM (tcPatSynBuilderBind sig_fn) patsyns
; patsyn_builders <- mapM tcPatSynBuilderBind patsyns
; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
......@@ -550,7 +548,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
; result@(tc_binds, poly_ids) <- case plan of
NoGen -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list
InferGen mn -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list
CheckGen lbind sig -> tcPolyCheck rec_tc prag_fn sig lbind
CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind
-- Check whether strict bindings are ok
-- These must be non-recursive etc, and are not generalised
......@@ -568,7 +566,32 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc closed bind_list
-- may no longer be adjacent; so find the narrowest
-- span that includes them all
------------------
--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
-- subsequent error messages
recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds TcId, [Id])
recoveryCode binder_names sig_fn
= do { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
; let poly_ids = map mk_dummy binder_names
; return (emptyBag, poly_ids) }
where
mk_dummy name
| Just sig <- sig_fn name
, Just poly_id <- completeSigPolyId_maybe sig
= poly_id
| otherwise
= mkLocalId name forall_a_a
forall_a_a :: TcType
forall_a_a = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] openAlphaTy
{- *********************************************************************
* *
tcPolyNoGen
* *
********************************************************************* -}
tcPolyNoGen -- No generalisation whatsoever
:: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
......@@ -594,57 +617,87 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
-- Indeed that is why we call it here!
-- So we can safely ignore _specs
------------------
tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> TcPragEnv
-> TcIdSigInfo
-> LHsBind Name
{- *********************************************************************
* *
tcPolyCheck
* *
********************************************************************* -}
tcPolyCheck :: TcPragEnv
-> TcIdSigInfo -- Must be a complete signature
-> LHsBind Name -- Must be a FunBind
-> TcM (LHsBinds TcId, [TcId])
-- There is just one binding,
-- it binds a single variable,
-- it is a Funbind
-- it has a complete type signature,
tcPolyCheck rec_tc prag_fn
sig@(TISI { sig_bndr = CompleteSig poly_id
, sig_skols = skol_prs
, sig_theta = theta
, sig_tau = tau
, sig_ctxt = ctxt
, sig_loc = loc })
bind
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol ctxt (mkPhiTy theta tau)
prag_sigs = lookupPragEnv prag_fn name
skol_tvs = map snd skol_prs
-- Find the location of the original source type sig, if
-- there is was one. This will appear in messages like
-- "type variable x is bound by .. at <loc>"
name = idName poly_id
; (ev_binds, (binds', _))
<- setSrcSpan loc $
checkConstraints skol_info skol_tvs ev_vars $
tcMonoBinds rec_tc (\_ -> Just (TcIdSig sig)) LetLclBndr [bind]
tcPolyCheck prag_fn
(CompleteSig { sig_bndr = poly_id
, sig_ctxt = ctxt
, sig_loc = sig_loc })
(L loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
= setSrcSpan sig_loc $
do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
; (tv_prs, theta, tau) <- tcInstType (tcInstSigTyVars sig_loc) poly_id
-- See Note [Instantiate sig with fresh variables]
; mono_name <- newNameAt (nameOccName name) nm_loc
; ev_vars <- newEvVars theta
; let mono_id = mkLocalId mono_name tau
skol_info = SigSkol ctxt (mkPhiTy theta tau)
skol_tvs = map snd tv_prs
; (ev_binds, (co_fn, matches'))
<- checkConstraints skol_info skol_tvs ev_vars $
tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
tcExtendTyVarEnv2 tv_prs $
setSrcSpan loc $
tcMatchesFun (L nm_loc mono_name) matches (mkCheckExpType tau)
; let prag_sigs = lookupPragEnv prag_fn name
; spec_prags <- tcSpecPrags poly_id prag_sigs
; poly_id <- addInlinePrags poly_id prag_sigs
; let bind' = case bagToList binds' of
[b] -> b
_ -> pprPanic "tcPolyCheck" (ppr binds')
; let bind' = FunBind { fun_id = L nm_loc mono_id
, fun_matches = matches'
, fun_co_fn = co_fn