summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/basicTypes/PatSyn.hs45
-rw-r--r--compiler/hsSyn/HsBinds.hs16
-rw-r--r--compiler/iface/IfaceSyn.hs2
-rw-r--r--compiler/iface/MkIface.hs2
-rw-r--r--compiler/rename/RnBinds.hs8
-rw-r--r--compiler/typecheck/TcBinds.hs15
-rw-r--r--compiler/typecheck/TcPat.hs2
7 files changed, 70 insertions, 20 deletions
diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs
index 503ebd87a4..2546ff4ea0 100644
--- a/compiler/basicTypes/PatSyn.hs
+++ b/compiler/basicTypes/PatSyn.hs
@@ -46,6 +46,7 @@ import Data.Function
-- | A pattern synonym
-- See Note [Pattern synonym representation]
+-- See Note [Patten synonym signatures]
data PatSyn
= MkPatSyn {
psName :: Name,
@@ -89,7 +90,44 @@ data PatSyn
}
deriving Data.Typeable.Typeable
-{-
+{- Note [Patten synonym signatures]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a pattern synonym signature we write
+ pattern P :: req => prov => t1 -> ... tn -> res_ty
+
+Note that the "required" context comes first, then the "provided"
+context. Moreover, the "required" context must not mention
+existentially-bound type variables; that is, ones not mentioned in
+res_ty. See lots of discussion in Trac #10928.
+
+If there is no "provided" context, you can omit it; but you
+can't omit the "required" part (unless you omit both).
+
+Example 1:
+ pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b)
+ pattern P1 x = Just (3,x)
+
+ We require (Num a, Eq a) to match the 3; there is no provided
+ context.
+
+Example 2:
+ data T2 where
+ MkT2 :: (Num a, Eq a) => a -> a -> T2
+
+ patttern P2 :: () => (Num a, Eq a) => a -> T2
+ pattern P2 x = MkT2 3 x
+
+ When we match against P2 we get a Num dictionary provided.
+ We can use that to check the match against 3.
+
+Example 3:
+ pattern P3 :: Eq a => a -> b -> T3 b
+
+ This signature is illegal because the (Eq a) is a required
+ constraint, but it mentions the existentially-bound variable 'a'.
+ You can see it's existential because it doesn't appear in the
+ result type (T3 b).
+
Note [Pattern synonym representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym declaration
@@ -267,6 +305,7 @@ patSynName = psName
patSynType :: PatSyn -> Type
-- The full pattern type, used only in error messages
+-- See Note [Patten synonym signatures]
patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
@@ -288,11 +327,11 @@ patSynArgs = psArgs
patSynExTyVars :: PatSyn -> [TyVar]
patSynExTyVars = psExTyVars
-patSynSig :: PatSyn -> ([TyVar], [TyVar], ThetaType, ThetaType, [Type], Type)
+patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type)
patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs
, psProvTheta = prov, psReqTheta = req
, psArgs = arg_tys, psOrigResTy = res_ty })
- = (univ_tvs, ex_tvs, prov, req, arg_tys, res_ty)
+ = (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty)
patSynMatcher :: PatSyn -> (Id,Bool)
patSynMatcher = psMatcher
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 4b661ff6cd..18756f632f 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -641,8 +641,8 @@ data Sig name
-- For details on above see note [Api annotations] in ApiAnnotation
| PatSynSig (Located name)
(HsExplicitFlag, LHsTyVarBndrs name)
- (LHsContext name) -- Provided context
(LHsContext name) -- Required context
+ (LHsContext name) -- Provided context
(LHsType name)
-- | A type signature for a default method inside a class
@@ -839,23 +839,23 @@ ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLo
ppr_sig (SpecInstSig _ ty)
= pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name (flag, qtvs) (L _ prov) (L _ req) ty)
+ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty)
= pprPatSynSig (unLoc name) False -- TODO: is_bindir
(pprHsForAll flag qtvs (noLoc []))
- (pprHsContextMaybe prov) (pprHsContextMaybe req)
+ (pprHsContextMaybe req) (pprHsContextMaybe prov)
(ppr ty)
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
-pprPatSynSig ident _is_bidir tvs prov req ty
+pprPatSynSig ident _is_bidir tvs req prov ty
= ptext (sLit "pattern") <+> pprPrefixOcc ident <+> dcolon <+>
tvs <+> context <+> ty
where
- context = case (prov, req) of
+ context = case (req, prov) of
(Nothing, Nothing) -> empty
- (Nothing, Just req) -> parens empty <+> darrow <+> req <+> darrow
- (Just prov, Nothing) -> prov <+> darrow
- (Just prov, Just req) -> prov <+> darrow <+> req <+> darrow
+ (Nothing, Just prov) -> parens empty <+> darrow <+> prov <+> darrow
+ (Just req, Nothing) -> req <+> darrow
+ (Just req, Just prov) -> req <+> darrow <+> prov <+> darrow
instance OutputableBndr name => Outputable (FixitySig name) where
ppr (FixitySig names fixity) = sep [ppr fixity, pprops]
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 85210cd6f3..42342aec85 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -772,8 +772,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatBuilder = builder,
ifPatTy = pat_ty} )
= pprPatSynSig name is_bidirectional
(pprUserIfaceForAll tvs)
- (pprIfaceContextMaybe prov_ctxt)
(pprIfaceContextMaybe req_ctxt)
+ (pprIfaceContextMaybe prov_ctxt)
(pprIfaceType ty)
where
is_bidirectional = isJust builder
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index d4b764b613..84d9fd99b5 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1524,7 +1524,7 @@ patSynToIfaceDecl ps
, ifPatTy = tidyToIfaceType env2 rhs_ty
}
where
- (univ_tvs, ex_tvs, prov_theta, req_theta, args, rhs_ty) = patSynSig ps
+ (univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps
(env1, univ_tvs') = tidyTyVarBndrs emptyTidyEnv univ_tvs
(env2, ex_tvs') = tidyTyVarBndrs env1 ex_tvs
to_if_pr (id, needs_dummy) = (idName id, needs_dummy)
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 10c5b7bb03..d63808edb6 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -923,7 +923,7 @@ renameSig ctxt sig@(MinimalSig s bf)
= do new_bf <- traverse (lookupSigOccRn ctxt sig) bf
return (MinimalSig s new_bf, emptyFVs)
-renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
+renameSig ctxt sig@(PatSynSig v (flag, qtvs) req prov ty)
= do { v' <- lookupSigOccRn ctxt sig v
; let doc = TypeSigCtx $ quotes (ppr v)
; loc <- getSrcSpanM
@@ -940,12 +940,12 @@ renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
Qualified -> panic "renameSig: Qualified"
; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
- { (prov', fvs1) <- rnContext doc prov
- ; (req', fvs2) <- rnContext doc req
+ { (req', fvs2) <- rnContext doc req
+ ; (prov', fvs1) <- rnContext doc prov
; (ty', fvs3) <- rnLHsType doc ty
; let fvs = plusFVs [fvs1, fvs2, fvs3]
- ; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }}
+ ; return (PatSynSig v' (flag, tyvars) req' prov' ty', fvs) }}
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index f927ffa2df..d939ad3ed3 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -1621,20 +1621,31 @@ tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty wcs))
; sig <- instTcTySig ctxt hs_ty sigma_ty (extra_cts hs_ty) wc_prs name
; return (TcIdSig sig) }
-tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
+tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) req prov ty))
= setSrcSpan loc $
- do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
+ do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr req $$ ppr prov $$ ppr ty
; let ctxt = PatSynCtxt name
; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
{ ty' <- tcHsSigType ctxt ty
; req' <- tcHsContext req
; prov' <- tcHsContext prov
+ -- These are /signatures/ so we zonk to squeeze out any kind
+ -- unification variables. Thta has happened automatically in tcHsSigType
+ ; req' <- zonkTcThetaType req'
+ ; prov' <- zonkTcThetaType prov'
+
; qtvs' <- mapM zonkQuantifiedTyVar qtvs'
; let (_, pat_ty) = tcSplitFunTys ty'
univ_set = tyVarsOfType pat_ty
(univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
+ bad_tvs = varSetElems (tyVarsOfTypes req' `minusVarSet` univ_set)
+
+ ; unless (null bad_tvs) $ addErr $
+ hang (ptext (sLit "The 'required' context") <+> quotes (pprTheta req'))
+ 2 (ptext (sLit "mentions existential type variable") <> plural bad_tvs
+ <+> pprQuotedList bad_tvs)
; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
; let tpsi = TPSI{ patsig_name = name,
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 486e5f5d24..e39b0f51c6 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -882,7 +882,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
-> HsConPatDetails Name -> TcM a
-> TcM (Pat TcId, a)
tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
- = do { let (univ_tvs, ex_tvs, prov_theta, req_theta, arg_tys, ty) = patSynSig pat_syn
+ = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
; (subst, univ_tvs') <- tcInstTyVars univ_tvs
View Lorry Controller Status