module GHC.Types.Name.Shape
   ( NameShape(..)
   , emptyNameShape
   , mkNameShape
   , extendNameShape
   , nameShapeExports
   , substNameShape
   , maybeSubstNameShape
   )
where

import GHC.Prelude

import GHC.Driver.Env

import GHC.Unit.Module

import GHC.Types.Avail
import GHC.Types.Name
import GHC.Types.Name.Env

import GHC.Tc.Utils.Monad
import GHC.Iface.Env
import GHC.Tc.Errors.Types

import GHC.Utils.Panic.Plain

import Control.Monad

-- Note [NameShape]
-- ~~~~~~~~~~~~~~~~
-- When we write a declaration in a signature, e.g., data T, we
-- ascribe to it a *name variable*, e.g., {m.T}.  This
-- name variable may be substituted with an actual original
-- name when the signature is implemented (or even if we
-- merge the signature with one which reexports this entity
-- from another module).

-- When we instantiate a signature m with a module M,
-- we also need to substitute over names.  To do so, we must
-- compute the *name substitution* induced by the *exports*
-- of the module in question.  A NameShape represents
-- such a name substitution for a single module instantiation.
-- The "shape" in the name comes from the fact that the computation
-- of a name substitution is essentially the *shaping pass* from
-- Backpack'14, but in a far more restricted form.

-- The name substitution for an export list is easy to explain.  If we are
-- filling the module variable <m>, given an export N of the form
-- M.n or {m'.n} (where n is an OccName), the induced name
-- substitution is from {m.n} to N.  So, for example, if we have
-- A=impl:B, and the exports of impl:B are impl:B.f and
-- impl:C.g, then our name substitution is {A.f} to impl:B.f
-- and {A.g} to impl:C.g




-- The 'NameShape' type is defined in GHC.Tc.Types, because GHC.Tc.Types
-- needs to refer to NameShape, and having GHC.Tc.Types import
-- NameShape (even by SOURCE) would cause a large number of
-- modules to be pulled into the DynFlags cycle.
{-
data NameShape = NameShape {
        ns_mod_name :: ModuleName,
        ns_exports :: [AvailInfo],
        ns_map :: OccEnv Name
    }
-}

-- NB: substitution functions need 'HscEnv' since they need the name cache
-- to allocate new names if we change the 'Module' of a 'Name'

-- | Create an empty 'NameShape' (i.e., the renaming that
-- would occur with an implementing module with no exports)
-- for a specific hole @mod_name@.
emptyNameShape :: ModuleName -> NameShape
emptyNameShape :: ModuleName -> NameShape
emptyNameShape ModuleName
mod_name = ModuleName -> [AvailInfo] -> OccEnv Name -> NameShape
NameShape ModuleName
mod_name [] OccEnv Name
forall a. OccEnv a
emptyOccEnv

-- | Create a 'NameShape' corresponding to an implementing
-- module for the hole @mod_name@ that exports a list of 'AvailInfo's.
mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
mkNameShape :: ModuleName -> [AvailInfo] -> NameShape
mkNameShape ModuleName
mod_name [AvailInfo]
as =
    ModuleName -> [AvailInfo] -> OccEnv Name -> NameShape
NameShape ModuleName
mod_name [AvailInfo]
as (OccEnv Name -> NameShape) -> OccEnv Name -> NameShape
forall a b. (a -> b) -> a -> b
$ [(OccName, Name)] -> OccEnv Name
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv ([(OccName, Name)] -> OccEnv Name)
-> [(OccName, Name)] -> OccEnv Name
forall a b. (a -> b) -> a -> b
$ do
        a <- [AvailInfo]
as
        n <- availName a : availNames a
        return (occName n, n)

-- | Given an existing 'NameShape', merge it with a list of 'AvailInfo's
-- with Backpack style mix-in linking.  This is used solely when merging
-- signatures together: we successively merge the exports of each
-- signature until we have the final, full exports of the merged signature.
--
-- What makes this operation nontrivial is what we are supposed to do when
-- we want to merge in an export for M.T when we already have an existing
-- export {H.T}.  What should happen in this case is that {H.T} should be
-- unified with @M.T@: we've determined a more *precise* identity for the
-- export at 'OccName' @T@.
--
-- Note that we don't do unrestricted unification: only name holes from
-- @ns_mod_name ns@ are flexible.  This is because we have a much more
-- restricted notion of shaping than in Backpack'14: we do shaping
-- *as* we do type-checking.  Thus, once we shape a signature, its
-- exports are *final* and we're not allowed to refine them further,
extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either HsigShapeMismatchReason NameShape)
extendNameShape :: HscEnv
-> NameShape
-> [AvailInfo]
-> IO (Either HsigShapeMismatchReason NameShape)
extendNameShape HscEnv
hsc_env NameShape
ns [AvailInfo]
as =
    case ModuleName
