Record pattern synonyms
authorMatthew Pickering <matthewtpickering@gmail.com>
Mon, 19 Oct 2015 20:17:29 +0000 (21:17 +0100)
committerBen Gamari <ben@smart-cactus.org>
Thu, 29 Oct 2015 11:24:21 +0000 (12:24 +0100)
This patch implements an extension to pattern synonyms which allows user
to specify pattern synonyms using record syntax. Doing so generates
appropriate selectors and update functions.

=== Interaction with Duplicate Record Fields ===

The implementation given here isn't quite as general as it could be with
respect to the recently-introduced `DuplicateRecordFields` extension.

Consider the following module:

    {-# LANGUAGE DuplicateRecordFields #-}
    {-# LANGUAGE PatternSynonyms #-}

    module Main where

    pattern S{a, b} = (a, b)
    pattern T{a}    = Just a

    main = do
      print S{ a = "fst", b = "snd" }
      print T{ a = "a" }

In principle, this ought to work, because there is no ambiguity. But at
the moment it leads to a "multiple declarations of a" error. The problem
is that pattern synonym record selectors don't do the same name mangling
as normal datatypes when DuplicateRecordFields is enabled. They could,
but this would require some work to track the field label and selector
name separately.

In particular, we currently represent datatype selectors in the third
component of AvailTC, but pattern synonym selectors are just represented
as Avails (because they don't have a corresponding type constructor).
Moreover, the GlobalRdrElt for a selector currently requires it to have
a parent tycon.

(example due to Adam Gundry)

=== Updating Explicitly Bidirectional Pattern Synonyms ===

Consider the following

```
pattern Silly{a} <- [a] where
  Silly a = [a, a]

f1 = a [5] -- 5

f2 = [5] {a = 6} -- currently [6,6]
```

=== Fixing Polymorphic Updates ===

They were fixed by adding these two lines in `dsExpr`. This might break
record updates but will be easy to fix.

```
+ ; let req_wrap = mkWpTyApps (mkTyVarTys univ_tvs)

- , pat_wrap = idHsWrapper }
+, pat_wrap = req_wrap }
```

=== Mixed selectors error ===

Note [Mixed Record Field Updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Consider the following pattern synonym.

    data MyRec = MyRec { foo :: Int, qux :: String }

    pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

This allows updates such as the following

    updater :: MyRec -> MyRec
    updater a = a {f1 = 1 }

It would also make sense to allow the following update (which we
reject).

    updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"

This leads to confusing behaviour when the selectors in fact refer the
same field.

    updater a = a {f1 = 1, foo = 2} ==? ???

For this reason, we reject a mixture of pattern synonym and normal
record selectors in the same update block. Although of course we still
allow the following.

    updater a = (a {f1 = 1}) {foo = 2}

    > updater (MyRec 0 "str")
    MyRec 2 "str"

60 files changed:
compiler/basicTypes/ConLike.hs
compiler/basicTypes/ConLike.hs-boot [new file with mode: 0644]
compiler/basicTypes/Id.hs
compiler/basicTypes/IdInfo.hs
compiler/basicTypes/PatSyn.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsBinds.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/iface/BuildTyCl.hs
compiler/iface/IfaceSyn.hs
compiler/iface/MkIface.hs
compiler/iface/TcIface.hs
compiler/main/HscTypes.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/prelude/TysWiredIn.hs
compiler/rename/RnBinds.hs
compiler/rename/RnExpr.hs
compiler/rename/RnNames.hs
compiler/rename/RnSource.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcPatSyn.hs-boot
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/types/TyCon.hs
compiler/types/TypeRep.hs
compiler/types/TypeRep.hs-boot
testsuite/tests/patsyn/should_compile/all.T
testsuite/tests/patsyn/should_compile/records-compile.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/records-poly.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/records-prov-req.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/records-req-only.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_compile/records-req.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/all.T
testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/mixed-pat-syn-record-sels.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-check-sels.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-check-sels.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-exquant.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-exquant.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-mixing-fields.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-mixing-fields.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-no-uni-update.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-no-uni-update.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-no-uni-update2.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-no-uni-update2.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-poly-update.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_fail/records-poly-update.stderr [new file with mode: 0644]
testsuite/tests/patsyn/should_run/all.T
testsuite/tests/patsyn/should_run/records-run.hs [new file with mode: 0644]
testsuite/tests/patsyn/should_run/records-run.stdout [new file with mode: 0644]

index 772065f..69a7992 100644 (file)
@@ -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 (file)
index 0000000..3463287
--- /dev/null
@@ -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
index 7b54baa..e22a77c 100644 (file)
@@ -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.
index d8d0e7f..ea1eb19 100644 (file)
@@ -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")
 
 {-
 ************************************************************************
index 2546ff4..01e52af 100644 (file)
@@ -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
 
index 8d9f37d..dfe3807 100644 (file)
@@ -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
index d91ccfb..f47843a 100644 (file)
@@ -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
 
index df2eaf2..ad1d501 100644 (file)
@@ -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 }
index f514863..deabf37 100644 (file)
@@ -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' }
 
index 18756f6..b1b6e62 100644 (file)
@@ -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
index e51ca98..0b62d1f 100644 (file)
@@ -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 _)
index 3b6b0fa..be01baa 100644 (file)
@@ -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])
index 196c94a..ed44d2c 100644 (file)
@@ -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)
   )
