1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3-- 4-- (c) The University of Glasgow 5-- 6 7#include "GhclibHsVersions.h" 8 9module GHC.Types.Avail ( 10 Avails, 11 AvailInfo(..), 12 avail, 13 availField, 14 availTC, 15 availsToNameSet, 16 availsToNameSetWithSelectors, 17 availsToNameEnv, 18 availExportsDecl, 19 availName, availGreName, 20 availNames, availNonFldNames, 21 availNamesWithSelectors, 22 availFlds, 23 availGreNames, 24 availSubordinateGreNames, 25 stableAvailCmp, 26 plusAvail, 27 trimAvail, 28 filterAvail, 29 filterAvails, 30 nubAvails, 31 32 GreName(..), 33 greNameMangledName, 34 greNamePrintableName, 35 greNameSrcSpan, 36 greNameFieldLabel, 37 partitionGreNames, 38 stableGreNameCmp, 39 ) where 40 41import GHC.Prelude 42 43import GHC.Types.Name 44import GHC.Types.Name.Env 45import GHC.Types.Name.Set 46import GHC.Types.SrcLoc 47 48import GHC.Types.FieldLabel 49import GHC.Utils.Binary 50import GHC.Data.List.SetOps 51import GHC.Utils.Outputable 52import GHC.Utils.Panic 53import GHC.Utils.Misc 54 55import Data.Data ( Data ) 56import Data.Either ( partitionEithers ) 57import Data.List ( find ) 58import Data.Maybe 59 60-- ----------------------------------------------------------------------------- 61-- The AvailInfo type 62 63-- | Records what things are \"available\", i.e. in scope 64data AvailInfo 65 66 -- | An ordinary identifier in scope, or a field label without a parent type 67 -- (see Note [Representing pattern synonym fields in AvailInfo]). 68 = Avail GreName 69 70 -- | A type or class in scope 71 -- 72 -- The __AvailTC Invariant__: If the type or class is itself to be in scope, 73 -- it must be /first/ in this list. Thus, typically: 74 -- 75 -- > AvailTC Eq [Eq, ==, \/=] 76 | AvailTC 77 Name -- ^ The name of the type or class 78 [GreName] -- ^ The available pieces of type or class 79 -- (see Note [Representing fields in AvailInfo]). 80 81 deriving ( Eq -- ^ Used when deciding if the interface has changed 82 , Data ) 83 84-- | A collection of 'AvailInfo' - several things that are \"available\" 85type Avails = [AvailInfo] 86 87{- 88Note [Representing fields in AvailInfo] 89~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 90See also Note [FieldLabel] in GHC.Types.FieldLabel. 91 92When -XDuplicateRecordFields is disabled (the normal case), a 93datatype like 94 95 data T = MkT { foo :: Int } 96 97gives rise to the AvailInfo 98 99 AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo] 100 101whereas if -XDuplicateRecordFields is enabled it gives 102 103 AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] 104 105where the label foo does not match the selector name $sel:foo:MkT. 106 107The labels in a field list are not necessarily unique: 108data families allow the same parent (the family tycon) to have 109multiple distinct fields with the same label. For example, 110 111 data family F a 112 data instance F Int = MkFInt { foo :: Int } 113 data instance F Bool = MkFBool { foo :: Bool} 114 115gives rise to 116 117 AvailTC F [ F, MkFInt, MkFBool 118 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt 119 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] 120 121Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags 122need not be the same for all the elements of the list. In the example above, 123this occurs if the two data instances are defined in different modules, with 124different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors` 125extensions. Thus it is possible to have 126 127 AvailTC F [ F, MkFInt, MkFBool 128 , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt 129 , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] 130 131If the two data instances are defined in different modules, both without 132`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to 133export them from the same module (even with `-XDuplicateRecordfields` enabled), 134because they would be represented identically. The workaround here is to enable 135`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules. See 136also #13352. 137 138 139Note [Representing pattern synonym fields in AvailInfo] 140~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 141Record pattern synonym fields cannot be represented using AvailTC like fields of 142normal record types (see Note [Representing fields in AvailInfo]), because they 143do not always have a parent type constructor. So we represent them using the 144Avail constructor, with a NormalGreName that carries the underlying FieldLabel. 145 146Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration 147 148 pattern MkFoo{f} = Bar f 149 150gives rise to the AvailInfo 151 152 Avail (NormalGreName MkFoo) 153 Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo)) 154 155However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in 156an export list, then whenever `f` is imported the parent will be `T`, 157represented as 158 159 AvailTC T [ NormalGreName T 160 , NormalGreName MkFoo 161 , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ] 162 163See also Note [GreNames] in GHC.Types.Name.Reader. 164-} 165 166-- | Compare lexicographically 167stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering 168stableAvailCmp (Avail c1) (Avail c2) = c1 `stableGreNameCmp` c2 169stableAvailCmp (Avail {}) (AvailTC {}) = LT 170stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` 171 (cmpList stableGreNameCmp ns ms) 172stableAvailCmp (AvailTC {}) (Avail {}) = GT 173 174stableGreNameCmp :: GreName -> GreName -> Ordering 175stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2 176stableGreNameCmp (NormalGreName {}) (FieldGreName {}) = LT 177stableGreNameCmp (FieldGreName f1) (FieldGreName f2) = flSelector f1 `stableNameCmp` flSelector f2 178stableGreNameCmp (FieldGreName {}) (NormalGreName {}) = GT 179 180avail :: Name -> AvailInfo 181avail n = Avail (NormalGreName n) 182 183availField :: FieldLabel -> AvailInfo 184availField fl = Avail (FieldGreName fl) 185 186availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo 187availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls) 188 189 190-- ----------------------------------------------------------------------------- 191-- Operations on AvailInfo 192 193availsToNameSet :: [AvailInfo] -> NameSet 194availsToNameSet avails = foldr add emptyNameSet avails 195 where add avail set = extendNameSetList set (availNames avail) 196 197availsToNameSetWithSelectors :: [AvailInfo] -> NameSet 198availsToNameSetWithSelectors avails = foldr add emptyNameSet avails 199 where add avail set = extendNameSetList set (availNamesWithSelectors avail) 200 201availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo 202availsToNameEnv avails = foldr add emptyNameEnv avails 203 where add avail env = extendNameEnvList env 204 (zip (availNames avail) (repeat avail)) 205 206-- | Does this 'AvailInfo' export the parent decl? This depends on the 207-- invariant that the parent is first if it appears at all. 208availExportsDecl :: AvailInfo -> Bool 209availExportsDecl (AvailTC ty_name names) 210 | n : _ <- names = NormalGreName ty_name == n 211 | otherwise = False 212availExportsDecl _ = True 213 214-- | Just the main name made available, i.e. not the available pieces 215-- of type or class brought into scope by the 'AvailInfo' 216availName :: AvailInfo -> Name 217availName (Avail n) = greNameMangledName n 218availName (AvailTC n _) = n 219 220availGreName :: AvailInfo -> GreName 221availGreName (Avail c) = c 222availGreName (AvailTC n _) = NormalGreName n 223 224-- | All names made available by the availability information (excluding overloaded selectors) 225availNames :: AvailInfo -> [Name] 226availNames (Avail c) = childNonOverloadedNames c 227availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs 228 229childNonOverloadedNames :: GreName -> [Name] 230childNonOverloadedNames (NormalGreName n) = [n] 231childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ] 232 233-- | All names made available by the availability information (including overloaded selectors) 234availNamesWithSelectors :: AvailInfo -> [Name] 235availNamesWithSelectors (Avail c) = [greNameMangledName c] 236availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs 237 238-- | Names for non-fields made available by the availability information 239availNonFldNames :: AvailInfo -> [Name] 240availNonFldNames (Avail (NormalGreName n)) = [n] 241availNonFldNames (Avail (FieldGreName {})) = [] 242availNonFldNames (AvailTC _ ns) = mapMaybe f ns 243 where 244 f (NormalGreName n) = Just n 245 f (FieldGreName {}) = Nothing 246 247-- | Fields made available by the availability information 248availFlds :: AvailInfo -> [FieldLabel] 249availFlds (Avail c) = maybeToList (greNameFieldLabel c) 250availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs 251 252-- | Names and fields made available by the availability information. 253availGreNames :: AvailInfo -> [GreName] 254availGreNames (Avail c) = [c] 255availGreNames (AvailTC _ cs) = cs 256 257-- | Names and fields made available by the availability information, other than 258-- the main decl itself. 259availSubordinateGreNames :: AvailInfo -> [GreName] 260availSubordinateGreNames (Avail {}) = [] 261availSubordinateGreNames avail@(AvailTC _ ns) 262 | availExportsDecl avail = tail ns 263 | otherwise = ns 264 265 266-- | Used where we may have an ordinary name or a record field label. 267-- See Note [GreNames] in GHC.Types.Name.Reader. 268data GreName = NormalGreName Name 269 | FieldGreName FieldLabel 270 deriving (Data, Eq) 271 272instance Outputable GreName where 273 ppr (NormalGreName n) = ppr n 274 ppr (FieldGreName fl) = ppr fl 275 276instance HasOccName GreName where 277 occName (NormalGreName n) = occName n 278 occName (FieldGreName fl) = occName fl 279 280-- | A 'Name' for internal use, but not for output to the user. For fields, the 281-- 'OccName' will be the selector. See Note [GreNames] in GHC.Types.Name.Reader. 282greNameMangledName :: GreName -> Name 283greNameMangledName (NormalGreName n) = n 284greNameMangledName (FieldGreName fl) = flSelector fl 285 286-- | A 'Name' suitable for output to the user. For fields, the 'OccName' will 287-- be the field label. See Note [GreNames] in GHC.Types.Name.Reader. 288greNamePrintableName :: GreName -> Name 289greNamePrintableName (NormalGreName n) = n 290greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl 291 292greNameSrcSpan :: GreName -> SrcSpan 293greNameSrcSpan (NormalGreName n) = nameSrcSpan n 294greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl) 295 296greNameFieldLabel :: GreName -> Maybe FieldLabel 297greNameFieldLabel (NormalGreName {}) = Nothing 298greNameFieldLabel (FieldGreName fl) = Just fl 299 300partitionGreNames :: [GreName] -> ([Name], [FieldLabel]) 301partitionGreNames = partitionEithers . map to_either 302 where 303 to_either (NormalGreName n) = Left n 304 to_either (FieldGreName fl) = Right fl 305 306 307-- ----------------------------------------------------------------------------- 308-- Utility 309 310plusAvail :: AvailInfo -> AvailInfo -> AvailInfo 311plusAvail a1 a2 312 | debugIsOn && availName a1 /= availName a2 313 = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) 314plusAvail a1@(Avail {}) (Avail {}) = a1 315plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 316plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 317plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) 318 = case (NormalGreName n1==s1, NormalGreName n2==s2) of -- Maintain invariant the parent is first 319 (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) 320 (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) 321 (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) 322 (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) 323plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2]) 324 325-- | trims an 'AvailInfo' to keep only a single name 326trimAvail :: AvailInfo -> Name -> AvailInfo 327trimAvail avail@(Avail {}) _ = avail 328trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of 329 Just c -> AvailTC n [c] 330 Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m]) 331 332-- | filters 'AvailInfo's by the given predicate 333filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] 334filterAvails keep avails = foldr (filterAvail keep) [] avails 335 336-- | filters an 'AvailInfo' by the given predicate 337filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] 338filterAvail keep ie rest = 339 case ie of 340 Avail c | keep (greNameMangledName c) -> ie : rest 341 | otherwise -> rest 342 AvailTC tc cs -> 343 let cs' = filter (keep . greNameMangledName) cs 344 in if null cs' then rest else AvailTC tc cs' : rest 345 346 347-- | Combines 'AvailInfo's from the same family 348-- 'avails' may have several items with the same availName 349-- E.g import Ix( Ix(..), index ) 350-- will give Ix(Ix,index,range) and Ix(index) 351-- We want to combine these; addAvail does that 352nubAvails :: [AvailInfo] -> [AvailInfo] 353nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) 354 where 355 add env avail = extendNameEnv_C plusAvail env (availName avail) avail 356 357-- ----------------------------------------------------------------------------- 358-- Printing 359 360instance Outputable AvailInfo where 361 ppr = pprAvail 362 363pprAvail :: AvailInfo -> SDoc 364pprAvail (Avail n) 365 = ppr n 366pprAvail (AvailTC n ns) 367 = ppr n <> braces (fsep (punctuate comma (map ppr ns))) 368 369instance Binary AvailInfo where 370 put_ bh (Avail aa) = do 371 putByte bh 0 372 put_ bh aa 373 put_ bh (AvailTC ab ac) = do 374 putByte bh 1 375 put_ bh ab 376 put_ bh ac 377 get bh = do 378 h <- getByte bh 379 case h of 380 0 -> do aa <- get bh 381 return (Avail aa) 382 _ -> do ab <- get bh 383 ac <- get bh 384 return (AvailTC ab ac) 385 386instance Binary GreName where 387 put_ bh (NormalGreName aa) = do 388 putByte bh 0 389 put_ bh aa 390 put_ bh (FieldGreName ab) = do 391 putByte bh 1 392 put_ bh ab 393 get bh = do 394 h <- getByte bh 395 case h of 396 0 -> do aa <- get bh 397 return (NormalGreName aa) 398 _ -> do ab <- get bh 399 return (FieldGreName ab) 400