-> [AvailInfo]
-> [AvailInfo]
-> Either HsigShapeMismatchReason ShNameSubst
uAvailInfos (NameShape -> ModuleName
ns_mod_name NameShape
ns) (NameShape -> [AvailInfo]
ns_exports NameShape
ns) [AvailInfo]
as of
        Left HsigShapeMismatchReason
err -> Either HsigShapeMismatchReason NameShape
-> IO (Either HsigShapeMismatchReason NameShape)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HsigShapeMismatchReason -> Either HsigShapeMismatchReason NameShape
forall a b. a -> Either a b
Left HsigShapeMismatchReason
err)
        Right ShNameSubst
nsubst -> do
            as1 <- (AvailInfo -> IO AvailInfo) -> [AvailInfo] -> IO [AvailInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (IO AvailInfo -> IO AvailInfo
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO AvailInfo -> IO AvailInfo)
-> (AvailInfo -> IO AvailInfo) -> AvailInfo -> IO AvailInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo HscEnv
hsc_env ShNameSubst
nsubst) (NameShape -> [AvailInfo]
ns_exports NameShape
ns)
            as2 <- mapM (liftIO . substNameAvailInfo hsc_env nsubst) as
            let new_avails = [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails [AvailInfo]
as1 [AvailInfo]
as2
            return . Right $ ns {
                ns_exports = new_avails,
                -- TODO: stop repeatedly rebuilding the OccEnv
                ns_map = mkOccEnv $ do
                            a <- new_avails
                            n <- availName a : availNames a
                            return (occName n, n)
                }

-- | The export list associated with this 'NameShape' (i.e., what
-- the exports of an implementing module which induces this 'NameShape'
-- would be.)
nameShapeExports :: NameShape -> [AvailInfo]
nameShapeExports :: NameShape -> [AvailInfo]
nameShapeExports = NameShape -> [AvailInfo]
ns_exports

-- | Given a 'Name', substitute it according to the 'NameShape' implied
-- substitution, i.e. map @{A.T}@ to @M.T@, if the implementing module
-- exports @M.T@.
substNameShape :: NameShape -> Name -> Name
substNameShape :: NameShape -> Name -> Name
substNameShape NameShape
ns Name
n | HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== NameShape -> Module
ns_module NameShape
ns
                    , Just Name
n' <- OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv (NameShape -> OccEnv Name
ns_map NameShape
ns) (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n)
                    = Name
n'
                    | Bool
otherwise
                    = Name
n

-- | Like 'substNameShape', but returns @Nothing@ if no substitution
-- works.
maybeSubstNameShape :: NameShape -> Name -> Maybe Name
maybeSubstNameShape :: NameShape -> Name -> Maybe Name
maybeSubstNameShape NameShape
ns Name
n
    | HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== NameShape -> Module
ns_module NameShape
ns
    = OccEnv Name -> OccName -> Maybe Name
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv (NameShape -> OccEnv Name
ns_map NameShape
ns) (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n)
    | Bool