index 945678a..1187307 100644 (file)
@@ -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
index 42342ae..8bf744f 100644 (file)
@@ -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
index 84d9fd9..df96f6a 100644 (file)
@@ -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
index c833ab0..1328b3c 100644 (file)
@@ -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
index a2a2f50..fb65a67 100644 (file)
@@ -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
index 895d1bf..7f8eb59 100644 (file)
@@ -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
index a1577a7..af88e90 100644 (file)
@@ -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 }
index 97c84cd..e8a06e7 100644 (file)
@@ -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 )
index d63808e..1a24c11 100644 (file)
@@ -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
index da6bf58..b4c63f3 100644 (file)
@@ -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
index b517ce1..12f9024 100644 (file)
@@ -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
index 286b431..90bf09a 100644 (file)
@@ -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
+
 {-
 *********************************************************
 *                                                      *
index d939ad3..2177392 100644 (file)
@@ -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
 
index e6cc5d1..dd765ca 100644 (file)
@@ -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)
index e40ad39..5aa797c 100644 (file)
@@ -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
index e39b0f5..c73bf6d 100644 (file)
@@ -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
index 121a898..3872460 100644 (file)
@@ -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
index 102404a..477ce9b 100644 (file)
@@ -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
index dfeffb9..45c25e4 100644 (file)
@@ -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)
    }
 
index 0dbda16..2d68aa0 100644 (file)
@@ -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)
index 28923b7..465ccb1 100644 (file)
@@ -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
index 9a4bccf..7f57073 100644 (file)
@@ -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:
index 42b8a70..7233c5d 100644 (file)
@@ -5,6 +5,7 @@ import Data.Data (Data,Typeable)
 
 data Type
 data TyThing
+data TvSubst
 
 type PredType = Type
 type Kind = Type
index 0ff777d..19dbd75 100644 (file)
@@ -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 (file)
index 0000000..1213a60
--- /dev/null
@@ -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 (file)
index 0000000..8505f2f
--- /dev/null
@@ -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 (file)
index 0000000..f83176f
--- /dev/null
@@ -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 (file)
index 0000000..425afc1
--- /dev/null
@@ -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 (file)
index 0000000..ae1c72c
--- /dev/null
@@ -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
index 846d2d3..b960e37 100644 (file)
@@ -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 (file)
index 0000000..71a412f
--- /dev/null
@@ -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 (file)
index 0000000..27dedd0
--- /dev/null
@@ -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 (file)
index 0000000..fa377b3
--- /dev/null
@@ -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 (file)
index 0000000..22601c6
--- /dev/null
@@ -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 (file)
index 0000000..8541019
--- /dev/null
@@ -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 (file)
index 0000000..e742ada
--- /dev/null
@@ -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 (file)
index 0000000..ffbbafa
--- /dev/null
@@ -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 (file)
index 0000000..7928c74
--- /dev/null
@@ -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 (file)
index 0000000..fb68cb3
--- /dev/null
@@ -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 (file)
index 0000000..71e2a99
--- /dev/null
@@ -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 (file)
index 0000000..3520043
--- /dev/null
@@ -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 (file)
index 0000000..b30a236
--- /dev/null
@@ -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 (file)
index 0000000..f488b18
--- /dev/null
@@ -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 (file)
index 0000000..ed456ff
--- /dev/null
@@ -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}
index 2f496a6..45c48fb 100644 (file)
@@ -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 (file)
index 0000000..19a6bb2
--- /dev/null
@@ -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 (file)
index 0000000..a0878c7
--- /dev/null
@@ -0,0 +1,5 @@
+("a","b")
+"a"
+"b"
+("c","b")
+("fst","snd")