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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
{-# LANGUAGE DeriveDataTypeable #-}
--
-- (c) The University of Glasgow
--
module GHC.Types.Avail (
Avails,
AvailInfo(..),
availsToNameSet,
availsToNameEnv,
availExportsDecl,
availName,
availNames,
availSubordinateNames,
stableAvailCmp,
plusAvail,
trimAvail,
filterAvail,
filterAvails,
nubAvails,
) where
import GHC.Prelude
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
import GHC.Utils.Binary
import GHC.Data.List.SetOps
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import Control.DeepSeq
import Data.Data ( Data )
import Data.Functor.Classes ( liftCompare )
import Data.List ( find )
import qualified Data.Semigroup as S
-- -----------------------------------------------------------------------------
-- The AvailInfo type
-- | Records what things are \"available\", i.e. in scope
data AvailInfo
-- | An ordinary identifier in scope, or a field label without a parent type
-- (see Note [Representing pattern synonym fields in AvailInfo]).
= Avail Name
-- | A type or class in scope
--
-- The __AvailTC Invariant__: If the type or class is itself to be in scope,
-- it must be /first/ in this list. Thus, typically:
--
-- > AvailTC Eq [Eq, ==, \/=]
| AvailTC
Name -- ^ The name of the type or class
[Name] -- ^ The available pieces of type or class
deriving Data
-- | A collection of 'AvailInfo' - several things that are \"available\"
type Avails = [AvailInfo]
{- Note [Representing pattern synonym fields in AvailInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Record pattern synonym fields cannot be represented using AvailTC like fields of
normal record types, because they do not always have a parent type constructor.
So we represent them using the Avail constructor.
Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration
pattern MkFoo{f} = Bar f
gives rise to the AvailInfo
Avail MkFoo, Avail f
However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in
an export list, then whenever `f` is imported the parent will be `T`,
represented as
AvailTC T [ T, MkFoo, f ]
-}
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail c1) (Avail c2) = c1 `stableNameCmp` c2
stableAvailCmp (Avail {}) (AvailTC {}) = LT
stableAvailCmp (AvailTC n ns) (AvailTC m ms) = stableNameCmp n m S.<> liftCompare stableNameCmp ns ms
stableAvailCmp (AvailTC {}) (Avail {}) = GT
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo
availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
where add avail set = extendNameSetList set (availNames avail)
availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
where add avail env = extendNameEnvList env
(zip (availNames avail) (repeat avail))
-- | Does this 'AvailInfo' export the parent decl? This depends on the
-- invariant that the parent is first if it appears at all.
availExportsDecl :: AvailInfo -> Bool
availExportsDecl (AvailTC ty_name names)
| n : _ <- names = ty_name == n
| otherwise = False
availExportsDecl _ = True
-- | Just the main name made available, i.e. not the available pieces
-- of type or class brought into scope by the 'AvailInfo'
availName :: AvailInfo -> Name
availName (Avail n) = n
availName (AvailTC n _) = n
-- | Names and fields made available by the availability information.
availNames :: AvailInfo -> [Name]
availNames (Avail c) = [c]
availNames (AvailTC _ cs) = cs
-- | Names and fields made available by the availability information, other than
-- the main decl itself.
availSubordinateNames :: AvailInfo -> [Name]
availSubordinateNames (Avail {}) = []
availSubordinateNames avail@(AvailTC _ ns)
| availExportsDecl avail = tail ns
| otherwise = ns
-- -----------------------------------------------------------------------------
-- Utility
plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
| debugIsOn && availName a1 /= availName a2
= pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {}) (Avail {}) = a1
plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2
plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1
plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
= case (n1 == s1, n2 == s2) of -- Maintain invariant the parent is first
(True,True) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` ss2))
(True,False) -> AvailTC n1 (s1 : (ss1 `unionListsOrd` (s2:ss2)))
(False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionListsOrd` ss2))
(False,False) -> AvailTC n1 ((s1:ss1) `unionListsOrd` (s2:ss2))
plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])
-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
trimAvail avail@(Avail {}) _ = avail
trimAvail avail@(AvailTC n ns) m = case find (== m) ns of
Just c -> AvailTC n [c]
Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m])
-- | filters 'AvailInfo's by the given predicate
filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails
-- | filters an 'AvailInfo' by the given predicate
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
case ie of
Avail c | keep c -> ie : rest
| otherwise -> rest
AvailTC tc cs ->
let cs' = filter keep cs
in if null cs' then rest else AvailTC tc cs' : rest
-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
-- E.g import Ix( Ix(..), index )
-- will give Ix(Ix,index,range) and Ix(index)
-- We want to combine these; addAvail does that
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails)
where
add env avail = extendDNameEnv_C plusAvail env (availName avail) avail
-- -----------------------------------------------------------------------------
-- Printing
instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n)
= ppr n
pprAvail (AvailTC n ns)
= ppr n <> braces (pprWithCommas ppr ns)
instance Binary AvailInfo where
put_ bh (Avail aa) = do
putByte bh 0
put_ bh aa
put_ bh (AvailTC ab ac) = do
putByte bh 1
put_ bh ab
put_ bh ac
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
return (Avail aa)
_ -> do ab <- get bh
ac <- get bh
return (AvailTC ab ac)
instance NFData AvailInfo where
rnf (Avail n) = rnf n
rnf (AvailTC a b) = rnf a `seq` rnf b
|
