Commit 2eb04ca0 authored by David Himmelstrup's avatar David Himmelstrup

Add several new record features

1. Record disambiguation (-fdisambiguate-record-fields)

In record construction and pattern matching (although not
in record updates) it is clear which field name is intended
even if there are several in scope.  This extension uses
the constructor to disambiguate.  Thus
	C { x=3 }
uses the 'x' field from constructor C (assuming there is one)
even if there are many x's in scope.


2. Record punning (-frecord-puns)

In a record construction or pattern match or update you can 
omit the "=" part, thus
	C { x, y }
This is just syntactic sugar for
	C { x=x, y=y }


3.  Dot-dot notation for records (-frecord-dot-dot)

In record construction or pattern match (but not update) 
you can use ".." to mean "all the remaining fields".  So

	C { x=v, .. }

means to fill in the remaining fields to give

	C { x=v, y=y }

(assuming C has fields x and y).  This might reasonably
considered very dodgy stuff.  For pattern-matching it brings
into scope a bunch of things that are not explictly mentioned;
and in record construction it just picks whatver 'y' is in
scope for the 'y' field.   Still, Lennart Augustsson really
wants it, and it's a feature that is extremely easy to explain.


Implementation
~~~~~~~~~~~~~~
I thought of using the "parent" field in the GlobalRdrEnv, but
that's really used for import/export and just isn't right for this.
For example, for import/export a field is a subordinate of the *type
constructor* whereas here we need to know what fields belong to a
particular *data* constructor.

The main thing is that we need to map a data constructor to its
fields, and we need to do so in the renamer.   For imported modules
it's easy: just look in the imported TypeEnv.  For the module being
compiled, we make a new field tcg_field_env in the TcGblEnv.
The important functions are
	RnEnv.lookupRecordBndr
	RnEnv.lookupConstructorFields

There is still a significant infelicity in the way the renamer
works on patterns, which I'll tackle next.


I also did quite a bit of refactoring in the representation of
record fields (mainly in HsPat).***END OF DESCRIPTION***

Place the long patch description above the ***END OF DESCRIPTION*** marker.
The first line of this file will be the patch name.


This patch contains the following changes:

