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

Add a pattern-syn form of PromotionErr

The main change is to add PatSynPE to PromotionErr, so that
when we get an ill-staged use of a pattern synonym we get a
civilised error message.

We were already doing this in half-baked form in tcValBinds, but
this patch tidies up the impl (which previously used a hack rather
than APromotionErr), and does it in tcTyClsInstDecls too.
parent 19632501
......@@ -42,7 +42,6 @@ import DynFlags
import Data.Data hiding ( Fixity )
import Data.List hiding ( foldr )
import qualified Data.List as L (foldr)
import Data.Ord
import Data.Foldable ( Foldable(..) )
#if __GLASGOW_HASKELL__ < 709
......@@ -484,20 +483,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds"
getTypeSigNames :: HsValBinds a -> NameSet
-- Get the names that have a user type sig
getTypeSigNames (ValBindsOut _ sigs)
= L.foldr get_type_sig emptyNameSet sigs
where
get_type_sig :: LSig Name -> NameSet -> NameSet
get_type_sig sig ns =
case sig of
L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
_ -> ns
getTypeSigNames _
= panic "HsBinds.getTypeSigNames"
{-
What AbsBinds means
......
......@@ -32,7 +32,6 @@ import TcEvidence
import TcHsType
import TcPat
import TcMType
import ConLike
import Inst( deeplyInstantiate )
import FamInstEnv( normaliseType )
import FamInst( tcGetFamInstEnvs )
......@@ -174,10 +173,10 @@ Then we get
fm
-}
tcTopBinds :: HsValBinds Name -> TcM (TcGblEnv, TcLclEnv)
tcTopBinds :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM (TcGblEnv, TcLclEnv)
-- The TcGblEnv contains the new tcg_binds and tcg_spects
-- The TcLclEnv has an extended type envt for the new bindings
tcTopBinds (ValBindsOut binds sigs)
tcTopBinds binds sigs
= do { -- Pattern synonym bindings populate the global environment
(binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $
do { gbl <- getGblEnv
......@@ -192,8 +191,6 @@ tcTopBinds (ValBindsOut binds sigs)
-- The top level bindings are flattened into a giant
-- implicitly-mutually-recursive LHsBinds
tcTopBinds (ValBindsIn {}) = panic "tcTopBinds"
tcRecSelBinds :: HsValBinds Name -> TcM TcGblEnv
tcRecSelBinds (ValBindsOut binds sigs)
= tcExtendGlobalValEnv [sel_id | L _ (IdSig sel_id) <- sigs] $
......@@ -203,10 +200,10 @@ tcRecSelBinds (ValBindsOut binds sigs)
; return tcg_env' }
tcRecSelBinds (ValBindsIn {}) = panic "tcRecSelBinds"
tcHsBootSigs :: HsValBinds Name -> TcM [Id]
tcHsBootSigs :: [(RecFlag, LHsBinds Name)] -> [LSig Name] -> TcM [Id]
-- A hs-boot file has only one BindGroup, and it only has type
-- signatures in it. The renamer checked all this
tcHsBootSigs (ValBindsOut binds sigs)
tcHsBootSigs binds sigs
= do { checkTc (null binds) badBootDeclErr
; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }
where
......@@ -218,7 +215,6 @@ tcHsBootSigs (ValBindsOut binds sigs)
; return (mkVanillaGlobal name sigma_ty) }
-- Notice that we make GlobalIds, not LocalIds
tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)
tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
badBootDeclErr :: MsgDoc
badBootDeclErr = ptext (sLit "Illegal declarations in an hs-boot file")
......@@ -267,9 +263,8 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
toDict ipClass x ty = HsWrap $ mkWpCastR $
wrapIP $ mkClassPred ipClass [x,ty]
{-
Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
{- Note [Implicit parameter untouchables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We add the type variables in the types of the implicit parameters
as untouchables, not so much because we really must not unify them,
but rather because we otherwise end up with constraints like this
......@@ -282,29 +277,6 @@ time by defaulting. No no no.
However [Oct 10] this is all handled automatically by the
untouchable-range idea.
Note [Placeholder PatSyn kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #9161)
{-# LANGUAGE PatternSynonyms, DataKinds #-}
pattern A = ()
b :: A
b = undefined
Here, the type signature for b mentions A. But A is a pattern
synonym, which is typechecked (for very good reasons; a view pattern
in the RHS may mention a value binding) as part of a group of
bindings. It is entirely reasonable to reject this, but to do so
we need A to be in the kind environment when kind-checking the signature for B.
Hence the tcExtendKindEnv2 patsyn_placeholder_kinds, which adds a binding
A -> AGlobal (AConLike (PatSynCon _|_))
to the environment. Then TcHsType.tcTyVar will find A in the kind environment,
and will give a 'wrongThingErr' as a result. But the lookup of A won't fail.
The _|_ (= panic "fakePatSynCon") works because the wrongThingErr call, in
tcTyVar, doesn't look inside the TcTyThing.
Note [Inlining and hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this example (Trac #10083):
......@@ -359,9 +331,10 @@ tcValBinds :: TopLevelFlag
-> TcM ([(RecFlag, LHsBinds TcId)], thing)
tcValBinds top_lvl binds sigs thing_inside
= do { -- Typecheck the signature
; (poly_ids, sig_fn) <- tcExtendKindEnv2 patsyn_placeholder_kinds $
-- See Note [Placeholder PatSyn kinds]
= do { let patsyns = getPatSynBinds binds
-- Typecheck the signature
; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $
tcTySigs sigs
; _self_boot <- tcSelfBootInfo
......@@ -390,12 +363,6 @@ tcValBinds top_lvl binds sigs thing_inside
; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]
; return (extra_binds, thing) }
; return (binds' ++ extra_binds', thing) }}
where
patsyns = [psb | (_, lbinds) <- binds, L _ (PatSynBind psb) <- bagToList lbinds]
patsyn_placeholder_kinds -- See Note [Placeholder PatSyn kinds]
= [(name, placeholder_patsyn_tything)| PSB{ psb_id = L _ name } <- patsyns ]
placeholder_patsyn_tything
= AGlobal $ AConLike $ PatSynCon $ panic "fakePatSynCon"
------------------------
tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv
......
......@@ -36,6 +36,8 @@ module TcEnv(
getScopedTyVarBinds, getInLocalScope,
wrongThingErr, pprBinders,
tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,
getPatSynBinds, getTypeSigNames,
tcExtendRecEnv, -- For knot-tying
-- Instances
......@@ -84,6 +86,7 @@ import TyCon
import CoAxiom
import Class
import Name
import NameSet
import NameEnv
import VarEnv
import HscTypes
......@@ -94,6 +97,7 @@ import Module
import Outputable
import Encoding
import FastString
import Bag
import ListSetOps
import Util
import Maybes( MaybeErr(..) )
......@@ -538,7 +542,104 @@ tcExtendIdBndrs bndrs thing_inside
thing_inside }
{-
{- *********************************************************************
* *
Adding placeholders
* *
********************************************************************* -}
tcAddDataFamConPlaceholders :: [LInstDecl Name] -> TcM a -> TcM a
-- See Note [AFamDataCon: not promoting data family constructors]
tcAddDataFamConPlaceholders inst_decls thing_inside
= tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
| lid <- inst_decls, con <- get_cons lid ]
thing_inside
-- Note [AFamDataCon: not promoting data family constructors]
where
-- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl Name -> [Name]
get_cons (L _ (TyFamInstD {})) = []
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl Name -> [Name]
get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
= map unLoc $ concatMap (getConNames . unLoc) cons
tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a
-- See Note [Don't promote pattern synonyms]
tcAddPatSynPlaceholders pat_syns thing_inside
= tcExtendKindEnv2 [ (name, APromotionErr PatSynPE)
| PSB{ psb_id = L _ name } <- pat_syns ]
thing_inside
getPatSynBinds :: [(RecFlag, LHsBinds Name)] -> [PatSynBind Name Name]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
, L _ (PatSynBind psb) <- bagToList lbinds ]
getTypeSigNames :: [LSig Name] -> NameSet
-- Get the names that have a user type sig
getTypeSigNames sigs
= foldr get_type_sig emptyNameSet sigs
where
get_type_sig :: LSig Name -> NameSet -> NameSet
get_type_sig sig ns =
case sig of
L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names)
L _ (PatSynSig name _) -> extendNameSet ns (unLoc name)
_ -> ns
{- Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data family T a
data instance T Int = MkT
data Proxy (a :: k)
data S = MkS (Proxy 'MkT)
Is it ok to use the promoted data family instance constructor 'MkT' in
the data declaration for S? No, we don't allow this. It *might* make
sense, but at least it would mean that we'd have to interleave
typechecking instances and data types, whereas at present we do data
types *then* instances.
So to check for this we put in the TcLclEnv a binding for all the family
constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
type checking 'S' we'll produce a decent error message.
Note [Don't promote pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We never promote pattern synonyms.
Consider this (Trac #11265):
pattern A = True
instance Eq A
We want a civilised error message from the occurrence of 'A'
in the instance, yet 'A' really has not yet been type checked.
Similarly (Trac #9161)
{-# LANGUAGE PatternSynonyms, DataKinds #-}
pattern A = ()
b :: A
b = undefined
Here, the type signature for b mentions A. But A is a pattern
synonym, which is typechecked as part of a group of bindings (for very
good reasons; a view pattern in the RHS may mention a value binding).
It is entirely reasonable to reject this, but to do so we need A to be
in the kind environment when kind-checking the signature for B.
Hence tcAddPatSynPlaceholers adds a binding
A -> APromotionErr PatSynPE
to the environment. Then TcHsType.tcTyVar will find A in the kind
environment, and will give a 'wrongThingErr' as a result. But the
lookup of A won't fail.
************************************************************************
* *
\subsection{Rules}
......
......@@ -2134,6 +2134,7 @@ promotionErr name err
NoDataKinds -> text "Perhaps you intended to use DataKinds"
NoTypeInTypeTC -> text "Perhaps you intended to use TypeInType"
NoTypeInTypeDC -> text "Perhaps you intended to use TypeInType"
PatSynPE -> text "Pattern synonyms cannot be promoted"
_ -> text "it is defined and used in the same recursive group"
{-
......
......@@ -632,16 +632,16 @@ tcRnHsBootDecls hsc_src decls
= do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
; (tcg_env, HsGroup {
hs_tyclds = tycl_decls,
hs_instds = inst_decls,
hs_derivds = deriv_decls,
hs_fords = for_decls,
hs_defds = def_decls,
hs_ruleds = rule_decls,
hs_vects = vect_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls first_group
; (tcg_env, HsGroup { hs_tyclds = tycl_decls
, hs_instds = inst_decls
, hs_derivds = deriv_decls
, hs_fords = for_decls
, hs_defds = def_decls
, hs_ruleds = rule_decls
, hs_vects = vect_decls
, hs_annds = _
, hs_valds = ValBindsOut val_binds val_sigs })
<- rnTopSrcDecls first_group
-- The empty list is for extra dependencies coming from .hs-boot files
-- See Note [Extra dependencies from .hs-boot files] in RnSource
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
......@@ -659,12 +659,12 @@ tcRnHsBootDecls hsc_src decls
-- Typecheck type/class/isntance decls
; traceTc "Tc2 (boot)" empty
; (tcg_env, inst_infos, _deriv_binds)
<- tcTyClsInstDecls tycl_decls inst_decls deriv_decls
<- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
; traceTc "Tc5" empty
; val_ids <- tcHsBootSigs val_binds
; val_ids <- tcHsBootSigs val_binds val_sigs
-- Wrap up
-- No simplification or zonking to do
......@@ -1143,7 +1143,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
hs_annds = annotation_decls,
hs_ruleds = rule_decls,
hs_vects = vect_decls,
hs_valds = val_binds })
hs_valds = hs_val_binds@(ValBindsOut val_binds val_sigs) })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
traceTc "Tc2 (src)" empty ;
......@@ -1151,8 +1151,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Source-language instances, including derivings,
-- and import the supporting declarations
traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
<- tcTyClsInstDecls tycl_decls inst_decls deriv_decls ;
(tcg_env, inst_infos, ValBindsOut deriv_binds deriv_sigs)
<- tcTyClsInstDecls tycl_decls inst_decls deriv_decls val_binds ;
setGblEnv tcg_env $ do {
-- Generate Applicative/Monad proposal (AMP) warnings
......@@ -1175,12 +1175,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
-- Now GHC-generated derived bindings, generics, and selectors
-- Do not generate warnings from compiler-generated code;
-- hence the use of discardWarnings
tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
tc_envs <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;
setEnvs tc_envs $ do {
-- Value declarations next
traceTc "Tc5" empty ;
tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds val_sigs;
setEnvs tc_envs $ do { -- Environment doesn't change now
-- Second pass over class and instance declarations,
......@@ -1210,8 +1210,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)
emptyFVs fo_gres
; sig_names = mkNameSet (collectHsValBinders val_binds)
`minusNameSet` getTypeSigNames val_binds
; sig_names = mkNameSet (collectHsValBinders hs_val_binds)
`minusNameSet` getTypeSigNames val_sigs
-- Extend the GblEnv with the (as yet un-zonked)
-- bindings, rules, foreign decls
......@@ -1232,6 +1232,8 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
return (tcg_env', tcl_env)
}}}}}}
tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
tcSemigroupWarnings :: TcM ()
tcSemigroupWarnings = do
......@@ -1420,51 +1422,21 @@ tcMissingParentClassWarn warnFlag isName shouldName
tcTyClsInstDecls :: [TyClGroup Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> [(RecFlag, LHsBinds Name)]
-> TcM (TcGblEnv, -- The full inst env
[InstInfo Name], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
tcTyClsInstDecls tycl_decls inst_decls deriv_decls
= tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE)
| lid <- inst_decls, con <- get_cons lid ] $
-- Note [AFamDataCon: not promoting data family constructors]
tcTyClsInstDecls tycl_decls inst_decls deriv_decls binds
= tcAddDataFamConPlaceholders inst_decls $
tcAddPatSynPlaceholders (getPatSynBinds binds) $
do { tcg_env <- tcTyAndClassDecls tycl_decls ;
; setGblEnv tcg_env $
tcInstDecls1 tycl_decls inst_decls deriv_decls }
where
-- get_cons extracts the *constructor* bindings of the declaration
get_cons :: LInstDecl Name -> [Name]
get_cons (L _ (TyFamInstD {})) = []
get_cons (L _ (DataFamInstD { dfid_inst = fid })) = get_fi_cons fid
get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
= concatMap (get_fi_cons . unLoc) fids
get_fi_cons :: DataFamInstDecl Name -> [Name]
get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } })
= map unLoc $ concatMap (getConNames . unLoc) cons
{-
Note [AFamDataCon: not promoting data family constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data family T a
data instance T Int = MkT
data Proxy (a :: k)
data S = MkS (Proxy 'MkT)
Is it ok to use the promoted data family instance constructor 'MkT' in
the data declaration for S? No, we don't allow this. It *might* make
sense, but at least it would mean that we'd have to interleave
typechecking instances and data types, whereas at present we do data
types *then* instances.
So to check for this we put in the TcLclEnv a binding for all the family
constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
type checking 'S' we'll produce a decent error message.
************************************************************************
{- *********************************************************************
* *
Checking for 'main'
* *
......
......@@ -885,6 +885,8 @@ data PromotionErr
| FamDataConPE -- Data constructor for a data family
-- See Note [AFamDataCon: not promoting data family constructors] in TcRnDriver
| PatSynPE -- Pattern synonyms
-- See Note [Don't promote pattern synonyms] in TcEnv
| RecDataConPE -- Data constructor in a recursive loop
-- See Note [ARecDataCon: recusion and promoting data constructors] in TcTyClsDecls
......@@ -905,6 +907,7 @@ instance Outputable TcTyThing where -- Debugging only
instance Outputable PromotionErr where
ppr ClassPE = text "ClassPE"
ppr TyConPE = text "TyConPE"
ppr PatSynPE = text "PatSynPE"
ppr FamDataConPE = text "FamDataConPE"
ppr RecDataConPE = text "RecDataConPE"
ppr NoDataKinds = text "NoDataKinds"
......@@ -921,6 +924,7 @@ pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe
pprPECategory :: PromotionErr -> SDoc
pprPECategory ClassPE = ptext (sLit "Class")
pprPECategory TyConPE = ptext (sLit "Type constructor")
pprPECategory PatSynPE = ptext (sLit "Pattern synonym")
pprPECategory FamDataConPE = ptext (sLit "Data constructor")
pprPECategory RecDataConPE = ptext (sLit "Data constructor")
pprPECategory NoDataKinds = ptext (sLit "Data constructor")
......@@ -964,6 +968,7 @@ Note that:
*type variable* Eg
f :: forall a. blah
f x = let g y = ...(y::a)...
-}
type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))
......
{-# LANGUAGE PatternSynonyms, DataKinds #-}
pattern A = True
class F a
instance F A
T11265.hs:6:12: error:
• Pattern synonym ‘A’ cannot be used here
(Pattern synonyms cannot be promoted)
• In the first argument of ‘F’, namely ‘A’
In the instance declaration for ‘F A’
T9161-1.hs:6:14: error:
Pattern synonym ‘PATTERN’ used as a type
In the type signature:
wrongLift :: PATTERN
T9161-1.hs:6:14: error:
• Pattern synonym ‘PATTERN’ cannot be used here
(Pattern synonyms cannot be promoted)
• In the type signature:
wrongLift :: PATTERN
T9161-2.hs:8:20: error:
• Pattern synonym ‘PATTERN’ used as a type
• Pattern synonym ‘PATTERN’ cannot be used here
(Pattern synonyms cannot be promoted)
• In the first argument of ‘Proxy’, namely ‘PATTERN’
In the type signature:
wrongLift :: Proxy PATTERN ()
......@@ -27,3 +27,4 @@ test('export-type-synonym', normal, compile_fail, [''])
test('export-ps-rec-sel', normal, compile_fail, [''])
test('T11053', normal, compile, ['-fwarn-missing-pat-syn-sigs'])
test('T10426', normal, compile_fail, [''])
test('T11265', normal, compile_fail, [''])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment