Avail.hs 9.26 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
3
4
5
--
-- (c) The University of Glasgow
--

6
7
#include "HsVersions.h"

8
9
10
module Avail (
    Avails,
    AvailInfo(..),
11
    avail,
12
    availsToNameSet,
Adam Gundry's avatar
Adam Gundry committed
13
    availsToNameSetWithSelectors,
14
    availsToNameEnv,
Adam Gundry's avatar
Adam Gundry committed
15
16
17
    availName, availNames, availNonFldNames,
    availNamesWithSelectors,
    availFlds,
18
19
20
21
22
23
24
25
    stableAvailCmp,
    plusAvail,
    trimAvail,
    filterAvail,
    filterAvails,
    nubAvails


26
27
28
29
30
31
  ) where

import Name
import NameEnv
import NameSet

Adam Gundry's avatar
Adam Gundry committed
32
import FieldLabel
33
import Binary
34
import ListSetOps
35
36
37
import Outputable
import Util

38
import Data.List ( find )
Adam Gundry's avatar
Adam Gundry committed
39
40
import Data.Function

41
42
43
44
-- -----------------------------------------------------------------------------
-- The AvailInfo type

-- | Records what things are "available", i.e. in scope
45
data AvailInfo = Avail Name      -- ^ An ordinary identifier in scope
46
               | AvailTC Name
Adam Gundry's avatar
Adam Gundry committed
47
48
49
                         [Name]
                         [FieldLabel]
                                 -- ^ A type or class in scope. Parameters:
50
51
                                 --
                                 --  1) The name of the type or class
Adam Gundry's avatar
Adam Gundry committed
52
53
54
55
                                 --  2) The available pieces of type or class,
                                 --     excluding field selectors.
                                 --  3) The record fields of the type
                                 --     (see Note [Representing fields in AvailInfo]).
56
57
                                 --
                                 -- The AvailTC Invariant:
58
                                 --   * If the type or class is itself
59
60
                                 --     to be in scope, it must be
                                 --     *first* in this list.  Thus,
61
                                 --     typically: @AvailTC Eq [Eq, ==, \/=]@
62
                deriving( Eq )
63
64
65
66
                        -- Equality used when deciding if the
                        -- interface has changed

-- | A collection of 'AvailInfo' - several things that are \"available\"
67
type Avails = [AvailInfo]
68

Adam Gundry's avatar
Adam Gundry committed
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-
Note [Representing fields in AvailInfo]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When -XDuplicateRecordFields is disabled (the normal case), a
datatype like

  data T = MkT { foo :: Int }

gives rise to the AvailInfo

  AvailTC T [T, MkT] [FieldLabel "foo" False foo],

whereas if -XDuplicateRecordFields is enabled it gives

  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]

since the label does not match the selector name.

The labels in a field list are not necessarily unique:
data families allow the same parent (the family tycon) to have
multiple distinct fields with the same label. For example,

  data family F a
  data instance F Int  = MkFInt { foo :: Int }
  data instance F Bool = MkFBool { foo :: Bool}

gives rise to

  AvailTC F [F, MkFInt, MkFBool]
    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" True $sel:foo:MkFBool].