M ./compiler/deSugar/Check.lhs -3 +5
M ./compiler/deSugar/Coverage.lhs -6 +7
M ./compiler/deSugar/DsExpr.lhs -6 +13
M ./compiler/deSugar/DsMeta.hs -8 +8
M ./compiler/deSugar/DsUtils.lhs -1 +1
M ./compiler/deSugar/MatchCon.lhs -2 +2
M ./compiler/hsSyn/Convert.lhs -3 +3
M ./compiler/hsSyn/HsDecls.lhs -9 +25
M ./compiler/hsSyn/HsExpr.lhs -13 +3
M ./compiler/hsSyn/HsPat.lhs -25 +63
M ./compiler/hsSyn/HsUtils.lhs -3 +3
M ./compiler/main/DynFlags.hs +6
M ./compiler/parser/Parser.y.pp -13 +17
M ./compiler/parser/RdrHsSyn.lhs -16 +18
M ./compiler/rename/RnBinds.lhs -2 +2
M ./compiler/rename/RnEnv.lhs -22 +82
M ./compiler/rename/RnExpr.lhs -34 +12
M ./compiler/rename/RnHsSyn.lhs -3 +2
M ./compiler/rename/RnSource.lhs -50 +78
M ./compiler/rename/RnTypes.lhs -50 +84
M ./compiler/typecheck/TcExpr.lhs -18 +18
M ./compiler/typecheck/TcHsSyn.lhs -20 +21
M ./compiler/typecheck/TcPat.lhs -8 +6
M ./compiler/typecheck/TcRnMonad.lhs -6 +15
M ./compiler/typecheck/TcRnTypes.lhs -2 +11
M ./compiler/typecheck/TcTyClsDecls.lhs -3 +4
M ./docs/users_guide/flags.xml +7
M ./docs/users_guide/glasgow_exts.xml +42
parent 74b27e20
......@@ -145,7 +145,9 @@ untidy b (L loc p) = L loc (untidy' b p)
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
untidy_con (RecCon bs) = RecCon [ HsRecField f (untidy_pars p) d | HsRecField f p d <- bs ]
untidy_con (RecCon (HsRecFields flds dd))
= RecCon (HsRecFields [ fld { hsRecFieldArg = untidy_pars (hsRecFieldArg fld) }
| fld <- flds ] dd)
pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
......@@ -607,7 +609,7 @@ has_nplusk_pat (TuplePat ps _ _) = any has_nplusk_lpat ps
has_nplusk_pat (PArrPat ps _) = any has_nplusk_lpat ps
has_nplusk_pat (LazyPat p) = False -- Why?
has_nplusk_pat (BangPat p) = has_nplusk_lpat p -- I think
has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConArgs ps)
has_nplusk_pat (ConPatOut { pat_args = ps }) = any has_nplusk_lpat (hsConPatArgs ps)
has_nplusk_pat p = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat
simplify_lpat :: LPat Id -> LPat Id
......@@ -666,7 +668,7 @@ simplify_pat (CoPat co pat ty) = simplify_pat pat
-----------------
simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps)
simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2]
simplify_con con (RecCon fs)
simplify_con con (RecCon (HsRecFields fs _))
| null fs = PrefixCon [nlWildPat | t <- dataConOrigArgTys con]
-- Special case for null patterns; maybe not a record at all
| otherwise = PrefixCon (map (simplify_lpat.snd) all_pats)
......
......@@ -495,12 +495,13 @@ addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
addTickDictBinds x = addTickLHsBinds x
addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
addTickHsRecordBinds (HsRecordBinds pairs) = liftM HsRecordBinds (mapM process pairs)
where
process (ids,expr) =
liftM2 (,)
(return ids)
(addTickLHsExpr expr)
addTickHsRecordBinds (HsRecFields fields dd)
= do { fields' <- mapM process fields
; return (HsRecFields fields' dd) }
where
process (HsRecField ids expr doc)
= do { expr' <- addTickLHsExpr expr
; return (HsRecField ids expr' doc) }
addTickArithSeqInfo :: ArithSeqInfo Id -> TM (ArithSeqInfo Id)
addTickArithSeqInfo (From e1) =
......
......@@ -19,6 +19,7 @@ import DsListComp
import DsUtils
import DsArrows
import DsMonad
import Name
#ifdef GHCI
import PrelNames
......@@ -407,7 +408,7 @@ We also handle @C{}@ as valid construction syntax for an unlabelled
constructor @C@, setting all of @C@'s fields to bottom.
\begin{code}
dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
dsExpr (RecordCon (L _ data_con_id) con_expr rbinds)
= dsExpr con_expr `thenDs` \ con_expr' ->
let
(arg_tys, _) = tcSplitFunTys (exprType con_expr')
......@@ -415,7 +416,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr (HsRecordBinds rbinds))
-- hence TcType.tcSplitFunTys
mk_arg (arg_ty, lbl) -- Selector id has the field label as its name
= case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == idName sel_id] of
= case findField (rec_flds rbinds) lbl of
(rhs:rhss) -> ASSERT( null rhss )
dsLExpr rhs
[] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl))
......@@ -455,10 +456,11 @@ might do some argument-evaluation first; and may have to throw away some
dictionaries.
\begin{code}
dsExpr (RecordUpd record_expr (HsRecordBinds []) _ _ _)
dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
cons_to_upd in_inst_tys out_inst_tys)
| null fields
= dsLExpr record_expr
dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_tys out_inst_tys)
| otherwise
= -- Record stuff doesn't work for existentials
-- The type checker checks for this, but we need
-- worry only about the constructors that are to be updated
......@@ -473,7 +475,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecordBinds rbinds) cons_to_upd in_inst_ty
(mkFamilyTyConApp tycon out_inst_tys)
mk_val_arg field old_arg_id
= case [rhs | (L _ sel_id, rhs) <- rbinds, field == idName sel_id] of
= case findField fields field of
(rhs:rest) -> ASSERT(null rest) rhs
[] -> nlHsVar old_arg_id
......@@ -543,6 +545,11 @@ dsExpr (HsBinTick ixT ixF e) = do
dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig"
#endif
findField :: [HsRecField Id arg] -> Name -> [arg]
findField rbinds lbl
= [rhs | HsRecField { hsRecFieldId = id, hsRecFieldArg = rhs } <- rbinds
, lbl == idName (unLoc id) ]
\end{code}
%--------------------------------------------------------------------
......
......@@ -527,11 +527,11 @@ repE e@(ExplicitPArr ty es) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed)
| isBoxed boxed = do { xs <- repLEs es; repTup xs }
| otherwise = notHandled "Unboxed tuples" (ppr e)
repE (RecordCon c _ (HsRecordBinds flds))
repE (RecordCon c _ flds)
= do { x <- lookupLOcc c;
fs <- repFields flds;
repRecCon x fs }
repE (RecordUpd e (HsRecordBinds flds) _ _ _)
repE (RecordUpd e flds _ _ _)
= do { x <- repLE e;
fs <- repFields flds;
repRecUpd x fs }
......@@ -613,12 +613,12 @@ repGuards other
g <- repPatGE (nonEmptyCoreList ss') rhs'
return (gs, g)
repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repFields flds = do
fnames <- mapM lookupLOcc (map fst flds)
es <- mapM repLE (map snd flds)
fs <- zipWithM repFieldExp fnames es
coreList fieldExpQTyConName fs
repFields :: [HsRecField Name (LHsExpr Name)] -> DsM (Core [TH.Q TH.FieldExp])
repFields flds
= do { fnames <- mapM lookupLOcc (map hsRecFieldId flds)
; es <- mapM repLE (map hsRecFieldArg flds)
; fs <- zipWithM repFieldExp fnames es
; coreList fieldExpQTyConName fs }
-----------------------------------------------------------------------------
......
......@@ -647,7 +647,7 @@ mkSelectorBinds pat val_expr
is_simple_lpat p = is_simple_pat (unLoc p)
is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConArgs ps)
is_simple_pat (ConPatOut{ pat_args = ps }) = all is_triv_lpat (hsConPatArgs ps)
is_simple_pat (VarPat _) = True
is_simple_pat (ParPat p) = is_simple_lpat p
is_simple_pat other = False
......
......@@ -119,11 +119,11 @@ conArgPats :: DataCon
-> [Type] -- Instantiated argument types
-- Used only to fill in the types of WildPats, which
-- are probably never looked at anyway
-> HsConDetails Id (LPat Id)
-> HsConDetails (LPat Id) (HsRecFields Id (LPat Id))
-> [Pat Id]
conArgPats data_con arg_tys (PrefixCon ps) = map unLoc ps
conArgPats data_con arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]
conArgPats data_con arg_tys (RecCon rpats)
conArgPats data_con arg_tys (RecCon (HsRecFields rpats _))
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
......
......@@ -364,12 +364,12 @@ cvtl e = wrapL (cvt e)
; return $ ExprWithTySig e' t' }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM cvtFld flds
; return $ RecordCon c' noPostTcExpr (HsRecordBinds flds') }
; return $ RecordCon c' noPostTcExpr flds' }
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds
; return $ RecordUpd e' (HsRecordBinds flds') [] [] [] }
; return $ RecordUpd e' flds' [] [] [] }
cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (mkHsRecField v' e') }
cvtDD :: Range -> CvtM (ArithSeqInfo RdrName)
cvtDD (FromR x) = do { x' <- cvtl x; return $ From x' }
......
......@@ -17,7 +17,8 @@ module HsDecls (
DefaultDecl(..), LDefaultDecl, SpliceDecl(..),
ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), ResType(..), LConDecl,
ConDecl(..), ResType(..), ConDeclField(..), LConDecl,
HsConDeclDetails, hsConDeclArgTys,
DocDecl(..), LDocDecl, docDeclDoc,
DeprecDecl(..), LDeprecDecl,
HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups,
......@@ -25,7 +26,6 @@ module HsDecls (
isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
isFamInstDecl,
countTyClDecls,
conDetailsTys,
instDeclATs,
collectRuleBndrSigTys,
) where
......@@ -650,13 +650,25 @@ data ConDecl name
, con_cxt :: LHsContext name -- The context. This *does not* include the
-- "stupid theta" which lives only in the TyData decl
, con_details :: HsConDetails name (LBangType name) -- The main payload
, con_details :: HsConDeclDetails name -- The main payload
, con_res :: ResType name -- Result type of the constructor
, con_doc :: Maybe (LHsDoc name) -- A possible Haddock comment
}
type HsConDeclDetails name = HsConDetails (LBangType name) [ConDeclField name]
hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name]
hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map cd_fld_type flds
data ConDeclField name -- Record fields have Haddoc docs on them
= ConDeclField { cd_fld_name :: Located name,
cd_fld_type :: LBangType name,
cd_fld_doc :: Maybe (LHsDoc name) }
data ResType name
= ResTyH98 -- Constructor was declared using Haskell 98 syntax
| ResTyGADT (LHsType name) -- Constructor was declared using GADT-style syntax,
......@@ -664,7 +676,7 @@ data ResType name
\end{code}
\begin{code}
conDeclsNames :: Eq name => [ConDecl name] -> [Located name]
conDeclsNames :: forall name. Eq name => [ConDecl name] -> [Located name]
-- See tyClDeclNames for what this does
-- The function is boringly complicated because of the records
-- And since we only have equality, we have to be a little careful
......@@ -672,14 +684,13 @@ conDeclsNames cons
= snd (foldl do_one ([], []) cons)
where
do_one (flds_seen, acc) (ConDecl { con_name = lname, con_details = RecCon flds })
= (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc)
= (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
where
new_flds = [ f | (HsRecField f _ _) <- flds, not (unLoc f `elem` flds_seen) ]
new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
(map cd_fld_name flds)
do_one (flds_seen, acc) c
= (flds_seen, (con_name c):acc)
conDetailsTys details = map getBangType (hsConArgs details)
\end{code}
......@@ -687,6 +698,7 @@ conDetailsTys details = map getBangType (hsConArgs details)
instance (OutputableBndr name) => Outputable (ConDecl name) where
ppr = pprConDecl
pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
pprConDecl (ConDecl con expl tvs cxt details ResTyH98 doc)
= sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details con details]
where
......@@ -703,7 +715,11 @@ pprConDecl (ConDecl con expl tvs cxt (PrefixCon arg_tys) (ResTyGADT res_ty) _)
pprConDecl (ConDecl con expl tvs cxt (RecCon fields) (ResTyGADT res_ty) _)
= sep [pprHsForAll expl tvs cxt, ppr con <+> ppr_fields fields <+> dcolon <+> ppr res_ty]
ppr_fields fields = braces (sep (punctuate comma (map ppr fields)))
ppr_fields fields = braces (sep (punctuate comma (map ppr_fld fields)))
where
ppr_fld (ConDeclField { cd_fld_name = n, cd_fld_type = ty,
cd_fld_doc = doc })
= ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
%************************************************************************
......
......@@ -394,10 +394,10 @@ ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
ppr_expr (RecordCon con_id con_expr rbinds)
= pp_rbinds (ppr con_id) rbinds
= hang (ppr con_id) 2 (ppr rbinds)
ppr_expr (RecordUpd aexp rbinds _ _ _)
= pp_rbinds (pprParendExpr aexp) rbinds
= hang (pprParendExpr aexp) 2 (ppr rbinds)
ppr_expr (ExprWithTySig expr sig)
= hang (nest 2 (ppr_lexpr expr) <+> dcolon)
......@@ -584,17 +584,7 @@ data HsCmdTop id
%************************************************************************
\begin{code}
data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
recBindFields :: HsRecordBinds id -> [id]
recBindFields (HsRecordBinds rbinds) = [unLoc field | (field,_) <- rbinds]
pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
pp_rbinds thing (HsRecordBinds rbinds)
= hang thing
4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds))))
where
pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
type HsRecordBinds id = HsRecFields id (LHsExpr id)
\end{code}
......
......@@ -8,8 +8,9 @@
module HsPat (
Pat(..), InPat, OutPat, LPat,
HsConDetails(..), hsConArgs,
HsRecField(..), mkRecField,
HsConDetails(..),
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsRecField(..), hsRecFields,
mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat,
......@@ -85,7 +86,7 @@ data Pat id
------------ Constructor patterns ---------------
| ConPatIn (Located id)
(HsConDetails id (LPat id))
(HsConPatDetails id)
| ConPatOut {
pat_con :: Located DataCon,
......@@ -93,7 +94,7 @@ data Pat id
-- including any bound coercion variables
pat_dicts :: [id], -- Ditto dictionaries
pat_binds :: DictBinds id, -- Bindings involving those dictionaries
pat_args :: HsConDetails id (LPat id),
pat_args :: HsConPatDetails id,
pat_ty :: Type -- The type of the pattern
}
......@@ -134,26 +135,55 @@ data Pat id
-- the scrutinee, followed by a match on 'pat'
\end{code}
HsConDetails is use both for patterns and for data type declarations
HsConDetails is use for patterns/expressions *and* for data type declarations
\begin{code}
data HsConDetails id arg
= PrefixCon [arg] -- C p1 p2 p3
| RecCon [HsRecField id arg] -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
data HsConDetails arg rec
= PrefixCon [arg] -- C p1 p2 p3
| RecCon rec -- C { x = p1, y = p2 }
| InfixCon arg arg -- p1 `C` p2
type HsConPatDetails id = HsConDetails (LPat id) (HsRecFields id (LPat id))
hsConPatArgs :: HsConPatDetails id -> [LPat id]
hsConPatArgs (PrefixCon ps) = ps
hsConPatArgs (RecCon fs) = map hsRecFieldArg (rec_flds fs)
hsConPatArgs (InfixCon p1 p2) = [p1,p2]
\end{code}
However HsRecFields is used only for patterns and expressions
(not data type declarations)
\begin{code}
data HsRecFields id arg -- A bunch of record fields
-- { x = 3, y = True }
-- Used for both expressiona and patterns
= HsRecFields { rec_flds :: [HsRecField id arg],
rec_dotdot :: Maybe Int }
-- Nothing => the normal case
-- Just n => the group uses ".." notation,
-- and the first n elts of rec_flds
-- were the user-written ones
-- (In the latter case, the remaining elts of
-- rec_flds are the non-user-written ones)
data HsRecField id arg = HsRecField {
hsRecFieldId :: Located id,
hsRecFieldArg :: arg,
hsRecFieldDoc :: Maybe (LHsDoc id)
}
mkRecField id arg = HsRecField id arg Nothing
hsConArgs :: HsConDetails id arg -> [arg]
hsConArgs (PrefixCon ps) = ps
hsConArgs (RecCon fs) = map hsRecFieldArg fs
hsConArgs (InfixCon p1 p2) = [p1,p2]
hsRecPun :: Bool -- Note [Punning]
}
-- Note [Punning]
-- ~~~~~~~~~~~~~~
-- If you write T { x, y = v+1 }, the HsRecFields will be
-- HsRecField x x True ...
-- HsRecField y (v+1) False ...
-- That is, for "punned" field x is immediately expanded to x=x
-- but with a punning flag so we can detect it later
-- (e.g. when pretty printing)
hsRecFields :: HsRecFields id arg -> [id]
hsRecFields rbinds = map (unLoc . hsRecFieldId) (rec_flds rbinds)
\end{code}
......@@ -212,19 +242,27 @@ pprUserCon c details = ppr c <+> pprConArgs details
pprConArgs (PrefixCon pats) = interppSP pats
pprConArgs (InfixCon p1 p2) = interppSP [p1,p2]
pprConArgs (RecCon rpats) = braces (hsep (punctuate comma (map (pp_rpat) rpats)))
where
pp_rpat (HsRecField v p _d) =
hsep [ppr v, char '=', ppr p]
pprConArgs (RecCon rpats) = ppr rpats
instance (OutputableBndr id, Outputable arg)
=> Outputable (HsRecFields id arg) where
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })
= braces (fsep (punctuate comma (map ppr flds)))
ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n })
= braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))
where
dotdot = ptext SLIT("..") <+> ifPprDebug (ppr (drop n flds))
instance (OutputableBndr id, Outputable arg)
=> Outputable (HsRecField id arg) where
ppr (HsRecField { hsRecFieldId = f, hsRecFieldArg = arg,
hsRecPun = pun })
= ppr f <+> (if pun then empty else equals <+> ppr arg)
-- add parallel array brackets around a document
--
pabrackets :: SDoc -> SDoc
pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
instance (OutputableBndr id, Outputable arg) =>
Outputable (HsRecField id arg) where
ppr (HsRecField n ty doc) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc
\end{code}
......@@ -343,7 +381,7 @@ isIrrefutableHsPat pat
go1 (ConPatIn _ _) = False -- Conservative
go1 (ConPatOut{ pat_con = L _ con, pat_args = details })
= isProductTyCon (dataConTyCon con)
&& all go (hsConArgs details)
&& all go (hsConPatArgs details)
go1 (LitPat _) = False
go1 (NPat _ _ _ _) = False
......
......@@ -383,8 +383,8 @@ collectl (L l pat) bndrs
go (PArrPat pats _) = foldr collectl bndrs pats
go (TuplePat pats _ _) = foldr collectl bndrs pats
go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConArgs ps)
go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps)
-- See Note [Dictionary binders in ConPatOut]
go (LitPat _) = bndrs
go (NPat _ _ _ _) = bndrs
......@@ -425,6 +425,6 @@ collect_pat (ParPat pat) acc = collect_lpat pat acc
collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats
collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats
collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps)
collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConPatArgs ps)
collect_pat other acc = acc -- Literals, vars, wildcard
\end{code}
......@@ -177,6 +177,9 @@ data DynFlag
| Opt_BangPatterns
| Opt_TypeFamilies
| Opt_OverloadedStrings
| Opt_DisambiguateRecordFields
| Opt_RecordDotDot
| Opt_RecordPuns
| Opt_GADTs
| Opt_RelaxedPolyRec -- -X=RelaxedPolyRec
......
......@@ -1136,7 +1136,7 @@ forall :: { Located [LHsTyVarBndr RdrName] }
: 'forall' tv_bndrs '.' { LL $2 }
| {- empty -} { noLoc [] }
constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) }
-- We parse the constructor declaration
-- C t1 t2
-- as a btype (treating C as a type constructor) and then convert C to be
......@@ -1149,7 +1149,7 @@ constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrN
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL }
| btype conop btype { LL ($2, InfixCon $1 $3) }
constr_stuff_record :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) }
constr_stuff_record :: { Located (Located RdrName, HsConDeclDetails RdrName) }
: oqtycon '{' '}' {% mkRecCon $1 [] >>= return.sL (comb2 $1 $>) }
| oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.sL (comb2 $1 $>) }
......@@ -1321,9 +1321,8 @@ aexp :: { LHsExpr RdrName }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4)
$3;
return (LL r) }}
: aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) $3
; return (LL r) }}
| aexp2 { $1 }
-- Here was the syntax for type applications that I was planning
......@@ -1548,16 +1547,21 @@ qual :: { LStmt RdrName }
-----------------------------------------------------------------------------
-- Record Field Update/Construction
fbinds :: { HsRecordBinds RdrName }
: fbinds1 { HsRecordBinds (reverse $1) }
| {- empty -} { HsRecordBinds [] }
fbinds :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
: fbinds1 { $1 }
| {- empty -} { ([], False) }
fbinds1 :: { [(Located id, LHsExpr id)] }
: fbinds1 ',' fbind { $3 : $1 }
| fbind { [$1] }
fbinds1 :: { ([HsRecField RdrName (LHsExpr RdrName)], Bool) }
: fbind ',' fbinds1 { case $3 of (flds, dd) -> ($1 : flds, dd) }
| fbind { ([$1], False) }
| '..' { ([], True) }
fbind :: { (Located RdrName, LHsExpr RdrName) }
: qvar '=' exp { ($1,$3) }
fbind :: { HsRecField RdrName (LHsExpr RdrName) }
: qvar '=' exp { HsRecField $1 $3 False }
| qvar { HsRecField $1 (L (getLoc $1) (HsVar (unLoc $1))) True }
-- Here's where we say that plain 'x'
-- means exactly 'x = x'. The pun-flag boolean is
-- there so we can still print it right
-----------------------------------------------------------------------------
-- Implicit Parameter Bindings
......
......@@ -348,7 +348,7 @@ add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
-- arguments, and converts the type constructor back into a data constructor.
mkPrefixCon :: LHsType RdrName -> [LBangType RdrName]
-> P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
-> P (Located RdrName, HsConDeclDetails RdrName)
mkPrefixCon ty tys
= split ty tys
where
......@@ -359,10 +359,10 @@ mkPrefixCon ty tys
mkRecCon :: Located RdrName ->
[([Located RdrName], LBangType RdrName, Maybe (LHsDoc RdrName))] ->
P (Located RdrName, HsConDetails RdrName (LBangType RdrName))
P (Located RdrName, HsConDeclDetails RdrName)
mkRecCon (L loc con) fields
= do data_con <- tyConToDataCon loc con
return (data_con, RecCon [ (HsRecField l t d) | (ls, t, d) <- fields, l <- ls ])
return (data_con, RecCon [ ConDeclField l t d | (ls, t, d) <- fields, l <- ls ])
tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName)
tyConToDataCon loc tc
......@@ -689,8 +689,9 @@ checkAPat loc e = case e of
ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps ->
return (TuplePat ps b placeHolderType)
RecordCon c _ (HsRecordBinds fs) -> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon (map (uncurry mkRecField) fs)))
RecordCon c _ (HsRecFields fs dd)
-> mapM checkPatField fs >>= \fs ->
return (ConPatIn c (RecCon (HsRecFields fs dd)))
-- Generics
HsType ty -> return (TypePat ty)
_ -> patFail loc
......@@ -699,10 +700,9 @@ plus_RDR, bang_RDR :: RdrName
plus_RDR = mkUnqual varName FSLIT("+") -- Hack
bang_RDR = mkUnqual varName FSLIT("!") -- Hack
checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName)
checkPatField (n,e) = do
p <- checkLPat e
return (n,p)
checkPatField :: HsRecField RdrName (LHsExpr RdrName) -> P (HsRecField RdrName (LPat RdrName))
checkPatField fld = do { p <- checkLPat (hsRecFieldArg fld)
; return (fld { hsRecFieldArg = p }) }
patFail loc = parseError loc "Parse error in pattern"
......@@ -852,15 +852,17 @@ checkPrecP (L l i)
mkRecConstrOrUpdate
:: LHsExpr RdrName
-> SrcSpan
-> HsRecordBinds RdrName
-> ([HsRecField RdrName (LHsExpr RdrName)], Bool)
-> P (HsExpr RdrName)
mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr fs)
mkRecConstrOrUpdate exp loc fs@(HsRecordBinds (_:_))
= return (RecordUpd exp fs [] [] [])
mkRecConstrOrUpdate _ loc (HsRecordBinds [])
= parseError loc "Empty record update"
mkRecConstrOrUpdate (L l (HsVar c)) loc (fs,dd) | isRdrDataCon c
= return (RecordCon (L l c) noPostTcExpr (mk_rec_fields fs dd))
mkRecConstrOrUpdate exp loc (fs,dd)
| null fs = parseError loc "Empty record update"
| otherwise = return (RecordUpd exp (mk_rec_fields fs dd) [] [] [])
mk_rec_fields fs False = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }
mk_rec_fields fs True = HsRecFields { rec_flds = fs, rec_dotdot = Just (length fs) }
mkInlineSpec :: Maybe Activation -> Bool -> InlineSpec
-- The Maybe is becuase the user can omit the activation spec (and usually does)
......
......@@ -27,7 +27,7 @@ import TcRnMonad
import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,
rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn,
lookupLocatedInstDeclBndr, newIPNameRn,
lookupInstDeclBndr, newIPNameRn,
lookupLocatedSigOccRn, bindPatSigTyVarsFV,
bindLocalFixities, bindSigTyVarsFV,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
......@@ -422,7 +422,7 @@ rnMethodBinds cls sig_fn gen_tyvars binds
rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf,
fun_matches = MatchGroup matches _ }))
= setSrcSpan loc $
lookupLocatedInstDeclBndr cls name `thenM` \ sel_name ->
lookupInstDeclBndr cls name `thenM` \ sel_name ->
let plain_name = unLoc sel_name in
-- We use the selector name as the binder
......
......@@ -12,7 +12,7 @@ module RnEnv (
lookupLocatedGlobalOccRn, lookupGlobalOccRn,
lookupLocalDataTcNames, lookupSrcOcc_maybe,
lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn,
lookupLocatedInstDeclBndr,
lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
lookupGreRn, lookupGreRn_maybe,
getLookupOccRn,
......@@ -50,10 +50,13 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe,
importSpecLoc, importSpecModule
)
import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity )
import TcEnv ( tcLookupDataCon )
import TcRnMonad
import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
nameSrcLoc, nameOccName, nameModule, isExternalName )
import NameSet
import NameEnv
import DataCon ( dataConFieldLabels )
import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
reportIfUnused )
import Module ( Module, ModuleName )
......@@ -64,6 +67,7 @@ import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc,
srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan )
import Outputable
import Util ( sortLe )
import Maybes
import ListSetOps ( removeDups )
import List ( nubBy )
import Monad ( when )
......@@ -215,33 +219,88 @@ lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do
Nothing -> lookupGlobalOccRn rdr_name
}}}
-- lookupInstDeclBndr is used for the binders in an