never executed always true always false
1
2 {-# LANGUAGE DeriveDataTypeable #-}
3 --
4 -- (c) The University of Glasgow
5 --
6
7 module GHC.Types.Avail (
8 Avails,
9 AvailInfo(..),
10 avail,
11 availField,
12 availTC,
13 availsToNameSet,
14 availsToNameSetWithSelectors,
15 availsToNameEnv,
16 availExportsDecl,
17 availName, availGreName,
18 availNames, availNonFldNames,
19 availNamesWithSelectors,
20 availFlds,
21 availGreNames,
22 availSubordinateGreNames,
23 stableAvailCmp,
24 plusAvail,
25 trimAvail,
26 filterAvail,
27 filterAvails,
28 nubAvails,
29
30 GreName(..),
31 greNameMangledName,
32 greNamePrintableName,
33 greNameSrcSpan,
34 greNameFieldLabel,
35 partitionGreNames,
36 stableGreNameCmp,
37 ) where
38
39 import GHC.Prelude
40
41 import GHC.Types.Name
42 import GHC.Types.Name.Env
43 import GHC.Types.Name.Set
44 import GHC.Types.SrcLoc
45
46 import GHC.Types.FieldLabel
47 import GHC.Utils.Binary
48 import GHC.Data.List.SetOps
49 import GHC.Utils.Outputable
50 import GHC.Utils.Panic
51 import GHC.Utils.Misc
52 import GHC.Utils.Constants (debugIsOn)
53
54 import Data.Data ( Data )
55 import Data.Either ( partitionEithers )
56 import Data.List ( find )
57 import Data.Maybe
58
59 -- -----------------------------------------------------------------------------
60 -- The AvailInfo type
61
62 -- | Records what things are \"available\", i.e. in scope
63 data AvailInfo
64
65 -- | An ordinary identifier in scope, or a field label without a parent type
66 -- (see Note [Representing pattern synonym fields in AvailInfo]).
67 = Avail GreName
68
69 -- | A type or class in scope
70 --
71 -- The __AvailTC Invariant__: If the type or class is itself to be in scope,
72 -- it must be /first/ in this list. Thus, typically:
73 --
74 -- > AvailTC Eq [Eq, ==, \/=]
75 | AvailTC
76 Name -- ^ The name of the type or class
77 [GreName] -- ^ The available pieces of type or class
78 -- (see Note [Representing fields in AvailInfo]).
79
80 deriving ( Eq -- ^ Used when deciding if the interface has changed
81 , Data )
82
83 -- | A collection of 'AvailInfo' - several things that are \"available\"
84 type Avails = [AvailInfo]
85
86 {-
87 Note [Representing fields in AvailInfo]
88 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
89 See also Note [FieldLabel] in GHC.Types.FieldLabel.
90
91 When -XDuplicateRecordFields is disabled (the normal case), a
92 datatype like
93
94 data T = MkT { foo :: Int }
95
96 gives rise to the AvailInfo
97
98 AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo]
99
100 whereas if -XDuplicateRecordFields is enabled it gives
101
102 AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT]
103
104 where the label foo does not match the selector name $sel:foo:MkT.
105
106 The labels in a field list are not necessarily unique:
107 data families allow the same parent (the family tycon) to have
108 multiple distinct fields with the same label. For example,
109
110 data family F a
111 data instance F Int = MkFInt { foo :: Int }
112 data instance F Bool = MkFBool { foo :: Bool}
113
114 gives rise to
115
116 AvailTC F [ F, MkFInt, MkFBool
117 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt
118 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ]
119
120 Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags
121 need not be the same for all the elements of the list. In the example above,
122 this occurs if the two data instances are defined in different modules, with
123 different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors`
124 extensions. Thus it is possible to have
125
126 AvailTC F [ F, MkFInt, MkFBool
127 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt
128 , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ]
129
130 If the two data instances are defined in different modules, both without
131 `-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to
132 export them from the same module (even with `-XDuplicateRecordfields` enabled),
133 because they would be represented identically. The workaround here is to enable
134 `-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules. See
135 also #13352.
136
137
138 Note [Representing pattern synonym fields in AvailInfo]
139 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
140 Record pattern synonym fields cannot be represented using AvailTC like fields of
141 normal record types (see Note [Representing fields in AvailInfo]), because they
142 do not always have a parent type constructor. So we represent them using the
143 Avail constructor, with a NormalGreName that carries the underlying FieldLabel.
144
145 Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration
146
147 pattern MkFoo{f} = Bar f
148
149 gives rise to the AvailInfo
150
151 Avail (NormalGreName MkFoo)
152 Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo))
153
154 However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in
155 an export list, then whenever `f` is imported the parent will be `T`,
156 represented as
157
158 AvailTC T [ NormalGreName T
159 , NormalGreName MkFoo
160 , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ]
161
162 See also Note [GreNames] in GHC.Types.Name.Reader.
163 -}
164
165 -- | Compare lexicographically
166 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
167 stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2
168 stableAvailCmp (Avail {}) (AvailTC {}) = LT
169 stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
170 (cmpList stableGreNameCmp ns ms)
171 stableAvailCmp (AvailTC {}) (Avail {}) = GT
172
173 stableGreNameCmp :: GreName -> GreName -> Ordering
174 stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2
175 stableGreNameCmp (NormalGreName {}) (FieldGreName {}) = LT
176 stableGreNameCmp (FieldGreName f1) (FieldGreName f2) = flSelector f1 `stableNameCmp` flSelector f2
177 stableGreNameCmp (FieldGreName {}) (NormalGreName {}) = GT
178
179 avail :: Name -> AvailInfo
180 avail n = Avail (NormalGreName n)
181
182 availField :: FieldLabel -> AvailInfo
183 availField fl = Avail (FieldGreName fl)
184
185 availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo
186 availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls)
187
188
189 -- -----------------------------------------------------------------------------
190 -- Operations on AvailInfo
191
192 availsToNameSet :: [AvailInfo] -> NameSet
193 availsToNameSet avails = foldr add emptyNameSet avails
194 where add avail set = extendNameSetList set (availNames avail)
195
196 availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
197 availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
198 where add avail set = extendNameSetList set (availNamesWithSelectors avail)
199
200 availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
201 availsToNameEnv avails = foldr add emptyNameEnv avails
202 where add avail env = extendNameEnvList env
203 (zip (availNames avail) (repeat avail))
204
205 -- | Does this 'AvailInfo' export the parent decl? This depends on the
206 -- invariant that the parent is first if it appears at all.
207 availExportsDecl :: AvailInfo -> Bool
208 availExportsDecl (AvailTC ty_name names)
209 | n : _ <- names = NormalGreName ty_name == n
210 | otherwise = False
211 availExportsDecl _ = True
212
213 -- | Just the main name made available, i.e. not the available pieces
214 -- of type or class brought into scope by the 'AvailInfo'
215 availName :: AvailInfo -> Name
216 availName (Avail n) = greNameMangledName n
217 availName (AvailTC n _) = n
218
219 availGreName :: AvailInfo -> GreName
220 availGreName (Avail c) = c
221 availGreName (AvailTC n _) = NormalGreName n
222
223 -- | All names made available by the availability information (excluding overloaded selectors)
224 availNames :: AvailInfo -> [Name]
225 availNames (Avail c) = childNonOverloadedNames c
226 availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs
227
228 childNonOverloadedNames :: GreName -> [Name]
229 childNonOverloadedNames (NormalGreName n) = [n]
230 childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ]
231
232 -- | All names made available by the availability information (including overloaded selectors)
233 availNamesWithSelectors :: AvailInfo -> [Name]
234 availNamesWithSelectors (Avail c) = [greNameMangledName c]
235 availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs
236
237 -- | Names for non-fields made available by the availability information
238 availNonFldNames :: AvailInfo -> [Name]
239 availNonFldNames (Avail (NormalGreName n)) = [n]
240 availNonFldNames (Avail (FieldGreName {})) = []
241 availNonFldNames (AvailTC _ ns) = mapMaybe f ns
242 where
243 f (NormalGreName n) = Just n
244 f (FieldGreName {}) = Nothing
245
246 -- | Fields made available by the availability information
247 availFlds :: AvailInfo -> [FieldLabel]
248 availFlds (Avail c) = maybeToList (greNameFieldLabel c)
249 availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs
250
251 -- | Names and fields made available by the availability information.
252 availGreNames :: AvailInfo -> [GreName]
253 availGreNames (Avail c) = [c]
254 availGreNames (AvailTC _ cs) = cs
255
256 -- | Names and fields made available by the availability information, other than
257 -- the main decl itself.
258 availSubordinateGreNames :: AvailInfo -> [GreName]
259 availSubordinateGreNames (Avail {}) = []
260 availSubordinateGreNames avail@(AvailTC _ ns)
261 | availExportsDecl avail = tail ns
262 | otherwise = ns
263
264
265 -- | Used where we may have an ordinary name or a record field label.
266 -- See Note [GreNames] in GHC.Types.Name.Reader.
267 data GreName = NormalGreName Name
268 | FieldGreName FieldLabel
269 deriving (Data, Eq)
270
271 instance Outputable GreName where
272 ppr (NormalGreName n) = ppr n
273 ppr (FieldGreName fl) = ppr fl
274
275 instance HasOccName GreName where
276 occName (NormalGreName n) = occName n
277 occName (FieldGreName fl) = occName fl
278
279 -- | A 'Name' for internal use, but not for output to the user. For fields, the
280 -- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader.
281 greNameMangledName :: GreName -> Name
282 greNameMangledName (NormalGreName n) = n
283 greNameMangledName (FieldGreName fl) = flSelector fl
284
285 -- | A 'Name' suitable for output to the user. For fields, the 'OccName' will
286 -- be the field label. See Note [GreNames] in GHC.Types.Name.Reader.
287 greNamePrintableName :: GreName -> Name
288 greNamePrintableName (NormalGreName n) = n
289 greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl
290
291 greNameSrcSpan :: GreName -> SrcSpan
292 greNameSrcSpan (NormalGreName n) = nameSrcSpan n
293 greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl)
294
295 greNameFieldLabel :: GreName -> Maybe FieldLabel
296 greNameFieldLabel (NormalGreName {}) = Nothing
297 greNameFieldLabel (FieldGreName fl) = Just fl
298
299 partitionGreNames :: [GreName] -> ([Name], [FieldLabel])
300 partitionGreNames = partitionEithers . map to_either
301 where
302 to_either (NormalGreName n) = Left n
303 to_either (FieldGreName fl) = Right fl
304
305
306 -- -----------------------------------------------------------------------------
307 -- Utility
308
309 plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
310 plusAvail a1 a2
311 | debugIsOn && availName a1 /= availName a2
312 = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2])
313 plusAvail a1@(Avail {}) (Avail {}) = a1
314 plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2
315 plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1
316 plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))
317 = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first
318 (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
319 (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
320 (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
321 (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
322 plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])
323
324 -- | trims an 'AvailInfo' to keep only a single name
325 trimAvail :: AvailInfo -> Name -> AvailInfo
326 trimAvail avail@(Avail {}) _ = avail
327 trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of
328 Just c -> AvailTC n [c]
329 Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m])
330
331 -- | filters 'AvailInfo's by the given predicate
332 filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
333 filterAvails keep avails = foldr (filterAvail keep) [] avails
334
335 -- | filters an 'AvailInfo' by the given predicate
336 filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
337 filterAvail keep ie rest =
338 case ie of
339 Avail c | keep (greNameMangledName c) -> ie : rest
340 | otherwise -> rest
341 AvailTC tc cs ->
342 let cs' = filter (keep . greNameMangledName) cs
343 in if null cs' then rest else AvailTC tc cs' : rest
344
345
346 -- | Combines 'AvailInfo's from the same family
347 -- 'avails' may have several items with the same availName
348 -- E.g import Ix( Ix(..), index )
349 -- will give Ix(Ix,index,range) and Ix(index)
350 -- We want to combine these; addAvail does that
351 nubAvails :: [AvailInfo] -> [AvailInfo]
352 nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails)
353 where
354 add env avail = extendDNameEnv_C plusAvail env (availName avail) avail
355
356 -- -----------------------------------------------------------------------------
357 -- Printing
358
359 instance Outputable AvailInfo where
360 ppr = pprAvail
361
362 pprAvail :: AvailInfo -> SDoc
363 pprAvail (Avail n)
364 = ppr n
365 pprAvail (AvailTC n ns)
366 = ppr n <> braces (fsep (punctuate comma (map ppr ns)))
367
368 instance Binary AvailInfo where
369 put_ bh (Avail aa) = do
370 putByte bh 0
371 put_ bh aa
372 put_ bh (AvailTC ab ac) = do
373 putByte bh 1
374 put_ bh ab
375 put_ bh ac
376 get bh = do
377 h <- getByte bh
378 case h of
379 0 -> do aa <- get bh
380 return (Avail aa)
381 _ -> do ab <- get bh
382 ac <- get bh
383 return (AvailTC ab ac)
384
385 instance Binary GreName where
386 put_ bh (NormalGreName aa) = do
387 putByte bh 0
388 put_ bh aa
389 put_ bh (FieldGreName ab) = do
390 putByte bh 1
391 put_ bh ab
392 get bh = do
393 h <- getByte bh
394 case h of
395 0 -> do aa <- get bh
396 return (NormalGreName aa)
397 _ -> do ab <- get bh
398 return (FieldGreName ab)