Skip to content

Commit ce94cd9

Browse files
garybgaryb
authored
Add source spans to name constructors and fix ShadowedName warning (purescript#3213)
1 parent 30de1f8 commit ce94cd9

27 files changed

Lines changed: 271 additions & 257 deletions

‎src/Language/PureScript/AST/Binders.hs‎

Lines changed: 8 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -26,16 +26,16 @@ data Binder
2626
-- |
2727
-- A binder which binds an identifier
2828
--
29-
| VarBinder Ident
29+
| VarBinder SourceSpan Ident
3030
-- |
3131
-- A binder which matches a data constructor
3232
--
33-
| ConstructorBinder (Qualified (ProperName 'ConstructorName)) [Binder]
33+
| ConstructorBinder SourceSpan (Qualified (ProperName 'ConstructorName)) [Binder]
3434
-- |
3535
-- A operator alias binder. During the rebracketing phase of desugaring,
3636
-- this data constructor will be removed.
3737
--
38-
| OpBinder (Qualified (OpName 'ValueOpName))
38+
| OpBinder SourceSpan (Qualified (OpName 'ValueOpName))
3939
-- |
4040
-- Binary operator application. During the rebracketing phase of desugaring,
4141
-- this data constructor will be removed.
@@ -52,7 +52,7 @@ data Binder
5252
-- |
5353
-- A binder which binds its input to an identifier
5454
--
55-
| NamedBinder Ident Binder
55+
| NamedBinder SourceSpan Ident Binder
5656
-- |
5757
-- A binder with source position information
5858
--
@@ -70,11 +70,11 @@ binderNames :: Binder -> [Ident]
7070
binderNames = go []
7171
where
7272
go ns (LiteralBinder b) = lit ns b
73-
go ns (VarBinder name) = name : ns
74-
go ns (ConstructorBinder _ bs) = foldl go ns bs
73+
go ns (VarBinder _ name) = name : ns
74+
go ns (ConstructorBinder _ _ bs) = foldl go ns bs
7575
go ns (BinaryNoParensBinder b1 b2 b3) = foldl go ns [b1, b2, b3]
7676
go ns (ParensInBinder b) = go ns b
77-
go ns (NamedBinder name b) = go (name : ns) b
77+
go ns (NamedBinder _ name b) = go (name : ns) b
7878
go ns (PositionedBinder _ _ b) = go ns b
7979
go ns (TypedBinder _ b) = go ns b
8080
go ns _ = ns
@@ -84,8 +84,7 @@ binderNames = go []
8484

8585
isIrrefutable :: Binder -> Bool
8686
isIrrefutable NullBinder = True
87-
isIrrefutable (VarBinder _) = True
87+
isIrrefutable (VarBinder _ _) = True
8888
isIrrefutable (PositionedBinder _ _ b) = isIrrefutable b
8989
isIrrefutable (TypedBinder _ b) = isIrrefutable b
9090
isIrrefutable _ = False
91-

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -701,7 +701,7 @@ data Expr
701701
-- |
702702
-- A prefix -, will be desugared
703703
--
704-
| UnaryMinus Expr
704+
| UnaryMinus SourceSpan Expr
705705
-- |
706706
-- Binary operator application. During the rebracketing phase of desugaring, this data constructor
707707
-- will be removed.
@@ -741,20 +741,20 @@ data Expr
741741
-- |
742742
-- Variable
743743
--
744-
| Var (Qualified Ident)
744+
| Var SourceSpan (Qualified Ident)
745745
-- |
746746
-- An operator. This will be desugared into a function during the "operators"
747747
-- phase of desugaring.
748748
--
749-
| Op (Qualified (OpName 'ValueOpName))
749+
| Op SourceSpan (Qualified (OpName 'ValueOpName))
750750
-- |
751751
-- Conditional (if-then-else expression)
752752
--
753753
| IfThenElse Expr Expr Expr
754754
-- |
755755
-- A data constructor
756756
--
757-
| Constructor (Qualified (ProperName 'ConstructorName))
757+
| Constructor SourceSpan (Qualified (ProperName 'ConstructorName))
758758
-- |
759759
-- A case expression. During the case expansion phase of desugaring, top-level binders will get
760760
-- desugared into case expressions, hence the need for guards and multiple binders per branch here.
@@ -887,8 +887,8 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ImportDe
887887

888888
isTrueExpr :: Expr -> Bool
889889
isTrueExpr (Literal (BooleanLiteral True)) = True
890-
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
891-
isTrueExpr (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
890+
isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Prelude"])) (Ident "otherwise"))) = True
891+
isTrueExpr (Var _ (Qualified (Just (ModuleName [ProperName "Data", ProperName "Boolean"])) (Ident "otherwise"))) = True
892892
isTrueExpr (TypedValue _ e _) = isTrueExpr e
893893
isTrueExpr (PositionedValue _ _ e) = isTrueExpr e
894894
isTrueExpr _ = False

‎src/Language/PureScript/AST/SourcePos.hs‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -80,3 +80,6 @@ instance A.FromJSON SourceSpan where
8080

8181
internalModuleSourceSpan :: String -> SourceSpan
8282
internalModuleSourceSpan name = SourceSpan name (SourcePos 0 0) (SourcePos 0 0)
83+
84+
nullSourceSpan :: SourceSpan
85+
nullSourceSpan = internalModuleSourceSpan ""

‎src/Language/PureScript/AST/Traversals.hs‎

Lines changed: 21 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ everywhereOnValues f g h = (f', g', h')
6363

6464
g' :: Expr -> Expr
6565
g' (Literal l) = g (Literal (lit g' l))
66-
g' (UnaryMinus v) = g (UnaryMinus (g' v))
66+
g' (UnaryMinus ss v) = g (UnaryMinus ss (g' v))
6767
g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
6868
g' (Parens v) = g (Parens (g' v))
6969
g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
@@ -82,11 +82,11 @@ everywhereOnValues f g h = (f', g', h')
8282
g' other = g other
8383

8484
h' :: Binder -> Binder
85-
h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (fmap h' bs))
85+
h' (ConstructorBinder ss ctor bs) = h (ConstructorBinder ss ctor (fmap h' bs))
8686
h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3))
8787
h' (ParensInBinder b) = h (ParensInBinder (h' b))
8888
h' (LiteralBinder l) = h (LiteralBinder (lit h' l))
89-
h' (NamedBinder name b) = h (NamedBinder name (h' b))
89+
h' (NamedBinder ss name b) = h (NamedBinder ss name (h' b))
9090
h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
9191
h' (TypedBinder t b) = h (TypedBinder t (h' b))
9292
h' other = h other
@@ -137,7 +137,7 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
137137

