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