Commit 584cbd4a authored by Simon Peyton Jones's avatar Simon Peyton Jones

Simplify HsPatSynDetails

This is a pure refactoring.  Use HsConDetails to implement
HsPatSynDetails, instead of defining a whole new data type.
Less code, fewer types, all good.
parent 4d41e921
......@@ -1491,10 +1491,10 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn
-- API. Whereas inside GHC, record pattern synonym selectors and
-- their pattern-only bound right hand sides have different names,
-- we want to treat them the same in TH. This is the reason why we
-- need an adjusted mkGenArgSyms in the `RecordPatSyn` case below.
mkGenArgSyms (PrefixPatSyn args) = mkGenSyms (map unLoc args)
mkGenArgSyms (InfixPatSyn arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecordPatSyn fields)
-- need an adjusted mkGenArgSyms in the `RecCon` case below.
mkGenArgSyms (PrefixCon args) = mkGenSyms (map unLoc args)
mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]
mkGenArgSyms (RecCon fields)
= do { let pats = map (unLoc . recordPatSynPatVar) fields
sels = map (unLoc . recordPatSynSelectorId) fields
; ss <- mkGenSyms sels
......@@ -1506,8 +1506,8 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn
wrapGenArgSyms :: HsPatSynDetails (Located Name)
-> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)
wrapGenArgSyms (RecordPatSyn _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
wrapGenArgSyms (RecCon _) _ dec = return dec
wrapGenArgSyms _ ss dec = wrapGenSyms ss dec
repPatSynD :: Core TH.Name
-> Core TH.PatSynArgsQ
......@@ -1518,14 +1518,14 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)
= rep2 patSynDName [syn, args, dir, pat]
repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)
repPatSynArgs (PrefixPatSyn args)
repPatSynArgs (PrefixCon args)
= do { args' <- repList nameTyConName lookupLOcc args
; repPrefixPatSynArgs args' }
repPatSynArgs (InfixPatSyn arg1 arg2)
repPatSynArgs (InfixCon arg1 arg2)
= do { arg1' <- lookupLOcc arg1
; arg2' <- lookupLOcc arg2
; repInfixPatSynArgs arg1' arg2' }
repPatSynArgs (RecordPatSyn fields)
repPatSynArgs (RecCon fields)
= do { sels' <- repList nameTyConName lookupLOcc sels
; repRecordPatSynArgs sels' }
where sels = map recordPatSynSelectorId fields
......
......@@ -367,12 +367,12 @@ cvtDec (TH.PatSynD nm args dir pat)
; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' }
where
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2
cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args
cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2
cvtArgs (TH.RecordPatSyn sels)
= do { sels' <- mapM vNameL sels
; vars' <- mapM (vNameL . mkNameS . nameBase) sels
; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }
cvtDir _ Unidir = return Unidirectional
cvtDir _ ImplBidir = return ImplicitBidirectional
......
......@@ -716,11 +716,10 @@ instance (SourceTextX idR,
ppr_simple syntax = syntax <+> ppr pat
ppr_details = case details of
InfixPatSyn v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
PrefixPatSyn vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecordPatSyn vs ->
pprPrefixOcc psyn
<> braces (sep (punctuate comma (map ppr vs)))
InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]
PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs)
RecCon vs -> pprPrefixOcc psyn
<> braces (sep (punctuate comma (map ppr vs)))
ppr_rhs = case dir of
Unidirectional -> ppr_simple (text "<-")
......@@ -1137,12 +1136,7 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)
-}
-- | Haskell Pattern Synonym Details
data HsPatSynDetails a
= InfixPatSyn a a -- ^ Infix Pattern Synonym
| PrefixPatSyn [a] -- ^ Prefix Pattern Synonym
| RecordPatSyn [RecordPatSynField a] -- ^ Record Pattern Synonym
deriving Data
type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]
-- See Note [Record PatSyn Fields]
-- | Record Pattern Synonym Field
......@@ -1199,43 +1193,6 @@ instance Traversable RecordPatSynField where
<$> 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)
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
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
-- | Haskell Pattern Synonym Direction
data HsPatSynDir id
= Unidirectional
......
......@@ -1070,7 +1070,7 @@ hsPatSynSelectors (ValBindsOut binds _)
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
| L _ (PatSynBind (PSB { psb_args = RecordPatSyn as })) <- bind
| L _ (PatSynBind (PSB { psb_args = RecCon as })) <- bind
= map (unLoc . recordPatSynSelectorId) as ++ sels
| otherwise = sels
......
......@@ -1375,9 +1375,9 @@ pattern_synonym_decl :: { LHsDecl GhcPs }
}}
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] ) }
: con vars0 { ($1, PrefixCon $2, []) }
| varid conop varid { ($2, InfixCon $1 $3, []) }
| con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }
vars0 :: { [Located RdrName] }
: {- empty -} { [] }
......
......@@ -660,19 +660,19 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
-- so that the binding locations are reported
-- from the left-hand side
case details of
PrefixPatSyn vars ->
PrefixCon vars ->
do { checkDupRdrNames vars
; names <- mapM lookupPatSynBndr vars
; return ( (pat', PrefixPatSyn names)
; return ( (pat', PrefixCon names)
, mkFVs (map unLoc names)) }
InfixPatSyn var1 var2 ->
InfixCon var1 var2 ->
do { checkDupRdrNames [var1, var2]
; name1 <- lookupPatSynBndr var1
; name2 <- lookupPatSynBndr var2
-- ; checkPrecMatch -- TODO
; return ( (pat', InfixPatSyn name1 name2)
; return ( (pat', InfixCon name1 name2)
, mkFVs (map unLoc [name1, name2])) }
RecordPatSyn vars ->
RecCon vars ->
do { checkDupRdrNames (map recordPatSynSelectorId vars)
; let rnRecordPatSynField
(RecordPatSynField { recordPatSynSelectorId = visible
......@@ -682,7 +682,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
; return $ RecordPatSynField { recordPatSynSelectorId = visible'
, recordPatSynPatVar = hidden' } }
; names <- mapM rnRecordPatSynField vars
; return ( (pat', RecordPatSyn names)
; return ( (pat', RecCon names)
, mkFVs (map (unLoc . recordPatSynPatVar) names)) }
; (dir', fvs2) <- case dir of
......@@ -706,7 +706,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
, psb_dir = dir'
, psb_fvs = fvs' }
selector_names = case details' of
RecordPatSyn names ->
RecCon names ->
map (unLoc . recordPatSynSelectorId) names
_ -> []
......
......@@ -2005,7 +2005,7 @@ extendPatSynEnv val_decls local_fix_env thing = do {
-> TcM [(Name, [FieldLabel])]
new_ps' bind names
| L bind_loc (PatSynBind (PSB { psb_id = L _ n
, psb_args = RecordPatSyn as })) <- bind
, psb_args = RecCon as })) <- bind
= do
bnd_name <- newTopSrcBinder (L bind_loc n)
let rnames = map recordPatSynSelectorId as
......
......@@ -267,6 +267,9 @@ zonkEnvIds (ZonkEnv _ _ id_env) =
-- It's OK to use nonDetEltsUFM here because we forget the ordering
-- immediately by creating a TypeEnv
zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id
zonkLIdOcc env (L loc id) = L loc (zonkIdOcc env id)
zonkIdOcc :: ZonkEnv -> TcId -> Id
-- Ids defined in this module should be in the envt;
-- ignore others. (Actually, data constructors are also
......@@ -508,8 +511,8 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
, psb_def = lpat
, psb_dir = dir }))
= do { id' <- zonkIdBndr env id
; details' <- zonkPatSynDetails env details
; (env1, lpat') <- zonkPat env lpat
; let details' = zonkPatSynDetails env1 details
; (_env2, dir') <- zonkPatSynDir env1 dir
; return $ PatSynBind $
bind { psb_id = L loc id'
......@@ -519,12 +522,17 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id
zonkPatSynDetails :: ZonkEnv
-> HsPatSynDetails (Located TcId)
-> TcM (HsPatSynDetails (Located Id))
zonkPatSynDetails env = traverse (wrapLocM $ zonkIdBndr env)
-> HsPatSynDetails (Located Id)
zonkPatSynDetails env (PrefixCon as)
= PrefixCon (map (zonkLIdOcc env) as)
zonkPatSynDetails env (InfixCon a1 a2)
= InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)
zonkPatSynDetails env (RecCon flds)
= RecCon (map (fmap (zonkLIdOcc env)) flds)
zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId
-> TcM (ZonkEnv, HsPatSynDir GhcTc)
zonkPatSynDir env Unidirectional = return (env, Unidirectional)
zonkPatSynDir env Unidirectional = return (env, Unidirectional)
zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)
zonkPatSynDir env (ExplicitBidirectional mg) = do
mg' <- zonkMatchGroup env zonkLExpr mg
......@@ -1342,7 +1350,7 @@ zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls
zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)
zonkForeignExport env (ForeignExport { fd_name = i, fd_co = co, fd_fe = spec })
= return (ForeignExport { fd_name = fmap (zonkIdOcc env) i
= return (ForeignExport { fd_name = zonkLIdOcc env i
, fd_sig_ty = undefined, fd_co = co
, fd_fe = spec })
zonkForeignExport _ for_imp
......
......@@ -555,7 +555,8 @@ solveOneFromTheOther ev_i ev_w
-- See Note [Replacement vs keeping]
| lvl_i == lvl_w
= do { binds <- getTcEvBindsMap
= do { ev_binds_var <- getTcEvBindsVar
; binds <- getTcEvBindsMap ev_binds_var
; return (same_level_strategy binds) }
| otherwise -- Both are Given, levels differ
......
......@@ -402,12 +402,11 @@ 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)
PrefixCon names -> (map unLoc names, [], False)
InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)
RecCon names -> (vars, sels, False)
where
(vars, sels) = unzip (map splitRecordPatSyn names)
where
splitRecordPatSyn :: RecordPatSynField (Located Name)
-> (Name, Name)
......@@ -710,9 +709,9 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
(noLoc EmptyLocalBinds)
args = case details of
PrefixPatSyn args -> args
InfixPatSyn arg1 arg2 -> [arg1, arg2]
RecordPatSyn args -> map recordPatSynPatVar args
PrefixCon args -> args
InfixCon arg1 arg2 -> [arg1, arg2]
RecCon args -> map recordPatSynPatVar args
add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)
-> MatchGroup GhcRn (LHsExpr GhcRn)
......
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