{-# LANGUAGE CPP #-}
module GHC.Types.Name.Shape
( NameShape(..)
, emptyNameShape
, mkNameShape
, extendNameShape
, nameShapeExports
, substNameShape
, maybeSubstNameShape
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Env
import GHC.Unit.Module
import GHC.Types.Unique.FM
import GHC.Types.Avail
import GHC.Types.FieldLabel
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Tc.Utils.Monad
import GHC.Iface.Env
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import Control.Monad
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
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
AvailInfo
a <- [AvailInfo]
as
Name
n <- AvailInfo -> Name
availName AvailInfo
a Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: AvailInfo -> [Name]
availNamesWithSelectors AvailInfo
a
(OccName, Name) -> [(OccName, Name)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n, Name
n)
extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
extendNameShape :: HscEnv -> NameShape -> [AvailInfo] -> IO (Either SDoc NameShape)
extendNameShape HscEnv
hsc_env NameShape
ns [AvailInfo]
as =
case ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
uAvailInfos (NameShape -> ModuleName
ns_mod_name NameShape
ns) (NameShape -> [AvailInfo]
ns_exports NameShape
ns) [AvailInfo]
as of
Left SDoc
err -> Either SDoc NameShape -> IO (Either SDoc NameShape)
forall (m :: * -> *) a. Monad m => a -> m a
return (SDoc -> Either SDoc NameShape
forall a b. a -> Either a b
Left SDoc
err)
Right ShNameSubst
nsubst -> do
[AvailInfo]
as1 <- (AvailInfo -> IO AvailInfo) -> [AvailInfo] -> IO [AvailInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO AvailInfo -> IO AvailInfo
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)
[AvailInfo]
as2 <- (AvailInfo -> IO AvailInfo) -> [AvailInfo] -> IO [AvailInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (IO AvailInfo -> IO AvailInfo
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) [AvailInfo]
as
let new_avails :: [AvailInfo]
new_avails = [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails [AvailInfo]
as1 [AvailInfo]
as2
Either SDoc NameShape -> IO (Either SDoc NameShape)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SDoc NameShape -> IO (Either SDoc NameShape))
-> (NameShape -> Either SDoc NameShape)
-> NameShape
-> IO (Either SDoc NameShape)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameShape -> Either SDoc NameShape
forall a b. b -> Either a b
Right (NameShape -> IO (Either SDoc NameShape))
-> NameShape -> IO (Either SDoc NameShape)
forall a b. (a -> b) -> a -> b
$ NameShape
ns {
ns_exports :: [AvailInfo]
ns_exports = [AvailInfo]
new_avails,
ns_map :: OccEnv Name
ns_map = [(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
AvailInfo
a <- [AvailInfo]
new_avails
Name
n <- AvailInfo -> Name
availName AvailInfo
a Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: AvailInfo -> [Name]
availNames AvailInfo
a
(OccName, Name) -> [(OccName, Name)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> OccName
forall name. HasOccName name => name -> OccName
occName Name
n, Name
n)
}
nameShapeExports :: NameShape -> [AvailInfo]
nameShapeExports :: NameShape -> [AvailInfo]
nameShapeExports = NameShape -> [AvailInfo]
ns_exports
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
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
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
type ShNameSubst = NameEnv 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
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo
substNameAvailInfo HscEnv
_ ShNameSubst
env (Avail (NormalGreName Name
n)) = AvailInfo -> IO AvailInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (GreName -> AvailInfo
Avail (Name -> GreName
NormalGreName (ShNameSubst -> Name -> Name
substName ShNameSubst
env Name
n)))
substNameAvailInfo HscEnv
_ ShNameSubst
env (Avail (FieldGreName FieldLabel
fl)) =
AvailInfo -> IO AvailInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (GreName -> AvailInfo
Avail (FieldLabel -> GreName
FieldGreName FieldLabel
fl { flSelector :: Name
flSelector = ShNameSubst -> Name -> Name
substName ShNameSubst
env (FieldLabel -> Name
flSelector FieldLabel
fl) }))
substNameAvailInfo HscEnv
hsc_env ShNameSubst
env (AvailTC Name
n [GreName]
ns) =
let mb_mod :: Maybe Module
mb_mod = (Name -> Module) -> Maybe Name -> Maybe Module
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 -> [GreName] -> AvailInfo
AvailTC (ShNameSubst -> Name -> Name
substName ShNameSubst
env Name
n) ([GreName] -> AvailInfo) -> IO [GreName] -> IO AvailInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (GreName -> IO GreName) -> [GreName] -> IO [GreName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HscEnv -> Maybe Module -> GreName -> IO GreName
setNameGreName HscEnv
hsc_env Maybe Module
mb_mod) [GreName]
ns
setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName
setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName
setNameGreName HscEnv
hsc_env Maybe Module
mb_mod GreName
gname = case GreName
gname of
NormalGreName Name
n -> Name -> GreName
NormalGreName (Name -> GreName) -> IO Name -> IO GreName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
n)
FieldGreName FieldLabel
fl -> FieldLabel -> GreName
FieldGreName (FieldLabel -> GreName) -> IO FieldLabel -> IO GreName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
setNameFieldSelector HscEnv
hsc_env Maybe Module
mb_mod FieldLabel
fl
setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel
setNameFieldSelector HscEnv
_ Maybe Module
Nothing FieldLabel
f = FieldLabel -> IO FieldLabel
forall (m :: * -> *) a. Monad m => a -> m a
return FieldLabel
f
setNameFieldSelector HscEnv
hsc_env Maybe Module
mb_mod (FieldLabel FieldLabelString
l DuplicateRecordFields
b FieldSelectors
has_sel Name
sel) = do
Name
sel' <- HscEnv -> IfG Name -> IO Name
forall a. HscEnv -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (IfG Name -> IO Name) -> IfG Name -> IO Name
forall a b. (a -> b) -> a -> b
$ Maybe Module -> Name -> IfG Name
forall m n. Maybe Module -> Name -> TcRnIf m n Name
setNameModule Maybe Module
mb_mod Name
sel
FieldLabel -> IO FieldLabel
forall (m :: * -> *) a. Monad m => a -> m a
return (FieldLabelString
-> DuplicateRecordFields -> FieldSelectors -> Name -> FieldLabel
FieldLabel FieldLabelString
l DuplicateRecordFields
b FieldSelectors
has_sel Name
sel')
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]
nameEnvElts ((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))
uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
uAvailInfos :: ModuleName -> [AvailInfo] -> [AvailInfo] -> Either SDoc ShNameSubst
uAvailInfos ModuleName
flexi [AvailInfo]
as1 [AvailInfo]
as2 =
let mkOE :: [AvailInfo] -> UniqFM OccName AvailInfo
mkOE [AvailInfo]
as = [(OccName, AvailInfo)] -> UniqFM OccName AvailInfo
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM ([(OccName, AvailInfo)] -> UniqFM OccName AvailInfo)
-> [(OccName, AvailInfo)] -> UniqFM OccName AvailInfo
forall a b. (a -> b) -> a -> b
$ do AvailInfo
a <- [AvailInfo]
as
Name
n <- AvailInfo -> [Name]
availNames AvailInfo
a
(OccName, AvailInfo) -> [(OccName, AvailInfo)]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> OccName
nameOccName Name
n, AvailInfo
a)
in (ShNameSubst -> (AvailInfo, AvailInfo) -> Either SDoc ShNameSubst)
-> ShNameSubst
-> [(AvailInfo, AvailInfo)]
-> Either SDoc 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 SDoc ShNameSubst
uAvailInfo ModuleName
flexi ShNameSubst
subst AvailInfo
a1 AvailInfo
a2) ShNameSubst
forall a. NameEnv a
emptyNameEnv
(UniqFM OccName (AvailInfo, AvailInfo) -> [(AvailInfo, AvailInfo)]
forall key elt. UniqFM key elt -> [elt]
eltsUFM ((AvailInfo -> AvailInfo -> (AvailInfo, AvailInfo))
-> UniqFM OccName AvailInfo
-> UniqFM OccName AvailInfo
-> UniqFM OccName (AvailInfo, AvailInfo)
forall elt1 elt2 elt3 key.
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C (,) ([AvailInfo] -> UniqFM OccName AvailInfo
mkOE [AvailInfo]
as1) ([AvailInfo] -> UniqFM OccName AvailInfo
mkOE [AvailInfo]
as2)))
uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo
-> Either SDoc ShNameSubst
uAvailInfo :: ModuleName
-> ShNameSubst -> AvailInfo -> AvailInfo -> Either SDoc ShNameSubst
uAvailInfo ModuleName
flexi ShNameSubst
subst (Avail (NormalGreName Name
n1)) (Avail (NormalGreName Name
n2)) = ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
uAvailInfo ModuleName
flexi ShNameSubst
subst (AvailTC Name
n1 [GreName]
_) (AvailTC Name
n2 [GreName]
_) = ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
uAvailInfo ModuleName
_ ShNameSubst
_ AvailInfo
a1 AvailInfo
a2 = SDoc -> Either SDoc ShNameSubst
forall a b. a -> Either a b
Left (SDoc -> Either SDoc ShNameSubst)
-> SDoc -> Either SDoc ShNameSubst
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"While merging export lists, could not combine"
SDoc -> SDoc -> SDoc
<+> AvailInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr AvailInfo
a1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> AvailInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr AvailInfo
a2
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text String
"one is a type, the other is a plain identifier")
uName :: ModuleName -> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uName :: ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc 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 SDoc ShNameSubst
forall a b. b -> Either a b
Right ShNameSubst
subst
| Name -> Bool
isFlexi Name
n1 = ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
n1 Name
n2
| Name -> Bool
isFlexi Name
n2 = ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
n2 Name
n1
| Bool
otherwise = SDoc -> Either SDoc ShNameSubst
forall a b. a -> Either a b
Left (String -> SDoc
text String
"While merging export lists, could not unify"
SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1 SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2 SDoc -> SDoc -> SDoc
$$ SDoc
extra)
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
extra :: SDoc
extra | Name -> Bool
isHoleName Name
n1 Bool -> Bool -> Bool
|| Name -> Bool
isHoleName Name
n2
= String -> SDoc
text String
"Neither name variable originates from the current signature."
| Bool
otherwise
= SDoc
empty
uHoleName :: ModuleName -> ShNameSubst -> Name -> Name
-> Either SDoc ShNameSubst
uHoleName :: ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uHoleName ModuleName
flexi ShNameSubst
subst Name
h Name
n =
ASSERT( isHoleName h )
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 SDoc ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
n' Name
n
Maybe Name
Nothing | Just Name
n' <- ShNameSubst -> Name -> Maybe Name
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv ShNameSubst
subst Name
n ->
ASSERT( isHoleName n ) uName flexi subst h n'
| Bool
otherwise ->
ShNameSubst -> Either SDoc 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)