Skip to content

Commit 7004ca7

Browse files
committed
Fix bugs with record wildcards and record puns.
1 parent 0d52fc3 commit 7004ca7

14 files changed

+251
-119
lines changed

CHANGELOG.md

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ Version 0.9.0
66

77
* Preliminary support for pattern synonyms
88
* Relax bounds on aeson and haskell-src-exts
9+
* Fix bugs with record wildcards and record puns
910

1011
Version 0.8.0
1112
------------

src/Language/Haskell/Names/Annotated.hs

Lines changed: 82 additions & 39 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import Language.Haskell.Names.Open.Base
1717
import Language.Haskell.Names.Open.Instances ()
1818
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
1919
import qualified Language.Haskell.Names.LocalSymbolTable as Local
20-
import Language.Haskell.Names.SyntaxUtils (dropAnn, annName,setAnn)
20+
import Language.Haskell.Names.SyntaxUtils (dropAnn, setAnn)
2121
import Language.Haskell.Exts
2222
import Data.Proxy
2323
import Data.Lens.Light
@@ -46,25 +46,26 @@ annotateRec _ sc a = go sc a where
4646
= lookupName (fmap sLoc a) sc <$ a
4747
| Just (Refl :: FieldUpdate (Scoped l) :~: a) <- eqT
4848
= case a of
49-
FieldPun l qname -> FieldPun l (lookupQName (sLoc <$> qname) sc <$ qname)
50-
FieldWildcard l -> FieldWildcard (Scoped (RecExpWildcard namesRes) (sLoc l)) where
51-
namesRes = do
49+
FieldWildcard l ->
50+
FieldWildcard (Scoped (RecExpWildcard namesRes) (sLoc l)) where
51+
namesRes = do
5252
f <- sc ^. wcNames
53-
let qname = setAnn (sLoc l) (UnQual () (annName (wcFieldName f)))
54-
case lookupQName qname sc of
55-
Scoped info@(GlobalSymbol _ _) _ -> return (wcFieldName f,info)
56-
Scoped info@(LocalValue _) _ -> return (wcFieldName f,info)
57-
_ -> []
53+
let localQName = qualifyName Nothing (setAnn (sLoc l) (wcFieldName f))
54+
selectorQName = qualifyName (Just (wcFieldModuleName f)) (wcFieldName f)
55+
Scoped info _ <- return (lookupQName localQName sc)
56+
Scoped (GlobalSymbol symbol _) _ <- return (lookupQName selectorQName (exprRS sc))
57+
return (symbol, info)
5858
_ -> rmap go sc a
5959
| Just (Refl :: PatField (Scoped l) :~: a) <- eqT
60-
, PFieldWildcard l <- a
61-
= let
62-
namesRes = do
60+
= case a of
61+
PFieldWildcard l ->
62+
PFieldWildcard (Scoped (RecPatWildcard namesRes) (sLoc l)) where
63+
namesRes = do
6364
f <- sc ^. wcNames
64-
let qname = UnQual () (annName (wcFieldName f))
65-
Scoped (GlobalSymbol symbol _) _ <- return (lookupQName qname (exprV sc))
66-
return (symbol {symbolModule = wcFieldModuleName f})
67-
in PFieldWildcard (Scoped (RecPatWildcard namesRes) (sLoc l))
65+
let qname = qualifyName (Just (wcFieldModuleName f)) (wcFieldName f)
66+
Scoped (GlobalSymbol symbol _) _ <- return (lookupQName qname (exprRS sc))
67+
return symbol
68+
_ -> rmap go sc a
6869
| otherwise
6970
= rmap go sc a
7071

@@ -73,23 +74,47 @@ lookupQName :: QName l -> Scope -> Scoped l
7374
lookupQName (Special l _) _ = Scoped None l
7475
lookupQName qname scope = Scoped nameInfo (ann qname) where
7576