138138
g' :: Expr -> m Expr
139139
g' (Literal l) = Literal <$> litM (g >=> g') l
140-
g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
140+
g' (UnaryMinus ss v) = UnaryMinus ss <$> (g v >>= g')
141141
g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
142142
g' (Parens v) = Parens <$> (g v >>= g')
143143
g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
@@ -157,10 +157,10 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
157157

158158
h' :: Binder -> m Binder
159159
h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l
160-
h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs
160+
h' (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h' <=< h) bs
161161
h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h')
162162
h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h')
163-
h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
163+
h' (NamedBinder ss name b) = NamedBinder ss name <$> (h b >>= h')
164164
h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
165165
h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h')
166166
h' other = h other
@@ -206,7 +206,7 @@ everywhereOnValuesM f g h = (f', g', h')
206206

207207
g' :: Expr -> m Expr
208208
g' (Literal l) = (Literal <$> litM g' l) >>= g
209-
g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
209+
g' (UnaryMinus ss v) = (UnaryMinus ss <$> g' v) >>= g
210210
g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
211211
g' (Parens v) = (Parens <$> g' v) >>= g
212212
g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
@@ -226,10 +226,10 @@ everywhereOnValuesM f g h = (f', g', h')
226226

227227
h' :: Binder -> m Binder
228228
h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h
229-
h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h
229+
h' (ConstructorBinder ss ctor bs) = (ConstructorBinder ss ctor <$> traverse h' bs) >>= h
230230
h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h
231231
h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h
232-
h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
232+
h' (NamedBinder ss name b) = (NamedBinder ss name <$> h' b) >>= h
233233
h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
234234
h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h
235235
h' other = h other
@@ -278,7 +278,7 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
278278

279279
g' :: Expr -> r
280280
g' v@(Literal l) = lit (g v) g' l
281-
g' v@(UnaryMinus v1) = g v <> g' v1
281+
g' v@(UnaryMinus _ v1) = g v <> g' v1
282282
g' v@(BinaryNoParens op v1 v2) = g v <> g' op <> g' v1 <> g' v2
283283
g' v@(Parens v1) = g v <> g' v1
284284
g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
@@ -298,10 +298,10 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
298298