otherwise
    = Maybe Name
forall a. Maybe a
Nothing

-- | The 'Module' of any 'Name's a 'NameShape' has action over.
ns_module :: NameShape -> Module
ns_module :: NameShape -> Module
ns_module = ModuleName -> Module
forall u. ModuleName -> GenModule (GenUnit u)
mkHoleModule (ModuleName -> Module)
-> (NameShape -> ModuleName) -> NameShape -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameShape -> ModuleName
ns_mod_name

{-
************************************************************************
*                                                                      *
                        Name substitutions
*                                                                      *
************************************************************************
-}

-- | Substitution on @{A.T}@.  We enforce the invariant that the
-- 'nameModule' of keys of this map have 'moduleUnit' @hole@
-- (meaning that if we have a hole substitution, the keys of the map
-- are never affected.)  Alternatively, this is isomorphic to
-- @Map ('ModuleName', 'OccName') 'Name'@.
type ShNameSubst = NameEnv Name

-- NB: In this module, we actually only ever construct 'ShNameSubst'
-- at a single 'ModuleName'.  But 'ShNameSubst' is more convenient to
-- work with.

-- | Substitute names in a 'Name'.
substName :: ShNameSubst -> Name -> Name
substName :: ShNameSubst -> Name -> Name
substName ShNameSubst
env Name
n | Just Name
n' <- ShNameSubst -> Name -> Maybe Name
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ShNameSubst
env Name
n = Name
n'
                | Bool
otherwise                      = Name
n

-- | Substitute names in an 'AvailInfo'.  This has special behavior
-- for type constructors, where it is sufficient to substitute the 'availName'
-- to induce a substitution on 'availNames'.
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo HscEnv
_ ShNameSubst
env (Avail Name
gre) =
    AvailInfo -> IO AvailInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AvailInfo -> IO AvailInfo) -> AvailInfo -> IO AvailInfo
forall a b. (a -> b) -> a -> b
$ Name -> AvailInfo
Avail (ShNameSubst -> Name -> Name
substName ShNameSubst
env Name
gre)
substNameAvailInfo HscEnv
hsc_env ShNameSubst
env (AvailTC Name
n [Name]
ns) =
    let mb_mod :: Maybe Module
mb_mod = (Name -> Module) -> Maybe Name -> Maybe Module
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HasDebugCallStack => Name -> Module
Name -> Module
nameModule (ShNameSubst -> Name -> Maybe Name
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ShNameSubst
env Name
n)
    in Name -> [Name] -> AvailInfo
AvailTC (ShNameSubst -> Name -> Name
substName ShNameSubst
env Name
n) ([Name] -> AvailInfo) -> IO [Name] -> IO AvailInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> IO Name) -> [Name] -> IO [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HscEnv -> Maybe Module -> Name -> IO Name
setName HscEnv
hsc_env Maybe Module
mb_mod) [Name]
ns

setName :: HscEnv -> Maybe Module -> Name -> IO Name
setName :: HscEnv -> Maybe Module -> Name -> IO Name
setName HscEnv
hsc_env Maybe Module
mb_mod Name
nm = HscEnv -> IfG Name -> IO Name
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (Maybe Module -> Name -> IfG Name
forall m n. Maybe Module -> Name -> TcRnIf m n Name
setNameModule Maybe Module
mb_mod Name
nm)

{-
************************************************************************
*                                                                      *
                        AvailInfo merging
*                                                                      *
************************************************************************
-}

-- | Merges to 'AvailInfo' lists together, assuming the 'AvailInfo's have
-- already been unified ('uAvailInfos').
mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails [AvailInfo]
as1 [AvailInfo]
as2 =
    let mkNE :: [AvailInfo] -> NameEnv AvailInfo
mkNE [AvailInfo]
as = [(Name, AvailInfo)] -> NameEnv AvailInfo
forall a. [(Name, a)] -> NameEnv a
mkNameEnv [(AvailInfo -> Name
availName AvailInfo
a, AvailInfo
a) | AvailInfo
a <- [AvailInfo]
as]
    in NameEnv AvailInfo -> [AvailInfo]
