The Backpack patch.
[ghc.git] / compiler / basicTypes / Avail.hs
1 --
2 -- (c) The University of Glasgow
3 --
4
5 module Avail (
6 Avails,
7 AvailInfo(..),
8 IsPatSyn(..),
9 avail,
10 patSynAvail,
11 availsToNameSet,
12 availsToNameSetWithSelectors,
13 availsToNameEnv,
14 availName, availNames, availNonFldNames,
15 availNamesWithSelectors,
16 availFlds,
17 stableAvailCmp
18 ) where
19
20 import Name
21 import NameEnv
22 import NameSet
23
24 import FieldLabel
25 import Binary
26 import Outputable
27 import Util
28
29 import Data.Function
30
31 -- -----------------------------------------------------------------------------
32 -- The AvailInfo type
33
34 -- | Records what things are "available", i.e. in scope
35 data AvailInfo = Avail IsPatSyn Name -- ^ An ordinary identifier in scope
36 | AvailTC Name
37 [Name]
38 [FieldLabel]
39 -- ^ A type or class in scope. Parameters:
40 --
41 -- 1) The name of the type or class
42 -- 2) The available pieces of type or class,
43 -- excluding field selectors.
44 -- 3) The record fields of the type
45 -- (see Note [Representing fields in AvailInfo]).
46 --
47 -- The AvailTC Invariant:
48 -- * If the type or class is itself
49 -- to be in scope, it must be
50 -- *first* in this list. Thus,
51 -- typically: @AvailTC Eq [Eq, ==, \/=]@
52 deriving( Eq )
53 -- Equality used when deciding if the
54 -- interface has changed
55
56 data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq
57
58 -- | A collection of 'AvailInfo' - several things that are \"available\"
59 type Avails = [AvailInfo]
60
61 {-
62 Note [Representing fields in AvailInfo]
63 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
64 When -XDuplicateRecordFields is disabled (the normal case), a
65 datatype like
66
67 data T = MkT { foo :: Int }
68
69 gives rise to the AvailInfo
70
71 AvailTC T [T, MkT] [FieldLabel "foo" False foo],
72
73 whereas if -XDuplicateRecordFields is enabled it gives
74
75 AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]
76
77 since the label does not match the selector name.
78
79 The labels in a field list are not necessarily unique:
80 data families allow the same parent (the family tycon) to have
81 multiple distinct fields with the same label. For example,
82
83 data family F a
84 data instance F Int = MkFInt { foo :: Int }
85 data instance F Bool = MkFBool { foo :: Bool}
86
87 gives rise to
88
89 AvailTC F [F, MkFInt, MkFBool]
90 [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool].
91
92 Moreover, note that the flIsOverloaded flag need not be the same for
93 all the elements of the list. In the example above, this occurs if
94 the two data instances are defined in different modules, one with
95 `-XDuplicateRecordFields` enabled and one with it disabled. Thus it
96 is possible to have
97
98 AvailTC F [F, MkFInt, MkFBool]
99 [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo].
100
101 If the two data instances are defined in different modules, both
102 without `-XDuplicateRecordFields`, it will be impossible to export
103 them from the same module (even with `-XDuplicateRecordfields`
104 enabled), because they would be represented identically. The
105 workaround here is to enable `-XDuplicateRecordFields` on the defining
106 modules.
107 -}
108
109 -- | Compare lexicographically
110 stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
111 stableAvailCmp (Avail _ n1) (Avail _ n2) = n1 `stableNameCmp` n2
112 stableAvailCmp (Avail {}) (AvailTC {}) = LT
113 stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
114 (n `stableNameCmp` m) `thenCmp`
115 (cmpList stableNameCmp ns ms) `thenCmp`
116 (cmpList (stableNameCmp `on` flSelector) nfs mfs)
117 stableAvailCmp (AvailTC {}) (Avail {}) = GT
118
119 patSynAvail :: Name -> AvailInfo
120 patSynAvail n = Avail IsPatSyn n
121
122 avail :: Name -> AvailInfo
123 avail n = Avail NotPatSyn n
124
125 -- -----------------------------------------------------------------------------
126 -- Operations on AvailInfo
127
128 availsToNameSet :: [AvailInfo] -> NameSet
129 availsToNameSet avails = foldr add emptyNameSet avails
130 where add avail set = extendNameSetList set (availNames avail)
131
132 availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
133 availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
134 where add avail set = extendNameSetList set (availNamesWithSelectors avail)
135
136 availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
137 availsToNameEnv avails = foldr add emptyNameEnv avails
138 where add avail env = extendNameEnvList env
139 (zip (availNames avail) (repeat avail))
140
141 -- | Just the main name made available, i.e. not the available pieces
142 -- of type or class brought into scope by the 'GenAvailInfo'
143 availName :: AvailInfo -> Name
144 availName (Avail _ n) = n
145 availName (AvailTC n _ _) = n
146
147 -- | All names made available by the availability information (excluding overloaded selectors)
148 availNames :: AvailInfo -> [Name]
149 availNames (Avail _ n) = [n]
150 availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]
151
152 -- | All names made available by the availability information (including overloaded selectors)
153 availNamesWithSelectors :: AvailInfo -> [Name]
154 availNamesWithSelectors (Avail _ n) = [n]
155 availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs
156
157 -- | Names for non-fields made available by the availability information
158 availNonFldNames :: AvailInfo -> [Name]
159 availNonFldNames (Avail _ n) = [n]
160 availNonFldNames (AvailTC _ ns _) = ns
161
162 -- | Fields made available by the availability information
163 availFlds :: AvailInfo -> [FieldLabel]
164 availFlds (AvailTC _ _ fs) = fs
165 availFlds _ = []
166
167 -- -----------------------------------------------------------------------------
168 -- Printing
169
170 instance Outputable AvailInfo where
171 ppr = pprAvail
172
173 pprAvail :: AvailInfo -> SDoc
174 pprAvail (Avail _ n)
175 = ppr n
176 pprAvail (AvailTC n ns fs)
177 = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
178 , fsep (punctuate comma (map (ppr . flLabel) fs))])
179
180 instance Binary AvailInfo where
181 put_ bh (Avail b aa) = do
182 putByte bh 0
183 put_ bh aa
184 put_ bh b
185 put_ bh (AvailTC ab ac ad) = do
186 putByte bh 1
187 put_ bh ab
188 put_ bh ac
189 put_ bh ad
190 get bh = do
191 h <- getByte bh
192 case h of
193 0 -> do aa <- get bh
194 b <- get bh
195 return (Avail b aa)
196 _ -> do ab <- get bh
197 ac <- get bh
198 ad <- get bh
199 return (AvailTC ab ac ad)
200
201 instance Binary IsPatSyn where
202 put_ bh IsPatSyn = putByte bh 0
203 put_ bh NotPatSyn = putByte bh 1
204 get bh = do
205 h <- getByte bh
206 case h of
207 0 -> return IsPatSyn
208 _ -> return NotPatSyn