Avail.hs 6.94 KB
Newer Older
1
2
3
4
--
-- (c) The University of Glasgow
--

Adam Gundry's avatar
Adam Gundry committed
5
6
{-# LANGUAGE DeriveDataTypeable #-}

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

import Name
import NameEnv
import NameSet

Adam Gundry's avatar
Adam Gundry committed
26
import FieldLabel
27
import Binary
28
29
30
import Outputable
import Util

Adam Gundry's avatar
Adam Gundry committed
31
32
import Data.Function

33
34
35
36
-- -----------------------------------------------------------------------------
-- The AvailInfo type

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

58
59
data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq

60
-- | A collection of 'AvailInfo' - several things that are \"available\"
61
type Avails = [AvailInfo]
62

Adam Gundry's avatar
Adam Gundry committed
63
64
65
66
67
68
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
{-
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.
-}

111
112
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
113
stableAvailCmp (Avail _ n1)       (Avail _ n2)   = n1 `stableNameCmp` n2
Adam Gundry's avatar
Adam Gundry committed
114
115
116
117
118
119
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
120

121
122
123
124
125
126
patSynAvail :: Name -> AvailInfo
patSynAvail n = Avail IsPatSyn n

avail :: Name -> AvailInfo
avail n = Avail NotPatSyn n

127
128
129
130
131
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo

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

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

138
139
140
141
142
143
144
145
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
146
availName (Avail _ n)     = n
Adam Gundry's avatar
Adam Gundry committed
147
availName (AvailTC n _ _) = n
148

Adam Gundry's avatar
Adam Gundry committed
149
-- | All names made available by the availability information (excluding overloaded selectors)
150
availNames :: AvailInfo -> [Name]
151
availNames (Avail _ n)         = [n]
Adam Gundry's avatar
Adam Gundry committed
152
153
154
155
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]
156
availNamesWithSelectors (Avail _ n)         = [n]
Adam Gundry's avatar
Adam Gundry committed
157
158
159
160
availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs

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

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

169
170
171
172
173
174
175
-- -----------------------------------------------------------------------------
-- Printing

instance Outputable AvailInfo where
   ppr = pprAvail

pprAvail :: AvailInfo -> SDoc
176
pprAvail (Avail _ n)         = ppr n
Adam Gundry's avatar
Adam Gundry committed
177
pprAvail (AvailTC n ns fs) = ppr n <> braces (hsep (punctuate comma (map ppr ns ++ map (ppr . flLabel) fs)))
178

179
instance Binary AvailInfo where
180
    put_ bh (Avail b aa) = do
181
182
            putByte bh 0
            put_ bh aa
183
            put_ bh b
Adam Gundry's avatar
Adam Gundry committed
184
    put_ bh (AvailTC ab ac ad) = do
185
186
187
            putByte bh 1
            put_ bh ab
            put_ bh ac
Adam Gundry's avatar
Adam Gundry committed
188
            put_ bh ad
189
190
191
192
    get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
193
194
                      b  <- get bh
                      return (Avail b aa)
195
196
              _ -> do ab <- get bh
                      ac <- get bh
Adam Gundry's avatar
Adam Gundry committed
197
198
                      ad <- get bh
                      return (AvailTC ab ac ad)
199
200
201
202
203
204
205
206
207

instance Binary IsPatSyn where
  put_ bh IsPatSyn = putByte bh 0
  put_ bh NotPatSyn = putByte bh 1
  get bh = do
    h <- getByte bh
    case h of
      0 -> return IsPatSyn
      _ -> return NotPatSyn