forall a. NameEnv a -> [a]
nonDetNameEnvElts ((AvailInfo -> AvailInfo -> AvailInfo)
-> NameEnv AvailInfo -> NameEnv AvailInfo -> NameEnv AvailInfo
forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C AvailInfo -> AvailInfo -> AvailInfo
plusAvail ([AvailInfo] -> NameEnv AvailInfo
mkNE [AvailInfo]
as1) ([AvailInfo] -> NameEnv AvailInfo
mkNE [AvailInfo]
as2))

{-
************************************************************************
*                                                                      *
                        AvailInfo unification
*                                                                      *
************************************************************************
-}

-- | Unify two lists of 'AvailInfo's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either HsigShapeMismatchReason ShNameSubst
uAvailInfos :: ModuleName
-> [AvailInfo]
-> [AvailInfo]
-> Either HsigShapeMismatchReason ShNameSubst
uAvailInfos ModuleName
flexi [AvailInfo]
as1 [AvailInfo]
as2 = -- pprTrace "uAvailInfos" (ppr as1 $$ ppr as2) $
    let mkOE :: [AvailInfo] -> OccEnv AvailInfo
mkOE [AvailInfo]
as = [(OccName, AvailInfo)] -> OccEnv AvailInfo
forall a. [(OccName, a)] -> OccEnv a
mkOccEnv [(Name -> OccName
nameOccName Name
n, AvailInfo
a) | AvailInfo
a <- [AvailInfo]
as, Name
n <- AvailInfo -> [Name]
availNames AvailInfo
a]
    in (ShNameSubst
 -> (AvailInfo, AvailInfo)
 -> Either HsigShapeMismatchReason ShNameSubst)
-> ShNameSubst
-> [(AvailInfo, AvailInfo)]
-> Either HsigShapeMismatchReason ShNameSubst
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ShNameSubst
subst (AvailInfo
a1, AvailInfo
a2) -> ModuleName
-> ShNameSubst
-> AvailInfo
-> AvailInfo
-> Either HsigShapeMismatchReason ShNameSubst
uAvailInfo ModuleName
flexi ShNameSubst
subst AvailInfo
a1 AvailInfo
a2) ShNameSubst
forall a. NameEnv a
emptyNameEnv
             (OccEnv (AvailInfo, AvailInfo) -> [(AvailInfo, AvailInfo)]
forall a. OccEnv a -> [a]
nonDetOccEnvElts (OccEnv (AvailInfo, AvailInfo) -> [(AvailInfo, AvailInfo)])
-> OccEnv (AvailInfo, AvailInfo) -> [(AvailInfo, AvailInfo)]
forall a b. (a -> b) -> a -> b
$ (AvailInfo -> AvailInfo -> (AvailInfo, AvailInfo))
-> OccEnv AvailInfo
-> OccEnv AvailInfo
-> OccEnv (AvailInfo, AvailInfo)
forall a b c. (a -> b -> c) -> OccEnv a -> OccEnv b -> OccEnv c
intersectOccEnv_C (,) ([AvailInfo] -> OccEnv AvailInfo
mkOE [AvailInfo]
as1) ([AvailInfo] -> OccEnv AvailInfo
mkOE [AvailInfo]
as2))
             -- Edward: I have to say, this is pretty clever.

-- | Unify two 'AvailInfo's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
           -> Either HsigShapeMismatchReason ShNameSubst
uAvailInfo :: ModuleName
-> ShNameSubst
-> AvailInfo
-> AvailInfo
-> Either HsigShapeMismatchReason ShNameSubst
uAvailInfo ModuleName
flexi ShNameSubst
subst (Avail Name
n1) (Avail Name
n2)
  = ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
uAvailInfo ModuleName
flexi ShNameSubst
subst (AvailTC Name
n1 [Name]
_) (AvailTC Name
n2 [Name]
_)
  = ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