Moreover, note that the flIsOverloaded flag need not be the same for
all the elements of the list.  In the example above, this occurs if
the two data instances are defined in different modules, one with
`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it
is possible to have

  AvailTC F [F, MkFInt, MkFBool]
    [FieldLabel "foo" True $sel:foo:MkFInt, FieldLabel "foo" False foo].

If the two data instances are defined in different modules, both
without `-XDuplicateRecordFields`, it will be impossible to export
them from the same module (even with `-XDuplicateRecordfields`
enabled), because they would be represented identically.  The
workaround here is to enable `-XDuplicateRecordFields` on the defining
modules.
-}

117
118
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
119
stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2
Adam Gundry's avatar
Adam Gundry committed
120
121
122
123
124
125
stableAvailCmp (Avail {})         (AvailTC {})   = LT
stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =
    (n `stableNameCmp` m) `thenCmp`
    (cmpList stableNameCmp ns ms) `thenCmp`
    (cmpList (stableNameCmp `on` flSelector) nfs mfs)
stableAvailCmp (AvailTC {})       (Avail {})     = GT
126

127
avail :: Name -> AvailInfo
128
avail n = Avail n
129

130
131
132
133
134
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo

availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
135
      where add avail set = extendNameSetList set (availNames avail)
136

Adam Gundry's avatar
Adam Gundry committed
137
138
139
140
availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
      where add avail set = extendNameSetList set (availNamesWithSelectors avail)

141
142
143
144
145
146
147
148
availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
     where add avail env = extendNameEnvList env
                                (zip (availNames avail) (repeat avail))

-- | Just the main name made available, i.e. not the available pieces
-- of type or class brought into scope by the 'GenAvailInfo'
availName :: AvailInfo -> Name
149
availName (Avail n)     = n
Adam Gundry's avatar
Adam Gundry committed
150
availName (AvailTC n _ _) = n
151

Adam Gundry's avatar
Adam Gundry committed
152
-- | All names made available by the availability information (excluding overloaded selectors)
153
availNames :: AvailInfo -> [Name]
154
availNames (Avail n)         = [n]
Adam Gundry's avatar
Adam Gundry committed
155
156
157
158
availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]

-- | All names made available by the availability information (including overloaded selectors)
availNamesWithSelectors :: AvailInfo -> [Name]
159
availNamesWithSelectors (Avail n)         = [n]
Adam Gundry's avatar
Adam Gundry committed
160
161
162
163
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs

-- | Names for non-fields made available by the availability information
availNonFldNames :: AvailInfo -> [Name]
164
availNonFldNames (Avail n)        = [n]
Adam Gundry's avatar
Adam Gundry committed
165
166
167
168
169
170
171
availNonFldNames (AvailTC _ ns _) = ns

-- | Fields made available by the availability information
availFlds :: AvailInfo -> [FieldLabel]
availFlds (AvailTC _ _ fs) = fs
availFlds _                = []

172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231

-- -----------------------------------------------------------------------------
-- Utility

plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
plusAvail a1 a2
  | debugIsOn && availName a1 /= availName a2
  = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2])
plusAvail a1@(Avail {})         (Avail {})        = a1
plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2
plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1
plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)
  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first
       (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
                                   (fs1 `unionLists` fs2)
       (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
                                   (fs1 `unionLists` fs2)
       (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
                                   (fs1 `unionLists` fs2)
       (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
                                   (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)
  = AvailTC n1 ss1 (fs1 `unionLists` fs2)
plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)
  = AvailTC n1 ss2 (fs1 `unionLists` fs2)
plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])

-- | trims an 'AvailInfo' to keep only a single name
trimAvail :: AvailInfo -> Name -> AvailInfo
trimAvail (Avail n)         _ = Avail n
trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of
    Just x  -> AvailTC n [] [x]
    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []

-- | filters 'AvailInfo's by the given predicate
filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]
filterAvails keep avails = foldr (filterAvail keep) [] avails

-- | filters an 'AvailInfo' by the given predicate
filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo]
filterAvail keep ie rest =
  case ie of
    Avail n | keep n    -> ie : rest
            | otherwise -> rest
    AvailTC tc ns fs ->
        let ns' = filter keep ns
            fs' = filter (keep . flSelector) fs in
        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest


-- | Combines 'AvailInfo's from the same family
-- 'avails' may have several items with the same availName
-- E.g  import Ix( Ix(..), index )
-- will give Ix(Ix,index,range) and Ix(index)
-- We want to combine these; addAvail does that
nubAvails :: [AvailInfo] -> [AvailInfo]
nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails)
  where
    add env avail = extendNameEnv_C plusAvail env (availName avail) avail

232
233
234
235
236
237
238
-- -----------------------------------------------------------------------------
-- Printing

instance Outputable AvailInfo where
   ppr = pprAvail

pprAvail :: AvailInfo -> SDoc
239
pprAvail (Avail n)
240
241
242
243
  = ppr n
pprAvail (AvailTC n ns fs)
  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi
                         , fsep (punctuate comma (map (ppr . flLabel) fs))])
244

245
instance Binary AvailInfo where
246
    put_ bh (Avail aa) = do
247
248
            putByte bh 0
            put_ bh aa
Adam Gundry's avatar
Adam Gundry committed
249
    put_ bh (AvailTC ab ac ad) = do
250
251
252
            putByte bh 1
            put_ bh ab
            put_ bh ac
Adam Gundry's avatar
Adam Gundry committed
253
            put_ bh ad
254
255
256
257
    get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
258
                      return (Avail aa)
259
260
              _ -> do ab <- get bh
                      ac <- get bh
Adam Gundry's avatar
Adam Gundry committed
261
262
                      ad <- get bh
                      return (AvailTC ab ac ad)