/
Annotated.hs
100 lines (93 loc) · 3.47 KB
/
Annotated.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
-- This module uses the open recursion interface
-- ("Language.Haskell.Names.Open") to annotate the AST with binding
-- information.
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, ImplicitParams,
UndecidableInstances, OverlappingInstances, ScopedTypeVariables,
TypeOperators, GADTs #-}
module Language.Haskell.Names.Annotated
( Scoped(..)
, NameInfo(..)
, annotate
) where
import Language.Haskell.Names.Types
import Language.Haskell.Names.RecordWildcards
import Language.Haskell.Names.Open.Base
import Language.Haskell.Names.Open.Instances ()
import qualified Language.Haskell.Names.GlobalSymbolTable as Global
import qualified Language.Haskell.Names.LocalSymbolTable as Local
import Language.Haskell.Exts.Annotated
import Data.Proxy
import Data.Lens.Light
import Data.Typeable (Typeable)
-- in GHC 7.8 Data.Typeable exports (:~:). Be careful to avoid the clash.
import Control.Applicative
-- This should be incorporated into Data.Typeable soon
import Type.Eq
annotate
:: forall a l .
(Resolvable (a (Scoped l)), Functor a, Typeable l)
=> Scope -> a l -> a (Scoped l)
annotate sc = annotateRec (Proxy :: Proxy l) sc . fmap (Scoped None)
annotateRec
:: forall a l .
(Typeable l, Resolvable a)
=> Proxy l -> Scope -> a -> a
annotateRec _ sc a = go sc a where
go :: forall a . Resolvable a => Scope -> a -> a
go sc a
| ReferenceV <- getL nameCtx sc
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
= lookupValue (fmap sLoc a) sc <$ a
| ReferenceT <- getL nameCtx sc
, Just (Eq :: QName (Scoped l) :~: a) <- dynamicEq
= lookupType (fmap sLoc a) sc <$ a
| BindingV <- getL nameCtx sc
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
= Scoped ValueBinder (sLoc . ann $ a) <$ a
| BindingT <- getL nameCtx sc
, Just (Eq :: Name (Scoped l) :~: a) <- dynamicEq
= Scoped TypeBinder (sLoc . ann $ a) <$ a
| Just (Eq :: FieldUpdate (Scoped l) :~: a) <- dynamicEq
= case a of
FieldPun l n -> FieldPun l (lookupUnqualValue n sc <$ n)
FieldWildcard l ->
let
namesUnres = sc ^. wcNames
resolve n =
let Scoped info _ = lookupValue (sLoc l <$ UnQual () n) sc
in info
namesRes =
map
(\f -> (wcFieldOrigName f, resolve $ wcFieldName f))
namesUnres
in FieldWildcard $ Scoped (RecExpWildcard namesRes) (sLoc l)
_ -> rmap go sc a
| Just (Eq :: PatField (Scoped l) :~: a) <- dynamicEq
, PFieldWildcard l <- a
= PFieldWildcard $
Scoped
(RecPatWildcard $ map wcFieldOrigName $ sc ^. wcNames)
(sLoc l)
| otherwise
= rmap go sc a
lookupUnqualValue :: Name (Scoped l) -> Scope -> Scoped l
lookupUnqualValue n = lookupValue (UnQual (sLoc $ ann n) (sLoc <$> n))
lookupValue :: QName l -> Scope -> Scoped l
lookupValue qn sc = Scoped nameInfo (ann qn)
where
nameInfo =
case Local.lookupValue qn $ getL lTable sc of
Right r -> LocalValue r
_ ->
case Global.lookupValue qn $ getL gTable sc of
Global.Result r -> GlobalValue r
Global.Error e -> ScopeError e
Global.Special -> None
lookupType :: QName l -> Scope -> Scoped l
lookupType qn sc = Scoped nameInfo (ann qn)
where
nameInfo =
case Global.lookupType qn $ getL gTable sc of
Global.Result r -> GlobalType r
Global.Error e -> ScopeError e
Global.Special -> None