diff options
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") |