uAvailInfo ModuleName
_ ShNameSubst
_ AvailInfo
a1 AvailInfo
a2 = HsigShapeMismatchReason
-> Either HsigShapeMismatchReason ShNameSubst
forall a b. a -> Either a b
Left (HsigShapeMismatchReason
 -> Either HsigShapeMismatchReason ShNameSubst)
-> HsigShapeMismatchReason
-> Either HsigShapeMismatchReason ShNameSubst
forall a b. (a -> b) -> a -> b
$ AvailInfo -> AvailInfo -> HsigShapeMismatchReason
HsigShapeSortMismatch AvailInfo
a1 AvailInfo
a2

-- | Unify two 'Name's, given an existing substitution @subst@,
-- with only name holes from @flexi@ unifiable (all other name holes rigid.)
uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either HsigShapeMismatchReason ShNameSubst
uName :: ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
    | Name
n1 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n2      = ShNameSubst -> Either HsigShapeMismatchReason ShNameSubst
forall a b. b -> Either a b
Right ShNameSubst
subst
    | Name -> Bool
isFlexi Name
n1    = ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
    | Name -> Bool
isFlexi Name
n2    = ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
n2 Name
n1
    | Bool
otherwise     = HsigShapeMismatchReason
-> Either HsigShapeMismatchReason ShNameSubst
forall a b. a -> Either a b
Left (Name -> Name -> Bool -> HsigShapeMismatchReason
HsigShapeNotUnifiable Name
n1 Name
n2 (Name -> Bool
isHoleName Name
n1 Bool -> Bool -> Bool
|| Name -> Bool
isHoleName Name
n2))
  where
    isFlexi :: Name -> Bool
isFlexi Name
n = Name -> Bool
isHoleName Name
n Bool -> Bool -> Bool
&& Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n) ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
flexi

-- | Unify a name @h@ which 'isHoleName' with another name, given an existing
-- substitution @subst@, with only name holes from @flexi@ unifiable (all
-- other name holes rigid.)
uHoleName :: ModuleName -> ShNameSubst -> Name {- hole name -} -> Name
          -> Either HsigShapeMismatchReason ShNameSubst
uHoleName :: ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
h Name
n =
    Bool
-> Either HsigShapeMismatchReason ShNameSubst
-> Either HsigShapeMismatchReason ShNameSubst
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isHoleName Name
h) (Either HsigShapeMismatchReason ShNameSubst
 -> Either HsigShapeMismatchReason ShNameSubst)
-> Either HsigShapeMismatchReason ShNameSubst
-> Either HsigShapeMismatchReason ShNameSubst
forall a b. (a -> b) -> a -> b
$
    case ShNameSubst -> Name -> Maybe Name
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ShNameSubst
subst Name
h of
        Just Name
n' -> ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n' Name
n
                -- Do a quick check if the other name is substituted.
        Maybe Name
Nothing | Just Name
n' <- ShNameSubst -> Name -> Maybe Name
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ShNameSubst
subst Name
n ->
                    Bool
-> Either HsigShapeMismatchReason ShNameSubst
-> Either HsigShapeMismatchReason ShNameSubst
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isHoleName Name
n) (Either HsigShapeMismatchReason ShNameSubst
 -> Either HsigShapeMismatchReason ShNameSubst)
-> Either HsigShapeMismatchReason ShNameSubst
-> Either HsigShapeMismatchReason ShNameSubst
forall a b. (a -> b) -> a -> b
$ ModuleName
-> ShNameSubst
-> Name
-> Name
-> Either HsigShapeMismatchReason ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
h Name
n'
                | Bool
otherwise ->
                    ShNameSubst -> Either HsigShapeMismatchReason ShNameSubst
forall a b. b -> Either a b
Right (ShNameSubst -> Name -> Name -> ShNameSubst
forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv ShNameSubst
subst Name
h Name
n)