GHC/Types/Avail.hs

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    --
    -- (c) The University of Glasgow
    --

    #include "HsVersions.h"

    module GHC.Types.Avail (
        Avails,
        AvailInfo(..),
        avail,
        availField,
        availTC,
        availsToNameSet,
        availsToNameSetWithSelectors,
        availsToNameEnv,
        availExportsDecl,
        availName, availGreName,
        availNames, availNonFldNames,
        availNamesWithSelectors,
        availFlds,
        availGreNames,
        availSubordinateGreNames,
        stableAvailCmp,
        plusAvail,
        trimAvail,
        filterAvail,
        filterAvails,
        nubAvails,

        GreName(..),
        greNameMangledName,
        greNamePrintableName,
        greNameSrcSpan,
        greNameFieldLabel,
        partitionGreNames,
        stableGreNameCmp,
      ) where

    import GHC.Prelude

    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Types.Name.Set
    import GHC.Types.SrcLoc

    import GHC.Types.FieldLabel
    import GHC.Utils.Binary
    import GHC.Data.List.SetOps
    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Misc

    import Data.Data ( Data )
    import Data.Either ( partitionEithers )
    import Data.List ( find )
    import Data.Maybe

    -- -----------------------------------------------------------------------------
    -- The AvailInfo type

    -- | Records what things are \"available\", i.e. in scope
    data AvailInfo

      -- | An ordinary identifier in scope, or a field label without a parent type
      -- (see Note [Representing pattern synonym fields in AvailInfo]).
      = Avail GreName

      -- | A type or class in scope
      --
      -- The __AvailTC Invariant__: If the type or class is itself to be in scope,
      -- it must be /first/ in this list.  Thus, typically:
      --
      -- > AvailTC Eq [Eq, ==, \/=]
      | AvailTC
           Name         -- ^ The name of the type or class
           [GreName]      -- ^ The available pieces of type or class
                        -- (see Note [Representing fields in AvailInfo]).

       deriving ( Eq    -- ^ Used when deciding if the interface has changed
                , Data )

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

    {-
    Note [Representing fields in AvailInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    See also Note [FieldLabel] in GHC.Types.FieldLabel.

    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" NoDuplicateRecordFields FieldSelectors foo]

    whereas if -XDuplicateRecordFields is enabled it gives

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

    where the label foo does not match the selector name $sel:foo:MkT.

    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" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt
                , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ]

    Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags
    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, with
    different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors`
    extensions.  Thus it is possible to have

      AvailTC F [ F, MkFInt, MkFBool
                , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt
                , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ]

    If the two data instances are defined in different modules, both without
    `-XDuplicateRecordFields` or `-XNoFieldSelectors`, 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` or `-XNoFieldSelectors` on the defining modules.  See
    also #13352.

    Note [Representing pattern synonym fields in AvailInfo]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Record pattern synonym fields cannot be represented using AvailTC like fields of
    normal record types (see Note [Representing fields in AvailInfo]), because they
    do not always have a parent type constructor.  So we represent them using the
    Avail constructor, with a NormalGreName that carries the underlying FieldLabel.

    Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration

      pattern MkFoo{f} = Bar f

    gives rise to the AvailInfo

      Avail (NormalGreName MkFoo)
      Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo))

    However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in
    an export list, then whenever `f` is imported the parent will be `T`,
    represented as

      AvailTC T [ NormalGreName T
                , NormalGreName MkFoo
                , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ]

    See also Note [GreNames] in GHC.Types.Name.Reader.
    -}

    -- | Compare lexicographically
    stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
    stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableGreNameCmp` c2
    stableAvailCmp (Avail {})     (AvailTC {})   = LT
    stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
                                                   (cmpList stableGreNameCmp ns ms)
    stableAvailCmp (AvailTC {})   (Avail {})     = GT

    stableGreNameCmp :: GreName -> GreName -> Ordering
    stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2
    stableGreNameCmp (NormalGreName {}) (FieldGreName  {}) = LT
    stableGreNameCmp (FieldGreName  f1) (FieldGreName  f2) = flSelector f1 `stableNameCmp` flSelector f2
    stableGreNameCmp (FieldGreName  {}) (NormalGreName {}) = GT

    avail :: Name -> AvailInfo
    avail n = Avail (NormalGreName n)

    availField :: FieldLabel -> AvailInfo
    availField fl = Avail (FieldGreName fl)

    availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo
    availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls)

    -- -----------------------------------------------------------------------------
    -- Operations on AvailInfo

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

    availsToNameSetWithSelectors :: [AvailInfo] -> NameSet
    availsToNameSetWithSelectors avails = foldr add emptyNameSet avails
          where add avail set = extendNameSetList set (availNamesWithSelectors avail)

    availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
    availsToNameEnv avails = foldr add emptyNameEnv avails
         where add avail env = extendNameEnvList env
                                    (zip (availNames avail) (repeat avail))

    -- | Does this 'AvailInfo' export the parent decl?  This depends on the
    -- invariant that the parent is first if it appears at all.
    availExportsDecl :: AvailInfo -> Bool
    availExportsDecl (AvailTC ty_name names)
      | n : _ <- names = NormalGreName ty_name == n
      | otherwise      = False
    availExportsDecl _ = True

    -- | Just the main name made available, i.e. not the available pieces
    -- of type or class brought into scope by the 'AvailInfo'
    availName :: AvailInfo -> Name
    availName (Avail n)     = greNameMangledName n
    availName (AvailTC n _) = n

    availGreName :: AvailInfo -> GreName
    availGreName (Avail c) = c
    availGreName (AvailTC n _) = NormalGreName n

    -- | All names made available by the availability information (excluding overloaded selectors)
    availNames :: AvailInfo -> [Name]
    availNames (Avail c) = childNonOverloadedNames c
    availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs

    childNonOverloadedNames :: GreName -> [Name]
    childNonOverloadedNames (NormalGreName n) = [n]
    childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ]

    -- | All names made available by the availability information (including overloaded selectors)
    availNamesWithSelectors :: AvailInfo -> [Name]
    availNamesWithSelectors (Avail c) = [greNameMangledName c]
    availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs

    -- | Names for non-fields made available by the availability information
    availNonFldNames :: AvailInfo -> [Name]
    availNonFldNames (Avail (NormalGreName n)) = [n]
    availNonFldNames (Avail (FieldGreName {})) = []
    availNonFldNames (AvailTC _ ns) = mapMaybe f ns
      where
        f (NormalGreName n) = Just n
        f (FieldGreName {}) = Nothing

    -- | Fields made available by the availability information
    availFlds :: AvailInfo -> [FieldLabel]
    availFlds (Avail c) = maybeToList (greNameFieldLabel c)
    availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs

    -- | Names and fields made available by the availability information.
    availGreNames :: AvailInfo -> [GreName]
    availGreNames (Avail c)      = [c]
    availGreNames (AvailTC _ cs) = cs

    -- | Names and fields made available by the availability information, other than
    -- the main decl itself.
    availSubordinateGreNames :: AvailInfo -> [GreName]
    availSubordinateGreNames (Avail {}) = []
    availSubordinateGreNames avail@(AvailTC _ ns)
      | availExportsDecl avail = tail ns
      | otherwise              = ns

    -- | Used where we may have an ordinary name or a record field label.
    -- See Note [GreNames] in GHC.Types.Name.Reader.
    data GreName = NormalGreName Name
                 | FieldGreName FieldLabel
        deriving (Data, Eq)

    instance Outputable GreName where
      ppr (NormalGreName n) = ppr n
      ppr (FieldGreName fl) = ppr fl

    instance HasOccName GreName where
      occName (NormalGreName n) = occName n
      occName (FieldGreName fl) = occName fl

    -- | A 'Name' for internal use, but not for output to the user.  For fields, the
    -- 'OccName' will be the selector.  See Note [GreNames] in GHC.Types.Name.Reader.
    greNameMangledName :: GreName -> Name
    greNameMangledName (NormalGreName n) = n
    greNameMangledName (FieldGreName fl) = flSelector fl

    -- | A 'Name' suitable for output to the user.  For fields, the 'OccName' will
    -- be the field label.  See Note [GreNames] in GHC.Types.Name.Reader.
    greNamePrintableName :: GreName -> Name
    greNamePrintableName (NormalGreName n) = n
    greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl

    greNameSrcSpan :: GreName -> SrcSpan
    greNameSrcSpan (NormalGreName n) = nameSrcSpan n
    greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl)

    greNameFieldLabel :: GreName -> Maybe FieldLabel
    greNameFieldLabel (NormalGreName {}) = Nothing
    greNameFieldLabel (FieldGreName fl)  = Just fl

    partitionGreNames :: [GreName] -> ([Name], [FieldLabel])
    partitionGreNames = partitionEithers . map to_either
      where
        to_either (NormalGreName n) = Left n
        to_either (FieldGreName fl) = Right fl

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

    plusAvail :: AvailInfo -> AvailInfo -> AvailInfo
    plusAvail a1 a2
      | debugIsOn && availName a1 /= availName a2
      = pprPanic "GHC.Rename.Env.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)) (AvailTC n2 (s2:ss2))
      = case (NormalGreName n1==s1, NormalGreName n2==s2) of  -- Maintain invariant the parent is first
           (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))
           (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))
           (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))
           (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))
    plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])

    -- | trims an 'AvailInfo' to keep only a single name
    trimAvail :: AvailInfo -> Name -> AvailInfo
    trimAvail avail@(Avail {})         _ = avail
    trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of
        Just c  -> AvailTC n [c]
        Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr 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 c | keep (greNameMangledName c) -> ie : rest
                | otherwise -> rest
        AvailTC tc cs ->
            let cs' = filter (keep . greNameMangledName) cs
            in if null cs' then rest else AvailTC tc cs' : 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

    -- -----------------------------------------------------------------------------
    -- Printing

    instance Outputable AvailInfo where
       ppr = pprAvail

    pprAvail :: AvailInfo -> SDoc
    pprAvail (Avail n)
      = ppr n
    pprAvail (AvailTC n ns)
      = ppr n <> braces (fsep (punctuate comma (map ppr ns)))

    instance Binary AvailInfo where
        put_ bh (Avail aa) = do
                putByte bh 0
                put_ bh aa
        put_ bh (AvailTC ab ac) = do
                putByte bh 1
                put_ bh ab
                put_ bh ac
        get bh = do
                h <- getByte bh
                case h of
                  0 -> do aa <- get bh
                          return (Avail aa)
                  _ -> do ab <- get bh
                          ac <- get bh
                          return (AvailTC ab ac)

    instance Binary GreName where
        put_ bh (NormalGreName aa) = do
                putByte bh 0
                put_ bh aa
        put_ bh (FieldGreName ab) = do
                putByte bh 1
                put_ bh ab
        get bh = do
                h <- getByte bh
                case h of
                  0 -> do aa <- get bh
                          return (NormalGreName aa)
                  _ -> do ab <- get bh
                          return (FieldGreName ab)