76-
nameInfo = case getL nameCtx scope of
77+
nameInfo = case getL patSynMode scope of
78+
79+
Nothing -> case getL nameCtx scope of
80+
81+
ReferenceV -> case Local.lookupValue qname (getL lTable scope) of
82+
Right srcloc -> LocalValue srcloc
83+
_ ->
84+
checkUniqueness (Global.lookupValue qname globalTable)
85+
86+
ReferenceT ->
87+
checkUniqueness (Global.lookupType qname globalTable)
88+
89+
ReferenceUT ->
90+
checkUniqueness (Global.lookupMethodOrAssociate qname' globalTable) where
91+
qname' = case qname of
92+
UnQual _ name -> qualifyName (getL instQual scope) name
93+
_ -> qname
94+
95+
ReferenceRS ->
96+
checkUniqueness (Global.lookupSelector qname globalTable)
97+
98+
_ -> None
99+
100+
Just PatSynLeftHandSide -> case getL nameCtx scope of
101+
102+
ReferenceV -> ValueBinder
77103

78-
ReferenceV -> case Local.lookupValue qname (getL lTable scope) of
79-
Right srcloc -> LocalValue srcloc
80-
_ ->
81-
checkUniqueness (Global.lookupValue qname globalTable)
104+
ReferenceRS -> ValueBinder
82105

83-
ReferenceT ->
84-
checkUniqueness (Global.lookupType qname globalTable)
106+
_ -> None
85107

86-
ReferenceUT ->
87-
checkUniqueness (Global.lookupMethodOrAssociate qname' globalTable) where
88-
qname' = case qname of
89-
UnQual _ name -> qualifyName (getL instQual scope) name
90-
_ -> qname
108+
Just PatSynRightHandSide -> case getL nameCtx scope of
109+
110+
ReferenceV -> case Local.lookupValue qname (getL lTable scope) of
111+
Right srcloc -> LocalValue srcloc
112+
_ -> checkUniqueness (Global.lookupValue qname globalTable)
113+
ReferenceRS ->
114+
checkUniqueness (Global.lookupSelector qname globalTable)
115+
116+
_ -> None
91117

92-
_ -> None
93118

94119
globalTable = getL gTable scope
95120

@@ -102,21 +127,39 @@ lookupQName qname scope = Scoped nameInfo (ann qname) where
102127
lookupName :: Name l -> Scope -> Scoped l
103128
lookupName name scope = Scoped nameInfo (ann name) where
104129

105-
nameInfo = case getL nameCtx scope of
130+
nameInfo = case getL patSynMode scope of
131+
132+
Nothing -> case getL nameCtx scope of
133+
134+
ReferenceUV ->
135+
checkUniqueness qname (Global.lookupMethodOrAssociate qname globalTable) where
136+
qname = qualifyName (getL instQual scope) name
137+
138+
SignatureV ->
139+
checkUniqueness qname (Global.lookupValue qname globalTable) where
140+
qname = qualifyName (Just (getL moduName scope)) name
141+
142+
BindingV -> ValueBinder
143+
144+
BindingT -> TypeBinder
145+
146+
_ -> None
147+
148+
Just PatSynLeftHandSide -> case getL nameCtx scope of
149+
150+
BindingV -> ValueBinder
106151

107-
ReferenceUV ->
108-
checkUniqueness qname (Global.lookupMethodOrAssociate qname globalTable) where
109-
qname = qualifyName (getL instQual scope) name
152+
_ -> None
110153

111-
SignatureV ->
112-
checkUniqueness qname (Global.lookupValue qname globalTable) where
113-
qname = qualifyName (Just (getL moduName scope)) name
154+
Just PatSynRightHandSide -> case getL nameCtx scope of
114155

115-
BindingV -> ValueBinder
156+
BindingV ->
157+
case Local.lookupValue (qualifyName Nothing name) (getL lTable scope) of
158+
Right srcloc -> LocalValue srcloc
159+
_ -> None
116160

117-
BindingT -> TypeBinder
161+
_ -> None
118162

119-
_ -> None
120163

121164
globalTable = getL gTable scope
122165

src/Language/Haskell/Names/GlobalSymbolTable.hs

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,9 @@ lookupType qn = filter isType . lookupName qn
3636
lookupMethodOrAssociate :: QName l -> Table -> [Symbol]
3737
lookupMethodOrAssociate qn = filter isMethodOrAssociated . lookupName qn
3838

39+
lookupSelector :: QName l -> Table -> [Symbol]
40+
lookupSelector qn = filter isSelector . lookupName qn
41+
3942
lookupName :: QName l -> Table -> [Symbol]
4043
lookupName qn table = fromMaybe [] (Map.lookup (dropAnn qn) table)
4144

@@ -66,6 +69,12 @@ isMethodOrAssociated symbol = case symbol of
6669
DataFam {} -> True
6770
_ -> False
6871

72+
isSelector :: Symbol -> Bool
73+
isSelector symbol = case symbol of
74+
Selector {} -> True
75+
PatternSelector {} -> True
76+
_ -> False
77+
6978
fromList :: [(QName (),Symbol)] -> Table
7079
fromList = Map.fromListWith List.union . map (second (:[]))
7180

src/Language/Haskell/Names/Open/Base.hs

Lines changed: 15 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -36,18 +36,20 @@ data NameContext
3636
-- ^ Reference an associated type in an instance declaration
3737
-- Unqualified names also match qualified names in scope
3838
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
39+
| ReferenceRS
40+
-- ^ Reference a record field selector
3941
| SignatureV
4042
-- ^ A type signature contains an always unqualified 'Name' that always
4143
-- refers to a value bound in the same module.
4244
| Other
4345

44-
-- | Pat node can work in different modes depending on where it got from
45-
data ResolveMode
46-
= NormalMode
47-
| SuppressBindings
48-
-- ^ Supress bindings, force references instead (even for Name)
49-
| BindQNames
46+
-- | Pattern synonyms can work in different modes depending on if we are on the
47+
-- left hand side or right hand side
48+
data PatSynMode
49+
= PatSynLeftHandSide
5050
-- ^ Bind QName's too
51+
| PatSynRightHandSide
52+
-- ^ Supress bindings, force references instead (even for Name)
5153

5254
-- | Contains information about the node's enclosing scope. Can be
5355
-- accessed through the lenses: 'gTable', 'lTable', 'nameCtx',
@@ -61,14 +63,14 @@ data Scope = Scope
6163
, _nameCtx :: NameContext
6264
, _instQual :: Maybe (ModuleName ())
6365
, _wcNames :: WcNames
64-
, _resMode :: ResolveMode
66+
, _patSynMode :: Maybe PatSynMode
6567
}
6668

6769
makeLens ''Scope
6870

6971
-- | Create an initial scope
7072
initialScope :: ModuleName () -> Global.Table -> Scope
71-
initialScope moduleName tbl = Scope moduleName tbl Local.empty Other Nothing [] NormalMode
73+
initialScope moduleName tbl = Scope moduleName tbl Local.empty Other Nothing [] Nothing
7274

7375
-- | Merge local tables of two scopes. The other fields of the scopes are
7476
-- assumed to be the same.
@@ -166,8 +168,11 @@ exprUV = setNameCtx ReferenceUV
166168
exprUT :: Scope -> Scope
167169
exprUT = setNameCtx ReferenceUT
168170

171+
exprRS :: Scope -> Scope
172+
exprRS = setNameCtx ReferenceRS
173+
169174
instQ :: Maybe (ModuleName ()) -> Scope -> Scope
170175
instQ m = setL instQual m
171176

172-
setMode :: ResolveMode -> Scope -> Scope
173-
setMode = setL resMode
177+
setPatSynMode :: PatSynMode -> Scope -> Scope
178+
setPatSynMode = setL patSynMode . Just

src/Language/Haskell/Names/Open/Instances.hs

Lines changed: 31 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -65,10 +65,10 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Decl l) where
6565
scWithPat = intro pat scWithPatSyn
6666
in
6767
c PatSyn
68-
<| sc -: l
69-
<| (setMode BindQNames sc) -: pat
70-
<| (setMode SuppressBindings $ exprV scWithPat) -: rpat
71-
<| sc -: dir
68+
<| sc -: l
69+
<| (setPatSynMode PatSynLeftHandSide sc) -: pat
70+
<| (setPatSynMode PatSynRightHandSide scWithPat) -: rpat
71+
<| sc -: dir
7272
TypeSig l names ty ->
7373
c TypeSig
7474
<| sc -: l
@@ -147,55 +147,29 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (FieldDecl l) where
147147
<| binderV sc -: name
148148
<| sc -: tys
149149

