summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs18
-rw-r--r--compiler/hsSyn/Convert.hs6
-rw-r--r--compiler/hsSyn/HsBinds.hs53
-rw-r--r--compiler/hsSyn/HsUtils.hs2
-rw-r--r--compiler/parser/Parser.y6
-rw-r--r--compiler/rename/RnBinds.hs14
-rw-r--r--compiler/rename/RnSource.hs2
-rw-r--r--compiler/typecheck/TcHsSyn.hs18
-rw-r--r--compiler/typecheck/TcInteract.hs3
-rw-r--r--compiler/typecheck/TcPatSyn.hs17
10 files changed, 52 insertions, 87 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f77d23ec06..db25c55837 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -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
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 47c2182a7a..de72878cda 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 0d06543d10..40617e33ef 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 8f4c2feeb4..e3bc371aad 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -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
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index c920f0c6e4..d40b62b0f7 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -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 -} { [] }
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 02a37b20ef..dc6c946f17 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -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
_ -> []
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index c1f0df160c..e51d9efc43 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -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
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 01b7176a6e..e188466107 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -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
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index 324b88c090..0ea08f47bc 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -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
diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 2bd30f4c06..7e21af5faa 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -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)
View Lorry Controller Status