Smarter HsType pretty-print for promoted datacons
[ghc.git] / compiler / basicTypes / Avail.hs
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE DeriveDataTypeable #-}
3 --
4 -- (c) The University of Glasgow
5 --
6
7 #include "HsVersions.h"
8
9 module Avail (
10 Avails,
11 AvailInfo(..),
12 avail,
13 availsToNameSet,
14 availsToNameSetWithSelectors,
15 availsToNameEnv,
16 availName, availNames, availNonFldNames,
17 availNamesWithSelectors,
18 availFlds,
19 availsNamesWithOccs,
20 availNamesWithOccs,
21 stableAvailCmp,
22 plusAvail,
23 trimAvail,
24 filterAvail,
25 filterAvails,
26 nubAvails
27
28
29 ) where
30
31 import GhcPrelude
32
33 import Name
34 import NameEnv
35 import NameSet
36
37 import FieldLabel
38 import Binary
39 import ListSetOps
40 import Outputable
41 import Util
42
43 import Data.Data ( Data )
44 import Data.List ( find )
45 import Data.Function
46
47 -- -----------------------------------------------------------------------------
48 -- The AvailInfo type
49
50 -- | Records what things are "available", i.e. in scope
51 data AvailInfo = Avail Name -- ^ An ordinary identifier in scope
52 | AvailTC Name
53 [Name]
54 [FieldLabel]
55 -- ^ A type or class in scope. Parameters:
56 --
57 -- 1) The name of the type or class
58 -- 2) The available pieces of type or class,
59 -- excluding field selectors.
60 -- 3) The record fields of the type
61 -- (see Note [Representing fields in AvailInfo]).
62 --
63 -- The AvailTC Invariant:
64 -- * If the type or class is itself
65 -- to be in scope, it must be
66 -- *first* in this list. Thus,
67 -- typically: @AvailTC Eq [Eq, ==, \/=]@
68 deriving( Eq, Data )
69 -- Equality used when deciding if the
70 -- interface has changed
71
72 -- | A collection of 'AvailInfo' - several things that are \"available\"
73 type Avails = [AvailInfo]
74
75 {-
76 Note [Representing fields in AvailInfo]
77 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
78 When -XDuplicateRecordFields is disabled (the normal case), a
79 datatype like
80
81 data T = MkT { foo :: Int }
82
83 gives rise to the AvailInfo
84
85 AvailTC T [T, MkT] [FieldLabel "foo" False foo]
86
87 whereas if -XDuplicateRecordFields is enabled it gives
88
89 AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]
90
91 since the label does not match the selector name.
92
93 The labels in a field list are not necessarily unique:
94 data families allow the same parent (the family tycon) to have
95 multiple distinct fields with the same label. For example,
96
97 data family F a
98 data instance F Int = MkFInt { foo :: Int }
99 data instance F Bool = MkFBool { foo :: Bool}
100
101 gives rise to
102
103 AvailTC F [ F, MkFInt, MkFBool ]
104 [ FieldLabel "foo" True $sel:foo:MkFInt
105 , FieldLabel "foo" True $sel:foo:MkFBool ]
106
107 Moreover, note that the flIsOverloaded flag need not be the same for
108 all the elements of the list. In the example above, this occurs if
109 the two data instances are defined in different modules, one with
110 `-XDuplicateRecordFields` enabled and one with it disabled. Thus it
111 is possible to have
112
113 AvailTC F [ F, MkFInt, MkFBool ]
114 [ FieldLabel "foo" True $sel:foo:MkFInt
115 , FieldLabel "foo" False foo ]
116
117 If the two data instances are defined in different modules, both
118 without `-XDuplicateRecordFields`, it will be impossible to export
119 them from the same module (even with `-XDuplicateRecordfields`
120 enabled), because they would be represented identically. The
121 workaround here is to enable `-XDuplicateRecordFields` on the defining
122 modules.
123 -}
124
125 -- | Compare lexicographically
126 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
127 stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
128 stableAvailCmp (Avail {}) (AvailTC {}) = LT
129 stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
130 (n `stableNameCmp` m) `thenCmp`
131 (cmpList stableNameCmp ns ms) `thenCmp`
132 (cmpList (stableNameCmp `on` flSelector) nfs mfs)
133 stableAvailCmp (AvailTC {}) (Avail {}) = GT
134
135 avail :: Name -> AvailInfo
136 avail n = Avail n
137
138 -- -----------------------------------------------------------------------------
139 -- Operations on AvailInfo
140
141 availsToNameSet :: [AvailInfo] -> NameSet
142 availsToNameSet avails = foldr add emptyNameSet avails
143 where add avail set = extendNameSetList set (availNames avail)
144
145 availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
146 availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
147 where add avail set = extendNameSetList set (availNamesWithSelectors avail)
148
149 availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
150 availsToNameEnv avails = foldr add emptyNameEnv avails
151 where add avail env = extendNameEnvList env
152 (zip (availNames avail) (repeat avail))
153
154 -- | Just the main name made available, i.e. not the available pieces
155 -- of type or class brought into scope by the 'GenAvailInfo'
156 availName :: AvailInfo -> Name
157 availName (Avail n) = n
158 availName (AvailTC n _ _) = n
159
160 -- | All names made available by the availability information (excluding overloaded selectors)
161 availNames :: AvailInfo -> [Name]
162 availNames (Avail n) = [n]
163 availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
164
165 -- | All names made available by the availability information (including overloaded selectors)
166 availNamesWithSelectors :: AvailInfo -> [Name]
167 availNamesWithSelectors (Avail n) = [n]
168 availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
169
170 -- | Names for non-fields made available by the availability information
171 availNonFldNames :: AvailInfo -> [Name]
172 availNonFldNames (Avail n) = [n]
173 availNonFldNames (AvailTC _ ns _) = ns
174
175 -- | Fields made available by the availability information
176 availFlds :: AvailInfo -> [FieldLabel]
177 availFlds (AvailTC _ _ fs) = fs
178 availFlds _ = []
179
180 availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]
181 availsNamesWithOccs = concatMap availNamesWithOccs
182
183 -- | 'Name's made available by the availability information, paired with
184 -- the 'OccName' used to refer to each one.
185 --
186 -- When @DuplicateRecordFields@ is in use, the 'Name' may be the
187 -- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the
188 -- 'OccName' will be the label of the field (e.g. @foo@).
189 --
190 -- See Note [Representing fields in AvailInfo].
191 availNamesWithOccs :: AvailInfo -> [(Name, OccName)]
192 availNamesWithOccs (Avail n) = [(n, nameOccName n)]
193 availNamesWithOccs (AvailTC _ ns fs)
194 = [ (n, nameOccName n) | n <- ns ] ++
195 [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]
196
197 -- -----------------------------------------------------------------------------
198 -- Utility
199
200 plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
201 plusAvail a1 a2
202 | debugIsOn && availName a1 /= availName a2
203 = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
204 plusAvail a1@(Avail {}) (Avail {}) = a1
205 plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2
206 plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1
207 plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
208 = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first
209 (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
210 (fs1 `unionLists` fs2)
211 (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
212 (fs1 `unionLists` fs2)
213 (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
214 (fs1 `unionLists` fs2)
215 (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
216 (fs1 `unionLists` fs2)
217 plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
218 = AvailTC n1 ss1 (fs1 `unionLists` fs2)
219 plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2)
220 = AvailTC n1 ss2 (fs1 `unionLists` fs2)
221 plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
222
223 -- | trims an 'AvailInfo' to keep only a single name
224 trimAvail :: AvailInfo -> Name -> AvailInfo
225 trimAvail (Avail n) _ = Avail n
226 trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
227 Just x -> AvailTC n [] [x]
228 Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []
229
230 -- | filters 'AvailInfo's by the given predicate
231 filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
232 filterAvails keep avails = foldr (filterAvail keep) [] avails
233
234 -- | filters an 'AvailInfo' by the given predicate
235 filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
236 filterAvail keep ie rest =
237 case ie of
238 Avail n | keep n -> ie : rest
239 | otherwise -> rest
240 AvailTC tc ns fs ->
241 let ns' = filter keep ns
242 fs' = filter (keep . flSelector) fs in
243 if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest
244
245
246 -- | Combines 'AvailInfo's from the same family
247 -- 'avails' may have several items with the same availName
248 -- E.g import Ix( Ix(..), index )
249 -- will give Ix(Ix,index,range) and Ix(index)
250 -- We want to combine these; addAvail does that
251 nubAvails :: [AvailInfo] -> [AvailInfo]
252 nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails)
253 where
254 add env avail = extendNameEnv_C plusAvail env (availName avail) avail
255
256 -- -----------------------------------------------------------------------------
257 -- Printing
258
259 instance Outputable AvailInfo where
260 ppr = pprAvail
261
262 pprAvail :: AvailInfo -> SDoc
263 pprAvail (Avail n)
264 = ppr n
265 pprAvail (AvailTC n ns fs)
266 = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
267 , fsep (punctuate comma (map (ppr . flLabel) fs))])
268
269 instance Binary AvailInfo where
270 put_ bh (Avail aa) = do
271 putByte bh 0
272 put_ bh aa
273 put_ bh (AvailTC ab ac ad) = do
274 putByte bh 1
275 put_ bh ab
276 put_ bh ac
277 put_ bh ad
278 get bh = do
279 h <- getByte bh
280 case h of
281 0 -> do aa <- get bh
282 return (Avail aa)
283 _ -> do ab <- get bh
284 ac <- get bh
285 ad <- get bh
286 return (AvailTC ab ac ad)