never executed always true always false
    1 
    2 
    3 module GHC.Types.Name.Shape
    4    ( NameShape(..)
    5    , emptyNameShape
    6    , mkNameShape
    7    , extendNameShape
    8    , nameShapeExports
    9    , substNameShape
   10    , maybeSubstNameShape
   11    )
   12 where
   13 
   14 import GHC.Prelude
   15 
   16 import GHC.Driver.Env
   17 
   18 import GHC.Unit.Module
   19 
   20 import GHC.Types.Unique.FM
   21 import GHC.Types.Avail
   22 import GHC.Types.FieldLabel
   23 import GHC.Types.Name
   24 import GHC.Types.Name.Env
   25 
   26 import GHC.Tc.Utils.Monad
   27 import GHC.Iface.Env
   28 
   29 import GHC.Utils.Outputable
   30 import GHC.Utils.Panic.Plain
   31 
   32 import Control.Monad
   33 
   34 -- Note [NameShape]
   35 -- ~~~~~~~~~~~~~~~~
   36 -- When we write a declaration in a signature, e.g., data T, we
   37 -- ascribe to it a *name variable*, e.g., {m.T}.  This
   38 -- name variable may be substituted with an actual original
   39 -- name when the signature is implemented (or even if we
   40 -- merge the signature with one which reexports this entity
   41 -- from another module).
   42 
   43 -- When we instantiate a signature m with a module M,
   44 -- we also need to substitute over names.  To do so, we must
   45 -- compute the *name substitution* induced by the *exports*
   46 -- of the module in question.  A NameShape represents
   47 -- such a name substitution for a single module instantiation.
   48 -- The "shape" in the name comes from the fact that the computation
   49 -- of a name substitution is essentially the *shaping pass* from
   50 -- Backpack'14, but in a far more restricted form.
   51 
   52 -- The name substitution for an export list is easy to explain.  If we are
   53 -- filling the module variable <m>, given an export N of the form
   54 -- M.n or {m'.n} (where n is an OccName), the induced name
   55 -- substitution is from {m.n} to N.  So, for example, if we have
   56 -- A=impl:B, and the exports of impl:B are impl:B.f and
   57 -- impl:C.g, then our name substitution is {A.f} to impl:B.f
   58 -- and {A.g} to impl:C.g
   59 
   60 
   61 
   62 
   63 -- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types
   64 -- needs to refer to NameShape, and having GHC.Tc.Types import
   65 -- NameShape (even by SOURCE) would cause a large number of
   66 -- modules to be pulled into the DynFlags cycle.
   67 {-
   68 data NameShape = NameShape {
   69         ns_mod_name :: ModuleName,
   70         ns_exports :: [AvailInfo],
   71         ns_map :: OccEnv Name
   72     }
   73 -}
   74 
   75 -- NB: substitution functions need 'HscEnv' since they need the name cache
   76 -- to allocate new names if we change the 'Module' of a 'Name'
   77 
   78 -- | Create an empty 'NameShape' (i.e., the renaming that
   79 -- would occur with an implementing module with no exports)
   80 -- for a specific hole @mod_name@.
   81 emptyNameShape :: ModuleName -> NameShape
   82 emptyNameShape mod_name = NameShape mod_name [] emptyOccEnv
   83 
   84 -- | Create a 'NameShape' corresponding to an implementing
   85 -- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
   86 mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
   87 mkNameShape mod_name as =
   88     NameShape mod_name as $ mkOccEnv $ do
   89         a <- as
   90         n <- availName a : availNamesWithSelectors a
   91         return (occName n, n)
   92 
   93 -- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
   94 -- with Backpack style mix-in linking.  This is used solely when merging
   95 -- signatures together: we successively merge the exports of each
   96 -- signature until we have the final, full exports of the merged signature.
   97 --
   98 -- What makes this operation nontrivial is what we are supposed to do when
   99 -- we want to merge in an export for M.T when we already have an existing
  100 -- export {H.T}.  What should happen in this case is that {H.T} should be
  101 -- unified with @M.T@: we've determined a more *precise* identity for the
  102 -- export at 'OccName' @T@.
  103 --
  104 -- Note that we don't do unrestricted unification: only name holes from
  105 -- @ns_mod_name ns@ are flexible.  This is because we have a much more
  106 -- restricted notion of shaping than in Backpack'14: we do shaping
  107 -- *as* we do type-checking.  Thus, once we shape a signature, its
  108 -- exports are *final* and we're not allowed to refine them further,
  109 extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
  110 extendNameShape hsc_env ns as =
  111     case uAvailInfos (ns_mod_name ns) (ns_exports ns) as of
  112         Left err -> return (Left err)
  113         Right nsubst -> do
  114             as1 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) (ns_exports ns)
  115             as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
  116             let new_avails = mergeAvails as1 as2
  117             return . Right $ ns {
  118                 ns_exports = new_avails,
  119                 -- TODO: stop repeatedly rebuilding the OccEnv
  120                 ns_map = mkOccEnv $ do
  121                             a <- new_avails
  122                             n <- availName a : availNames a
  123                             return (occName n, n)
  124                 }
  125 
  126 -- | The export list associated with this 'NameShape' (i.e., what
  127 -- the exports of an implementing module which induces this 'NameShape'
  128 -- would be.)
  129 nameShapeExports :: NameShape -> [AvailInfo]
  130 nameShapeExports = ns_exports
  131 
  132 -- | Given a 'Name', substitute it according to the 'NameShape' implied
  133 -- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
  134 -- exports @M.T@.
  135 substNameShape :: NameShape -> Name -> Name
  136 substNameShape ns n | nameModule n == ns_module ns
  137                     , Just n' <- lookupOccEnv (ns_map ns) (occName n)
  138                     = n'
  139                     | otherwise
  140                     = n
  141 
  142 -- | Like 'substNameShape', but returns @Nothing@ if no substitution
  143 -- works.
  144 maybeSubstNameShape :: NameShape -> Name -> Maybe Name
  145 maybeSubstNameShape ns n
  146     | nameModule n == ns_module ns
  147     = lookupOccEnv (ns_map ns) (occName n)
  148     | otherwise
  149     = Nothing
  150 
  151 -- | The 'Module' of any 'Name's a 'NameShape' has action over.
  152 ns_module :: NameShape -> Module
  153 ns_module = mkHoleModule . ns_mod_name
  154 
  155 {-
  156 ************************************************************************
  157 *                                                                      *
  158                         Name substitutions
  159 *                                                                      *
  160 ************************************************************************
  161 -}
  162 
  163 -- | Substitution on @{A.T}@.  We enforce the invariant that the
  164 -- 'nameModule' of keys of this map have 'moduleUnit' @hole@
  165 -- (meaning that if we have a hole substitution, the keys of the map
  166 -- are never affected.)  Alternatively, this is isomorphic to
  167 -- @Map ('ModuleName', 'OccName') 'Name'@.
  168 type ShNameSubst = NameEnv Name
  169 
  170 -- NB: In this module, we actually only ever construct 'ShNameSubst'
  171 -- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
  172 -- work with.
  173 
  174 -- | Substitute names in a 'Name'.
  175 substName :: ShNameSubst -> Name -> Name
  176 substName env n | Just n' <- lookupNameEnv env n = n'
  177                 | otherwise                      = n
  178 
  179 -- | Substitute names in an 'AvailInfo'.  This has special behavior
  180 -- for type constructors, where it is sufficient to substitute the 'availName'
  181 -- to induce a substitution on 'availNames'.
  182 substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
  183 substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n)))
  184 substNameAvailInfo _ env (Avail (FieldGreName fl)) =
  185     return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) }))
  186 substNameAvailInfo hsc_env env (AvailTC n ns) =
  187     let mb_mod = fmap nameModule (lookupNameEnv env n)
  188     in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns
  189 
  190 setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName
  191 setNameGreName hsc_env mb_mod gname = case gname of
  192     NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n)
  193     FieldGreName fl -> FieldGreName  <$> setNameFieldSelector hsc_env mb_mod fl
  194 
  195 -- | Set the 'Module' of a 'FieldSelector'
  196 setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
  197 setNameFieldSelector _ Nothing f = return f
  198 setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do
  199     sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel
  200     return (FieldLabel l b has_sel sel')
  201 
  202 {-
  203 ************************************************************************
  204 *                                                                      *
  205                         AvailInfo merging
  206 *                                                                      *
  207 ************************************************************************
  208 -}
  209 
  210 -- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
  211 -- already been unified ('uAvailInfos').
  212 mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
  213 mergeAvails as1 as2 =
  214     let mkNE as = mkNameEnv [(availName a, a) | a <- as]
  215     in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))
  216 
  217 {-
  218 ************************************************************************
  219 *                                                                      *
  220                         AvailInfo unification
  221 *                                                                      *
  222 ************************************************************************
  223 -}
  224 
  225 -- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
  226 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
  227 uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
  228 uAvailInfos flexi as1 as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
  229     let mkOE as = listToUFM $ do a <- as
  230                                  n <- availNames a
  231                                  return (nameOccName n, a)
  232     in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv
  233              (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))
  234              -- Edward: I have to say, this is pretty clever.
  235 
  236 -- | Unify two 'AvailInfo's, given an existing substitution @subst@,
  237 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
  238 uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
  239            -> Either SDoc ShNameSubst
  240 uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2
  241 uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2
  242 uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"
  243                            <+> ppr a1 <+> text "with" <+> ppr a2
  244                            <+> parens (text "one is a type, the other is a plain identifier")
  245 
  246 -- | Unify two 'Name's, given an existing substitution @subst@,
  247 -- with only name holes from @flexi@ unifiable (all other name holes rigid.)
  248 uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
  249 uName flexi subst n1 n2
  250     | n1 == n2      = Right subst
  251     | isFlexi n1    = uHoleName flexi subst n1 n2
  252     | isFlexi n2    = uHoleName flexi subst n2 n1
  253     | otherwise     = Left (text "While merging export lists, could not unify"
  254                          <+> ppr n1 <+> text "with" <+> ppr n2 $$ extra)
  255   where
  256     isFlexi n = isHoleName n && moduleName (nameModule n) == flexi
  257     extra | isHoleName n1 || isHoleName n2
  258           = text "Neither name variable originates from the current signature."
  259           | otherwise
  260           = empty
  261 
  262 -- | Unify a name @h@ which 'isHoleName' with another name, given an existing
  263 -- substitution @subst@, with only name holes from @flexi@ unifiable (all
  264 -- other name holes rigid.)
  265 uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
  266           -> Either SDoc ShNameSubst
  267 uHoleName flexi subst h n =
  268     assert (isHoleName h) $
  269     case lookupNameEnv subst h of
  270         Just n' -> uName flexi subst n' n
  271                 -- Do a quick check if the other name is substituted.
  272         Nothing | Just n' <- lookupNameEnv subst n ->
  273                     assert (isHoleName n) $ uName flexi subst h n'
  274                 | otherwise ->
  275                     Right (extendNameEnv subst h n)