diff options
| author | Matthew Pickering <matthewtpickering@gmail.com> | 2015-10-19 21:17:29 +0100 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2015-10-29 12:24:21 +0100 |
| commit | 2a74a64e8329ab9e0c74bec47198cb492d25affb (patch) | |
| tree | 2f0ac8dc3f1d372062eba5a4945fad55580cf9f0 | |
| parent | a0517889383127848faf82b32919d3f742a59278 (diff) | |
| download | haskell-2a74a64e8329ab9e0c74bec47198cb492d25affb.tar.gz | |
Record pattern synonyms
This patch implements an extension to pattern synonyms which allows user
to specify pattern synonyms using record syntax. Doing so generates
appropriate selectors and update functions.
=== Interaction with Duplicate Record Fields ===
The implementation given here isn't quite as general as it could be with
respect to the recently-introduced `DuplicateRecordFields` extension.
Consider the following module:
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE PatternSynonyms #-}
module Main where
pattern S{a, b} = (a, b)
pattern T{a} = Just a
main = do
print S{ a = "fst", b = "snd" }
print T{ a = "a" }
In principle, this ought to work, because there is no ambiguity. But at
the moment it leads to a "multiple declarations of a" error. The problem
is that pattern synonym record selectors don't do the same name mangling
as normal datatypes when DuplicateRecordFields is enabled. They could,
but this would require some work to track the field label and selector
name separately.
In particular, we currently represent datatype selectors in the third
component of AvailTC, but pattern synonym selectors are just represented
as Avails (because they don't have a corresponding type constructor).
Moreover, the GlobalRdrElt for a selector currently requires it to have
a parent tycon.
(example due to Adam Gundry)
=== Updating Explicitly Bidirectional Pattern Synonyms ===
Consider the following
```
pattern Silly{a} <- [a] where
Silly a = [a, a]
f1 = a [5] -- 5
f2 = [5] {a = 6} -- currently [6,6]
```
=== Fixing Polymorphic Updates ===
They were fixed by adding these two lines in `dsExpr`. This might break
record updates but will be easy to fix.
```
+ ; let req_wrap = mkWpTyApps (mkTyVarTys univ_tvs)
- , pat_wrap = idHsWrapper }
+, pat_wrap = req_wrap }
```
=== Mixed selectors error ===
Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following pattern synonym.
data MyRec = MyRec { foo :: Int, qux :: String }
pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
This allows updates such as the following
updater :: MyRec -> MyRec
updater a = a {f1 = 1 }
It would also make sense to allow the following update (which we
reject).
updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
This leads to confusing behaviour when the selectors in fact refer the
same field.
updater a = a {f1 = 1, foo = 2} ==? ???
For this reason, we reject a mixture of pattern synonym and normal
record selectors in the same update block. Although of course we still
allow the following.
updater a = (a {f1 = 1}) {foo = 2}
> updater (MyRec 0 "str")
MyRec 2 "str"
60 files changed, 1061 insertions, 268 deletions
diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs index 772065fec2..69a7992ded 100644 --- a/compiler/basicTypes/ConLike.hs +++ b/compiler/basicTypes/ConLike.hs @@ -15,24 +15,33 @@ module ConLike ( , conLikeExTyVars , conLikeName , conLikeStupidTheta + , conLikeWrapId_maybe + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikesWithFields ) where #include "HsVersions.h" -import {-# SOURCE #-} DataCon -import {-# SOURCE #-} PatSyn +import DataCon +import PatSyn import Outputable import Unique import Util import Name -import FieldLabel import BasicTypes import {-# SOURCE #-} TypeRep (Type, ThetaType) import Var +import Type (mkTyConApp) import Data.Function (on) import qualified Data.Data as Data import qualified Data.Typeable +#if __GLASGOW_HASKELL__ <= 708 +import Control.Applicative ((<$>)) +#endif {- ************************************************************************ @@ -90,21 +99,25 @@ instance Data.Data ConLike where gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "ConLike" - +-- | Number of arguments conLikeArity :: ConLike -> Arity conLikeArity (RealDataCon data_con) = dataConSourceArity data_con conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn +-- | Names of fields used for selectors conLikeFieldLabels :: ConLike -> [FieldLabel] conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con -conLikeFieldLabels (PatSynCon _) = [] +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] conLikeInstOrigArgTys (RealDataCon data_con) tys = dataConInstOrigArgTys data_con tys conLikeInstOrigArgTys (PatSynCon pat_syn) tys = patSynInstArgTys pat_syn tys +-- | Existentially quantified type variables conLikeExTyVars :: ConLike -> [TyVar] conLikeExTyVars (RealDataCon dcon1) = dataConExTyVars dcon1 conLikeExTyVars (PatSynCon psyn1) = patSynExTyVars psyn1 @@ -113,6 +126,69 @@ conLikeName :: ConLike -> Name conLikeName (RealDataCon data_con) = dataConName data_con conLikeName (PatSynCon pat_syn) = patSynName pat_syn +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. conLikeStupidTheta :: ConLike -> ThetaType conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con conLikeStupidTheta (PatSynCon {}) = [] + +-- | Returns the `Id` of the wrapper. This is also known as the builder in +-- some contexts. The value is Nothing only in the case of unidirectional +-- pattern synonyms. +conLikeWrapId_maybe :: ConLike -> Maybe Id +conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con +conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quanitifed type variables +-- +-- 2) The existentially quantified type variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyVar], [(TyVar,Type)] + , ThetaType, ThetaType, [Type], Type) +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + + +-- | The ConLikes that have *all* the given fields +conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] +conLikesWithFields con_likes lbls = filter has_flds con_likes + where has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) diff --git a/compiler/basicTypes/ConLike.hs-boot b/compiler/basicTypes/ConLike.hs-boot new file mode 100644 index 0000000000..3463287f25 --- /dev/null +++ b/compiler/basicTypes/ConLike.hs-boot @@ -0,0 +1,18 @@ +module ConLike where +import Data.Typeable +import Name (NamedThing) +import {-# SOURCE #-} DataCon (DataCon) +import {-# SOURCE #-} PatSyn (PatSyn) +import Outputable +import Data.Data (Data) + +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +instance Eq ConLike +instance Typeable ConLike +instance Ord ConLike +instance NamedThing ConLike +instance Data ConLike +instance Outputable ConLike +instance OutputableBndr ConLike diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs index 7b54baae15..e22a77c07c 100644 --- a/compiler/basicTypes/Id.hs +++ b/compiler/basicTypes/Id.hs @@ -54,11 +54,13 @@ module Id ( isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, - isConLikeId, isBottomingId, idIsFrom, + idConLike, isConLikeId, isBottomingId, idIsFrom, hasNoBinding, -- ** Evidence variables @@ -114,7 +116,6 @@ import Var( Id, DictId, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var -import TyCon import Type import TysPrim import DataCon @@ -132,6 +133,7 @@ import UniqSupply import FastString import Util import StaticFlags +import {-# SOURCE #-} ConLike ( ConLike(..) ) -- infixl so you can say (id `set` a `set` b) infixl 1 `setIdUnfoldingLazily`, @@ -354,14 +356,17 @@ That is what is happening in, say tidy_insts in TidyPgm. -} -- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. -recordSelectorTyCon :: Id -> TyCon +recordSelectorTyCon :: Id -> RecSelParent recordSelectorTyCon id = case Var.idDetails id of - RecSelId { sel_tycon = tycon } -> tycon + RecSelId { sel_tycon = parent } -> parent _ -> panic "recordSelectorTyCon" + isRecordSelector :: Id -> Bool isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool isPrimOpId :: Id -> Bool isFCallId :: Id -> Bool isDataConWorkId :: Id -> Bool @@ -373,7 +378,15 @@ isFCallId_maybe :: Id -> Maybe ForeignCall isDataConWorkId_maybe :: Id -> Maybe DataCon isRecordSelector id = case Var.idDetails id of - RecSelId {} -> True + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True _ -> False isNaughtyRecordSelector id = case Var.idDetails id of @@ -424,6 +437,14 @@ idDataCon :: Id -> DataCon -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) +idConLike :: Id -> ConLike +idConLike id = + case Var.idDetails id of + DataConWorkId con -> RealDataCon con + DataConWrapId con -> RealDataCon con + PatSynBuilderId ps -> PatSynCon ps + _ -> pprPanic "idConLike" (ppr id) + hasNoBinding :: Id -> Bool -- ^ Returns @True@ of an 'Id' which may not have a -- binding, even though it is defined in this module. diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs index d8d0e7fcad..ea1eb19c35 100644 --- a/compiler/basicTypes/IdInfo.hs +++ b/compiler/basicTypes/IdInfo.hs @@ -11,6 +11,7 @@ Haskell. [WDP 94/11]) module IdInfo ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, + RecSelParent(..), -- * The IdInfo type IdInfo, -- Abstract @@ -76,6 +77,7 @@ import VarSet import BasicTypes import DataCon import TyCon +import {-# SOURCE #-} PatSyn import ForeignCall import Outputable import Module @@ -108,8 +110,7 @@ data IdDetails -- | The 'Id' for a record selector | RecSelId - { sel_tycon :: TyCon -- ^ For a data type family, this is the /instance/ 'TyCon' - -- not the family 'TyCon' + { sel_tycon :: RecSelParent , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: -- data T = forall a. MkT { x :: a } } -- See Note [Naughty record selectors] in TcTyClsDecls @@ -121,6 +122,7 @@ data IdDetails -- a) to support isImplicitId -- b) when desugaring a RecordCon we can get -- from the Id back to the data con] + | PatSynBuilderId PatSyn -- ^ As for DataConWrapId | ClassOpId Class -- ^ The 'Id' is a superclass selector, -- or class operation of a class @@ -148,6 +150,20 @@ data IdDetails | PatSynId -- ^ A top-level Id to support pattern synonyms; -- the builder or matcher for the patern synonym + +data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq + -- Either `TyCon` or `PatSyn` depending + -- on the origin of the record selector. + -- For a data type family, this is the + -- /instance/ 'TyCon' not the family 'TyCon' + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData ty_con -> ppr ty_con + RecSelPatSyn ps -> ppr ps + + + coVarDetails :: IdDetails coVarDetails = VanillaId @@ -172,6 +188,7 @@ pprIdDetails other = brackets (pp other) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") <> ppWhen is_naughty (ptext (sLit "(naughty)")) + pp (PatSynBuilderId _) = ptext (sLit "PatSynBuilder") {- ************************************************************************ diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 2546ff4ea0..01e52afa5c 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -16,7 +16,9 @@ module PatSyn ( patSynArgs, patSynType, patSynMatcher, patSynBuilder, patSynExTyVars, patSynSig, - patSynInstArgTys, patSynInstResTy, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + tidyPatSynIds ) where @@ -31,10 +33,12 @@ import Util import BasicTypes import FastString import Var +import FieldLabel import qualified Data.Data as Data import qualified Data.Typeable import Data.Function +import Data.List {- ************************************************************************ @@ -50,17 +54,26 @@ import Data.Function data PatSyn = MkPatSyn { psName :: Name, - psUnique :: Unique, -- Cached from Name + psUnique :: Unique, -- Cached from Name psArgs :: [Type], - psArity :: Arity, -- == length psArgs - psInfix :: Bool, -- True <=> declared infix - - psUnivTyVars :: [TyVar], -- Universially-quantified type variables - psReqTheta :: ThetaType, -- Required dictionaries - psExTyVars :: [TyVar], -- Existentially-quantified type vars - psProvTheta :: ThetaType, -- Provided dictionaries - psOrigResTy :: Type, -- Mentions only psUnivTyVars + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + psUnivTyVars :: [TyVar], -- Universially-quantified type variables + psReqTheta :: ThetaType, -- Required dictionaries + -- these constraints are very much like + -- stupid thetas (which is a useful + -- guideline when implementing) + -- but are actually needed. + psExTyVars :: [TyVar], -- Existentially-quantified type vars + psProvTheta :: ThetaType, -- Provided dictionaries + psOrigResTy :: Type, -- Mentions only psUnivTyVars -- See Note [Matchers and builders for pattern synonyms] psMatcher :: (Id, Bool), @@ -282,13 +295,15 @@ mkPatSyn :: Name -> Type -- ^ Original result type -> (Id, Bool) -- ^ Name of matcher -> Maybe (Id, Bool) -- ^ Name of builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym -> PatSyn mkPatSyn name declared_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) orig_args orig_res_ty - matcher builder + matcher builder field_labels = MkPatSyn {psName = name, psUnique = getUnique name, psUnivTyVars = univ_tvs, psExTyVars = ex_tvs, psProvTheta = prov_theta, psReqTheta = req_theta, @@ -297,7 +312,9 @@ mkPatSyn name declared_infix psArity = length orig_args, psOrigResTy = orig_res_ty, psMatcher = matcher, - psBuilder = builder } + psBuilder = builder, + psFieldLabels = field_labels + } -- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification patSynName :: PatSyn -> Name @@ -324,6 +341,16 @@ patSynArity = psArity patSynArgs :: PatSyn -> [Type] patSynArgs = psArgs +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + patSynExTyVars :: PatSyn -> [TyVar] patSynExTyVars = psExTyVars diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 8d9f37d24e..dfe3807b1a 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -540,11 +540,12 @@ addTickHsExpr (RecordCon id ty rec_binds) = (return id) (return ty) (addTickHsRecordBinds rec_binds) -addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2) = - liftM5 RecordUpd - (addTickLHsExpr e) - (mapM addTickHsRecField rec_binds) - (return cons) (return tys1) (return tys2) +addTickHsExpr (RecordUpd e rec_binds cons tys1 tys2 req_wrap) = + return RecordUpd `ap` + (addTickLHsExpr e) `ap` + (mapM addTickHsRecField rec_binds) `ap` + (return cons) `ap` (return tys1) `ap` (return tys2) `ap` + (return req_wrap) addTickHsExpr (ExprWithTySigOut e ty) = liftM2 ExprWithTySigOut diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index d91ccfbc6c..f47843aa06 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -57,6 +57,7 @@ import Util import Bag import Outputable import FastString +import PatSyn import IfaceEnv import IdInfo @@ -492,7 +493,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. -} -dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do +dsExpr (RecordCon (L _ con_like_id) con_expr rbinds) = do con_expr' <- dsExpr con_expr let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -506,7 +507,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty - labels = dataConFieldLabels (idDataCon data_con_id) + labels = conLikeFieldLabels (idConLike con_like_id) -- The data_con_id is guaranteed to be the wrapper id of the constructor con_args <- if null labels @@ -551,7 +552,7 @@ So we need to cast (T a Int) to (T a b). Sigh. -} dsExpr expr@(RecordUpd record_expr fields - cons_to_upd in_inst_tys out_inst_tys) + cons_to_upd in_inst_tys out_inst_tys dict_req_wrap ) | null fields = dsLExpr record_expr | otherwise @@ -591,26 +592,37 @@ dsExpr expr@(RecordUpd record_expr fields -- Awkwardly, for families, the match goes -- from instance type to family type - tycon = dataConTyCon (head cons_to_upd) - in_ty = mkTyConApp tycon in_inst_tys - out_ty = mkFamilyTyConApp tycon out_inst_tys - + (in_ty, out_ty) = + case (head cons_to_upd) of + RealDataCon data_con -> + let tycon = dataConTyCon data_con in + (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys) + PatSynCon pat_syn -> + (patSynInstResTy pat_syn in_inst_tys + , patSynInstResTy pat_syn out_inst_tys) mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, - theta, arg_tys, _) = dataConFullSig con + prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst theta) + ; theta_vars <- mapM newPredVarDs (substTheta subst prov_theta) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) - ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg - (dataConFieldLabels con) arg_ids + ; let field_labels = conLikeFieldLabels con + val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg + field_labels arg_ids mk_val_arg fl pat_arg_id = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) - inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con)) + -- SAFE: the typechecker will complain if the synonym is + -- not bidirectional + wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con) + inst_con = noLoc $ HsWrap wrap (HsVar wrap_id) -- Reconstruct with the WrapId so that unpacking happens - wrap = mkWpEvVarApps theta_vars <.> + -- The order here is because of the order in `TcPatSyn`. + wrap = + dict_req_wrap <.> + mkWpEvVarApps theta_vars <.> mkWpTyApps (mkTyVarTys ex_tvs) <.> mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys , not (tv `elemVarEnv` wrap_subst) ] @@ -618,24 +630,39 @@ dsExpr expr@(RecordUpd record_expr fields -- Tediously wrap the application in a cast -- Note [Update for GADTs] - wrap_co = mkTcTyConAppCo Nominal tycon - [ lookup tv ty | (tv,ty) <- univ_tvs `zip` out_inst_tys ] - lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of - Just co' -> co' - Nothing -> mkTcReflCo Nominal ty - wrap_subst = mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) - | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] - - pat = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon con) + wrapped_rhs = + case con of + RealDataCon data_con -> + let + wrap_co = + mkTcTyConAppCo Nominal + (dataConTyCon data_con) + [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys ] + lookup univ_tv ty = + case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkTcReflCo Nominal ty + in if null eq_spec + then rhs + else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs + -- eq_spec is always null for a PatSynCon + PatSynCon _ -> rhs + + wrap_subst = + mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var)) + | ((tv,_),eq_var) <- eq_spec `zip` eqs_vars ] + + req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys + pat = noLoc $ ConPatOut { pat_con = noLoc con , pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds , pat_args = PrefixCon $ map nlVarPat arg_ids , pat_arg_tys = in_inst_tys - , pat_wrap = idHsWrapper } - ; let wrapped_rhs | null eq_spec = rhs - | otherwise = mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs - ; return (mkSimpleMatch [pat] wrapped_rhs) } + , pat_wrap = req_wrap } + + ; return (mkSimpleMatch [pat] wrapped_rhs) } -- Here is where we desugar the Template Haskell brackets and escapes diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index df2eaf2846..ad1d5016cc 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1142,7 +1142,7 @@ repE (RecordCon c _ flds) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } -repE (RecordUpd e flds _ _ _) +repE (RecordUpd e flds _ _ _ _) = do { x <- repLE e; fs <- repUpdFields flds; repRecUpd x fs } diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index f514863791..deabf37d5b 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -7,6 +7,7 @@ This module converts Template Haskell syntax into HsSyn -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module Convert( convertToHsExpr, convertToPat, convertToHsDecls, convertToHsType, @@ -35,6 +36,7 @@ import Lexeme import Util import FastString import Outputable +--import TcEvidence import qualified Data.ByteString as BS import Control.Monad( unless, liftM, ap ) @@ -711,9 +713,11 @@ cvtl e = wrapL (cvt e) ; flds' <- mapM (cvtFld mkFieldOcc) flds ; return $ RecordCon c' noPostTcExpr (HsRecFields flds' Nothing)} cvt (RecUpdE e flds) = do { e' <- cvtl e - ; flds' <- mapM (cvtFld mkAmbiguousFieldOcc) flds - ; return $ RecordUpd e' flds' - PlaceHolder PlaceHolder PlaceHolder } + ; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds + ; return $ RecordUpd e' + flds' + PlaceHolder PlaceHolder + PlaceHolder PlaceHolder } cvt (StaticE e) = fmap HsStatic $ cvtl e cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar s' } diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 18756f632f..b1b6e62f31 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -257,7 +257,7 @@ data PatSynBind idL idR psb_def :: LPat idR, -- ^ Right-hand side psb_dir :: HsPatSynDir idR -- ^ Directionality } deriving (Typeable) -deriving instance (DataId idL, DataId idR ) +deriving instance (DataId idL, DataId idR) => Data (PatSynBind idL idR) {- @@ -525,6 +525,9 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL (is_infix, ppr_details) = case details of InfixPatSyn v1 v2 -> (True, hsep [ppr v1, pprInfixOcc psyn, ppr v2]) PrefixPatSyn vs -> (False, hsep (pprPrefixOcc psyn : map ppr vs)) + RecordPatSyn vs -> + (False, pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr vs)))) ppr_rhs = case dir of Unidirectional -> ppr_simple (ptext (sLit "<-")) @@ -625,7 +628,7 @@ data Sig name -- 'ApiAnnotation.AnnComma' -- For details on above see note [Api annotations] in ApiAnnotation - TypeSig + TypeSig [Located name] -- LHS of the signature; e.g. f,g,h :: blah (LHsType name) -- RHS of the signature (PostRn name [Name]) -- Wildcards (both named and anonymous) of the RHS @@ -897,37 +900,97 @@ pprMinimalSig bf = ptext (sLit "MINIMAL") <+> ppr (fmap unLoc bf) data HsPatSynDetails a = InfixPatSyn a a | PrefixPatSyn [a] - deriving (Data, Typeable) + | RecordPatSyn [RecordPatSynField a] + deriving (Typeable, Data) + + +-- See Note [Record PatSyn Fields] +data RecordPatSynField a + = RecordPatSynField { + recordPatSynSelectorId :: a -- Selector name visible in rest of the file + , recordPatSynPatVar :: a + -- Filled in by renamer, the name used internally + -- by the pattern + } deriving (Typeable, Data) + + + +{- +Note [Record PatSyn Fields] + +Consider the following two pattern synonyms. + +pattern P x y = ([x,True], [y,'v']) +pattern Q{ x, y } =([x,True], [y,'v']) + +In P, we just have two local binders, x and y. + +In Q, we have local binders but also top-level record selectors +x :: ([Bool], [Char]) -> Bool and similarly for y. + +It would make sense to support record-like syntax + +pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + +when we have a different name for the local and top-level binder +the distinction between the two names clear + +-} +instance Functor RecordPatSynField where + fmap f (RecordPatSynField visible hidden) = + RecordPatSynField (f visible) (f hidden) + +instance Outputable a => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField v _) = ppr v + +instance Foldable RecordPatSynField where + foldMap f (RecordPatSynField visible hidden) = + f visible `mappend` f hidden + +instance Traversable RecordPatSynField where + traverse f (RecordPatSynField visible hidden) = + RecordPatSynField <$> f visible <*> f hidden + instance Functor HsPatSynDetails where fmap f (InfixPatSyn left right) = InfixPatSyn (f left) (f right) fmap f (PrefixPatSyn args) = PrefixPatSyn (fmap f args) + fmap f (RecordPatSyn args) = RecordPatSyn (map (fmap f) args) instance Foldable HsPatSynDetails where foldMap f (InfixPatSyn left right) = f left `mappend` f right foldMap f (PrefixPatSyn args) = foldMap f args + foldMap f (RecordPatSyn args) = foldMap (foldMap f) args foldl1 f (InfixPatSyn left right) = left `f` right foldl1 f (PrefixPatSyn args) = Data.List.foldl1 f args + foldl1 f (RecordPatSyn args) = + Data.List.foldl1 f (map (Data.Foldable.foldl1 f) args) foldr1 f (InfixPatSyn left right) = left `f` right foldr1 f (PrefixPatSyn args) = Data.List.foldr1 f args + foldr1 f (RecordPatSyn args) = + Data.List.foldr1 f (map (Data.Foldable.foldr1 f) args) -- TODO: After a few more versions, we should probably use these. #if __GLASGOW_HASKELL__ >= 709 length (InfixPatSyn _ _) = 2 length (PrefixPatSyn args) = Data.List.length args + length (RecordPatSyn args) = Data.List.length args null (InfixPatSyn _ _) = False null (PrefixPatSyn args) = Data.List.null args + null (RecordPatSyn args) = Data.List.null args toList (InfixPatSyn left right) = [left, right] toList (PrefixPatSyn args) = args + toList (RecordPatSyn args) = foldMap toList args #endif instance Traversable HsPatSynDetails where traverse f (InfixPatSyn left right) = InfixPatSyn <$> f left <*> f right traverse f (PrefixPatSyn args) = PrefixPatSyn <$> traverse f args + traverse f (RecordPatSyn args) = RecordPatSyn <$> traverse (traverse f) args data HsPatSynDir id = Unidirectional diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index e51ca98daf..0b62d1f2c8 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -29,7 +29,7 @@ import CoreSyn import Var import Name import BasicTypes -import DataCon +import ConLike import SrcLoc import Util import StaticFlags( opt_PprStyle_Debug ) @@ -295,12 +295,15 @@ data HsExpr id [LHsRecUpdField id] -- (HsMatchGroup Id) -- Filled in by the type checker to be -- -- a match that does the job - (PostTc id [DataCon]) + (PostTc id [ConLike]) -- Filled in by the type checker to the -- _non-empty_ list of DataCons that have -- all the upd'd fields (PostTc id [Type]) -- Argument types of *input* record type (PostTc id [Type]) -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + (PostTc id HsWrapper) -- See note [Record Update HsWrapper] -- For a type family, the arg types are of the *instance* tycon, -- not the family tycon @@ -558,6 +561,32 @@ whereas that would not be possible using a all to a polymorphic function (because you can't call a polymorphic function at an unboxed type). So we use Nothing to mean "use the old built-in typing rule". + +Note [Record Update HsWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There is a wrapper in RecordUpd which is used for the *required* constraints for +pattern synonyms. This wrapper is created in the typechecking and is then +directly used in the desugaring without modification. + +For example, if we have the record pattern synonym P, + +``` +pattern P :: (Show a) => a -> Maybe a +pattern P{x} = Just x + +foo = (Just True) { x = False } +``` + +then `foo` desugars to something like + +``` +P x = P False +``` + +hence we need to provide the correct dictionaries to P on the RHS so that we can +build the expression. + -} instance OutputableBndr id => Outputable (HsExpr id) where @@ -701,7 +730,7 @@ ppr_expr (ExplicitPArr _ exprs) ppr_expr (RecordCon con_id _ rbinds) = hang (ppr con_id) 2 (ppr rbinds) -ppr_expr (RecordUpd aexp rbinds _ _ _) +ppr_expr (RecordUpd aexp rbinds _ _ _ _) = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) ppr_expr (ExprWithTySig expr sig _) diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 3b6b0faafd..be01baa4ea 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -860,20 +860,27 @@ hsForeignDeclsBinders foreign_decls = [ L decl_loc n | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls] + + ------------------- -hsPatSynBinders :: HsValBinds RdrName -> [Located RdrName] +hsPatSynBinders :: HsValBinds RdrName + -> ([Located RdrName], [Located RdrName]) -- Collect pattern-synonym binders only, not Ids -- See Note [SrcSpan for binders] -hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr [] binds +hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds hsPatSynBinders _ = panic "hsPatSynBinders" -addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL] +addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id]) + -> ([Located id], [Located id]) -- (selectors, other) -- See Note [SrcSpan for binders] -addPatSynBndr bind pss - | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind - = L bind_loc n : pss +addPatSynBndr bind (sels, pss) + | L bind_loc (PatSynBind (PSB { psb_id = L _ n + , psb_args = RecordPatSyn as })) <- bind + = (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss) + | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind + = (sels, L bind_loc n : pss) | otherwise - = pss + = (sels, pss) ------------------- hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs index 196c94ab58..ed44d2c73f 100644 --- a/compiler/hsSyn/PlaceHolder.hs +++ b/compiler/hsSyn/PlaceHolder.hs @@ -14,7 +14,8 @@ import NameSet import RdrName import Var import Coercion -import DataCon (DataCon) +import {-# SOURCE #-} ConLike (ConLike) +import TcEvidence (HsWrapper) import Data.Data hiding ( Fixity ) import BasicTypes (Fixity) @@ -108,5 +109,6 @@ type DataId id = , Data (PostTc id Coercion) , Data (PostTc id id) , Data (PostTc id [Type]) - , Data (PostTc id [DataCon]) + , Data (PostTc id [ConLike]) + , Data (PostTc id HsWrapper) ) diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index 945678a859..11873077ce 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -198,9 +198,12 @@ buildPatSyn :: Name -> Bool -> ([TyVar], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types -> Type -- ^ Result type + -> [FieldLabel] -- ^ Field labels for + -- a record pattern synonym -> PatSyn buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder - (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty + (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys + pat_ty field_labels = ASSERT((and [ univ_tvs == univ_tvs' , ex_tvs == ex_tvs' , pat_ty `eqType` pat_ty' @@ -211,7 +214,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder mkPatSyn src_name declared_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty - matcher builder + matcher builder field_labels where ((_:univ_tvs'), req_theta', tau) = tcSplitSigmaTy $ idType matcher_id ([pat_ty', cont_sigma, _], _) = tcSplitFunTys tau diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 42342aec85..8bf744f0c7 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -154,7 +154,8 @@ data IfaceDecl ifPatProvCtxt :: IfaceContext, ifPatReqCtxt :: IfaceContext, ifPatArgs :: [IfaceType], - ifPatTy :: IfaceType } + ifPatTy :: IfaceType, + ifFieldLabels :: [FieldLabel] } data IfaceTyConParent @@ -324,7 +325,7 @@ data IfaceUnfolding data IfaceIdDetails = IfVanillaId - | IfRecSelId IfaceTyCon Bool + | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool | IfDFunId {- @@ -1151,7 +1152,8 @@ freeNamesIfDecl d@IfacePatSyn{} = freeNamesIfContext (ifPatProvCtxt d) &&& freeNamesIfContext (ifPatReqCtxt d) &&& fnList freeNamesIfType (ifPatArgs d) &&& - freeNamesIfType (ifPatTy d) + freeNamesIfType (ifPatTy d) &&& + mkNameSet (map flSelector (ifFieldLabels d)) freeNamesIfAxBranch :: IfaceAxBranch -> NameSet freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars @@ -1162,7 +1164,8 @@ freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars freeNamesIfType rhs freeNamesIfIdDetails :: IfaceIdDetails -> NameSet -freeNamesIfIdDetails (IfRecSelId tc _) = freeNamesIfTc tc +freeNamesIfIdDetails (IfRecSelId tc _) = + either freeNamesIfTc freeNamesIfDecl tc freeNamesIfIdDetails _ = emptyNameSet -- All other changes are handled via the version info on the tycon @@ -1439,7 +1442,7 @@ instance Binary IfaceDecl where put_ bh a3 put_ bh a4 - put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10) = do + put_ bh (IfacePatSyn name a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do putByte bh 7 put_ bh (occNameFS name) put_ bh a2 @@ -1451,6 +1454,7 @@ instance Binary IfaceDecl where put_ bh a8 put_ bh a9 put_ bh a10 + put_ bh a11 get bh = do h <- getByte bh @@ -1516,8 +1520,9 @@ instance Binary IfaceDecl where a8 <- get bh a9 <- get bh a10 <- get bh + a11 <- get bh occ <- return $! mkDataOccFS a1 - return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10) + return (IfacePatSyn occ a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) instance Binary IfaceFamTyConFlav where diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 84d9fd99b5..df96f6a4af 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -526,7 +526,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) = do let hash_fn = mk_put_name local_env decl = abiDecl abi - -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do + --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do hash <- computeFingerprint hash_fn abi env' <- extend_hash_env local_env (hash,decl) return (env', (hash,decl) : decls_w_hashes) @@ -1522,6 +1522,7 @@ patSynToIfaceDecl ps , ifPatReqCtxt = tidyToIfaceContext env2 req_theta , ifPatArgs = map (tidyToIfaceType env2) args , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) } where (univ_tvs, req_theta, ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps @@ -1843,12 +1844,16 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn --------------------------- +--------------------------t toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n - , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n + , sel_tycon = tc }) = + let iface = case tc of + RecSelData ty_con -> Left (toIfaceTyCon ty_con) + RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) + in IfRecSelId iface n -- Currently we don't persist these three "advisory" IdInfos -- through interface files. We easily could if it mattered diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index c833ab07a8..1328b3c002 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -464,7 +464,8 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name , ifPatProvCtxt = prov_ctxt , ifPatReqCtxt = req_ctxt , ifPatArgs = args - , ifPatTy = pat_ty }) + , ifPatTy = pat_ty + , ifFieldLabels = field_labels }) = do { name <- lookupIfaceTop occ_name ; traceIf (ptext (sLit "tc_iface_decl") <+> ppr name) ; matcher <- tc_pr if_matcher @@ -478,7 +479,7 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = occ_name ; arg_tys <- mapM tcIfaceType args ; return $ buildPatSyn name is_infix matcher builder (univ_tvs, req_theta) (ex_tvs, prov_theta) - arg_tys pat_ty } + arg_tys pat_ty field_labels } ; return $ AConLike . PatSynCon $ patsyn }}} where mk_doc n = ptext (sLit "Pattern synonym") <+> ppr n @@ -1180,8 +1181,13 @@ tcIdDetails ty IfDFunId (_, _, cls, _) = tcSplitDFunTy ty tcIdDetails _ (IfRecSelId tc naughty) - = do { tc' <- tcIfaceTyCon tc + = do { tc' <- either (fmap RecSelData . tcIfaceTyCon) + (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False) + tc ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) } + where + tyThingPatSyn (AConLike (PatSynCon ps)) = ps + tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn" tcIdInfo :: Bool -> Name -> Type -> IfaceIdInfo -> IfL IdInfo tcIdInfo ignore_prags name ty info diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index a2a2f50224..fb65a67e6e 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -148,7 +148,7 @@ import VarEnv import VarSet import Var import Id -import IdInfo ( IdDetails(..) ) +import IdInfo ( IdDetails(..), RecSelParent(..)) import Type import ApiAnnotation ( ApiAnns ) @@ -1691,11 +1691,14 @@ implicitConLikeThings :: ConLike -> [TyThing] implicitConLikeThings (RealDataCon dc) = map AnId (dataConImplicitIds dc) -- For data cons add the worker and (possibly) wrapper - implicitConLikeThings (PatSynCon {}) = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher -- are not "implicit"; they are simply new top-level bindings, -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. implicitClassThings :: Class -> [TyThing] implicitClassThings cl @@ -1764,9 +1767,11 @@ tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of Just cls -> Just (ATyCon (classTyCon cls)) Nothing -> Nothing tyThingParent_maybe (AnId id) = case idDetails id of - RecSelId { sel_tycon = tc } -> Just (ATyCon tc) - ClassOpId cls -> Just (ATyCon (classTyCon cls)) - _other -> Nothing + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + ClassOpId cls -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing tyThingParent_maybe _other = Nothing tyThingsTyVars :: [TyThing] -> TyVarSet diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 895d1bfc57..7f8eb59f42 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1129,31 +1129,37 @@ role : VARID { sL1 $1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } : 'pattern' pattern_synonym_lhs '=' pat - {%ams ( let (name, args) = $2 - in sLL $1 $> . ValD $ mkPatSynBind name args $4 + {% let (name, args,as ) = $2 in + ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 ImplicitBidirectional) - [mj AnnPattern $1,mj AnnEqual $3] + (as ++ [mj AnnPattern $1, mj AnnEqual $3]) } | 'pattern' pattern_synonym_lhs '<-' pat - {%ams (let (name, args) = $2 - in sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) - [mj AnnPattern $1,mj AnnLarrow $3] } + {% let (name, args, as) = $2 in + ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 Unidirectional) + (as ++ [mj AnnPattern $1,mj AnnLarrow $3]) } | 'pattern' pattern_synonym_lhs '<-' pat where_decls - {% do { let (name, args) = $2 + {% do { let (name, args, as) = $2 ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5) ; ams (sLL $1 $> . ValD $ mkPatSynBind name args $4 (ExplicitBidirectional mg)) - (mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5)) + (as ++ ((mj AnnPattern $1:mj AnnLarrow $3:(fst $ unLoc $5))) ) }} -pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName)) } - : con vars0 { ($1, PrefixPatSyn $2) } - | varid conop varid { ($2, InfixPatSyn $1 $3) } +pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } + : con vars0 { ($1, PrefixPatSyn $2, []) } + | varid conop varid { ($2, InfixPatSyn $1 $3, []) } + | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) } vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } +cvars1 :: { [RecordPatSynField (Located RdrName)] } + : varid { [RecordPatSynField $1 $1] } + | varid ',' cvars1 {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >> + return ((RecordPatSynField $1 $1) : $3 )} + where_decls :: { Located ([AddAnn] , Located (OrdList (LHsDecl RdrName))) } : 'where' '{' decls '}' { sLL $1 $> ((mj AnnWhere $1:moc $2 diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index a1577a767e..af88e909b0 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -1192,7 +1192,7 @@ mkRecConstrOrUpdate (L l (HsVar c)) _ (fs,dd) mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") | otherwise = return (RecordUpd exp (map (fmap mk_rec_upd_field) fs) - PlaceHolder PlaceHolder PlaceHolder) + PlaceHolder PlaceHolder PlaceHolder PlaceHolder) mk_rec_fields :: [LHsRecField id arg] -> Bool -> HsRecFields id arg mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index 97c84cd9f9..e8a06e7ad4 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -103,7 +103,7 @@ import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import Module ( Module ) import Type ( mkTyConApp ) import DataCon -import ConLike +import {-# SOURCE #-} ConLike import Var import TyCon import Class ( Class, mkClass ) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index d63808edb6..1a24c11893 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -653,6 +653,18 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name ; name2 <- lookupVar var2 -- ; checkPrecMatch -- TODO ; return (InfixPatSyn name1 name2, mkFVs (map unLoc [name1, name2])) } + RecordPatSyn vars -> + do { checkDupRdrNames (map recordPatSynSelectorId vars) + ; let rnRecordPatSynField + (RecordPatSynField visible hidden) = do { + ; visible' <- lookupLocatedTopBndrRn visible + ; hidden' <- lookupVar hidden + ; return $ RecordPatSynField visible' hidden' } + ; names <- mapM rnRecordPatSynField vars + ; return (RecordPatSyn names + , mkFVs (map (unLoc . recordPatSynPatVar) names)) } + + ; return ((pat', details'), fvs) } ; (dir', fvs2) <- case dir of Unidirectional -> return (Unidirectional, emptyFVs) @@ -672,9 +684,13 @@ rnPatSynBind _sig_fn bind@(PSB { psb_id = L _ name , psb_def = pat' , psb_dir = dir' , psb_fvs = fvs' } + ; let selector_names = case details' of + RecordPatSyn names -> + map (unLoc . recordPatSynSelectorId) names + _ -> [] ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', [name], fvs1) + return (bind', name : selector_names , fvs1) -- See Note [Pattern synonym builders don't yield dependencies] } where diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index da6bf58b2c..b4c63f3d93 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -254,11 +254,13 @@ rnExpr (RecordCon con_id _ rbinds) ; return (RecordCon conname noPostTcExpr rbinds', fvRbinds `addOneFV` unLoc conname) } -rnExpr (RecordUpd expr rbinds _ _ _) +rnExpr (RecordUpd expr rbinds _ _ _ _) = do { (expr', fvExpr) <- rnLExpr expr ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds - ; return (RecordUpd expr' rbinds' PlaceHolder PlaceHolder PlaceHolder, - fvExpr `plusFV` fvRbinds) } + ; return (RecordUpd expr' rbinds' + PlaceHolder PlaceHolder + PlaceHolder PlaceHolder + , fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty PlaceHolder) = do { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index b517ce1cd4..12f9024331 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -7,7 +7,7 @@ {-# LANGUAGE CPP, NondecreasingIndentation #-} module RnNames ( - rnImports, getLocalNonValBinders, + rnImports, getLocalNonValBinders, newRecordSelector, rnExports, extendGlobalRdrEnvRn, gresFromAvails, calculateAvails, @@ -587,21 +587,12 @@ getLocalNonValBinders fixity_env new_tc overload_ok tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds ; let fld_env = case unLoc tc_decl of DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' _ -> [] ; return (AvailTC main_name names flds', fld_env) } - new_rec_sel :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel - new_rec_sel _ [] _ = error "new_rec_sel: datatype has no constructors!" - new_rec_sel overload_ok (dc:_) (L loc (FieldOcc fld _)) = - do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ - ; return $ fl { flSelector = sel_name } } - where - lbl = occNameFS $ rdrNameOcc fld - fl = mkFieldLabelOccs lbl (nameOccName dc) overload_ok - sel_occ = flSelector fl -- Calculate the mapping from constructor names to fields, which -- will go in tcg_field_env. It's convenient to do this here where @@ -652,7 +643,7 @@ getLocalNonValBinders fixity_env = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) ; let (bndrs, flds) = hsDataFamInstBinders ti_decl ; sub_names <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (new_rec_sel overload_ok sub_names) flds + ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds ; let avail = AvailTC (unLoc main_name) sub_names flds' -- main_name is not bound here! fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds' @@ -662,6 +653,16 @@ getLocalNonValBinders fixity_env -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d +newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel +newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" +newRecordSelector overload_ok (dc:_) (L loc (FieldOcc fld _)) = + do { sel_name <- newTopSrcBinder $ L loc $ mkRdrUnqual sel_occ + ; return $ fl { flSelector = sel_name } } + where + lbl = occNameFS $ rdrNameOcc fld + fl = mkFieldLabelOccs lbl (nameOccName dc) overload_ok + sel_occ = flSelector fl + {- Note [Looking up family names in family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -959,7 +960,7 @@ trimAvail :: AvailInfo -> Name -> AvailInfo trimAvail (Avail n) _ = Avail n trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of Just x -> AvailTC n [] [x] - Nothing -> ASSERT(m `elem` ns) AvailTC n [m] [] + Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] -- | filters 'AvailInfo's by the given predicate filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] @@ -1159,6 +1160,7 @@ rnExports explicit_mod exports -- turns out to be out of scope ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; traceRn (ppr avails) ; let final_avails = nubAvails avails -- Combine families final_ns = availsToNameSetWithSelectors final_avails @@ -1186,7 +1188,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod | gre <- globalRdrEnvElts rdr_env , isLocalGRE gre ] in - return (Nothing, avails) + return (Nothing, avails) exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod = do (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 286b431482..90bf09a708 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -16,6 +16,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr ) import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls ) import HsSyn +import FieldLabel import RdrName import RnTypes import RnBinds @@ -105,6 +106,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ; + setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -112,9 +114,8 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- (D1) Bring pattern synonyms into scope. -- Need to do this before (D2) because rnTopBindsLHS -- looks up those pattern synonyms (Trac #9889) - pat_syn_bndrs <- mapM newTopSrcBinder (hsPatSynBinders val_decls) ; - tc_envs <- extendGlobalRdrEnvRn (map Avail pat_syn_bndrs) local_fix_env ; - setEnvs tc_envs $ do { + + extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { -- (D2) Rename the left-hand sides of the value bindings. -- This depends on everything from (B) being in scope, @@ -127,6 +128,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- They are already in scope traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ; tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ; + traceRn (text "D2" <+> ppr (tcg_rdr_env (fst tc_envs))); setEnvs tc_envs $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -209,7 +211,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, in -- we return the deprecs in the env, not in the HsGroup above tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns }; } ; - + traceRn (text "last" <+> ppr (tcg_rdr_env final_tcg_env)) ; traceRn (text "finish rnSrc" <+> ppr rn_group) ; traceRn (text "finish Dus" <+> ppr src_dus ) ; return (final_tcg_env, rn_group) @@ -1538,6 +1540,48 @@ deprecRecSyntax decl badRecResTy :: SDoc -> SDoc badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc +-- | Brings pattern synonym names and also pattern synonym selectors +-- from record pattern synonyms into scope. +extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv + -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a +extendPatSynEnv val_decls local_fix_env thing = do { + names_with_fls <- new_ps val_decls + ; let pat_syn_bndrs = + concat [name: map flSelector fields | (name, fields) <- names_with_fls] + ; let avails = map Avail pat_syn_bndrs + ; (gbl_env, lcl_env) <- + extendGlobalRdrEnvRn avails local_fix_env + + + ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls + final_gbl_env = gbl_env { tcg_field_env = field_env' } + ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } + where + new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])] + new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds + new_ps _ = panic "new_ps" + + new_ps' :: LHsBindLR RdrName RdrName + -> [(Name, [FieldLabel])] + -> TcM [(Name, [FieldLabel])] + new_ps' bind names + | L bind_loc (PatSynBind (PSB { psb_id = L _ n + , psb_args = RecordPatSyn as })) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + let rnames = map recordPatSynSelectorId as + mkFieldOcc :: Located RdrName -> LFieldOcc RdrName + mkFieldOcc (L l name) = L l (FieldOcc name PlaceHolder) + field_occs = map mkFieldOcc rnames + flds <- mapM (newRecordSelector False [bnd_name]) field_occs + return ((bnd_name, flds): names) + | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind + = do + bnd_name <- newTopSrcBinder (L bind_loc n) + return ((bnd_name, []): names) + | otherwise + = return names + {- ********************************************************* * * diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index d939ad3ed3..217739201b 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -48,6 +48,7 @@ import NameSet import NameEnv import SrcLoc import Bag +import PatSyn import ListSetOps import ErrUtils import Digraph @@ -472,12 +473,13 @@ tc_single :: forall thing. -> LHsBind Name -> TcM thing -> TcM (LHsBinds TcId, thing) tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside - = do { (pat_syn, aux_binds) <- tc_pat_syn_decl + = do { (pat_syn, aux_binds, tcg_env) <- tc_pat_syn_decl ; let tything = AConLike (PatSynCon pat_syn) - ; thing <- tcExtendGlobalEnv [tything] thing_inside + ; thing <- setGblEnv tcg_env $ tcExtendGlobalEnv [tything] thing_inside ; return (aux_binds, thing) } where + tc_pat_syn_decl :: TcM (PatSyn, LHsBinds TcId, TcGblEnv) tc_pat_syn_decl = case sig_fn name of Nothing -> tcInferPatSynDecl psb Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi @@ -971,7 +973,7 @@ From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE: RULE: forall b (d:Num b). f b d = f_spec b The RULE is generated by taking apart the HsWrapper, which is a little -delicate, but works. +delicate, but works. Some wrinkles diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index e6cc5d1bf6..dd765ca41e 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -7,6 +7,7 @@ c% -} {-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, @@ -32,14 +33,16 @@ import TcEnv import TcArrows import TcMatches import TcHsType -import TcPatSyn( tcPatSynBuilderOcc ) +import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr ) import TcPat import TcMType import TcType import DsMonad import Id +import IdInfo import ConLike import DataCon +import PatSyn import Name import RdrName import TyCon @@ -535,20 +538,21 @@ to support expressions like this: -} tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty - = do { data_con <- tcLookupDataCon con_name + = do { con_like <- tcLookupConLike con_name -- Check for missing fields - ; checkMissingFields data_con rbinds + ; checkMissingFields con_like rbinds ; (con_expr, con_tau) <- tcInferId con_name - ; let arity = dataConSourceArity data_con + ; let arity = conLikeArity con_like (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity - con_id = dataConWrapId data_con - - ; co_res <- unifyType actual_res_ty res_ty - ; rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; return $ mkHsWrapCo co_res $ - RecordCon (L loc con_id) con_expr rbinds' } + ; case conLikeWrapId_maybe con_like of + Nothing -> nonBidirectionalErr (conLikeName con_like) + Just con_id -> do { + co_res <- unifyType actual_res_ty res_ty + ; rbinds' <- tcRecordBinds con_like arg_tys rbinds + ; return $ mkHsWrapCo co_res $ + RecordCon (L loc con_id) con_expr rbinds' } } {- Note [Type of a record update] @@ -651,51 +655,108 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys): * in_inst_tys, out_inst_tys have same length, and instantiate the *representation* tycon of the data cons. In Note [Data family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2] + +Note [Mixed Record Field Updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider the following pattern synonym. + + data MyRec = MyRec { foo :: Int, qux :: String } + + pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +This allows updates such as the following + + updater :: MyRec -> MyRec + updater a = a {f1 = 1 } + +It would also make sense to allow the following update (which we reject). + + updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two" + +This leads to confusing behaviour when the selectors in fact refer the same +field. + + updater a = a {f1 = 1, foo = 2} ==? ??? + +For this reason, we reject a mixture of pattern synonym and normal record +selectors in the same update block. Although of course we still allow the +following. + + updater a = (a {f1 = 1}) {foo = 2} + + > updater (MyRec 0 "str") + MyRec 2 "str" + -} -tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty - = ASSERT( notNull rbnds ) do { +tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty + = ASSERT( notNull rbnds ) + do { -- STEP -1 See Note [Disambiguating record updates] -- After this we know that rbinds is unambiguous rbinds <- disambiguateRecordBinds record_expr rbnds res_ty ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds - -- STEP 0 -- Check that the field names are really field names - -- The renamer has already checked that - -- selectors are all in scope + -- and they are all field names for proper records or + -- all field names for pattern synonyms. ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name) | fld <- rbinds, + -- Excludes class ops let L loc sel_id = hsRecUpdFieldId (unLoc fld), - not (isRecordSelector sel_id), -- Excludes class ops + not (isRecordSelector sel_id), let fld_name = idName sel_id ] ; unless (null bad_guys) (sequence bad_guys >> failM) + -- See note [Mixed Record Selectors] + ; let (data_sels, pat_syn_sels) = + partition isDataConRecordSelector sel_ids + ; MASSERT( all isPatSynRecordSelector pat_syn_sels ) + ; checkTc ( null data_sels || null pat_syn_sels ) + ( mixedSelectors data_sels pat_syn_sels ) -- STEP 1 -- Figure out the tycon and data cons from the first field name ; let -- It's OK to use the non-tc splitters here (for a selector) sel_id : _ = sel_ids - tycon = recordSelectorTyCon sel_id -- We've failed already if - data_cons = tyConDataCons tycon -- it's not a field label + mtycon = + case idDetails sel_id of + RecSelId (RecSelData tycon) _ -> Just tycon + _ -> Nothing + con_likes = + case idDetails sel_id of + RecSelId (RecSelData tc) _ -> + map RealDataCon (tyConDataCons tc) + RecSelId (RecSelPatSyn ps) _ -> + [PatSynCon ps] + _ -> panic "tcRecordUpd" -- NB: for a data type family, the tycon is the instance tycon - relevant_cons = tyConDataConsWithFields tycon upd_fld_occs + relevant_cons = conLikesWithFields con_likes upd_fld_occs -- A constructor is only relevant to this process if -- it contains *all* the fields that are being updated -- Other ones will cause a runtime error if they occur - -- Take apart a representative constructor - con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 - con1_flds = map flLabel $ dataConFieldLabels con1 - con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) - -- Step 2 -- Check that at least one constructor has all the named fields -- i.e. has an empty set of bad fields returned by badFields - ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons) + ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes) + + -- Take apart a representative constructor + ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons + (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _) = + conLikeFullSig con1 + con1_flds = map flLabel $ conLikeFieldLabels con1 + def_res_ty = conLikeResTy con1 + con1_res_ty = + (maybe def_res_ty mkFamilyTyConApp mtycon) (mkTyVarTys con1_tvs) + + -- Check that we're not dealing with a unidirectional pattern + -- synonym + ; unless (isJust $ conLikeWrapId_maybe con1) + (nonBidirectionalErr (conLikeName con1)) -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type @@ -745,18 +806,25 @@ tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds -- STEP 6: Deal with the stupid theta - ; let theta' = substTheta scrut_subst (dataConStupidTheta con1) + ; let theta' = substTheta scrut_subst (conLikeStupidTheta con1) ; instStupidTheta RecordUpdOrigin theta' -- Step 7: make a cast for the scrutinee, in the case that it's from a type family - ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon + ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe =<< mtycon = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys) | otherwise = idHsWrapper + + -- Step 8: Check that the req constraints are satisfied + -- For normal data constructors req_theta is empty but we must do + -- this check for pattern synonyms. + ; let req_theta' = substTheta scrut_subst req_theta + ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta' + -- Phew! ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' - relevant_cons scrut_inst_tys result_inst_tys } + relevant_cons scrut_inst_tys result_inst_tys req_wrap } tcExpr (HsSingleRecFld f) res_ty = tcCheckRecSelId f res_ty @@ -1314,12 +1382,17 @@ naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds. ************************************************************************ -} -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [DataCon] -> TyVarSet +getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet -- These tyvars must not change across the updates -getFixedTyVars upd_fld_occs tvs1 cons +getFixedTyVars upd_fld_occs univ_tvs cons = mkVarSet [tv1 | con <- cons - , let (tvs, theta, arg_tys, _) = dataConSig con - flds = dataConFieldLabels con + , let (u_tvs, _, eqspec, prov_theta + , req_theta, arg_tys, _) + = conLikeFullSig con + theta = eqSpecPreds eqspec + ++ prov_theta + ++ req_theta + flds = conLikeFieldLabels con fixed_tvs = exactTyVarsOfTypes fixed_tys -- fixed_tys: See Note [Type of a record update] `unionVarSet` tyVarsOfTypes theta @@ -1330,7 +1403,7 @@ getFixedTyVars upd_fld_occs tvs1 cons fixed_tys = [ty | (fl, ty) <- zip flds arg_tys , not (flLabel fl `elem` upd_fld_occs)] - , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs + , (tv1,tv) <- univ_tvs `zip` u_tvs , tv `elemVarSet` fixed_tvs ] {- @@ -1403,15 +1476,15 @@ disambiguateRecordBinds record_expr rbnds res_ty Just rbnds' -> lookupSelectors rbnds' Nothing -> do { fam_inst_envs <- tcGetFamInstEnvs - ; rbnds_with_parents <- fmap (zip rbnds) $ mapM getParents rbnds - ; p <- case possibleParents rbnds_with_parents of + ; (rbnds_with_parents) <- fmap (zip rbnds) $ mapM getParents rbnds + ; (p :: RecSelParent) <- case possibleParents (map snd rbnds_with_parents) of [] -> failWithTc (noPossibleParents rbnds) [p] -> return p - _ | Just p <- tyConOf fam_inst_envs res_ty -> return p + _ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p) _ | Just sig_ty <- obviousSig (unLoc record_expr) -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty ; case tyConOf fam_inst_envs sig_tc_ty of - Just p -> return p + Just p -> return (RecSelData p) Nothing -> failWithTc badOverloadedUpdate } _ -> failWithTc badOverloadedUpdate ; assignParent p rbnds_with_parents } @@ -1439,17 +1512,17 @@ disambiguateRecordBinds record_expr rbnds res_ty -- Calculate the list of possible parent tycons, by taking the -- intersection of the possibilities for each field. - possibleParents :: [(LHsRecUpdField Name, [(TyCon, a)])] -> [TyCon] - possibleParents = foldr1 intersect . map (\ (_, xs) -> map fst xs) + possibleParents :: [[(RecSelParent, a)]] -> [RecSelParent] + possibleParents = foldr1 intersect . map (map fst) -- Look up the parent tycon for each candidate record selector. - getParents :: LHsRecUpdField Name -> RnM [(TyCon, GlobalRdrElt)] + getParents :: LHsRecUpdField Name -> RnM [(RecSelParent, GlobalRdrElt)] getParents (L _ fld) = do { env <- getGlobalRdrEnv ; let gres = lookupGRE_RdrName (unLoc (hsRecUpdFieldRdr fld)) env ; mapM lookupParent gres } - lookupParent :: GlobalRdrElt -> RnM (TyCon, GlobalRdrElt) + lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) lookupParent gre = do { id <- tcLookupId (gre_name gre) ; ASSERT(isRecordSelector id) return (recordSelectorTyCon id, gre) } @@ -1459,7 +1532,7 @@ disambiguateRecordBinds record_expr rbnds res_ty -- that parent, e.g. if the user writes -- r { x = e } :: T -- where T does not have field x. - assignParent :: TyCon -> [(LHsRecUpdField Name, [(TyCon, GlobalRdrElt)])] + assignParent :: RecSelParent -> [(LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])] -> RnM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] assignParent p rbnds | null orphans = do rbnds'' <- mapM f rbnds' @@ -1478,7 +1551,7 @@ disambiguateRecordBinds record_expr rbnds res_ty ; return (fld, gre_name gre) } -- Returns Right if fld can have parent p, or Left lbl if not. - pickParent :: (LHsRecUpdField Name, [(TyCon, GlobalRdrElt)]) + pickParent :: (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)]) -> Either (Located RdrName) (LHsRecUpdField Name, GlobalRdrElt, Bool) pickParent (fld, xs) = case lookup p xs of @@ -1512,36 +1585,38 @@ This extends OK when the field types are universally quantified. -} tcRecordBinds - :: DataCon + :: ConLike -> [TcType] -- Expected type for each field -> HsRecordBinds Name -> TcM (HsRecordBinds TcId) -tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) +tcRecordBinds con_like arg_tys (HsRecFields rbinds dd) = do { mb_binds <- mapM do_bind rbinds ; return (HsRecFields (catMaybes mb_binds) dd) } where - flds_w_tys = zipEqual "tcRecordBinds" (map flLabel $ dataConFieldLabels data_con) arg_tys + fields = map flLabel $ conLikeFieldLabels con_like + flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys - do_bind :: LHsRecField Name (LHsExpr Name) -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId))) + do_bind :: LHsRecField Name (LHsExpr Name) + -> TcM (Maybe (LHsRecField TcId (LHsExpr TcId))) do_bind (L l fld@(HsRecField { hsRecFieldLbl = f , hsRecFieldArg = rhs })) - = do { mb <- tcRecordField data_con flds_w_tys f rhs + = do { mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f' , hsRecFieldArg = rhs' }))) } tcRecordUpd - :: DataCon + :: ConLike -> [TcType] -- Expected type for each field -> [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -> TcM [LHsRecUpdField TcId] -tcRecordUpd data_con arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds +tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds where - flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ dataConFieldLabels data_con) arg_tys + flds_w_tys = zipEqual "tcRecordUpd" (map flLabel $ conLikeFieldLabels con_like) arg_tys do_bind :: LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name) -> TcM (Maybe (LHsRecUpdField TcId)) do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af @@ -1549,15 +1624,15 @@ tcRecordUpd data_con arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds = do { let lbl = rdrNameAmbiguousFieldOcc af sel_id = selectorAmbiguousFieldOcc af f = L loc (FieldOcc lbl (idName sel_id)) - ; mb <- tcRecordField data_con flds_w_tys f rhs + ; mb <- tcRecordField con_like flds_w_tys f rhs ; case mb of Nothing -> return Nothing Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = L loc (Unambiguous lbl (selectorFieldOcc (unLoc f'))) , hsRecFieldArg = rhs' }))) } -tcRecordField :: DataCon -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name +tcRecordField :: ConLike -> Assoc FieldLabelString Type -> LFieldOcc Name -> LHsExpr Name -> TcM (Maybe (LFieldOcc Id, LHsExpr Id)) -tcRecordField data_con flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs +tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs | Just field_ty <- assocMaybe flds_w_tys field_lbl = addErrCtxt (fieldCtxt field_lbl) $ do { rhs' <- tcPolyExprNC rhs field_ty @@ -1569,30 +1644,30 @@ tcRecordField data_con flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs -- but is a LocalId with the appropriate type of the RHS -- (so the desugarer knows the type of local binder to make) ; return (Just (L loc (FieldOcc lbl field_id), rhs')) } - | otherwise - = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl) + | otherwise + = do { addErrTc (badFieldCon con_like field_lbl) ; return Nothing } where field_lbl = occNameFS $ rdrNameOcc lbl -checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () -checkMissingFields data_con rbinds +checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM () +checkMissingFields con_like rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields = if any isBanged field_strs then -- Illegal if any arg is strict - addErrTc (missingStrictFields data_con []) + addErrTc (missingStrictFields con_like []) else return () | otherwise = do -- A record unless (null missing_s_fields) - (addErrTc (missingStrictFields data_con missing_s_fields)) + (addErrTc (missingStrictFields con_like missing_s_fields)) warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) - (warnTc True (missingFields data_con missing_ns_fields)) + (warnTc True (missingFields con_like missing_ns_fields)) where missing_s_fields @@ -1607,13 +1682,13 @@ checkMissingFields data_con rbinds ] field_names_used = hsRecFields rbinds - field_labels = dataConFieldLabels data_con + field_labels = conLikeFieldLabels con_like field_info = zipEqual "missingFields" field_labels field_strs - field_strs = dataConImplBangs data_con + field_strs = conLikeImplBangs con_like fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds @@ -1683,7 +1758,7 @@ badFieldTypes prs badFieldsUpd :: [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)] -- Field names that don't belong to a single datacon - -> [DataCon] -- Data cons of the type which the first field name belongs to + -> [ConLike] -- Data cons of the type which the first field name belongs to -> SDoc badFieldsUpd rbinds data_cons = hang (ptext (sLit "No constructor has all these fields:")) @@ -1720,7 +1795,7 @@ badFieldsUpd rbinds data_cons map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds fieldLabelSets :: [Set.Set FieldLabelString] - fieldLabelSets = map (Set.fromList . map flLabel . dataConFieldLabels) data_cons + fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons -- Sort in order of increasing number of True, so that a smaller -- conflicting set can be found. @@ -1766,7 +1841,25 @@ notSelector :: Name -> SDoc notSelector field = hsep [quotes (ppr field), ptext (sLit "is not a record selector")] -missingStrictFields :: DataCon -> [FieldLabelString] -> SDoc +mixedSelectors :: [Id] -> [Id] -> SDoc +mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) + = ptext + (sLit "Cannot use a mixture of pattern synonym and record selectors") $$ + ptext (sLit "Record selectors defined by") + <+> quotes (ppr (tyConName rep_dc)) + <> text ":" + <+> pprWithCommas ppr data_sels $$ + ptext (sLit "Pattern synonym selectors defined by") + <+> quotes (ppr (patSynName rep_ps)) + <> text ":" + <+> pprWithCommas ppr pat_syn_sels + where + RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id + RecSelData rep_dc = recordSelectorTyCon dc_rep_id +mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists" + + +missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc missingStrictFields con fields = header <> rest where @@ -1777,7 +1870,7 @@ missingStrictFields con fields header = ptext (sLit "Constructor") <+> quotes (ppr con) <+> ptext (sLit "does not have the required strict field(s)") -missingFields :: DataCon -> [FieldLabelString] -> SDoc +missingFields :: ConLike -> [FieldLabelString] -> SDoc missingFields con fields = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:") <+> pprWithCommas ppr fields @@ -1794,7 +1887,7 @@ noPossibleParents rbinds badOverloadedUpdate :: SDoc badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature") -orphanFields :: TyCon -> [Located RdrName] -> SDoc +orphanFields :: RecSelParent -> [Located RdrName] -> SDoc orphanFields p flds = hang (ptext (sLit "Type") <+> ppr p <+> ptext (sLit "does not have field") <> plural flds <> colon) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index e40ad392df..5aa797c4c2 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -45,7 +45,6 @@ import TysWiredIn import Type import ConLike import DataCon -import PatSyn( patSynInstResTy ) import Name import NameSet import Var @@ -99,9 +98,6 @@ hsPatType (NPlusKPat id _ _ _) = idType (unLoc id) hsPatType (CoPat _ _ ty) = ty hsPatType p = pprPanic "hsPatType" (ppr p) -conLikeResTy :: ConLike -> [Type] -> Type -conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys -conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys hsLitType :: HsLit -> TcType hsLitType (HsChar _ _) = charTy @@ -302,8 +298,8 @@ zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) zonkTopLExpr e = zonkLExpr emptyZonkEnv e zonkTopDecls :: Bag EvBind - -> LHsBinds TcId - -> Maybe (Located [LIE RdrName]) + -> LHsBinds TcId + -> Maybe (Located [LIE RdrName]) -> NameSet -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] -> TcM ([Id], @@ -713,12 +709,14 @@ zonkExpr env (RecordCon data_con con_expr rbinds) ; new_rbinds <- zonkRecFields env rbinds ; return (RecordCon data_con new_con_expr new_rbinds) } -zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys) +zonkExpr env (RecordUpd expr rbinds cons in_tys out_tys req_wrap) = do { new_expr <- zonkLExpr env expr ; new_in_tys <- mapM (zonkTcTypeToType env) in_tys ; new_out_tys <- mapM (zonkTcTypeToType env) out_tys ; new_rbinds <- zonkRecUpdFields env rbinds - ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys) } + ; (_, new_recwrap) <- zonkCoFn env req_wrap + ; return (RecordUpd new_expr new_rbinds cons new_in_tys new_out_tys + new_recwrap) } zonkExpr env (ExprWithTySigOut e ty) = do { e' <- zonkLExpr env e @@ -1509,7 +1507,7 @@ zonkCoToCo env co do { (env', tv') <- zonkTyBndrX env tv ; co' <- zonkCoToCo env' co ; return (mkForAllCo tv' co') } - + zonkTvCollecting :: TcRef TyVarSet -> UnboundTyVarZonker -- This variant collects unbound type variables in a mutable variable -- Works on both types and kinds diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index e39b0f51c6..c73bf6dda2 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -1069,9 +1069,9 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside [] -> failWith (badFieldCon con_like lbl) -- The normal case, when the field comes from the right constructor - (pat_ty : extras) -> - ASSERT( null extras ) - return pat_ty + (pat_ty : extras) -> do + traceTc "find_field" (ppr pat_ty <+> ppr extras) + ASSERT( null extras ) (return pat_ty) field_tys :: [(FieldLabel, TcType)] field_tys = zip (conLikeFieldLabels con_like) arg_tys diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 121a898d01..38724607a3 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -8,7 +8,7 @@ {-# LANGUAGE CPP #-} module TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl - , tcPatSynBuilderBind, tcPatSynBuilderOcc + , tcPatSynBuilderBind, tcPatSynBuilderOcc, nonBidirectionalErr ) where import HsSyn @@ -17,6 +17,7 @@ import TcRnMonad import TcEnv import TcMType import TysPrim +import TypeRep import Name import SrcLoc import PatSyn @@ -26,7 +27,7 @@ import Outputable import FastString import Var import Id -import IdInfo( IdDetails(..) ) +import IdInfo( IdDetails(..), RecSelParent(..)) import TcBinds import BasicTypes import TcSimplify @@ -38,6 +39,9 @@ import VarSet import MkId import VarEnv import Inst +import TcTyClsDecls +import ConLike +import FieldLabel #if __GLASGOW_HASKELL__ < 709 import Data.Monoid #endif @@ -57,16 +61,15 @@ import Control.Monad (forM) -} tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (PatSyn, LHsBinds Id) + -> TcM (PatSyn, LHsBinds Id, TcGblEnv) tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, psb_def = lpat, psb_dir = dir } = setSrcSpan loc $ do { traceTc "tcInferPatSynDecl {" $ ppr name ; tcCheckPatSynPat lpat - ; let (arg_names, is_infix) = case details of - PrefixPatSyn names -> (map unLoc names, False) - InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) + ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details + ; ((lpat', (args, pat_ty)), tclvl, wanted) <- pushLevelAndCaptureConstraints $ do { pat_ty <- newFlexiTyVarTy openTypeKind @@ -89,11 +92,12 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, (univ_tvs, req_theta, ev_binds, req_dicts) (ex_tvs, map mkTyVarTy ex_tvs, prov_theta, emptyTcEvBinds, prov_dicts) (zip args $ repeat idHsWrapper) - pat_ty } + pat_ty rec_fields } + tcCheckPatSynDecl :: PatSynBind Name Name -> TcPatSynInfo - -> TcM (PatSyn, LHsBinds Id) + -> TcM (PatSyn, LHsBinds Id, TcGblEnv) tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, psb_def = lpat, psb_dir = dir } TPSI{ patsig_tau = tau, @@ -112,9 +116,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, -- TODO: find a better SkolInfo ; let skol_info = SigSkol (PatSynCtxt name) (mkFunTys arg_tys pat_ty) - ; let (arg_names, is_infix) = case details of - PrefixPatSyn names -> (map unLoc names, False) - InfixPatSyn name1 name2 -> (map unLoc [name1, name2], True) + ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details ; let ty_arity = length arg_tys ; checkTc (length arg_names == ty_arity) @@ -162,10 +164,25 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details, (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, ex_tys, prov_theta, prov_ev_binds, prov_dicts) wrapped_args - pat_ty } + pat_ty rec_fields } where (arg_tys, pat_ty) = tcSplitFunTys tau +collectPatSynArgInfo :: HsPatSynDetails (Located Name) -> ([Name], [Name], Bool) +collectPatSynArgInfo details = + case details of + PrefixPatSyn names -> (map unLoc names, [], False) + InfixPatSyn name1 name2 -> (map unLoc [name1, name2], [], True) + RecordPatSyn names -> + let (vars, sels) = unzip (map splitRecordPatSyn names) + in (vars, sels, False) + + where + splitRecordPatSyn :: RecordPatSynField (Located Name) -> (Name, Name) + splitRecordPatSyn (RecordPatSynField { recordPatSynPatVar = L _ patVar + , recordPatSynSelectorId = L _ selId }) + = (patVar, selId) + wrongNumberOfParmsErr :: Arity -> SDoc wrongNumberOfParmsErr ty_arity = ptext (sLit "Number of pattern synonym arguments doesn't match type; expected") @@ -173,20 +190,22 @@ wrongNumberOfParmsErr ty_arity ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name - -> HsPatSynDir Name - -> Bool - -> LPat Id +tc_patsyn_finish :: Located Name -- ^ PatSyn Name + -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) + -> Bool -- ^ Whether infix + -> LPat Id -- ^ Pattern of the PatSyn -> ([TcTyVar], [PredType], TcEvBinds, [EvVar]) -> ([TcTyVar], [TcType], [PredType], TcEvBinds, [EvVar]) - -> [(Var, HsWrapper)] - -> TcType - -> TcM (PatSyn, LHsBinds Id) + -> [(Var, HsWrapper)] -- ^ Pattern arguments + -> TcType -- ^ Pattern type + -> [Name] -- ^ Selector names + -- ^ Whether fields, empty if not record PatSyn + -> TcM (PatSyn, LHsBinds Id, TcGblEnv) tc_patsyn_finish lname dir is_infix lpat' (univ_tvs, req_theta, req_ev_binds, req_dicts) (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) wrapped_args - pat_ty + pat_ty field_labels = do { -- Zonk everything. We are about to build a final PatSyn -- so there had better be no unification variables in there univ_tvs <- mapM zonkQuantifiedTyVar univ_tvs @@ -196,10 +215,13 @@ tc_patsyn_finish lname dir is_infix lpat' ; pat_ty <- zonkTcType pat_ty ; wrapped_args <- mapM zonk_wrapped_arg wrapped_args ; let qtvs = univ_tvs ++ ex_tvs + -- See Note [Record PatSyn Desugaring] theta = prov_theta ++ req_theta arg_tys = map (varType . fst) wrapped_args - ; traceTc "tc_patsyn_finish {" $ + ; (patSyn, matcher_bind) <- fixM $ \ ~(patSyn,_) -> do { + + traceTc "tc_patsyn_finish {" $ ppr (unLoc lname) $$ ppr (unLoc lpat') $$ ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$ ppr (ex_tvs, subst, prov_theta, prov_ev_binds, prov_dicts) $$ @@ -213,18 +235,37 @@ tc_patsyn_finish lname dir is_infix lpat' wrapped_args -- Not necessarily zonked pat_ty + -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname qtvs theta arg_tys pat_ty + ; builder_id <- mkPatSynBuilderId dir lname qtvs theta + arg_tys pat_ty patSyn + + -- TODO: Make this have the proper information + ; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name + field_labels' = (map mkFieldLabel field_labels) + -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix + ; let patSyn' = mkPatSyn (unLoc lname) is_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty matcher_id builder_id + field_labels' + ; return (patSyn', matcher_bind) } + + -- Selectors + ; let (sigs, selector_binds) = + unzip (mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)) + ; let tything = AConLike (PatSynCon patSyn) + ; tcg_env <- + tcExtendGlobalEnv [tything] $ + tcRecSelBinds + (ValBindsOut (zip (repeat NonRecursive) selector_binds) sigs) + + ; return (patSyn, matcher_bind, tcg_env) } - ; return (patSyn, matcher_bind) } where zonk_wrapped_arg :: (Var, HsWrapper) -> TcM (Var, HsWrapper) -- The HsWrapper will get zonked later, as part of the LHsBinds @@ -323,6 +364,12 @@ tcPatSynMatcher (L loc name) lpat ; return ((matcher_id, is_unlifted), matcher_bind) } +mkPatSynRecSelBinds :: PatSyn + -> [FieldLabel] + -- ^ Visible field labels + -> [(LSig Name, LHsBinds Name)] +mkPatSynRecSelBinds ps fields = + map (mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps)) fields isUnidirectional :: HsPatSynDir a -> Bool isUnidirectional Unidirectional = True @@ -338,16 +385,18 @@ isUnidirectional ExplicitBidirectional{} = False -} mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [TyVar] -> ThetaType -> [Type] -> Type + -> [TyVar] -> ThetaType -> [Type] -> Type -> PatSyn -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty +mkPatSynBuilderId dir (L _ name) qtvs theta arg_tys pat_ty pat_syn | isUnidirectional dir = return Nothing | otherwise = do { builder_name <- newImplicitBinder name mkBuilderOcc ; let builder_sigma = mkSigmaTy qtvs theta (mkFunTys builder_arg_tys pat_ty) - builder_id = mkExportedLocalId VanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in Id + builder_id = + -- See Note [Exported LocalIds] in Id + mkExportedLocalId (PatSynBuilderId pat_syn) + builder_name builder_sigma ; return (Just (builder_id, need_dummy_arg)) } where builder_arg_tys | need_dummy_arg = [voidPrimTy] @@ -405,6 +454,7 @@ tcPatSynBuilderBind PSB{ psb_id = L loc name, psb_def = lpat args = case details of PrefixPatSyn args -> args InfixPatSyn arg1 arg2 -> [arg1, arg2] + RecordPatSyn args -> map recordPatSynPatVar args add_dummy_arg :: MatchGroup Name (LHsExpr Name) -> MatchGroup Name (LHsExpr Name) add_dummy_arg mg@(MG { mg_alts = [L loc (Match Nothing [] ty grhss)] }) @@ -424,9 +474,7 @@ tcPatSynBuilderOcc orig ps else return ( inst_fun, rho ) } | otherwise -- Unidirectional - = failWithTc $ - ptext (sLit "non-bidirectional pattern synonym") - <+> quotes (ppr name) <+> ptext (sLit "used in an expression") + = nonBidirectionalErr name where name = patSynName ps builder = patSynBuilder ps @@ -481,6 +529,15 @@ get a complaint that 'a' and 'b' are out of scope. (Actually the latter; Trac #9867.) No, the job of the signature is done, so when converting the pattern to an expression (for the builder RHS) we simply discard the signature. + +Note [Record PatSyn Desugaring] +------------------------------- + +It is important that prov_theta comes before req_theta as this ordering is used +when desugaring record pattern synonym updates. + +Any change to this ordering should make sure to change deSugar/DsExpr.hs if you +want to avoid difficult to decipher core lint errors! -} tcCheckPatSynPat :: LPat Name -> TcM () @@ -528,6 +585,11 @@ nPlusKPatInPatSynErr pat hang (ptext (sLit "Pattern synonym definition cannot contain n+k-pattern:")) 2 (ppr pat) +nonBidirectionalErr :: Outputable name => name -> TcM a +nonBidirectionalErr name = failWithTc $ + ptext (sLit "non-bidirectional pattern synonym") + <+> quotes (ppr name) <+> ptext (sLit "used in an expression") + tcPatToExpr :: [Located Name] -> LPat Name -> Maybe (LHsExpr Name) tcPatToExpr args = go where diff --git a/compiler/typecheck/TcPatSyn.hs-boot b/compiler/typecheck/TcPatSyn.hs-boot index 102404a0ca..477ce9bfda 100644 --- a/compiler/typecheck/TcPatSyn.hs-boot +++ b/compiler/typecheck/TcPatSyn.hs-boot @@ -6,13 +6,17 @@ import HsSyn ( PatSynBind, LHsBinds ) import TcRnTypes ( TcM ) import PatSyn ( PatSyn ) import TcPat ( TcPatSynInfo ) +import TcRnMonad ( TcGblEnv ) +import Outputable ( Outputable ) tcInferPatSynDecl :: PatSynBind Name Name - -> TcM (PatSyn, LHsBinds Id) + -> TcM (PatSyn, LHsBinds Id, TcGblEnv) tcCheckPatSynDecl :: PatSynBind Name Name -> TcPatSynInfo - -> TcM (PatSyn, LHsBinds Id) + -> TcM (PatSyn, LHsBinds Id, TcGblEnv) tcPatSynBuilderBind :: PatSynBind Name Name -> TcM (LHsBinds Id) + +nonBidirectionalErr :: Outputable name => name -> TcM a diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index dfeffb9405..45c25e4942 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -500,6 +500,7 @@ tcRnSrcDecls explicit_mod_hdr exports decls ; failIfErrsM -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! + ; traceTc "Tc10" empty -- Zonk the final code. This must be done last. -- Even simplifyTop may do some unification. @@ -518,6 +519,7 @@ tcRnSrcDecls explicit_mod_hdr exports decls <- {-# SCC "zonkTopDecls" #-} zonkTopDecls all_ev_binds binds exports sig_ns rules vects imp_specs fords ; + ; traceTc "Tc11" empty ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_binds = binds', @@ -1102,7 +1104,6 @@ rnTopSrcDecls group -- Dump trace of renaming part rnDump (ppr rn_decls) ; - return (tcg_env', rn_decls) } diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 0dbda160f0..2d68aa07bd 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -16,7 +16,7 @@ module TcTyClsDecls ( kcDataDefn, tcConDecls, dataDeclChecks, checkValidTyCon, tcFamTyPats, tcTyFamInstEqn, famTyConShape, tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt, - wrongKindOfFamily, dataConCtxt, badDataConTyCon + wrongKindOfFamily, dataConCtxt, badDataConTyCon, mkOneRecordSelector ) where #include "HsVersions.h" @@ -45,6 +45,7 @@ import Class import CoAxiom import TyCon import DataCon +import ConLike import Id import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo @@ -2037,30 +2038,38 @@ mkRecSelBinds tycons mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) mkRecSelBind (tycon, fl) - = (L loc (IdSig sel_id), unitBag (L loc sel_bind)) + = mkOneRecordSelector all_cons (RecSelData tycon) fl + where + all_cons = map RealDataCon (tyConDataCons tycon) + +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel + -> (LSig Name, LHsBinds Name) +mkOneRecordSelector all_cons idDetails fl = + (L loc (IdSig sel_id), unitBag (L loc sel_bind)) where loc = getSrcSpan sel_name - sel_id = mkExportedLocalId rec_details sel_name sel_ty lbl = flLabel fl sel_name = flSelector fl - rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty } + + sel_id = mkExportedLocalId rec_details sel_name sel_ty + rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty } -- Find a representative constructor, con1 - all_cons = tyConDataCons tycon - cons_w_field = tyConDataConsWithFields tycon [lbl] - con1 = ASSERT( not (null cons_w_field) ) head cons_w_field + cons_w_field = conLikesWithFields all_cons [lbl] + con1 = ASSERT( not (null cons_w_field) ) head cons_w_field -- Selector type; Note [Polymorphic selectors] - field_ty = dataConFieldType con1 lbl - data_ty = dataConOrigResTy con1 + field_ty = conLikeFieldType con1 lbl data_tvs = tyVarsOfType data_ty is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs) (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (varSetElemsKvsFirst $ data_tvs `extendVarSetList` field_tvs) $ - mkPhiTy (dataConStupidTheta con1) $ -- Urgh! + mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! mkPhiTy field_theta $ -- Urgh! + -- req_theta is empty for normal DataCon + mkPhiTy req_theta $ mkFunTy data_ty field_tau -- Make the binding: sel (C2 { fld = x }) = x @@ -2097,8 +2106,14 @@ mkRecSelBind (tycon, fl) -- data instance T Int a where -- A :: { fld :: Int } -> T Int Bool -- B :: { fld :: Int } -> T Int Char - dealt_with con = con `elem` cons_w_field || dataConCannotMatch inst_tys con - inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1) + dealt_with :: ConLike -> Bool + dealt_with (PatSynCon _) = False -- We can't predict overlap + dealt_with con@(RealDataCon dc) = + con `elem` cons_w_field || dataConCannotMatch inst_tys dc + + (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1 + + inst_tys = substTyVars (mkTopTvSubst eq_spec) univ_tvs unit_rhs = mkLHsTupleExpr [] msg_lit = HsStringPrim "" (fastStringToByteString lbl) diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 28923b76fd..465ccb14b6 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -17,7 +17,7 @@ module TyCon( FamTyConFlav(..), Role(..), Injectivity(..), -- ** Field labels - tyConFieldLabels, tyConFieldLabelEnv, tyConDataConsWithFields, + tyConFieldLabels, tyConFieldLabelEnv, -- ** Constructing TyCons mkAlgTyCon, @@ -1034,11 +1034,6 @@ tyConFieldLabelEnv tc | isAlgTyCon tc = algTcFields tc | otherwise = emptyFsEnv --- | The DataCons from this TyCon that have *all* the given fields -tyConDataConsWithFields :: TyCon -> [FieldLabelString] -> [DataCon] -tyConDataConsWithFields tc lbls = filter has_flds (tyConDataCons tc) - where has_flds dc = all (has_fld dc) lbls - has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (dataConFieldLabels dc) -- | Make a map from strings to FieldLabels from all the data -- constructors of this algebraic tycon diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs index 9a4bccf310..7f57073da8 100644 --- a/compiler/types/TypeRep.hs +++ b/compiler/types/TypeRep.hs @@ -60,7 +60,7 @@ module TypeRep ( #include "HsVersions.h" import {-# SOURCE #-} DataCon( dataConTyCon ) -import ConLike ( ConLike(..) ) +import {-# SOURCE #-} ConLike ( ConLike(..) ) import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop -- friends: diff --git a/compiler/types/TypeRep.hs-boot b/compiler/types/TypeRep.hs-boot index 42b8a7086a..7233c5d239 100644 --- a/compiler/types/TypeRep.hs-boot +++ b/compiler/types/TypeRep.hs-boot @@ -5,6 +5,7 @@ import Data.Data (Data,Typeable) data Type data TyThing +data TvSubst type PredType = Type type Kind = Type diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T index 0ff777d41a..19dbd75c4e 100644 --- a/testsuite/tests/patsyn/should_compile/all.T +++ b/testsuite/tests/patsyn/should_compile/all.T @@ -28,5 +28,8 @@ 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']) - - +test('records-compile', normal, compile, ['']) +test('records-poly', normal, compile, ['']) +test('records-req', normal, compile, ['']) +test('records-prov-req', normal, compile, ['']) +test('records-req-only', normal, compile, ['']) diff --git a/testsuite/tests/patsyn/should_compile/records-compile.hs b/testsuite/tests/patsyn/should_compile/records-compile.hs new file mode 100644 index 0000000000..1213a6085d --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/records-compile.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module ShouldCompile where + +pattern Single{x} = [x] + +-- Selector +selector :: Int +selector = x [5] + +update :: [String] +update = ["String"] { x = "updated" } diff --git a/testsuite/tests/patsyn/should_compile/records-poly.hs b/testsuite/tests/patsyn/should_compile/records-poly.hs new file mode 100644 index 0000000000..8505f2f137 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/records-poly.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +module PolyPat where + +-- Testing whether type changing updates work correctly. + +pattern MyTuple :: a -> b -> (a, b) +pattern MyTuple{mfst, msnd} = (mfst, msnd) + + +expr1 :: (Int, String) -> (Int, Int) +expr1 a = a { msnd = 2} + +expr3 a = a { msnd = 2} + +expr2 :: (a, b) -> a +expr2 a = mfst a diff --git a/testsuite/tests/patsyn/should_compile/records-prov-req.hs b/testsuite/tests/patsyn/should_compile/records-prov-req.hs new file mode 100644 index 0000000000..f83176f3fb --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/records-prov-req.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes, + StandaloneDeriving, FlexibleInstances #-} +module ShouldCompile where + +-- Testing that selectors work properly with prov and req thetas + +data T a b where + MkT :: (Show b) => a -> b -> T a b + +deriving instance Show (T Int A) + +data G a b = MkG { care :: a, y :: (Show b => b) } + +pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b +pattern ExNumPat{x} = MkT 42 x + +data A = A | B deriving (Show, Eq) + +f3 :: T Int A +f3 = (MkT 42 A) { x = B } + +f5 :: T Int A +f5 = (ExNumPat A) { x = B } + + +f4 = (MkG 42 True) { y = False } diff --git a/testsuite/tests/patsyn/should_compile/records-req-only.hs b/testsuite/tests/patsyn/should_compile/records-req-only.hs new file mode 100644 index 0000000000..425afc18b2 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/records-req-only.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoImplicitPrelude #-} +module Main where + +import Prelude (Maybe(..), Show(..), String, Bool(..), print) + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +p1 = ReqNoProv True + +p7 (ReqNoProv _) = ReqNoProv False + +p6 = p1 {j = False} + +main = print p6 diff --git a/testsuite/tests/patsyn/should_compile/records-req.hs b/testsuite/tests/patsyn/should_compile/records-req.hs new file mode 100644 index 0000000000..ae1c72ca71 --- /dev/null +++ b/testsuite/tests/patsyn/should_compile/records-req.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-} + +-- Pattern synonyms + +module ShouldCompile where + +data T a where + MkT :: (Eq b) => a -> b -> T a + +f :: (Show a) => a -> Bool +f = undefined + +pattern P{x} <- MkT (f -> True) x diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 846d2d37d9..b960e3795f 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -8,4 +8,11 @@ test('T9705-1', normal, compile_fail, ['']) test('T9705-2', normal, compile_fail, ['']) test('unboxed-bind', normal, compile_fail, ['']) test('unboxed-wrapper-naked', normal, compile_fail, ['']) -test('T11010', normal, compile_fail, [''])
\ No newline at end of file +test('T11010', normal, compile_fail, ['']) +test('records-check-sels', normal, compile_fail, ['']) +test('records-no-uni-update', normal, compile_fail, ['']) +test('records-no-uni-update2', normal, compile_fail, ['']) +test('records-mixing-fields', normal, compile_fail, ['']) +test('records-exquant', normal, compile_fail, ['']) +test('records-poly-update', normal, compile_fail, ['']) +test('mixed-pat-syn-record-sels', normal, compile_fail, ['']) diff --git a/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.hs b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.hs new file mode 100644 index 0000000000..71a412fd18 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PatternSynonyms #-} +module Foo where + + +pattern A { a } = Just a +pattern B { b } = Just b + +foo :: Maybe a -> Maybe Bool +foo x = x { a = True, b = False } diff --git a/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr new file mode 100644 index 0000000000..27dedd03b5 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr @@ -0,0 +1,5 @@ + +mixed-pat-syn-record-sels.hs:9:9: error: + No constructor has all these fields: ‘a’, ‘b’ + In the expression: x {a = True, b = False} + In an equation for ‘foo’: foo x = x {a = True, b = False} diff --git a/testsuite/tests/patsyn/should_fail/records-check-sels.hs b/testsuite/tests/patsyn/should_fail/records-check-sels.hs new file mode 100644 index 0000000000..fa377b3e07 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-check-sels.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms #-} +module Qux where + +-- Make sure selectors aren't generated for normal synonyms + +pattern Uni a = Just a + +pattern a :+: b = (a, b) + +qux = a (Just True) diff --git a/testsuite/tests/patsyn/should_fail/records-check-sels.stderr b/testsuite/tests/patsyn/should_fail/records-check-sels.stderr new file mode 100644 index 0000000000..22601c6501 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-check-sels.stderr @@ -0,0 +1,3 @@ + +records-check-sels.hs:10:7: error: + Variable not in scope: a :: Maybe Bool -> t diff --git a/testsuite/tests/patsyn/should_fail/records-exquant.hs b/testsuite/tests/patsyn/should_fail/records-exquant.hs new file mode 100644 index 0000000000..8541019f0e --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-exquant.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-} +module ExQuant where + +data Showable = forall a . Show a => Showable a + +pattern Nasty{a} = Showable a + +qux = a (Showable True) + +foo = (Showable ()) { a = True } diff --git a/testsuite/tests/patsyn/should_fail/records-exquant.stderr b/testsuite/tests/patsyn/should_fail/records-exquant.stderr new file mode 100644 index 0000000000..e742ada348 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-exquant.stderr @@ -0,0 +1,11 @@ + +records-exquant.hs:8:7: error: + Cannot use record selector ‘a’ as a function due to escaped type variables + Probable fix: use pattern-matching syntax instead + In the expression: a (Showable True) + In an equation for ‘qux’: qux = a (Showable True) + +records-exquant.hs:10:7: error: + Record update for insufficiently polymorphic field: a :: a + In the expression: (Showable ()) {a = True} + In an equation for ‘foo’: foo = (Showable ()) {a = True} diff --git a/testsuite/tests/patsyn/should_fail/records-mixing-fields.hs b/testsuite/tests/patsyn/should_fail/records-mixing-fields.hs new file mode 100644 index 0000000000..ffbbafa47e --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-mixing-fields.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PatternSynonyms #-} + +data MyRec = MyRec { foo :: Int, qux :: String } + +pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2} + +updater,updater1, updater2 :: MyRec -> MyRec +updater a = a {f1 = 1 } + +updater1 a = a {f1 = 1, qux = "two" } + +updater2 a = a {f1 = 1, foo = 2 } diff --git a/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr new file mode 100644 index 0000000000..7928c74258 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr @@ -0,0 +1,17 @@ + +records-mixing-fields.hs:1:1: error: + The IO action ‘main’ is not defined in module ‘Main’ + +records-mixing-fields.hs:10:14: error: + Cannot use a mixture of pattern synonym and record selectors + Record selectors defined by ‘MyRec’: qux + Pattern synonym selectors defined by ‘HisRec’: f1 + In the expression: a {f1 = 1, qux = "two"} + In an equation for ‘updater1’: updater1 a = a {f1 = 1, qux = "two"} + +records-mixing-fields.hs:12:14: error: + Cannot use a mixture of pattern synonym and record selectors + Record selectors defined by ‘MyRec’: foo + Pattern synonym selectors defined by ‘HisRec’: f1 + In the expression: a {f1 = 1, foo = 2} + In an equation for ‘updater2’: updater2 a = a {f1 = 1, foo = 2} diff --git a/testsuite/tests/patsyn/should_fail/records-no-uni-update.hs b/testsuite/tests/patsyn/should_fail/records-no-uni-update.hs new file mode 100644 index 0000000000..fb68cb3daf --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-no-uni-update.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a,b} <- (a, b) + +foo = ("a","b") { a = "b" } diff --git a/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr b/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr new file mode 100644 index 0000000000..71e2a99407 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr @@ -0,0 +1,5 @@ + +records-no-uni-update.hs:7:7: error: + non-bidirectional pattern synonym ‘Uni’ used in an expression + In the expression: ("a", "b") {a = "b"} + In an equation for ‘foo’: foo = ("a", "b") {a = "b"} diff --git a/testsuite/tests/patsyn/should_fail/records-no-uni-update2.hs b/testsuite/tests/patsyn/should_fail/records-no-uni-update2.hs new file mode 100644 index 0000000000..352004338d --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-no-uni-update2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE PatternSynonyms #-} +module RecordPats where + +-- No updates +pattern Uni{a} <- Just a + +qux = a (Just True) + +qux2 (Uni b) = b + +foo = Uni { a = "b" } diff --git a/testsuite/tests/patsyn/should_fail/records-no-uni-update2.stderr b/testsuite/tests/patsyn/should_fail/records-no-uni-update2.stderr new file mode 100644 index 0000000000..b30a236331 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-no-uni-update2.stderr @@ -0,0 +1,5 @@ + +records-no-uni-update2.hs:11:7: error: + non-bidirectional pattern synonym ‘Uni’ used in an expression + In the expression: Uni {a = "b"} + In an equation for ‘foo’: foo = Uni {a = "b"} diff --git a/testsuite/tests/patsyn/should_fail/records-poly-update.hs b/testsuite/tests/patsyn/should_fail/records-poly-update.hs new file mode 100644 index 0000000000..f488b18bc6 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-poly-update.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PatternSynonyms #-} +module Main where + +pattern ReqNoProv :: Show a => a -> Maybe a +pattern ReqNoProv{j} = Just j + +data A = A deriving Show + +p1 = Just True + +p6 = p1 {j = A} + +main = print p6 diff --git a/testsuite/tests/patsyn/should_fail/records-poly-update.stderr b/testsuite/tests/patsyn/should_fail/records-poly-update.stderr new file mode 100644 index 0000000000..ed456ff171 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-poly-update.stderr @@ -0,0 +1,5 @@ + +records-poly-update.hs:11:14: error: + Couldn't match expected type ‘Bool’ with actual type ‘A’ + In the ‘j’ field of a record + In the expression: p1 {j = A} diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T index 2f496a6946..45c48fbd1f 100644 --- a/testsuite/tests/patsyn/should_run/all.T +++ b/testsuite/tests/patsyn/should_run/all.T @@ -10,4 +10,5 @@ test('bidir-explicit-scope', normal, compile_and_run, ['']) test('T9783', normal, compile_and_run, ['']) 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']) diff --git a/testsuite/tests/patsyn/should_run/records-run.hs b/testsuite/tests/patsyn/should_run/records-run.hs new file mode 100644 index 0000000000..19a6bb2793 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/records-run.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Main where + +pattern Bi{a, b} = (a, b) + +foo = ("a","b") + +main = do + print foo + print (a foo) + print (b foo) + print (foo {a = "c"}) + print (foo {a = "fst", b = "snd"}) diff --git a/testsuite/tests/patsyn/should_run/records-run.stdout b/testsuite/tests/patsyn/should_run/records-run.stdout new file mode 100644 index 0000000000..a0878c75b3 --- /dev/null +++ b/testsuite/tests/patsyn/should_run/records-run.stdout @@ -0,0 +1,5 @@ +("a","b") +"a" +"b" +("c","b") +("fst","snd") |