Skip to content

Commit cd437b2

Browse files
phischuphischu
committed
annotate classes and instances
1 parent 9f2c7c6 commit cd437b2

15 files changed

+264
-7
lines changed

‎src/Language/Haskell/Names/Annotated.hs‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import Language.Haskell.Names.Open.Base
1616
import Language.Haskell.Names.Open.Instances ()
1717
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
1818
import qualified Language.Haskell.Names.LocalSymbolTable as Local
19+
import Language.Haskell.Names.SyntaxUtils (nameToQName)
1920
import Language.Haskell.Exts.Annotated
2021
import Data.Proxy
2122
import Data.Lens.Light
@@ -45,6 +46,9 @@ annotateRec _ sc a = go sc a where
4546
| ReferenceT <- getL nameCtx sc
4647
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
4748
= lookupType (fmap sLoc a) sc <$ a
49+
| ReferenceM <- getL nameCtx sc
50+
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
51+
= lookupMethod (fmap sLoc a) sc <$ a
4852
| BindingV <- getL nameCtx sc
4953
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
5054
= Scoped ValueBinder (sLoc . ann $ a) <$ a
@@ -95,3 +99,16 @@ lookupType qn sc = Scoped nameInfo (ann qn)
9599
Global.Result r -> GlobalType r
96100
Global.Error e -> ScopeError e
97101
Global.Special -> None
102+
103+
lookupMethod :: Name l -> Scope -> Scoped l
104+
lookupMethod name sc = Scoped nameInfo (ann name)
105+
where
106+
qn = nameToQName name
107+
nameInfo =
108+
case Local.lookupValue qn $ getL lTable sc of
109+
Right r -> LocalValue r
110+
_ ->
111+
case Global.lookupMethod qn $ getL gTable sc of
112+
Global.Result r -> GlobalValue r
113+
Global.Error e -> ScopeError e
114+
Global.Special -> None

‎src/Language/Haskell/Names/GlobalSymbolTable.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8,6 +8,7 @@ module Language.Haskell.Names.GlobalSymbolTable
88
, addValue
99
, lookupType
1010
, addType
11+
, lookupMethod
1112
, fromMaps
1213
, fromLists
1314
, types
@@ -41,6 +42,12 @@ valLens = lens (\(Table vs _) -> vs) (\vs (Table _ ts) -> Table vs ts)
4142
tyLens :: Lens Table (Map.Map GName (Set.Set (SymTypeInfo OrigName)))
4243
tyLens = lens (\(Table _ ts) -> ts) (\ts (Table vs _) -> Table vs ts)
4344

45+
unqualValLens :: Lens Table (Map.Map GName (Set.Set (SymValueInfo OrigName)))
46+
unqualValLens = lens
47+
(\(Table vs _) -> Map.mapKeysWith Set.union removeQualification vs)
48+
(\vs (Table _ ts) -> Table vs ts) where
49+
removeQualification (GName _ name) = GName "" name
50+
4451
instance Monoid Table where
4552
mempty = empty
4653
mappend (Table vs1 ts1) (Table vs2 ts2) =
@@ -83,6 +90,20 @@ data Result l a
8390
lookupValue :: QName l -> Table -> Result l (SymValueInfo OrigName)
8491
lookupValue = lookupL valLens
8592

93+
-- | This is a hack to work around an issue with unqualified reference of
94+
-- methods that are only in scope qualified.
95+
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
96+
-- The test for this is tests/annotations/QualifiedMethods.hs
97+
lookupMethod :: QName l -> Table -> Result l (SymValueInfo OrigName)
98+
lookupMethod qn tbl =
99+
let isMethod (SymMethod _ _ _) = True
100+
isMethod _ = False
101+
in case filter isMethod . Set.toList <$> (Map.lookup (toGName qn) $ getL unqualValLens tbl) of
102+
Nothing -> Error $ ENotInScope qn
103+
Just [] -> Error $ ENotInScope qn
104+
Just [i] -> Result i
105+
Just is -> Error $ EAmbiguous qn (map origName is)
106+
86107
lookupType :: QName l -> Table -> Result l (SymTypeInfo OrigName)
87108
lookupType = lookupL tyLens
88109

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

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,8 @@ data NameContext
2828
| BindingV
2929
| ReferenceT
3030
| ReferenceV
31+
| ReferenceM -- ^ Reference a method in an instance declaration
32+
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
3133
| Other
3234

3335
-- | Contains information about the node's enclosing scope. Can be
@@ -131,3 +133,6 @@ exprV = setNameCtx ReferenceV
131133

132134
exprT :: Scope -> Scope
133135
exprT = setNameCtx ReferenceT
136+
137+
exprM :: Scope -> Scope
138+
exprM = setNameCtx ReferenceM

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

Lines changed: 81 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,9 @@ import Language.Haskell.Names.Open.Base
1414
import Language.Haskell.Names.Open.Derived ()
1515
import Language.Haskell.Names.GetBound
1616
import Language.Haskell.Names.RecordWildcards
17+
import Language.Haskell.Names.SyntaxUtils
1718
import Language.Haskell.Exts.Annotated
19+
import Language.Haskell.Names.SyntaxUtils
1820
import qualified Data.Data as D
1921
import Control.Applicative
2022
import Data.Typeable
@@ -58,9 +60,9 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Decl l) where
5860
-- FunBind consists of Matches, which we handle below anyway.
5961
TypeSig l names ty ->
6062
c TypeSig
61-
<| sc -: l
62-
<| exprV sc -: names
63-
<| sc -: ty
63+
<| sc -: l
64+
<*> fmap (map qNameToName) (rtraverse (map nameToQName names) (exprV sc))
65+
<| sc -: ty
6466
_ -> defaultRtraverse e sc
6567

6668
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Type l) where
@@ -327,6 +329,82 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (QualStmt l) where
327329
QualStmt {} -> defaultRtraverse e sc
328330
_ -> error "haskell-names: TransformListComp is not supported yet"
329331

332+
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstRule l) where
333+
rtraverse e sc =
334+
case e of
335+
IRule l mtv mc ih ->
336+
c IRule
337+
<| sc -: l
338+
<| sc -: mtv
339+
<| exprT sc -: mc
340+
<| exprT sc -: ih
341+
_ -> defaultRtraverse e sc
342+
343+
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstDecl l) where
344+
rtraverse e sc =
345+
case e of
346+
InsDecl dl (PatBind l (PVar pl name) rhs mbWhere) ->
347+
let
348+
scWithWhere = intro mbWhere sc
349+
in
350+
c InsDecl
351+
<| sc -: dl
352+
<*> (c PatBind
353+
<| sc -: l
354+
<*> (c PVar
355+
<| sc -: pl
356+
<| exprM sc -: name)
357+
<| exprV scWithWhere -: rhs
358+
<| sc -: mbWhere)
359+
InsDecl dl (FunBind bl ms) ->
360+
c InsDecl
361+
<| sc -: dl
362+
<*> (c FunBind
363+
<| sc -: bl
364+
<*> T.for ms (\m -> case m of
365+
Match l name pats rhs mbWhere ->
366+
-- f x y z = ...
367+
-- where ...
368+
let
369+
(pats', scWithPats) = chain pats sc
370+
scWithWhere = intro mbWhere scWithPats
371+
in
372+
c Match
373+
<| sc -: l
374+
<| exprM sc -: name
375+
<*> pats' -- has been already traversed
376+
<| exprV scWithWhere -: rhs
377+
<| scWithPats -: mbWhere
378+
InfixMatch l pat1 name patsRest rhs mbWhere ->
379+
-- x <*> y = ...
380+
-- where ...
381+
let
382+
(pats', scWithPats) = chain (pat1:patsRest) sc
383+
pat1' = fmap head pats'
384+
patsRest' = fmap tail pats'
385+
scWithWhere = intro mbWhere scWithPats
386+
in
387+
c InfixMatch
388+
<| sc -: l
389+
<*> pat1' -- has been already traversed
390+
<| exprM sc -: name
391+
<*> patsRest' -- has been already traversed
392+
<| exprV scWithWhere -: rhs
393+
<| scWithPats -: mbWhere))
394+
_ -> defaultRtraverse e sc
395+
396+
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (ClassDecl l) where
397+
rtraverse e sc =
398+
case e of
399+
ClsDecl l (TypeSig sl [n] t) ->
400+
c ClsDecl
401+
<| sc -: l
402+
<*> (c TypeSig
403+
<| sc -: sl
404+
<| binderV sc -: [n]
405+
<| sc -: t)
406+
_ -> defaultRtraverse e sc
407+
330408
{-
331409
Note [Nested pattern scopes]
332410
~~~~~~~~~~~~~~~~~~~~~~

‎src/Language/Haskell/Names/SyntaxUtils.hs‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,7 @@ module Language.Haskell.Names.SyntaxUtils
1414
, stringToName
1515
, specialConToString
1616
, qNameToName
17+
, nameToQName
1718
, unCName
1819
, getErrors
1920
-- export ExtensionSet here for the outside users
@@ -66,6 +67,9 @@ qNameToName (UnQual _ n) = n
6667
qNameToName (Qual _ _ n) = n
6768
qNameToName (Special l s) = Ident l (specialConToString s)
6869

70+
nameToQName :: Name l -> QName l
71+
nameToQName n = UnQual (ann n) n
72+
6973
{-
7074
getImportDecls :: Module l -> [ImportDecl l]
7175
getImportDecls (Module _ _ _ is _) = is

‎tests/annotations/ClassInstances.hs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module ClassInstances where
2+
3+
data D a = D Bool a
4+
5+
class C a where
6+
wiggle :: a -> a
7+
woe :: a
8+
($$$) :: a -> a -> a
9+
10+
instance (C a) => C (D a) where
11+
wiggle (D b a) = D b (f a)
12+
woe = D False woe
13+
f $$$ x = ($$$) f x
14+
15+
f :: (C a) => a -> a
16+
f x = wiggle x

‎tests/annotations/ClassInstances.hs.golden‎

Lines changed: 66 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,66 @@
1+
D at 3:6 is a type or class defined here
2+
a at 3:8 is none
3+
D at 3:12 is a value bound here
4+
Bool at 3:14 is not in scope
5+
Bool at 3:14 is not in scope
6+
a at 3:19 is none
7+
C at 5:7 is a type or class defined here
8+
a at 5:9 is none
9+
wiggle at 6:5 is a value bound here
10+
a at 6:15 is none
11+
a at 6:20 is none
12+
woe at 7:5 is a value bound here
13+
a at 7:12 is none
14+
$$$ at 8:5 is a value bound here
15+
a at 8:14 is none
16+
a at 8:19 is none
17+
a at 8:24 is none
18+
C at 10:11 is a global type class, ClassInstances.C
19+
C at 10:11 is a global type class, ClassInstances.C
20+
a at 10:13 is none
21+
C at 10:19 is a global type class, ClassInstances.C
22+
C at 10:19 is a global type class, ClassInstances.C
23+
D at 10:22 is a global data type, ClassInstances.D
24+
D at 10:22 is a global data type, ClassInstances.D
25+
a at 10:24 is none
26+
wiggle at 11:5 is a global method, ClassInstances.wiggle
27+
D at 11:13 is a global constructor, ClassInstances.D
28+
D at 11:13 is a global constructor, ClassInstances.D
29+
b at 11:15 is a value bound here
30+
a at 11:17 is a value bound here
31+
D at 11:22 is a global constructor, ClassInstances.D
32+
D at 11:22 is a global constructor, ClassInstances.D
33+
b at 11:24 is a local value defined at 11:15
34+
b at 11:24 is a local value defined at 11:15
35+
f at 11:27 is a global value, ClassInstances.f
36+
f at 11:27 is a global value, ClassInstances.f
37+
a at 11:29 is a local value defined at 11:17
38+
a at 11:29 is a local value defined at 11:17
39+
woe at 12:5 is a global method, ClassInstances.woe
40+
D at 12:11 is a global constructor, ClassInstances.D
41+
D at 12:11 is a global constructor, ClassInstances.D
42+
False at 12:13 is not in scope
43+
False at 12:13 is not in scope
44+
woe at 12:19 is a global method, ClassInstances.woe
45+
woe at 12:19 is a global method, ClassInstances.woe
46+
f at 13:5 is a value bound here
47+
$$$ at 13:7 is a global method, ClassInstances.($$$)
48+
x at 13:11 is a value bound here
49+
$$$ at 13:15 is a global method, ClassInstances.($$$)
50+
$$$ at 13:15 is a global method, ClassInstances.($$$)
51+
f at 13:21 is a local value defined at 13:5
52+
f at 13:21 is a local value defined at 13:5
53+
x at 13:23 is a local value defined at 13:11
54+
x at 13:23 is a local value defined at 13:11
55+
f at 15:1 is a global value, ClassInstances.f
56+
C at 15:7 is a global type class, ClassInstances.C
57+
C at 15:7 is a global type class, ClassInstances.C
58+
a at 15:9 is none
59+
a at 15:15 is none
60+
a at 15:20 is none
61+
f at 16:1 is a value bound here
62+
x at 16:3 is a value bound here
63+
wiggle at 16:7 is a global method, ClassInstances.wiggle
64+
wiggle at 16:7 is a global method, ClassInstances.wiggle
65+
x at 16:14 is a local value defined at 16:3
66+
x at 16:14 is a local value defined at 16:3

‎tests/annotations/Global.hs.golden‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
foo at 5:1 is none
1+
foo at 5:1 is a global value, Global.foo
22
Newtype at 5:8 is a global newtype, Prelude.Newtype
33
Newtype at 5:8 is a global newtype, Prelude.Newtype
44
foo at 6:1 is a value bound here

‎tests/annotations/QualifiedMethods.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
module QualifiedMethods where
2+
3+
import qualified ExportListWildcards as ExportListWildcards
4+
5+
data Rodor = Rodor
6+
7+
x = ExportListWildcards.Foo1
8+
9+
instance ExportListWildcards.Bar Rodor where
10+
x Rodor = x

‎tests/annotations/QualifiedMethods.hs.golden‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
Rodor at 5:6 is a type or class defined here
2+
Rodor at 5:14 is a value bound here
3+
x at 7:1 is a value bound here
4+
Foo1 at 7:5 is a global constructor, ExportListWildcards.Foo1
5+
Foo1 at 7:5 is a global constructor, ExportListWildcards.Foo1
6+
Bar at 9:10 is a global type class, ExportListWildcards.Bar
7+
Bar at 9:10 is a global type class, ExportListWildcards.Bar
8+
Rodor at 9:34 is a global data type, QualifiedMethods.Rodor
9+
Rodor at 9:34 is a global data type, QualifiedMethods.Rodor
10+
x at 10:5 is a global method, ExportListWildcards.x
11+
Rodor at 10:7 is a global constructor, QualifiedMethods.Rodor
12+
Rodor at 10:7 is a global constructor, QualifiedMethods.Rodor
13+
x at 10:15 is a global value, QualifiedMethods.x
14+
x at 10:15 is a global value, QualifiedMethods.x

0 commit comments

Comments
 (0)