Avail.hs 6.96 KB
Newer Older
1 2 3 4 5 6 7
--
-- (c) The University of Glasgow
--

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

import Name
import NameEnv
import NameSet

Adam Gundry's avatar
Adam Gundry committed
24
import FieldLabel
25
import Binary
26 27 28
import Outputable
import Util

Adam Gundry's avatar
Adam Gundry committed
29 30
import Data.Function

31 32 33 34
-- -----------------------------------------------------------------------------
-- The AvailInfo type

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

56 57
data IsPatSyn = NotPatSyn | IsPatSyn deriving Eq

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

Adam Gundry's avatar
Adam Gundry committed
61 62 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
{-
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.
-}

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

119 120 121 122 123 124
patSynAvail :: Name -> AvailInfo
patSynAvail n = Avail IsPatSyn n

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

125 126 127 128 129
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo

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

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

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

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

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

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

167 168 169 170 171 172 173
-- -----------------------------------------------------------------------------
-- Printing

instance Outputable AvailInfo where
   ppr = pprAvail

pprAvail :: AvailInfo -> SDoc
174 175 176 177 178
pprAvail (Avail _ n)
  = 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))])
179

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

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