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