Avail.hs 9.33 KB
Newer Older
1
{-# LANGUAGE CPP #-}
alexbiehl's avatar
alexbiehl committed
2
{-# LANGUAGE DeriveDataTypeable #-}
3 4 5 6
--
-- (c) The University of Glasgow
--

7 8
#include "HsVersions.h"

9 10 11
module Avail (
    Avails,
    AvailInfo(..),
12
    avail,
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 20 21 22 23 24 25 26
    stableAvailCmp,
    plusAvail,
    trimAvail,
    filterAvail,
    filterAvails,
    nubAvails


27 28 29 30 31 32
  ) where

import Name
import NameEnv
import NameSet

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

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

43 44 45 46
-- -----------------------------------------------------------------------------
-- The AvailInfo type

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

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

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

119 120
-- | Compare lexicographically
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
121
stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2
Adam Gundry's avatar
Adam Gundry committed
122 123 124 125 126 127
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
128

129
avail :: Name -> AvailInfo
130
avail n = Avail n
131

132 133 134 135 136
-- -----------------------------------------------------------------------------
-- Operations on AvailInfo

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

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

143 144 145 146 147 148 149 150
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
151
availName (Avail n)     = n
Adam Gundry's avatar
Adam Gundry committed
152
availName (AvailTC n _ _) = n
153

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

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

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

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 232 233

-- -----------------------------------------------------------------------------
-- 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

234 235 236 237 238 239 240
-- -----------------------------------------------------------------------------
-- Printing

instance Outputable AvailInfo where
   ppr = pprAvail

pprAvail :: AvailInfo -> SDoc
241
pprAvail (Avail n)
242 243 244 245
  = 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))])
246

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