299299
h' :: Binder -> r
300300
h' b@(LiteralBinder l) = lit (h b) h' l
301-
h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (fmap h' bs)
301+
h' b@(ConstructorBinder _ _ bs) = foldl (<>) (h b) (fmap h' bs)
302302
h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3
303303
h' b@(ParensInBinder b1) = h b <> h' b1
304-
h' b@(NamedBinder _ b1) = h b <> h' b1
304+
h' b@(NamedBinder _ _ b1) = h b <> h' b1
305305
h' b@(PositionedBinder _ _ b1) = h b <> h' b1
306306
h' b@(TypedBinder _ b1) = h b <> h' b1
307307
h' b = h b
@@ -359,7 +359,7 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
359359

360360
g' :: s -> Expr -> r
361361
g' s (Literal l) = lit g'' s l
362-
g' s (UnaryMinus v1) = g'' s v1
362+
g' s (UnaryMinus _ v1) = g'' s v1
363363
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
364364
g' s (Parens v1) = g'' s v1
365365
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
@@ -382,10 +382,10 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
382382

383383
h' :: s -> Binder -> r
384384
h' s (LiteralBinder l) = lit h'' s l
385-
h' s (ConstructorBinder _ bs) = foldl (<>) r0 (fmap (h'' s) bs)
385+
h' s (ConstructorBinder _ _ bs) = foldl (<>) r0 (fmap (h'' s) bs)
386386
h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3
387387
h' s (ParensInBinder b) = h'' s b
388-
h' s (NamedBinder _ b1) = h'' s b1
388+
h' s (NamedBinder _ _ b1) = h'' s b1
389389
h' s (PositionedBinder _ _ b1) = h'' s b1
390390
h' s (TypedBinder _ b1) = h'' s b1
391391
h' _ _ = r0
@@ -444,7 +444,7 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
444444
g'' s = uncurry g' <=< g s
445445

446446
g' s (Literal l) = Literal <$> lit g'' s l
447-
g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
447+
g' s (UnaryMinus ss v) = UnaryMinus ss <$> g'' s v
448448
g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
449449
g' s (Parens v) = Parens <$> g'' s v
450450
g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
@@ -465,10 +465,10 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
465465
h'' s = uncurry h' <=< h s
466466

467467
h' s (LiteralBinder l) = LiteralBinder <$> lit h'' s l
468-
h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h'' s) bs
468+
h' s (ConstructorBinder ss ctor bs) = ConstructorBinder ss ctor <$> traverse (h'' s) bs
469469
h' s (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> h'' s b1 <*> h'' s b2 <*> h'' s b3
470470
h' s (ParensInBinder b) = ParensInBinder <$> h'' s b
471-
h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
471+
h' s (NamedBinder ss name b) = NamedBinder ss name <$> h'' s b
472472
h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
473473
h' s (TypedBinder t b) = TypedBinder t <$> h'' s b
474474
h' _ other = return other
@@ -534,7 +534,7 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
534534

535535
g' :: S.Set Ident -> Expr -> r
536536
g' s (Literal l) = lit g'' s l
537-
g' s (UnaryMinus v1) = g'' s v1
537+
g' s (UnaryMinus _ v1) = g'' s v1
538538
g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
539539
g' s (Parens v1) = g'' s v1
540540
g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
@@ -563,10 +563,10 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
563563

564564
h' :: S.Set Ident -> Binder -> r
565565
h' s (LiteralBinder l) = lit h'' s l
566-
h' s (ConstructorBinder _ bs) = foldMap (h'' s) bs
566+
h' s (ConstructorBinder _ _ bs) = foldMap (h'' s) bs
567567
h' s (BinaryNoParensBinder b1 b2 b3) = foldMap (h'' s) [b1, b2, b3]
568568
h' s (ParensInBinder b) = h'' s b
569-
h' s (NamedBinder name b1) = h'' (S.insert name s) b1
569+
h' s (NamedBinder _ name b1) = h'' (S.insert name s) b1
570570
h' s (PositionedBinder _ _ b1) = h'' s b1
571571
h' s (TypedBinder _ b1) = h'' s b1
572572
h' _ _ = mempty

