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