150-
-- | Affected by resolve mode
151-
mbinderV :: Scope -> Scope
152-
mbinderV sc = case getL resMode sc of
153-
SuppressBindings -> exprV sc
154-
_ -> binderV sc
155-
156-
mexprV :: Scope -> Scope
157-
mexprV sc = case getL resMode sc of
158-
BindQNames -> binderV sc
159-
_ -> exprV sc
160-
161-
(%|)
162-
:: (Applicative w, Resolvable (QName l), Resolvable (Name l), ?alg :: Alg w)
163-
=> w (QName l -> c) -> (QName l, Scope) -> w c
164-
f %| (name, sc) = case getL resMode sc of
165-
BindQNames -> (fmap (. nameToQName) f) <| (qNameToName name, sc)
166-
_ -> f <| (name, sc)
167-
infixl 4 %|
168-
169-
(%-)
170-
:: (Applicative w, Resolvable (QName l), Resolvable (Name l), ?alg :: Alg w)
171-
=> w (Name l -> c) -> (Name l, Scope) -> w c
172-
f %- (name, sc) = case getL resMode sc of
173-
SuppressBindings -> (fmap (. qNameToName) f) <| (nameToQName name, sc)
174-
_ -> f <| (name, sc)
175-
infixl 4 %-
176150

