Commit 2a74a64e authored by Matthew Pickering's avatar Matthew Pickering Committed by Ben Gamari

Record pattern synonyms

This patch implements an extension to pattern synonyms which allows user
to specify pattern synonyms using record syntax. Doing so generates
appropriate selectors and update functions.

=== Interaction with Duplicate Record Fields ===

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

Consider the following module:

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

    module Main where

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

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

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

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

(example due to Adam Gundry)

=== Updating Explicitly Bidirectional Pattern Synonyms ===

Consider the following

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

f1 = a [5] -- 5

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

=== Fixing Polymorphic Updates ===

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

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

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

=== Mixed selectors error ===

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

Consider the following pattern synonym.

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

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

This allows updates such as the following

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

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

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

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

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

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

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

    > updater (MyRec 0 "str")
    MyRec 2 "str"
parent a0517889
......@@ -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)
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
......@@ -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.
......
......@@ -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")
{-
************************************************************************
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 }
......
......@@ -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' }
......
......@@ -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