‎src/Language/PureScript/CoreFn/Desugar.hs‎

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -79,21 +79,21 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
7979
Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
8080
exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
8181
ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs
82-
exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) =
82+
exprToCoreFn ss com ty (A.Abs (A.VarBinder _ name) v) =
8383
Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
8484
exprToCoreFn _ _ _ (A.Abs _ _) =
8585
internalError "Abs with Binder argument was not desugared before exprToCoreFn mn"
8686
exprToCoreFn ss com ty (A.App v1 v2) =
8787
App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
88-
exprToCoreFn ss com ty (A.Var ident) =
88+
exprToCoreFn _ com ty (A.Var ss ident) =
8989
Var (ss, com, ty, getValueMeta ident) ident
9090
exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
9191
Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
9292
[ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True]
9393
(Right $ exprToCoreFn ss [] Nothing v2)
9494
, CaseAlternative [NullBinder (ssAnn ss)]
9595
(Right $ exprToCoreFn ss [] Nothing v3) ]
96-
exprToCoreFn ss com ty (A.Constructor name) =
96+
exprToCoreFn _ com ty (A.Constructor ss name) =
9797
Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
9898
exprToCoreFn ss com ty (A.Case vs alts) =
9999
Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts)
@@ -137,12 +137,12 @@ moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) =
137137
LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit)
138138
binderToCoreFn ss com A.NullBinder =
139139
NullBinder (ss, com, Nothing, Nothing)
140-
binderToCoreFn ss com (A.VarBinder name) =
140+
binderToCoreFn _ com (A.VarBinder ss name) =
141141
VarBinder (ss, com, Nothing, Nothing) name
142-
binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
142+
binderToCoreFn _ com (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) =
143143
let (_, tctor, _, _) = lookupConstructor env dctor
144144
in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs)
145-
binderToCoreFn ss com (A.NamedBinder name b) =
145+
binderToCoreFn _ com (A.NamedBinder ss name b) =
146146
NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
147147
binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
148148
binderToCoreFn ss (com ++ com1) b
@@ -198,16 +198,16 @@ findQualModules decls =
198198
fqDecls _ = []
199199

200200
fqValues :: A.Expr -> [ModuleName]
201-
fqValues (A.Var q) = getQual' q
202-
fqValues (A.Constructor q) = getQual' q
201+
fqValues (A.Var _ q) = getQual' q
202+
fqValues (A.Constructor _ q) = getQual' q
203203
-- Some instances are automatically solved and have their class dictionaries
204204
-- built inline instead of having a named instance defined and imported.
205205
-- We therefore need to import these constructors if they aren't already.
206206
fqValues (A.TypeClassDictionaryConstructorApp c _) = getQual' c
207207
fqValues _ = []
208208

209209
fqBinders :: A.Binder -> [ModuleName]
210-
fqBinders (A.ConstructorBinder q _) = getQual' q
210+
fqBinders (A.ConstructorBinder _ q _) = getQual' q
211211
fqBinders _ = []
212212

213213
getQual' :: Qualified a -> [ModuleName]

‎src/Language/PureScript/Interactive/Module.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -49,8 +49,8 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
4949
effModuleName = P.moduleNameFromString "Control.Monad.Eff"
5050
effImport = (effModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Eff"]))
5151
supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"]))
52-
eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
53-
mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it")))
52+
eval = P.Var internalSpan (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval"))
53+
mainValue = P.App eval (P.Var internalSpan (P.Qualified Nothing (P.Ident "it")))
5454
itDecl = P.ValueDecl (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val]
5555
typeDecl = P.TypeDeclaration
5656
(P.TypeDeclarationData (internalSpan, []) (P.Ident "$main")

‎src/Language/PureScript/Linter.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -54,24 +54,24 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
5454
f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec
5555

5656
stepE :: S.Set Ident -> Expr -> MultipleErrors
57-
stepE s (Abs (VarBinder name) _) | name `S.member` s = errorMessage (ShadowedName name)
57+
stepE s (Abs (VarBinder ss name) _) | name `S.member` s = errorMessage' ss (ShadowedName name)
5858
stepE s (Let ds' _) = foldMap go ds'
5959
where
6060
go d | Just i <- getDeclIdent d
61-
, i `S.member` s = errorMessage (ShadowedName i)
61+
, i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i)
6262
| otherwise = mempty
6363
stepE _ _ = mempty
6464

6565
stepB :: S.Set Ident -> Binder -> MultipleErrors
66-
stepB s (VarBinder name) | name `S.member` s = errorMessage (ShadowedName name)
67-
stepB s (NamedBinder name _) | name `S.member` s = errorMessage (ShadowedName name)
66+
stepB s (VarBinder ss name) | name `S.member` s = errorMessage' ss (ShadowedName name)
67+
stepB s (NamedBinder ss name _) | name `S.member` s = errorMessage' ss (ShadowedName name)
6868
stepB _ _ = mempty
6969

7070
stepDo :: S.Set Ident -> DoNotationElement -> MultipleErrors
7171
stepDo s (DoNotationLet ds') = foldMap go ds'
7272
where
7373
go d | Just i <- getDeclIdent d
74-
, i `S.member` s = errorMessage (ShadowedName i)
74+
, i `S.member` s = errorMessage' (declSourceSpan d) (ShadowedName i)
7575
| otherwise = mempty
7676
stepDo _ _ = mempty
7777

0 commit comments

Comments
 (0)