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.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.Panic.Plain
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 a. a -> [a]
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 a. a -> IO a
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)
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)
[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)
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) [AvailInfo]
as
let new_avails :: [AvailInfo]
new_avails = [AvailInfo] -> [AvailInfo] -> [AvailInfo]
mergeAvails [AvailInfo]
as1 [AvailInfo]
as2
Either SDoc NameShape -> IO (Either SDoc NameShape)
forall a. a -> IO a
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 = new_avails,
ns_map = mkOccEnv $ do
a <- new_avails
n <- availName a : availNames a
return (occName n, 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 | (() :: Constraint) => 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
| (() :: Constraint) => 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 a. a -> IO a
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GreName -> AvailInfo
Avail (FieldLabel -> GreName
FieldGreName FieldLabel
fl { flSelector = substName env (flSelector 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 a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() :: Constraint) => 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 a. a -> IO a
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 a. a -> IO a
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]
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))
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 a. a -> [a]
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]
nonDetEltsUFM ((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
forall doc. IsLine doc => String -> doc
text String
"While merging export lists, could not combine"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> AvailInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr AvailInfo
a1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> AvailInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr AvailInfo
a2
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
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
forall doc. IsLine doc => String -> doc
text String
"While merging export lists, could not unify"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n1 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"with" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n2 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ 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 ((() :: Constraint) => 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
forall doc. IsLine doc => String -> doc
text String
"Neither name variable originates from the current signature."
| Bool
otherwise
= SDoc
forall doc. IsOutput doc => doc
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 =
Bool -> Either SDoc ShNameSubst -> Either SDoc ShNameSubst
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isHoleName Name
h) (Either SDoc ShNameSubst -> Either SDoc ShNameSubst)
-> Either SDoc ShNameSubst -> Either SDoc 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 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 ->
Bool -> Either SDoc ShNameSubst -> Either SDoc ShNameSubst
forall a. HasCallStack => Bool -> a -> a
assert (Name -> Bool
isHoleName Name
n) (Either SDoc ShNameSubst -> Either SDoc ShNameSubst)
-> Either SDoc ShNameSubst -> Either SDoc ShNameSubst
forall a b. (a -> b) -> a -> b
$ ModuleName
-> ShNameSubst -> Name -> Name -> Either SDoc ShNameSubst
uName ModuleName
flexi ShNameSubst
subst Name
h Name
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)