Commit 3dce4f2d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor RecordPatSynField, FieldLabel

This patch uses the named fields of
 * FieldLabel
 * RecordPatSynField
in construction and pattern matching. The fields
existed before, but we were often using positional notation.

Also a minor refactor of the API of mkPatSynRecSelBinds

No change in functionality
parent 4c746cb2
......@@ -119,7 +119,8 @@ instance Binary a => Binary (FieldLbl a) where
-- See Note [Why selector names include data constructors].
mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName
mkFieldLabelOccs lbl dc is_overloaded
= FieldLabel lbl is_overloaded sel_occ
= FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
, flSelector = sel_occ }
where
str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc
sel_occ | is_overloaded = mkRecFldSelOcc str
......
......@@ -612,7 +612,8 @@ gresFromAvail prov_fn avail
Just is -> GRE { gre_name = n, gre_par = mkParent n avail
, gre_lcl = False, gre_imp = [is] }
mk_fld_gre (FieldLabel lbl is_overloaded n)
mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded
, flSelector = n })
= case prov_fn n of -- Nothing => bound locally
-- Just is => imported from 'is'
Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl
......@@ -676,12 +677,19 @@ mkParent n (AvailTC m _ _) | n == m = NoParent
availFromGRE :: GlobalRdrElt -> AvailInfo
availFromGRE (GRE { gre_name = me, gre_par = parent })
= case parent of
PatternSynonym -> patSynAvail me
ParentIs p -> AvailTC p [me] []
NoParent | isTyConName me -> AvailTC me [me] []
| otherwise -> avail me
FldParent p Nothing -> AvailTC p [] [FieldLabel (occNameFS $ nameOccName me) False me]
FldParent p (Just lbl) -> AvailTC p [] [FieldLabel lbl True me]
PatternSynonym -> patSynAvail me
FldParent p mb_lbl -> AvailTC p [] [fld]
where
fld = case mb_lbl of
Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me)
, flIsOverloaded = False
, flSelector = me }
Just lbl -> FieldLabel { flLabel = lbl
, flIsOverloaded = True
, flSelector = me }
emptyGlobalRdrEnv :: GlobalRdrEnv
emptyGlobalRdrEnv = emptyOccEnv
......
......@@ -977,19 +977,25 @@ the distinction between the two names clear
-}
instance Functor RecordPatSynField where
fmap f (RecordPatSynField visible hidden) =
RecordPatSynField (f visible) (f hidden)
fmap f (RecordPatSynField { recordPatSynSelectorId = visible
, recordPatSynPatVar = hidden })
= RecordPatSynField { recordPatSynSelectorId = f visible
, recordPatSynPatVar = f hidden }
instance Outputable a => Outputable (RecordPatSynField a) where
ppr (RecordPatSynField v _) = ppr v
ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v
instance Foldable RecordPatSynField where
foldMap f (RecordPatSynField visible hidden) =
f visible `mappend` f hidden
foldMap f (RecordPatSynField { recordPatSynSelectorId = visible
, recordPatSynPatVar = hidden })
= f visible `mappend` f hidden
instance Traversable RecordPatSynField where
traverse f (RecordPatSynField visible hidden) =
RecordPatSynField <$> f visible <*> f hidden
traverse f (RecordPatSynField { recordPatSynSelectorId =visible
, recordPatSynPatVar = hidden })
= (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id
, recordPatSynPatVar = pat_var })
<$> f visible <*> f hidden
instance Functor HsPatSynDetails where
......
......@@ -639,10 +639,12 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L _ name
RecordPatSyn vars ->
do { checkDupRdrNames (map recordPatSynSelectorId vars)
; let rnRecordPatSynField
(RecordPatSynField visible hidden) = do {
; visible' <- lookupLocatedTopBndrRn visible
; hidden' <- lookupVar hidden
; return $ RecordPatSynField visible' hidden' }
(RecordPatSynField { recordPatSynSelectorId = visible
, recordPatSynPatVar = hidden })
= do { visible' <- lookupLocatedTopBndrRn visible
; hidden' <- lookupVar hidden
; return $ RecordPatSynField { recordPatSynSelectorId = visible'
, recordPatSynPatVar = hidden' } }
; names <- mapM rnRecordPatSynField vars
; return ( (pat', RecordPatSyn names)
, mkFVs (map (unLoc . recordPatSynPatVar) names)) }
......
......@@ -1997,12 +1997,10 @@ 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 pat_syn_bndrs = concat [ name: map flSelector fields
| (name, fields) <- names_with_fls ]
; let avails = map patSynAvail pat_syn_bndrs
; (gbl_env, lcl_env) <-
extendGlobalRdrEnvRn avails local_fix_env
; (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' }
......
......@@ -467,8 +467,10 @@ tc_patsyn_finish lname dir is_infix lpat'
arg_tys pat_ty
-- TODO: Make this have the proper information
; let mkFieldLabel name = FieldLabel (occNameFS (nameOccName name)) False name
field_labels' = (map mkFieldLabel field_labels)
; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)
, flIsOverloaded = False
, flSelector = name }
field_labels' = map mkFieldLabel field_labels
-- Make the PatSyn itself
......@@ -481,13 +483,10 @@ tc_patsyn_finish lname dir is_infix lpat'
field_labels'
-- 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)
; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)
tything = AConLike (PatSynCon patSyn)
; tcg_env <- tcExtendGlobalEnv [tything] $
tcRecSelBinds rn_rec_sel_binds
; traceTc "tc_patsyn_finish }" empty
; return (matcher_bind, tcg_env) }
......@@ -586,14 +585,13 @@ 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 mkRecSel fields
-> [FieldLabel] -- ^ Visible field labels
-> HsValBinds Name
mkPatSynRecSelBinds ps fields
= ValBindsOut selector_binds sigs
where
mkRecSel fld_lbl =
case mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl of
(name, (_rec_flag, binds)) -> (name, binds)
(sigs, selector_binds) = unzip (map mkRecSel fields)
mkRecSel fld_lbl = mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl
isUnidirectional :: HsPatSynDir a -> Bool
isUnidirectional Unidirectional = True
......
......@@ -913,7 +913,7 @@ mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, (RecFlag, LHsBinds Name))
mkRecSelBind (tycon, fl)
= mkOneRecordSelector all_cons (RecSelData tycon) fl
where
all_cons = map RealDataCon (tyConDataCons tycon)
all_cons = map RealDataCon (tyConDataCons tycon)
mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
-> (LSig Name, (RecFlag, LHsBinds Name))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment