Skip to content

Commit 1617185

Browse files
phischuphischu
committed
Annotate associated types
1 parent 0bfb64e commit 1617185

11 files changed

+156
-40
lines changed

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

+17-6
Original file line numberDiff line numberDiff line change
@@ -16,7 +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 (annName,setAnn)
19+
import Language.Haskell.Names.SyntaxUtils (annName,setAnn,qNameToName)
2020
import Language.Haskell.Exts.Annotated.Simplify (sQName)
2121
import Language.Haskell.Exts.Annotated
2222
import Data.Proxy
@@ -47,9 +47,12 @@ annotateRec _ sc a = go sc a where
4747
| ReferenceT <- getL nameCtx sc
4848
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
4949
= lookupType (fmap sLoc a) sc <$ a
50-
| ReferenceM <- getL nameCtx sc
50+
| ReferenceUV <- getL nameCtx sc
5151
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
52-
= lookupMethod (fmap sLoc a) sc <$ a
52+
= lookupValueUnqualifiedAsQualified (fmap sLoc a) sc <$ a
53+
| ReferenceUT <- getL nameCtx sc
54+
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
55+
= lookupTypeUnqualifiedAsQualified (fmap sLoc a) sc <$ a
5356
| BindingV <- getL nameCtx sc
5457
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
5558
= Scoped ValueBinder (sLoc . ann $ a) <$ a
@@ -103,10 +106,18 @@ lookupType qn sc = Scoped nameInfo (ann qn)
103106
Global.Error e -> ScopeError e
104107
Global.Special -> None
105108

106-
lookupMethod :: Name l -> Scope -> Scoped l
107-
lookupMethod n sc = Scoped nameInfo (ann n)
109+
lookupValueUnqualifiedAsQualified :: Name l -> Scope -> Scoped l
110+
lookupValueUnqualifiedAsQualified n sc = Scoped nameInfo (ann n)
111+
where
112+
nameInfo = case Global.lookupUnqualifiedAsQualified n $ getL gTable sc of
113+
(Global.SymbolFound r,Just gn) -> GlobalSymbol r gn
114+
(Global.Error e,_) -> ScopeError e
115+
_ -> None
116+
117+
lookupTypeUnqualifiedAsQualified :: QName l -> Scope -> Scoped l
118+
lookupTypeUnqualifiedAsQualified qn sc = Scoped nameInfo (ann qn)
108119
where
109-
nameInfo = case Global.lookupMethod n $ getL gTable sc of
120+
nameInfo = case Global.lookupUnqualifiedAsQualified (qNameToName qn) $ getL gTable sc of
110121
(Global.SymbolFound r,Just gn) -> GlobalSymbol r gn
111122
(Global.Error e,_) -> ScopeError e
112123
_ -> None

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

+10-8
Original file line numberDiff line numberDiff line change
@@ -44,18 +44,18 @@ lookupValue qn = lookupName qn . filterTable isValue
4444
lookupType :: Ann.QName l -> Table -> Result l
4545
lookupType qn = lookupName qn . filterTable isType
4646

47-
-- | Methods can sometimes be referenced unqualified and still be resolved to
48-
-- a symbols that is only in scope qualified.
47+
-- | Methods and associated types in instance declarations are referenced
48+
-- unqualified and still resolved to a symbol that is only in scope qualified.
4949
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
5050
-- The test for this is tests/annotations/QualifiedMethods.hs
51-
lookupMethod :: Ann.Name l -> Table -> (Result l,Maybe QName)
52-
lookupMethod name tbl = (case Map.lookup unqualifiedName qualificationTable of
51+
lookupUnqualifiedAsQualified :: Ann.Name l -> Table -> (Result l,Maybe QName)
52+
lookupUnqualifiedAsQualified name tbl = (case Map.lookup unqualifiedName qualificationTable of
5353
Nothing -> (Error (ENotInScope (Ann.UnQual (Ann.ann name) name)),Nothing)
54-
Just qn -> (lookupName qn (filterTable isMethod tbl),Just (sQName qn))) where
54+
Just qn -> (lookupName qn (filterTable isMethodOrAssociated tbl),Just (sQName qn))) where
5555
unqualifiedName = UnQual (sName name)
5656
qualificationTable = Map.fromList (do
5757
(qn,symbols) <- Map.toList tbl
58-
guard (any isMethod symbols)
58+
guard (any isMethodOrAssociated symbols)
5959
case qn of
6060
Qual (ModuleName m) n -> return (UnQual n,Ann.Qual (Ann.ann name) (Ann.ModuleName (Ann.ann name) m) (setAnn (Ann.ann name) (annName n)))
6161
UnQual n -> return (UnQual n,Ann.UnQual (Ann.ann name) (setAnn (Ann.ann name) (annName n)))
@@ -89,9 +89,11 @@ isType symbol = case symbol of
8989
Class {} -> True
9090
_ -> False
9191

92-
isMethod :: Symbol -> Bool
93-
isMethod symbol = case symbol of
92+
isMethodOrAssociated :: Symbol -> Bool
93+
isMethodOrAssociated symbol = case symbol of
9494
Method {} -> True
95+
TypeFam {} -> True
96+
DataFam {} -> True
9597
_ -> False
9698

9799
fromList :: [(QName,Symbol)] -> Table

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

+13-4
Original file line numberDiff line numberDiff line change
@@ -28,8 +28,14 @@ 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
31+
| ReferenceUV
32+
-- ^ Reference a method in an instance declaration
33+
-- Unqualified names also match qualified names in scope
34+
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
35+
| ReferenceUT
36+
-- ^ Reference an associated type in an instance declaration
37+
-- Unqualified names also match qualified names in scope
38+
-- https://www.haskell.org/pipermail/haskell-prime/2008-April/002569.html
3339
| Other
3440

3541
-- | Contains information about the node's enclosing scope. Can be
@@ -134,5 +140,8 @@ exprV = setNameCtx ReferenceV
134140
exprT :: Scope -> Scope
135141
exprT = setNameCtx ReferenceT
136142

137-
exprM :: Scope -> Scope
138-
exprM = setNameCtx ReferenceM
143+
exprUV :: Scope -> Scope
144+
exprUV = setNameCtx ReferenceUV
145+
146+
exprUT :: Scope -> Scope
147+
exprUT = setNameCtx ReferenceUT

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

+45-7
Original file line numberDiff line numberDiff line change
@@ -339,12 +339,15 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstRule l) where
339339
case e of
340340
IRule l mtv mc ih ->
341341
c IRule
342-
<| sc -: l
343-
<| sc -: mtv
344-
<| exprT sc -: mc
342+
<| sc -: l
343+
<| sc -: mtv
344+
<| sc -: mc
345345
<| exprT sc -: ih
346346
_ -> defaultRtraverse e sc
347347

348+
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (Context l) where
349+
rtraverse e sc = defaultRtraverse e (exprT sc)
350+
348351
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstDecl l) where
349352
rtraverse e sc =
350353
case e of
@@ -357,8 +360,8 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstDecl l) where
357360
<*> (c PatBind
358361
<| sc -: l
359362
<*> (c PVar
360-
<| sc -: pl
361-
<| exprM sc -: name)
363+
<| sc -: pl
364+
<| exprUV sc -: name)
362365
<| exprV scWithWhere -: rhs
363366
<| sc -: mbWhere)
364367
InsDecl dl (FunBind bl ms) ->
@@ -376,7 +379,7 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstDecl l) where
376379
in
377380
c Match
378381
<| sc -: l
379-
<| exprM sc -: name
382+
<| exprUV sc -: name
380383
<*> pats' -- has been already traversed
381384
<| exprV scWithWhere -: rhs
382385
<| scWithPats -: mbWhere
@@ -392,10 +395,45 @@ instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (InstDecl l) where
392395
c InfixMatch
393396
<| sc -: l
394397
<*> pat1' -- has been already traversed
395-
<| exprM sc -: name
398+
<| exprUV sc -: name
396399
<*> patsRest' -- has been already traversed
397400
<| exprV scWithWhere -: rhs
398401
<| scWithPats -: mbWhere))
402+
InsType dl (TyApp al (TyCon cl qn) aa) rhs ->
403+
c InsType
404+
<| sc -: dl
405+
<*> (c TyApp
406+
<| sc -: al
407+
<*> (c TyCon
408+
<| sc -: cl
409+
<| exprUT sc -: qn)
410+
<| sc -: aa)
411+
<| sc -: rhs
412+
InsData dl don (TyApp al (TyCon cl qn) aa) cs md ->
413+
c InsData
414+
<| sc -: dl
415+
<| sc -: don
416+
<*> (c TyApp
417+
<| sc -: al
418+
<*> (c TyCon
419+
<| sc -: cl
420+
<| exprUT sc -: qn)
421+
<| sc -: aa)
422+
<| sc -: cs
423+
<| sc -: md
424+
InsGData dl don (TyApp al (TyCon cl qn) aa) mk cs md ->
425+
c InsGData
426+
<| sc -: dl
427+
<| sc -: don
428+
<*> (c TyApp
429+
<| sc -: al
430+
<*> (c TyCon
431+
<| sc -: cl
432+
<| exprUT sc -: qn)
433+
<| sc -: aa)
434+
<| sc -: mk
435+
<| sc -: cs
436+
<| sc -: md
399437
_ -> defaultRtraverse e sc
400438

401439
instance (Resolvable l, SrcInfo l, D.Data l) => Resolvable (ClassDecl l) where

‎tests/annotations/ClassConstraints.hs

+7
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
module ClassConstraints where
2+
3+
class C a where
4+
cee :: a
5+
6+
class (C a) => D a where
7+
dee :: a

‎tests/annotations/ClassConstraints.hs.golden

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
C at 3:7 is a type or class defined here
2+
a at 3:9 is none
3+
cee at 4:5 is a value bound here
4+
a at 4:12 is none
5+
C at 6:8 is a global type class, ClassConstraints.C
6+
C at 6:8 is a global type class, ClassConstraints.C
7+
a at 6:10 is none
8+
D at 6:16 is a type or class defined here
9+
a at 6:18 is none
10+
dee at 7:5 is a value bound here
11+
a at 7:12 is none

‎tests/annotations/QualifiedMethods.hs

+7
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,17 @@
1+
{-# LANGUAGE TypeFamilies #-}
12
module QualifiedMethods where
23

34
import qualified ExportListWildcards as ExportListWildcards
45

6+
import qualified DataFamilies as DataFamilies
7+
58
data Rodor = Rodor
69

710
x = ExportListWildcards.Foo1
811

912
instance ExportListWildcards.Bar Rodor where
1013
x Rodor = x
14+
15+
instance DataFamilies.ListLike Rodor where
16+
type I Rodor = Rodor
17+
h _ = Rodor

‎tests/annotations/QualifiedMethods.hs.golden

+28-14
Original file line numberDiff line numberDiff line change
@@ -1,14 +1,28 @@
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
1+
TypeFamilies at 1:14 is none
2+
Rodor at 8:6 is a type or class defined here
3+
Rodor at 8:14 is a value bound here
4+
x at 10:1 is a value bound here
5+
Foo1 at 10:5 is a global constructor, ExportListWildcards.Foo1
6+
Foo1 at 10:5 is a global constructor, ExportListWildcards.Foo1
7+
Bar at 12:10 is a global type class, ExportListWildcards.Bar
8+
Bar at 12:10 is a global type class, ExportListWildcards.Bar
9+
Rodor at 12:34 is a global data type, QualifiedMethods.Rodor
10+
Rodor at 12:34 is a global data type, QualifiedMethods.Rodor
11+
x at 13:5 is a global method, ExportListWildcards.x
12+
Rodor at 13:7 is a global constructor, QualifiedMethods.Rodor
13+
Rodor at 13:7 is a global constructor, QualifiedMethods.Rodor
14+
x at 13:15 is a global value, QualifiedMethods.x
15+
x at 13:15 is a global value, QualifiedMethods.x
16+
ListLike at 15:10 is a global type class, DataFamilies.ListLike
17+
ListLike at 15:10 is a global type class, DataFamilies.ListLike
18+
Rodor at 15:32 is a global data type, QualifiedMethods.Rodor
19+
Rodor at 15:32 is a global data type, QualifiedMethods.Rodor
20+
I at 16:10 is a global type family, DataFamilies.I
21+
I at 16:10 is a global type family, DataFamilies.I
22+
Rodor at 16:12 is a global data type, QualifiedMethods.Rodor
23+
Rodor at 16:12 is a global data type, QualifiedMethods.Rodor
24+
Rodor at 16:20 is a global data type, QualifiedMethods.Rodor
25+
Rodor at 16:20 is a global data type, QualifiedMethods.Rodor
26+
h at 17:5 is a global method, DataFamilies.h
27+
Rodor at 17:11 is a global constructor, QualifiedMethods.Rodor
28+
Rodor at 17:11 is a global constructor, QualifiedMethods.Rodor

‎tests/exports/DataFamilies.hs

+4
Original file line numberDiff line numberDiff line change
@@ -2,3 +2,7 @@
22
module DataFamilies where
33

44
data family Vector a
5+
6+
class ListLike a where
7+
type I a
8+
h :: a -> I a

‎tests/exports/DataFamilies.hs.golden

+13
Original file line numberDiff line numberDiff line change
@@ -2,4 +2,17 @@
22
{ symbolModule = ModuleName "DataFamilies"
33
, symbolName = Ident "Vector"
44
}
5+
, Class
6+
{ symbolModule = ModuleName "DataFamilies"
7+
, symbolName = Ident "ListLike"
8+
}
9+
, TypeFam
10+
{ symbolModule = ModuleName "DataFamilies"
11+
, symbolName = Ident "I"
12+
}
13+
, Method
14+
{ symbolModule = ModuleName "DataFamilies"
15+
, symbolName = Ident "h"
16+
, className = Ident "ListLike"
17+
}
518
]

‎utils/install_base.sh

+1-1
Original file line numberDiff line numberDiff line change
@@ -1 +1 @@
1-
cabal install --package-db=../packages.db --haskell-suite -w hs-gen-iface --gcc-option=-I/usr/lib/ghc/include --extra-include-dirs=/usr/lib/ghc/include --solver=topdown --force-reinstalls -v3 -f include-ghc-prim
1+
cabal install --package-db=../packages.db --haskell-suite -w hs-gen-iface --gcc-option=-I/usr/lib/ghc/include --extra-include-dirs=/usr/lib/ghc/include --solver=topdown --force-reinstalls -v3 -f include-ghc-prim

0 commit comments

Comments
 (0)