177151
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Pat l) where
178152
rtraverse e sc =
179153
case e of
180154
PVar l name ->
181155
c PVar
182156
<| sc -: l
183-
%- mbinderV sc -: name
157+
<| binderV sc -: name
184158
PNPlusK l name i ->
185159
c PNPlusK
186160
<| sc -: l
187-
%- mbinderV sc -: name
161+
<| binderV sc -: name
188162
<| sc -: i
189163
PInfixApp l pat1 name pat2 ->
190164
c PInfixApp
191165
<| sc -: l
192166
<| sc -: pat1
193-
%| mexprV sc -: name
167+
<| exprV sc -: name
194168
<| sc -: pat2
195169
PApp l qn pat ->
196170
c PApp
197171
<| sc -: l
198-
%| mexprV sc -: qn
172+
<| exprV sc -: qn
199173
<| sc -: pat
200174
PRec l qn pfs ->
201175
let
@@ -204,17 +178,17 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Pat l) where
204178
in
205179
c PRec
206180
<| sc -: l
207-
%| mexprV sc -: qn
181+
<| exprV sc -: qn
208182
<| scWc -: pfs
209183
PAsPat l n pat ->
210184
c PAsPat
211185
<| sc -: l
212-
%- mbinderV sc -: n
186+
<| binderV sc -: n
213187
<| sc -: pat
214188
PViewPat l exp pat ->
215189
c PViewPat
216190
<| sc -: l
217-
<| mexprV sc -: exp
191+
<| exprV sc -: exp
218192
<| sc -: pat
219193
_ -> defaultRtraverse e sc
220194

@@ -224,14 +198,12 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (PatField l) where
224198
PFieldPat l qn pat ->
225199
c PFieldPat
226200
<| sc -: l
227-
%| mexprV sc -: qn
201+
<| exprRS sc -: qn
228202
<| sc -: pat
229203
PFieldPun l qn ->
230204
c PFieldPun
231205
<| sc -: l
232-
%| mexprV sc -: qn
233-
-- In future we might want to annotate PFieldWildcard with the names
234-
-- it introduces.
206+
<| exprRS sc -: qn
235207
PFieldWildcard {} -> defaultRtraverse e sc
236208

237209
-- | Chain a sequence of nodes where every node may introduce some
@@ -350,12 +322,28 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Exp l) where
350322
sc
351323
in
352324
c RecConstr
353-
<| sc -: l
354-
<| sc -: qn
325+
<| sc -: l
326+
<| sc -: qn
355327
<| scWc -: fields
356328

357329
_ -> defaultRtraverse e sc
358330

331+
332+
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (FieldUpdate l) where
333+
rtraverse e sc =
334+
case e of
335+
FieldUpdate l qn exp ->
336+
c FieldUpdate
337+
<| sc -: l
338+
<| exprRS sc -: qn
339+
<| sc -: exp
340+
FieldPun l qn ->
341+
c FieldPun
342+
<| sc -: l
343+
<| exprRS sc -: qn
344+
FieldWildcard {} -> defaultRtraverse e sc
345+
346+
359347
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Alt l) where
360348
rtraverse e sc =
361349
case e of

0 commit comments

Comments
 (0)