Commit f40e122b authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari

Fix typechecking for pattern synonym signatures

Various tickets have revealed bad shortcomings in the typechecking of
pattern type synonyms.  Discussed a lot in (the latter part of)
Trac #11224.

This patch fixes the most complex issues:

- Both parser and renamer now treat pattern synonyms as an
  ordinary LHsSigType.  Nothing special.  Hooray.

- tcPatSynSig (now in TcPatSyn) typechecks the signature, and
  decomposes it into its pieces.
  See Note [Pattern synonym signatures]

- tcCheckPatSyn has had a lot of refactoring.
  See Note [Checking against a pattern signature]

The result is a lot tidier and more comprehensible.
Plus, it actually works!

NB: this patch doesn't actually address the precise
    target of #11224, namely "inlining pattern synonym
    does not preserve semantics".  That's an unrelated
    bug, with a separate patch.

ToDo: better documentation in the user manual

Test Plan: Validate

Reviewers: austin, hvr, goldfire

Subscribers: goldfire, mpickering, thomie, simonpj

Differential Revision: https://phabricator.haskell.org/D1685

GHC Trac Issues: #11224
parent 29928f29
......@@ -159,8 +159,8 @@ so pattern P has type
with the following typeclass constraints:
provides: (Show (Maybe t), Ord b)
requires: (Eq t, Num t)
provides: (Show (Maybe t), Ord b)
In this case, the fields of MkPatSyn will be set as follows:
......
......@@ -606,7 +606,7 @@ instTyVars :: [TyVar] -> TR (TCvSubst, [TcTyVar])
-- Instantiate fresh mutable type variables from some TyVars
-- This function preserves the print-name, which helps error messages
instTyVars tvs
= liftTcM $ fst <$> captureConstraints (tcInstTyVars tvs)
= liftTcM $ fst <$> captureConstraints (newMetaTyVars tvs)
type RttiInstantiation = [(TcTyVar, TyVar)]
-- Associates the typechecker-world meta type variables
......
......@@ -892,13 +892,8 @@ ppr_sig (SpecInstSig _ ty)
= pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf)
ppr_sig (PatSynSig name sig_ty)
= pprPatSynSig (unLoc name) False -- TODO: is_bindir
(pprHsForAllTvs qtvs)
(pprHsContextMaybe (unLoc req))
(pprHsContextMaybe (unLoc prov))
(ppr ty)
where
(qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty)
= ptext (sLit "pattern") <+> pprPrefixOcc (unLoc name) <+> dcolon
<+> ppr sig_ty
pprPatSynSig :: (OutputableBndr name)
=> name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc
......
......@@ -1191,29 +1191,10 @@ where_decls :: { Located ([AddAnn]
,sL1 $3 (snd $ unLoc $3)) }
pattern_synonym_sig :: { LSig RdrName }
: 'pattern' con '::' ptype
: 'pattern' con '::' sigtype
{% ams (sLL $1 $> $ PatSynSig $2 (mkLHsSigType $4))
[mj AnnPattern $1, mu AnnDcolon $3] }
ptype :: { LHsType RdrName }
: 'forall' tv_bndrs '.' ptype
{% hintExplicitForall (getLoc $1) >>
ams (sLL $1 $> $
HsForAllTy { hst_bndrs = $2
, hst_body = $4 })
[mu AnnForall $1, mj AnnDot $3] }
| context '=>' context '=>' type
{% ams (sLL $1 $> $
HsQualTy { hst_ctxt = $1, hst_body = sLL $3 $> $
HsQualTy { hst_ctxt = $3, hst_body = $5 } })
[mu AnnDarrow $2, mu AnnDarrow $4] }
| context '=>' type
{% ams (sLL $1 $> $
HsQualTy { hst_ctxt = $1, hst_body = $3 })
[mu AnnDarrow $2] }
| type { $1 }
-----------------------------------------------------------------------------
-- Nested declarations
......
......@@ -157,7 +157,7 @@ deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
deeplyInstantiate orig ty
| Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
= do { (subst, tvs') <- tcInstTyVars tvs
= do { (subst, tvs') <- newMetaTyVars tvs
; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
; let theta' = substTheta subst theta
; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
......@@ -248,7 +248,7 @@ instDFunType dfun_id dfun_inst_tys
= do { (subst', tys) <- go (extendTCvSubst subst tv ty) tvs mb_tys
; return (subst', ty : tys) }
go subst (tv:tvs) (Nothing : mb_tys)
= do { (subst', tv') <- tcInstTyVarX subst tv
= do { (subst', tv') <- newMetaTyVarX subst tv
; (subst'', tys) <- go subst' tvs mb_tys
; return (subst'', mkTyVarTy tv' : tys) }
go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
......
......@@ -19,7 +19,8 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl
, tcPatSynBuilderBind, tcPatSynSig )
import DynFlags
import HsSyn
import HscTypes( isHsBootOrSig )
......@@ -63,7 +64,6 @@ import TcValidity (checkValidType)
import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Data.List (partition)
#include "HsVersions.h"
......@@ -1684,46 +1684,8 @@ tcTySig (L loc (TypeSig names sig_ty))
; return (map TcIdSig sigs) }
tcTySig (L loc (PatSynSig (L _ name) sig_ty))
| HsIB { hsib_vars = sig_vars
, hsib_body = hs_ty } <- sig_ty
, (tv_bndrs, req, prov, body_ty) <- splitLHsPatSynTy hs_ty
= setSrcSpan loc $
do { (tvs1, (req', prov', ty', tvs2))
<- tcImplicitTKBndrs sig_vars $
tcHsTyVarBndrs tv_bndrs $ \ tvs2 ->
do { req' <- tcHsContext req
; prov' <- tcHsContext prov
; ty' <- tcHsLiftedType body_ty
; let bound_tvs
= unionVarSets [ allBoundVariabless req'
, allBoundVariabless prov'
, allBoundVariables ty' ]
; return ((req', prov', ty', tvs2), bound_tvs) }
-- These are /signatures/ so we zonk to squeeze out any kind
-- unification variables. ToDo: checkValidType?
; qtvs' <- mapMaybeM zonkQuantifiedTyVar (tvs1 ++ tvs2)
; req' <- zonkTcTypes req'
; prov' <- zonkTcTypes prov'
; ty' <- zonkTcType ty'
; let (_, pat_ty) = tcSplitFunTys ty'
univ_set = tyCoVarsOfType pat_ty
(univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
bad_tvs = varSetElems (tyCoVarsOfTypes 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,
patsig_tau = ty',
patsig_ex = ex_tvs,
patsig_univ = univ_tvs,
patsig_prov = prov',
patsig_req = req' }
do { tpsi <- tcPatSynSig name sig_ty
; return [TcPatSynSig tpsi] }
tcTySig _ = return []
......
......@@ -842,15 +842,15 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty
mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
-- Deals with instantiation of kind variables
-- c.f. TcMType.tcInstTyVars
-- c.f. TcMType.newMetaTyVars
mk_inst_ty subst (tv, result_inst_ty)
| is_fixed_tv tv -- Same as result type
= return (extendTCvSubst subst tv result_inst_ty, result_inst_ty)
| otherwise -- Fresh type, of correct kind
= do { (subst', new_tv) <- tcInstTyVarX subst tv
= do { (subst', new_tv) <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy new_tv) }
; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
; let result_inst_tys = mkTyVarTys con1_tvs'
; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTCvSubst
......@@ -1327,7 +1327,7 @@ tc_infer_id orig lbl id_name
-- * No need to deeply instantiate because type has all foralls at top
= do { let wrap_id = dataConWrapId con
(tvs, theta, rho) = tcSplitSigmaTy (idType wrap_id)
; (subst, tvs') <- tcInstTyVars tvs
; (subst, tvs') <- newMetaTyVars tvs
; let tys' = mkTyVarTys tvs'
theta' = substTheta subst theta
rho' = substTy subst rho
......
......@@ -827,7 +827,7 @@ tcInstBinderX mb_kind_info subst binder
| Just tv <- binderVar_maybe binder
= case lookup_tv tv of
Just ki -> return (extendTCvSubst subst tv ki, ki)
Nothing -> do { (subst', tv') <- tcInstTyVarX subst tv
Nothing -> do { (subst', tv') <- newMetaTyVarX subst tv
; return (subst', mkTyVarTy tv') }
-- This is the *only* constraint currently handled in types.
......@@ -2055,7 +2055,7 @@ Here
* The type signature pattern (f :: a->Int) binds "a" -> a_sig in the envt
* Then unificaiton makes a_sig := a_sk
* Then unification makes a_sig := a_sk
That's why we must make a_sig a MetaTv (albeit a SigTv),
not a SkolemTv, so that it can unify to a_sk.
......
......@@ -27,7 +27,7 @@ module TcMType (
cloneMetaTyVar,
newFmvTyVar, newFskTyVar,
newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,
--------------------------------
......@@ -47,7 +47,7 @@ module TcMType (
--------------------------------
-- Instantiation
tcInstTyVars, tcInstTyVarX,
newMetaTyVars, newMetaTyVarX, newMetaSigTyVars,
newSigTyVar,
tcInstType,
tcInstSkolTyVars, tcInstSkolTyVarsLoc, tcInstSuperSkolTyVarsX,
......@@ -437,19 +437,6 @@ mkMetaTyVarName :: Unique -> FastString -> Name
-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)
mkMetaTyVarName uniq str = mkSysTvName uniq str
newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newMetaTyVar meta_info kind
= do { uniq <- newUnique
; let name = mkMetaTyVarName uniq s
s = case meta_info of
ReturnTv -> fsLit "r"
TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv"
SigTv -> fsLit "a"
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
newSigTyVar :: Name -> Kind -> TcM TcTyVar
newSigTyVar name kind
= do { details <- newMetaDetails SigTv
......@@ -615,8 +602,21 @@ coercion variables, except for the special case of the promoted Eq#. But,
that can't ever appear in user code, so we're safe!
-}
newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
-- Make a new meta tyvar out of thin air
newAnonMetaTyVar meta_info kind
= do { uniq <- newUnique
; let name = mkMetaTyVarName uniq s
s = case meta_info of
ReturnTv -> fsLit "r"
TauTv -> fsLit "t"
FlatMetaTv -> fsLit "fmv"
SigTv -> fsLit "a"
; details <- newMetaDetails meta_info
; return (mkTcTyVar name kind details) }
newFlexiTyVar :: Kind -> TcM TcTyVar
newFlexiTyVar kind = newMetaTyVar TauTv kind
newFlexiTyVar kind = newAnonMetaTyVar TauTv kind
newFlexiTyVarTy :: Kind -> TcM TcType
newFlexiTyVarTy kind = do
......@@ -627,7 +627,7 @@ newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
newReturnTyVar :: Kind -> TcM TcTyVar
newReturnTyVar kind = newMetaTyVar ReturnTv kind
newReturnTyVar kind = newAnonMetaTyVar ReturnTv kind
newReturnTyVarTy :: Kind -> TcM TcType
newReturnTyVarTy kind = mkTyVarTy <$> newReturnTyVar kind
......@@ -652,20 +652,23 @@ newOpenReturnTyVar
; tv <- newReturnTyVar k
; return (tv, k) }
tcInstTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst
newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
-- Instantiate with META type variables
-- Note that this works for a sequence of kind, type, and coercion variables
-- variables. Eg [ (k:*), (a:k->k) ]
-- Gives [ (k7:*), (a8:k7->k7) ]
tcInstTyVars = mapAccumLM tcInstTyVarX emptyTCvSubst
newMetaTyVars = mapAccumLM newMetaTyVarX emptyTCvSubst
-- emptyTCvSubst has an empty in-scope set, but that's fine here
-- Since the tyvars are freshly made, they cannot possibly be
-- captured by any existing for-alls.
tcInstTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
-- Make a new unification variable tyvar whose Name and Kind come from
-- an existing TyVar. We substitute kind variables in the kind.
tcInstTyVarX subst tyvar
newMetaTyVarX subst tyvar
= do { uniq <- newUnique
-- See Note [Levity polymorphic variables accept foralls]
; let info = if isLevityPolymorphic (tyVarKind tyvar)
......@@ -678,6 +681,16 @@ tcInstTyVarX subst tyvar
new_tv = mkTcTyVar name kind details
; return (extendTCvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
newMetaSigTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
-- Just like newMetaTyVarX, but make a SigTv
newMetaSigTyVarX subst tyvar
= do { uniq <- newUnique
; details <- newMetaDetails SigTv
; let name = mkSystemName uniq (getOccName tyvar)
kind = substTy subst (tyVarKind tyvar)
new_tv = mkTcTyVar name kind details
; return (extendTCvSubst subst tyvar (mkTyVarTy new_tv), new_tv) }
{- Note [Name of an instantiated type variable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
At the moment we give a unification variable a System Name, which
......
......@@ -706,7 +706,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn
tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
= do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn
; (subst, univ_tvs') <- tcInstTyVars univ_tvs
; (subst, univ_tvs') <- newMetaTyVars univ_tvs
; let all_arg_tys = ty : prov_theta ++ arg_tys
; checkExistentials ex_tvs all_arg_tys penv
......@@ -776,7 +776,7 @@ matchExpectedPatTy inner_match pat_ty
-- that is the other way round to matchExpectedPatTy
| otherwise
= do { (subst, tvs') <- tcInstTyVars tvs
= do { (subst, tvs') <- newMetaTyVars tvs
; wrap1 <- instCall PatOrigin (mkTyVarTys tvs') (substTheta subst theta)
; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau)
; return (wrap2 <.> wrap1, arg_tys) }
......@@ -800,7 +800,7 @@ matchExpectedConTy data_tc pat_ty
| Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
-- Comments refer to Note [Matching constructor patterns]
-- co_tc :: forall a. T [a] ~ T7 a
= do { (subst, tvs') <- tcInstTyVars (tyConTyVars data_tc)
= do { (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)
-- tys = [ty1,ty2]
; traceTc "matchExpectedConTy" (vcat [ppr data_tc,
......
This diff is collapsed.
......@@ -2,11 +2,14 @@ module TcPatSyn where
import Name ( Name )
import Id ( Id )
import HsSyn ( PatSynBind, LHsBinds )
import HsSyn ( PatSynBind, LHsBinds, LHsSigType )
import TcRnTypes ( TcM, TcPatSynInfo )
import TcRnMonad ( TcGblEnv)
import Outputable ( Outputable )
tcPatSynSig :: Name -> LHsSigType Name
-> TcM TcPatSynInfo
tcInferPatSynDecl :: PatSynBind Name Name
-> TcM (LHsBinds Id, TcGblEnv)
......
......@@ -1178,12 +1178,13 @@ data TcIdSigBndr -- See Note [Complete and partial type signatures]
data TcPatSynInfo
= TPSI {
patsig_name :: Name,
patsig_tau :: TcSigmaType,
patsig_ex :: [TcTyVar],
patsig_prov :: TcThetaType,
patsig_univ :: [TcTyVar],
patsig_req :: TcThetaType
patsig_name :: Name,
patsig_univ_tvs :: [TcTyVar],
patsig_req :: TcThetaType,
patsig_ex_tvs :: [TcTyVar],
patsig_prov :: TcThetaType,
patsig_arg_tys :: [TcSigmaType],
patsig_body_ty :: TcSigmaType
}
findScopedTyVars -- See Note [Binding scoped type variables]
......
......@@ -267,7 +267,7 @@ matchExpectedTyConApp tc orig_ty
-- This happened in Trac #7368
defer is_return
= ASSERT2( classifiesTypeWithValues res_kind, ppr tc )
do { (k_subst, kvs') <- tcInstTyVars kvs
do { (k_subst, kvs') <- newMetaTyVars kvs
; let arg_kinds' = substTys k_subst arg_kinds
kappa_tys = mkTyVarTys kvs'
; tau_tys <- mapM (newMaybeReturnTyVarTy is_return) arg_kinds'
......@@ -482,7 +482,7 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected
| (tvs, theta, in_rho) <- tcSplitSigmaTy ty_actual
, not (null tvs && null theta)
= do { (subst, tvs') <- tcInstTyVars tvs
= do { (subst, tvs') <- newMetaTyVars tvs
; let tys' = mkTyVarTys tvs'
theta' = substTheta subst theta
in_rho' = substTy subst in_rho
......
......@@ -57,7 +57,7 @@ module TyCoRep (
-- Free variables
tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet,
tyCoVarsOfTypeAcc, tyCoVarsOfTypeList,
tyCoVarsBndrAcc, tyCoVarsOfTypeAcc, tyCoVarsOfTypeList,
tyCoVarsOfTypesAcc, tyCoVarsOfTypesList,
closeOverKindsDSet, closeOverKindsAcc,
coVarsOfType, coVarsOfTypes,
......@@ -1049,19 +1049,24 @@ tyCoVarsOfTypeList ty = runFVList $ tyCoVarsOfTypeAcc ty
-- | The worker for `tyVarsOfType` and `tyVarsOfTypeList`.
-- The previous implementation used `unionVarSet` which is O(n+m) and can
-- make the function quadratic.
-- It's exported, so that it can be composed with other functions that compute
-- free variables.
-- It's exported, so that it can be composed with
-- other functions that compute free variables.
-- See Note [FV naming conventions] in FV.
--
-- Eta-expanded because that makes it run faster (apparently)
tyCoVarsOfTypeAcc :: Type -> FV
tyCoVarsOfTypeAcc (TyVarTy v) fv_cand in_scope acc = (oneVar v `unionFV` tyCoVarsOfTypeAcc (tyVarKind v)) fv_cand in_scope acc
tyCoVarsOfTypeAcc (TyConApp _ tys) fv_cand in_scope acc = tyCoVarsOfTypesAcc tys fv_cand in_scope acc
tyCoVarsOfTypeAcc (LitTy {}) fv_cand in_scope acc = noVars fv_cand in_scope acc
tyCoVarsOfTypeAcc (AppTy fun arg) fv_cand in_scope acc = (tyCoVarsOfTypeAcc fun `unionFV` tyCoVarsOfTypeAcc arg) fv_cand in_scope acc
tyCoVarsOfTypeAcc (ForAllTy bndr ty) fv_cand in_scope acc
= (delBinderVarFV bndr (tyCoVarsOfTypeAcc ty)
`unionFV` tyCoVarsOfTypeAcc (binderType bndr)) fv_cand in_scope acc
tyCoVarsOfTypeAcc (CastTy ty co) fv_cand in_scope acc = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfCoAcc co) fv_cand in_scope acc
tyCoVarsOfTypeAcc (CoercionTy co) fv_cand in_scope acc = tyCoVarsOfCoAcc co fv_cand in_scope acc
tyCoVarsOfTypeAcc (TyVarTy v) a b c = (oneVar v `unionFV` tyCoVarsOfTypeAcc (tyVarKind v)) a b c
tyCoVarsOfTypeAcc (TyConApp _ tys) a b c = tyCoVarsOfTypesAcc tys a b c
tyCoVarsOfTypeAcc (LitTy {}) a b c = noVars a b c
tyCoVarsOfTypeAcc (AppTy fun arg) a b c = (tyCoVarsOfTypeAcc fun `unionFV` tyCoVarsOfTypeAcc arg) a b c
tyCoVarsOfTypeAcc (ForAllTy bndr ty) a b c = tyCoVarsBndrAcc bndr (tyCoVarsOfTypeAcc ty) a b c
tyCoVarsOfTypeAcc (CastTy ty co) a b c = (tyCoVarsOfTypeAcc ty `unionFV` tyCoVarsOfCoAcc co) a b c
tyCoVarsOfTypeAcc (CoercionTy co) a b c = tyCoVarsOfCoAcc co a b c
tyCoVarsBndrAcc :: TyBinder -> FV -> FV
-- Free vars of (forall b. <thing with fvs>)
tyCoVarsBndrAcc bndr fvs = delBinderVarFV bndr fvs
`unionFV` tyCoVarsOfTypeAcc (binderType bndr)
-- | Returns free variables of types, including kind variables as
-- a non-deterministic set. For type synonyms it does /not/ expand the
......
{-# LANGUAGE GADTs, PatternSynonyms #-}
-- Tests that for unidirectional pattern synonyms
-- the pattern synonym can be more existential
-- (i.e. lose information) wrt the original
module MoreEx where
pattern ExCons :: a -> [a] -> [b]
pattern ExCons x xs <- x : xs
data T where
MkT1 :: ([a] -> Int) -> [a] -> T
MkT2 :: (a -> Int) -> a -> T
pattern ExT1 :: b -> (b -> Int) -> T
pattern ExT1 x f <- MkT1 f x
pattern ExT2 :: b -> (c -> Int) -> T
pattern ExT2 x f <- MkT2 f x
{-# LANGUAGE PatternSynonyms, GADTs, RankNTypes #-}
module T11224b where
data T b where
MkT :: a -> b -> T b
-- Should be fine!
-- pattern P :: c -> d -> T d
pattern P :: forall d. forall c. c -> d -> T d
pattern P x y <- MkT x y
......@@ -24,6 +24,7 @@ test('T9889', normal, compile, [''])
test('T9867', normal, compile, [''])
test('T9975a', normal, compile_fail, [''])
test('T9975b', normal, compile, [''])
test('T10426', [expect_broken(10426)], compile, [''])
test('T10747', normal, compile, [''])
test('T10997', [extra_clean(['T10997a.hi', 'T10997a.o'])], multimod_compile, ['T10997', '-v0'])
test('T10997_1', [extra_clean(['T10997_1a.hi', 'T10997_1a.o'])], multimod_compile, ['T10997_1', '-v0'])
......@@ -45,3 +46,5 @@ test('T10897', expect_broken(10897), multi_compile, ['T10897', [
('T10897a.hs','-c')
,('T10897b.hs', '-c')], ''])
test('T9793', normal, compile, [''])
test('T11224b', normal, compile, [''])
test('MoreEx', normal, compile, [''])
T11010.hs:8:1: error:
The 'required' context ‘a ~ Int’
mentions existential type variable ‘a’
T11010.hs:16:1: error:
The 'required' context ‘a ~ Int’
mentions existential type variable ‘a’
T11010.hs:9:36: error:
• Couldn't match type ‘a1’ with ‘Int’
‘a1’ is a rigid type variable bound by
a pattern with constructor:
Fun :: forall b a. String -> (a -> b) -> Expr a -> Expr b,
in a pattern synonym declaration
at T11010.hs:9:26
Expected type: a -> b
Actual type: a1 -> b
• In the declaration for pattern synonym ‘IntFun’
• Relevant bindings include
x :: Expr a1 (bound at T11010.hs:9:36)
f :: a1 -> b (bound at T11010.hs:9:34)
T9793-fail.hs:6:16: error:
Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(y : _)
• Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(y : _)
• In the declaration for pattern synonym ‘P’
as-pattern.hs:4:18: error:
Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(Just y)
• Pattern synonym definition cannot contain as-patterns (@) which contain free variables:
x@(Just y)
• In the declaration for pattern synonym ‘P’
{-# LANGUAGE PatternSynonyms , ViewPatterns #-}
{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
-- inlining a pattern synonym shouldn't change semantics
module Main where
import Text.Read
-- pattern PRead :: () => Read a => a -> String
pattern PRead :: Read a => () => a -> String
pattern PRead a <- (readMaybe -> Just a)
foo :: String -> Int
......@@ -26,3 +26,4 @@ main = do
print $ bar "1" -- 1
print $ bar "[1,2,3]" -- 6
print $ bar "xxx" -- 666
......@@ -12,4 +12,5 @@ test('match-unboxed', normal, compile_and_run, [''])
test('unboxed-wrapper', normal, compile_and_run, [''])
test('records-run', normal, compile_and_run, [''])
test('ghci', just_ghci, ghci_script, ['ghci.script'])
test('T11224', [expect_broken(11224)], compile_and_run, [''])
\ No newline at end of file
test('T11224', [expect_broken(11224)], compile_and_run, [''])
test('T11224', normal, compile_and_run, [''])
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