summaryrefslogtreecommitdiff
path: root/compiler/GHC/Rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Rename')
-rw-r--r--compiler/GHC/Rename/Bind.hs15
-rw-r--r--compiler/GHC/Rename/Expr.hs2
-rw-r--r--compiler/GHC/Rename/HsType.hs88
-rw-r--r--compiler/GHC/Rename/Module.hs39
-rw-r--r--compiler/GHC/Rename/Pat.hs2
5 files changed, 93 insertions, 53 deletions
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index a2566220b6..bb4a3c1b76 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -955,7 +955,7 @@ renameSig _ (IdSig _ x)
renameSig ctxt sig@(TypeSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
; let doc = TypeSigCtx (ppr_sig_bndrs vs)
- ; (new_ty, fvs) <- rnHsSigWcType doc ty
+ ; (new_ty, fvs) <- rnHsSigWcType doc Nothing ty
; return (TypeSig noExtField new_vs new_ty, fvs) }
renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
@@ -963,16 +963,21 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
- ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
+ ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel inf_msg ty
; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
ty_ctxt = GenericCtx (text "a class method signature for"
<+> quotes (ppr v1))
+ inf_msg = if is_deflt
+ then Just (text "A default type signature cannot contain inferred type variables")
+ else Nothing
renameSig _ (SpecInstSig _ src ty)
- = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty
+ = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel inf_msg ty
; return (SpecInstSig noExtField src new_ty,fvs) }
+ where
+ inf_msg = Just (text "Inferred type variables are not allowed")
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
@@ -988,7 +993,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
<+> quotes (ppr v))
do_one (tys,fvs) ty
- = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
+ = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel Nothing ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig ctxt sig@(InlineSig _ v s)
@@ -1005,7 +1010,7 @@ renameSig ctxt sig@(MinimalSig _ s (L l bf))
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
- ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
+ ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel Nothing ty
; return (PatSynSig noExtField new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 5ac352b0d0..db05756067 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -316,7 +316,7 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
, fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig _ expr pty)
- = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty
+ = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx Nothing pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
rnLExpr expr
; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index f3727221a0..1b3b601e23 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -36,6 +36,7 @@ import GHC.Prelude
import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )
+import GHC.Core.Type
import GHC.Driver.Session
import GHC.Hs
import GHC.Rename.Doc ( rnLHsDoc, rnMbLHsDoc )
@@ -64,7 +65,7 @@ import GHC.Data.FastString
import GHC.Data.Maybe
import qualified GHC.LanguageExtensions as LangExt
-import Data.List ( nubBy, partition, (\\) )
+import Data.List ( nubBy, partition, (\\), find )
import Control.Monad ( unless, when )
#include "HsVersions.h"
@@ -119,16 +120,21 @@ data HsSigWcTypeScoping
-- See also @Note [Pattern signature binders and scoping]@ in
-- "GHC.Hs.Types".
-rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
+rnHsSigWcType :: HsDocContext
+ -> Maybe SDoc
+ -- ^ The error msg if the signature is not allowed to contain
+ -- manually written inferred variables.
+ -> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
-rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
- = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body ->
+rnHsSigWcType doc inf_err (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
+ = rn_hs_sig_wc_type BindUnlessForall doc inf_err hs_ty $ \nwcs imp_tvs body ->
let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body }
wc_ty = HsWC { hswc_ext = nwcs, hswc_body = ib_ty } in
pure (wc_ty, emptyFVs)
rnHsPatSigType :: HsSigWcTypeScoping
- -> HsDocContext -> HsPatSigType GhcPs
+ -> HsDocContext -> Maybe SDoc
+ -> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- Used for
@@ -138,10 +144,10 @@ rnHsPatSigType :: HsSigWcTypeScoping
-- Wildcards are allowed
--
-- See Note [Pattern signature binders and scoping] in GHC.Hs.Types
-rnHsPatSigType scoping ctx sig_ty thing_inside
+rnHsPatSigType scoping ctx inf_err sig_ty thing_inside
= do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)
- ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $
+ ; rn_hs_sig_wc_type scoping ctx inf_err (hsPatSigType sig_ty) $
\nwcs imp_tvs body ->
do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }
sig_ty' = HsPS { hsps_ext = sig_names, hsps_body = body }
@@ -149,14 +155,16 @@ rnHsPatSigType scoping ctx sig_ty thing_inside
} }
-- The workhorse for rnHsSigWcType and rnHsPatSigType.
-rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsType GhcPs
+rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> Maybe SDoc
+ -> LHsType GhcPs
-> ([Name] -- Wildcard names
-> [Name] -- Implicitly bound type variable names
-> LHsType GhcRn
-> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside
- = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
+rn_hs_sig_wc_type scoping ctxt inf_err hs_ty thing_inside
+ = do { check_inferred_vars ctxt inf_err hs_ty
+ ; free_vars <- extractFilteredRdrTyVarsDups hs_ty
; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars
; let nwc_rdrs = nubL nwc_rdrs'
implicit_bndrs = case scoping of
@@ -323,13 +331,17 @@ of the HsWildCardBndrs structure, and we are done.
rnHsSigType :: HsDocContext
-> TypeOrKind
+ -> Maybe SDoc
+ -- ^ The error msg if the signature is not allowed to contain
+ -- manually written inferred variables.
-> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
-rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
+rnHsSigType ctx level inf_err (HsIB { hsib_body = hs_ty })
= do { traceRn "rnHsSigType" (ppr hs_ty)
; vars <- extractFilteredRdrTyVarsDups hs_ty
+ ; check_inferred_vars ctx inf_err hs_ty
; rnImplicitBndrs (forAllOrNothing (isLHsForAllTy hs_ty) vars) $ \ vars ->
do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty
@@ -383,6 +395,25 @@ rnImplicitBndrs implicit_vs_with_dups
; bindLocalNamesFV vars $
thing_inside vars }
+check_inferred_vars :: HsDocContext
+ -> Maybe SDoc
+ -- ^ The error msg if the signature is not allowed to contain
+ -- manually written inferred variables.
+ -> LHsType GhcPs
+ -> RnM ()
+check_inferred_vars _ Nothing _ = return ()
+check_inferred_vars ctxt (Just msg) ty =
+ let bndrs = forallty_bndrs ty
+ in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of
+ Nothing -> return ()
+ Just _ -> addErr $ withHsDocContext ctxt msg
+ where
+ forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]
+ forallty_bndrs (L _ ty) = case ty of
+ HsParTy _ ty' -> forallty_bndrs ty'
+ HsForAllTy { hst_bndrs = tvs } -> map unLoc tvs
+ _ -> []
+
{- ******************************************************
* *
LHsType and HsType
@@ -982,12 +1013,13 @@ So tvs is {k,a} and kvs is {k}.
NB: we do this only at the binding site of 'tvs'.
-}
-bindLHsTyVarBndrs :: HsDocContext
+bindLHsTyVarBndrs :: (OutputableBndrFlag flag)
+ => HsDocContext
-> Maybe SDoc -- Just d => check for unused tvs
-- d is a phrase like "in the type ..."
-> Maybe a -- Just _ => an associated type decl
- -> [LHsTyVarBndr GhcPs] -- User-written tyvars
- -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
+ -> [LHsTyVarBndr flag GhcPs] -- User-written tyvars
+ -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
= do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
@@ -1009,24 +1041,24 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
bindLHsTyVarBndr :: HsDocContext
-> Maybe a -- associated class
- -> LHsTyVarBndr GhcPs
- -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
+ -> LHsTyVarBndr flag GhcPs
+ -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr _doc mb_assoc (L loc
- (UserTyVar x
+ (UserTyVar x fl
lrdr@(L lv _))) thing_inside
= do { nm <- newTyVarNameRn mb_assoc lrdr
; bindLocalNamesFV [nm] $
- thing_inside (L loc (UserTyVar x (L lv nm))) }
+ thing_inside (L loc (UserTyVar x fl (L lv nm))) }
-bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
+bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x fl lrdr@(L lv _) kind))
thing_inside
= do { sig_ok <- xoptM LangExt.KindSignatures
; unless sig_ok (badKindSigErr doc kind)
; (kind', fvs1) <- rnLHsKind doc kind
; tv_nm <- newTyVarNameRn mb_assoc lrdr
; (b, fvs2) <- bindLocalNamesFV [tv_nm]
- $ thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
+ $ thing_inside (L loc (KindedTyVar x fl (L lv tv_nm) kind'))
; return (b, fvs1 `plusFV` fvs2) }
newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
@@ -1448,7 +1480,7 @@ dataKindsErr env thing
inTypeDoc :: HsType GhcPs -> SDoc
inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
-warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
+warnUnusedForAll :: (OutputableBndrFlag flag) => SDoc -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll in_doc (L loc tv) used_names
= whenWOptM Opt_WarnUnusedForalls $
unless (hsTyVarName tv `elemNameSet` used_names) $
@@ -1693,7 +1725,7 @@ extractHsTysRdrTyVarsDups tys
-- However duplicates are removed
-- E.g. given [k1, a:k1, b:k2]
-- the function returns [k1,k2], even though k1 is bound here
-extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups
+extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsNoDups
extractHsTyVarBndrsKVs tv_bndrs
= nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
@@ -1702,8 +1734,8 @@ extractHsTyVarBndrsKVs tv_bndrs
-- See Note [Ordering of implicit variables].
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
extractRdrKindSigVars (L _ resultSig) = case resultSig of
- KindSig _ k -> extractHsTyRdrTyVars k
- TyVarSig _ (L _ (KindedTyVar _ _ k)) -> extractHsTyRdrTyVars k
+ KindSig _ k -> extractHsTyRdrTyVars k
+ TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k
_ -> []
-- | Get type/kind variables mentioned in the kind signature, preserving
@@ -1766,13 +1798,13 @@ extract_lty (L _ ty) acc
-- We deal with these separately in rnLHsTypeWithWildCards
HsWildCardTy {} -> acc
-extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
+extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVarsWithDups -- Free in body
-> FreeKiTyVarsWithDups -- Free in result
extractHsTvBndrs tv_bndrs body_fvs
= extract_hs_tv_bndrs tv_bndrs [] body_fvs
-extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
+extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVarsWithDups -- Accumulator
-> FreeKiTyVarsWithDups -- Free in body
-> FreeKiTyVarsWithDups
@@ -1789,7 +1821,7 @@ extract_hs_tv_bndrs tv_bndrs acc_vars body_vars
bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
-extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsWithDups
+extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVarsWithDups
-- Returns the free kind variables of any explicitly-kinded binders, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
@@ -1799,7 +1831,7 @@ extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsWithDups
-- the function returns [k1,k2], even though k1 is bound here
extract_hs_tv_bndrs_kvs tv_bndrs =
foldr extract_lty []
- [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
+ [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs]
extract_tv :: Located RdrName
-> [Located RdrName] -> [Located RdrName]
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index f7a677504f..c7c648bd87 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -370,7 +370,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty
-- Mark any PackageTarget style imports as coming from the current package
; let unitId = thisPackage $ hsc_dflags topEnv
@@ -382,7 +382,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
= do { name' <- lookupLocatedOccRn name
- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel Nothing ty
; return (ForeignExport { fd_e_ext = noExtField
, fd_name = name', fd_sig_ty = ty'
, fd_fe = spec }
@@ -602,7 +602,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
= do { (inst_ty', inst_fvs)
- <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty
+ <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inf_err inst_ty
; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
; cls <-
case hsTyGetAppHead_maybe head_ty' of
@@ -659,6 +659,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- the instance context after renaming. This is a bit
-- strange, but should not matter (and it would be more work
-- to remove the context).
+ where
+ inf_err = Just (text "Inferred type variables are not allowed")
rnFamInstEqn :: HsDocContext
-> AssocTyFamInfo
@@ -957,10 +959,11 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap)
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; (mds', ty', fvs)
<- rnLDerivStrategy DerivDeclCtx mds $
- rnHsSigWcType DerivDeclCtx ty
+ rnHsSigWcType DerivDeclCtx inf_err ty
; warnNoDerivStrat mds' loc
; return (DerivDecl noExtField ty' mds' overlap, fvs) }
where
+ inf_err = Just (text "Inferred type variables are not allowed")
loc = getLoc $ hsib_body $ hswc_body ty
standaloneDerivErr :: SDoc
@@ -1028,7 +1031,7 @@ bindRuleTmVars doc tyvs vars names thing_inside
go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)
(n : ns) thing_inside
- = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->
+ = rnHsPatSigType bind_free_tvs doc Nothing bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars')
@@ -1038,8 +1041,8 @@ bindRuleTmVars doc tyvs vars names thing_inside
bind_free_tvs = case tyvs of Nothing -> AlwaysBind
Just _ -> NeverBind
-bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]
- -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
+bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr () GhcPs]
+ -> (Maybe [LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindRuleTyVars doc in_doc (Just bndrs) thing_inside
= bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)
@@ -1368,7 +1371,7 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr
; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v
; let doc = StandaloneKindSigCtx (ppr v)
- ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki
+ ; (new_ki, fvs) <- rnHsSigType doc KindLevel Nothing ki
; return (StandaloneKindSig noExtField new_v new_ki, fvs)
}
where
@@ -1767,12 +1770,14 @@ rnLHsDerivingClause doc
, deriv_clause_strategy = dcs
, deriv_clause_tys = L loc' dct }))
= do { (dcs', dct', fvs)
- <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct
+ <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel inf_err) dct
; warnNoDerivStrat dcs' loc
; pure ( L loc (HsDerivingClause { deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs'
, deriv_clause_tys = L loc' dct' })
, fvs ) }
+ where
+ inf_err = Just (text "Inferred type variables are not allowed")
rnLDerivStrategy :: forall a.
HsDocContext
@@ -1805,7 +1810,7 @@ rnLDerivStrategy doc mds thing_inside
AnyclassStrategy -> boring_case AnyclassStrategy
NewtypeStrategy -> boring_case NewtypeStrategy
ViaStrategy via_ty ->
- do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
+ do (via_ty', fvs1) <- rnHsSigType doc TypeLevel inf_err via_ty
let HsIB { hsib_ext = via_imp_tvs
, hsib_body = via_body } = via_ty'
(via_exp_tv_bndrs, _, _) = splitLHsSigmaTyInvis via_body
@@ -1814,6 +1819,8 @@ rnLDerivStrategy doc mds thing_inside
(thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside
pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)
+ inf_err = Just (text "Inferred type variables are not allowed")
+
boring_case :: ds -> RnM (ds, a, FreeVars)
boring_case ds = do
(thing, fvs) <- thing_inside
@@ -2072,7 +2079,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
rnConDecl decl@(ConDeclGADT { con_names = names
, con_forall = L _ explicit_forall
- , con_qvars = qtvs
+ , con_qvars = explicit_tkvs
, con_mb_cxt = mcxt
, con_args = args
, con_res_ty = res_ty
@@ -2081,8 +2088,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names
; new_names <- mapM lookupLocatedTopBndrRn names
; mb_doc' <- rnMbLHsDoc mb_doc
- ; let explicit_tkvs = hsQTvExplicit qtvs
- theta = hsConDeclTheta mcxt
+ ; let theta = hsConDeclTheta mcxt
arg_tys = hsConDeclArgTys args
-- We must ensure that we extract the free tkvs in left-to-right
@@ -2113,12 +2119,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names
-- See Note [GADT abstract syntax] in GHC.Hs.Decls
(PrefixCon arg_tys, final_res_ty)
- new_qtvs = HsQTvs { hsq_ext = implicit_tkvs
- , hsq_explicit = explicit_tkvs }
-
; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
- ; return (decl { con_g_ext = noExtField, con_names = new_names
- , con_qvars = new_qtvs, con_mb_cxt = new_cxt
+ ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names
+ , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt
, con_args = args', con_res_ty = res_ty'
, con_doc = mb_doc' },
all_fvs) } }
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 09e2ea8cbe..06619cd142 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -412,7 +412,7 @@ rnPatAndThen mk (SigPat x pat sig)
; return (SigPat x pat' sig' ) }
where
rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)
- rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig)
+ rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx Nothing sig)
rnPatAndThen mk (LitPat x lit)
| HsString src s <- lit
View Lorry Controller Status