-- |
-- Module      :  Cryptol.ModuleSystem.NamingEnv
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RecordWildCards #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.ModuleSystem.NamingEnv
  ( module Cryptol.ModuleSystem.NamingEnv.Types
  , module Cryptol.ModuleSystem.NamingEnv
  ) where

import Data.Maybe (mapMaybe,maybeToList)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Foldable(foldl')

import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Ident(allNamespaces)
import Cryptol.Parser.AST
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.Names
import Cryptol.ModuleSystem.Interface

import Cryptol.ModuleSystem.NamingEnv.Types


{- | This "joins" two naming environments by matching the text name.
The result maps the unique names from the first environment with the
matching names in the second.  This is used to compute the naming for
an instantiated functor:
  * if the left environment has the defined names of the functor, and
  * the right one has the defined names of the instantiation, then
  * the result maps functor names to instance names.
-}
zipByTextName :: NamingEnv -> NamingEnv -> Map Name Name
zipByTextName :: NamingEnv -> NamingEnv -> Map Name Name
zipByTextName (NamingEnv Map Namespace (Map PName Names)
k) (NamingEnv Map Namespace (Map PName Names)
v) = [(Name, Name)] -> Map Name Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Name, Name)] -> Map Name Name)
-> [(Name, Name)] -> Map Name Name
forall a b. (a -> b) -> a -> b
$ (Map PName Names -> Map PName Names -> [(Name, Name)])
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
-> [(Name, Name)]
forall k a b c.
Ord k =>
(a -> b -> [c]) -> Map k a -> Map k b -> [c]
doInter Map PName Names -> Map PName Names -> [(Name, Name)]
doNS Map Namespace (Map PName Names)
k Map Namespace (Map PName Names)
v
  where
  doInter :: Ord k => (a -> b -> [c]) -> Map k a -> Map k b -> [c]
  doInter :: forall k a b c.
Ord k =>
(a -> b -> [c]) -> Map k a -> Map k b -> [c]
doInter a -> b -> [c]
f Map k a
a Map k b
b = [[c]] -> [c]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Map k [c] -> [[c]]
forall k a. Map k a -> [a]
Map.elems ((a -> b -> [c]) -> Map k a -> Map k b -> Map k [c]
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith a -> b -> [c]
f Map k a
a Map k b
b))

  doNS :: Map PName Names -> Map PName Names -> [(Name,Name)]
  doNS :: Map PName Names -> Map PName Names -> [(Name, Name)]
doNS Map PName Names
as Map PName Names
bs = (Names -> Names -> [(Name, Name)])
-> Map PName Names -> Map PName Names -> [(Name, Name)]
forall k a b c.
Ord k =>
(a -> b -> [c]) -> Map k a -> Map k b -> [c]
doInter Names -> Names -> [(Name, Name)]
doPName Map PName Names
as Map PName Names
bs

  doPName :: Names -> Names -> [(Name,Name)]
  doPName :: Names -> Names -> [(Name, Name)]
doPName Names
xs Names
ys = [ (Name
x,Name
y) | Name
x <- Names -> [Name]
namesToList Names
xs, Name
y <- Names -> [Name]
namesToList Names
ys ]
  -- NOTE: we'd exepct that there are no ambiguities in the environments.

-- | Keep only the bindings in the 1st environment that are *NOT* in the second.
without :: NamingEnv -> NamingEnv -> NamingEnv
NamingEnv Map Namespace (Map PName Names)
keep without :: NamingEnv -> NamingEnv -> NamingEnv
`without` NamingEnv Map Namespace (Map PName Names)
remove = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv Map Namespace (Map PName Names)
result
  where
  result :: Map Namespace (Map PName Names)
result     = (Map PName Names -> Map PName Names -> Maybe (Map PName Names))
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith Map PName Names -> Map PName Names -> Maybe (Map PName Names)
forall {k}.
Ord k =>
Map k Names -> Map k Names -> Maybe (Map k Names)
rmInNS Map Namespace (Map PName Names)
keep Map Namespace (Map PName Names)
remove
  rmInNS :: Map k Names -> Map k Names -> Maybe (Map k Names)
rmInNS Map k Names
a Map k Names
b = let c :: Map k Names
c = (Names -> Names -> Maybe Names)
-> Map k Names -> Map k Names -> Map k Names
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith Names -> Names -> Maybe Names
diffNames Map k Names
a Map k Names
b
               in if Map k Names -> Bool
forall k a. Map k a -> Bool
Map.null Map k Names
c then Maybe (Map k Names)
forall a. Maybe a
Nothing else Map k Names -> Maybe (Map k Names)
forall a. a -> Maybe a
Just Map k Names
c

-- | All names mentioned in the environment
namingEnvNames :: NamingEnv -> Set Name
namingEnvNames :: NamingEnv -> Set Name
namingEnvNames (NamingEnv Map Namespace (Map PName Names)
xs) =
  case [Names] -> Maybe Names
unionManyNames ((Map PName Names -> Maybe Names) -> [Map PName Names] -> [Names]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Names] -> Maybe Names
unionManyNames ([Names] -> Maybe Names)
-> (Map PName Names -> [Names]) -> Map PName Names -> Maybe Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PName Names -> [Names]
forall k a. Map k a -> [a]
Map.elems) (Map Namespace (Map PName Names) -> [Map PName Names]
forall k a. Map k a -> [a]
Map.elems Map Namespace (Map PName Names)
xs)) of
    Maybe Names
Nothing -> Set Name
forall a. Set a
Set.empty
    Just (One Name
x) -> Name -> Set Name
forall a. a -> Set a
Set.singleton Name
x
    Just (Ambig Set Name
as) -> Set Name
as

-- | Get a naming environment for the given names.  The `PName`s correspond
-- to the definition sites of the corresponding `Name`s, so typically they
-- will be unqualified.  The exception is for names that comre from parameters,
-- which are qualified with the relevant parameter.
namingEnvFromNames :: Set Name -> NamingEnv
namingEnvFromNames :: Set Name -> NamingEnv
namingEnvFromNames Set Name
xs = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Map Namespace (Map PName Names)
 -> Name -> Map Namespace (Map PName Names))
-> Map Namespace (Map PName Names)
-> Set Name
-> Map Namespace (Map PName Names)
forall b a. (b -> a -> b) -> b -> Set a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Namespace (Map PName Names)
-> Name -> Map Namespace (Map PName Names)
add Map Namespace (Map PName Names)
forall a. Monoid a => a
mempty Set Name
xs)
  where
  add :: Map Namespace (Map PName Names)
-> Name -> Map Namespace (Map PName Names)
add Map Namespace (Map PName Names)
mp Name
x = let ns :: Namespace
ns = Name -> Namespace
nameNamespace Name
x
             in (Map PName Names -> Map PName Names -> Map PName Names)
-> Namespace
-> Map PName Names
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((Names -> Names -> Names)
-> Map PName Names -> Map PName Names -> Map PName Names
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Names -> Names -> Names
forall a. Semigroup a => a -> a -> a
(<>))
                               Namespace
ns (PName -> Names -> Map PName Names
forall k a. k -> a -> Map k a
Map.singleton (Name -> PName
nameToDefPName Name
x) (Name -> Names
One Name
x))
                               Map Namespace (Map PName Names)
mp


-- | Get the names in a given namespace
namespaceMap :: Namespace -> NamingEnv -> Map PName Names
namespaceMap :: Namespace -> NamingEnv -> Map PName Names
namespaceMap Namespace
ns (NamingEnv Map Namespace (Map PName Names)
env) = Map PName Names
-> Namespace -> Map Namespace (Map PName Names) -> Map PName Names
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Map PName Names
forall k a. Map k a
Map.empty Namespace
ns Map Namespace (Map PName Names)
env

-- | Resolve a name in the given namespace.
lookupNS :: Namespace -> PName -> NamingEnv -> Maybe Names
lookupNS :: Namespace -> PName -> NamingEnv -> Maybe Names
lookupNS Namespace
ns PName
x NamingEnv
env = PName -> Map PName Names -> Maybe Names
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PName
x (Namespace -> NamingEnv -> Map PName Names
namespaceMap Namespace
ns NamingEnv
env)

-- | Resolve a name in the given namespace.
lookupListNS :: Namespace -> PName -> NamingEnv -> [Name]
lookupListNS :: Namespace -> PName -> NamingEnv -> [Name]
lookupListNS Namespace
ns PName
x NamingEnv
env =
  case Namespace -> PName -> NamingEnv -> Maybe Names
lookupNS Namespace
ns PName
x NamingEnv
env of
    Maybe Names
Nothing -> []
    Just Names
as -> Names -> [Name]
namesToList Names
as

-- | Singleton renaming environment for the given namespace.
singletonNS :: Namespace -> PName -> Name -> NamingEnv
singletonNS :: Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
ns PName
pn Name
n = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (Namespace -> Map PName Names -> Map Namespace (Map PName Names)
forall k a. k -> a -> Map k a
Map.singleton Namespace
ns (PName -> Names -> Map PName Names
forall k a. k -> a -> Map k a
Map.singleton PName
pn (Name -> Names
One Name
n)))

-- | Generate a mapping from 'PrimIdent' to 'Name' for a
-- given naming environment.
toPrimMap :: NamingEnv -> PrimMap
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv
env =
  PrimMap
    { primDecls :: Map PrimIdent Name
primDecls = Namespace -> Map PrimIdent Name
fromNS Namespace
NSValue
    , primTypes :: Map PrimIdent Name
primTypes = Namespace -> Map PrimIdent Name
fromNS Namespace
NSType
    }
  where
  fromNS :: Namespace -> Map PrimIdent Name
fromNS Namespace
ns = [(PrimIdent, Name)] -> Map PrimIdent Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ Name -> (PrimIdent, Name)
entry Name
x | Names
xs <- Map PName Names -> [Names]
forall k a. Map k a -> [a]
Map.elems (Namespace -> NamingEnv -> Map PName Names
namespaceMap Namespace
ns NamingEnv
env)
                          , Name
x <- Names -> [Name]
namesToList Names
xs ]

  entry :: Name -> (PrimIdent, Name)
entry Name
n = case Name -> Maybe PrimIdent
asPrim Name
n of
              Just PrimIdent
p  -> (PrimIdent
p,Name
n)
              Maybe PrimIdent
Nothing -> String -> [String] -> (PrimIdent, Name)
forall a. HasCallStack => String -> [String] -> a
panic String
"toPrimMap" [ String
"Not a declared name?"
                                           , Name -> String
forall a. Show a => a -> String
show Name
n
                                           ]


-- | Generate a display format based on a naming environment.
toNameDisp :: NamingEnv -> NameDisp
toNameDisp :: NamingEnv -> NameDisp
toNameDisp NamingEnv
env = (OrigName -> Maybe NameFormat) -> NameDisp
NameDisp (OrigName -> Map OrigName NameFormat -> Maybe NameFormat
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map OrigName NameFormat
names)
  where
  names :: Map OrigName NameFormat
names = [(OrigName, NameFormat)] -> Map OrigName NameFormat
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (OrigName
og, NameFormat
qn)
              | Namespace
ns            <- [Namespace]
allNamespaces
              , (PName
pn,Names
xs)       <- Map PName Names -> [(PName, Names)]
forall k a. Map k a -> [(k, a)]
Map.toList (Namespace -> NamingEnv -> Map PName Names
namespaceMap Namespace
ns NamingEnv
env)
              , Name
x             <- Names -> [Name]
namesToList Names
xs
              , OrigName
og            <- Maybe OrigName -> [OrigName]
forall a. Maybe a -> [a]
maybeToList (Name -> Maybe OrigName
asOrigName Name
x)
              , let qn :: NameFormat
qn = case PName -> Maybe ModName
getModName PName
pn of
                          Just ModName
q  -> ModName -> NameFormat
Qualified ModName
q
                          Maybe ModName
Nothing -> NameFormat
UnQualified
            ]


-- | Produce sets of visible names for types and declarations.
--
-- NOTE: if entries in the NamingEnv would have produced a name clash,
-- they will be omitted from the resulting sets.
visibleNames :: NamingEnv -> Map Namespace (Set Name)
visibleNames :: NamingEnv -> Map Namespace (Set Name)
visibleNames (NamingEnv Map Namespace (Map PName Names)
env) = Map PName Names -> Set Name
forall {k}. Map k Names -> Set Name
check (Map PName Names -> Set Name)
-> Map Namespace (Map PName Names) -> Map Namespace (Set Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName Names)
env
  where check :: Map k Names -> Set Name
check Map k Names
mp = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [ Name
a | One Name
a <- Map k Names -> [Names]
forall k a. Map k a -> [a]
Map.elems Map k Names
mp ]

-- | Qualify all symbols in a 'NamingEnv' with the given prefix.
qualify :: ModName -> NamingEnv -> NamingEnv
qualify :: ModName -> NamingEnv -> NamingEnv
qualify ModName
pfx (NamingEnv Map Namespace (Map PName Names)
env) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((PName -> PName) -> Map PName Names -> Map PName Names
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PName -> PName
toQual (Map PName Names -> Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName Names)
env)
  where
  -- We don't qualify fresh names, because they should not be directly
  -- visible to the end users (i.e., they shouldn't really be exported)
  toQual :: PName -> PName
toQual (Qual ModName
_ Ident
n)  = ModName -> Ident -> PName
Qual ModName
pfx Ident
n
  toQual (UnQual Ident
n)  = ModName -> Ident -> PName
Qual ModName
pfx Ident
n
  toQual n :: PName
n@NewName{} = PName
n

filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterPNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterPNames PName -> Bool
p (NamingEnv Map Namespace (Map PName Names)
env) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Map PName Names -> Maybe (Map PName Names))
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Map PName Names -> Maybe (Map PName Names)
forall {a}. Map PName a -> Maybe (Map PName a)
checkNS Map Namespace (Map PName Names)
env)
  where
  checkNS :: Map PName a -> Maybe (Map PName a)
checkNS Map PName a
nsMap = let new :: Map PName a
new = (PName -> a -> Bool) -> Map PName a -> Map PName a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (\PName
n a
_ -> PName -> Bool
p PName
n) Map PName a
nsMap
                  in if Map PName a -> Bool
forall k a. Map k a -> Bool
Map.null Map PName a
new then Maybe (Map PName a)
forall a. Maybe a
Nothing else Map PName a -> Maybe (Map PName a)
forall a. a -> Maybe a
Just Map PName a
new

filterUNames :: (Name -> Bool) -> NamingEnv -> NamingEnv
filterUNames :: (Name -> Bool) -> NamingEnv -> NamingEnv
filterUNames Name -> Bool
p (NamingEnv Map Namespace (Map PName Names)
env) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Map PName Names -> Maybe (Map PName Names))
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Map PName Names -> Maybe (Map PName Names)
forall {k}. Map k Names -> Maybe (Map k Names)
check Map Namespace (Map PName Names)
env)
  where
  check :: Map k Names -> Maybe (Map k Names)
check Map k Names
nsMap = let new :: Map k Names
new = (Names -> Maybe Names) -> Map k Names -> Map k Names
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe ((Name -> Bool) -> Names -> Maybe Names
filterNames Name -> Bool
p) Map k Names
nsMap
                in if Map k Names -> Bool
forall k a. Map k a -> Bool
Map.null Map k Names
new then Maybe (Map k Names)
forall a. Maybe a
Nothing else Map k Names -> Maybe (Map k Names)
forall a. a -> Maybe a
Just Map k Names
new


-- | Find the ambiguous entries in an environmet.
-- A name is ambiguous if it might refer to multiple entities.
findAmbig :: NamingEnv -> [ [Name] ]
findAmbig :: NamingEnv -> [[Name]]
findAmbig NamingEnv
env =
  [ Set Name -> [Name]
forall a. Set a -> [a]
Set.toList Set Name
xs
  | Map PName Names
mp <- Map Namespace (Map PName Names) -> [Map PName Names]
forall k a. Map k a -> [a]
Map.elems Map Namespace (Map PName Names)
ns
  , Ambig Set Name
xs <- Map PName Names -> [Names]
forall k a. Map k a -> [a]
Map.elems Map PName Names
mp
  ]
  where
  NamingEnv Map Namespace (Map PName Names)
ns = NamingEnv -> NamingEnv
consToValues NamingEnv
env

-- | Get the subset of the first environment that shadows something
-- in the second one.
findShadowing :: NamingEnv -> NamingEnv -> [ (PName,Name,[Name]) ]
findShadowing :: NamingEnv -> NamingEnv -> [(PName, Name, [Name])]
findShadowing (NamingEnv Map Namespace (Map PName Names)
lhs) NamingEnv
rhs =
  [ (PName
p, Names -> Name
anyOne Names
xs, Names -> [Name]
namesToList Names
ys)
  | (Namespace
ns,Map PName Names
mp) <- Map Namespace (Map PName Names) -> [(Namespace, Map PName Names)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Namespace (Map PName Names)
lhs
  , (PName
p,Names
xs) <- Map PName Names -> [(PName, Names)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName Names
mp
  , Just Names
ys <- [ Namespace -> PName -> NamingEnv -> Maybe Names
lookupNS Namespace
ns PName
p NamingEnv
rhs ]
  ]

-- | Do an arbitrary choice for ambiguous names.
-- We do this to continue checking afetr we've reported an ambiguity error.
forceUnambig :: NamingEnv -> NamingEnv
forceUnambig :: NamingEnv -> NamingEnv
forceUnambig (NamingEnv Map Namespace (Map PName Names)
mp) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Names -> Names) -> Map PName Names -> Map PName Names
forall a b. (a -> b) -> Map PName a -> Map PName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Names
One (Name -> Names) -> (Names -> Name) -> Names -> Names
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> Name
anyOne) (Map PName Names -> Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName Names)
mp)

-- | Like mappend, but when merging, prefer values on the lhs.
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing (NamingEnv Map Namespace (Map PName Names)
l) (NamingEnv Map Namespace (Map PName Names)
r) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Map PName Names -> Map PName Names -> Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Map PName Names -> Map PName Names -> Map PName Names
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Namespace (Map PName Names)
l Map Namespace (Map PName Names)
r)

mapNamingEnv :: (Name -> Name) -> NamingEnv -> NamingEnv
mapNamingEnv :: (Name -> Name) -> NamingEnv -> NamingEnv
mapNamingEnv Name -> Name
f (NamingEnv Map Namespace (Map PName Names)
mp) = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv ((Names -> Names) -> Map PName Names -> Map PName Names
forall a b. (a -> b) -> Map PName a -> Map PName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Name) -> Names -> Names
mapNames Name -> Name
f) (Map PName Names -> Map PName Names)
-> Map Namespace (Map PName Names)
-> Map Namespace (Map PName Names)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName Names)
mp)

travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv :: forall (f :: * -> *).
Applicative f =>
(Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv Name -> f Name
f (NamingEnv Map Namespace (Map PName Names)
mp) =
  Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (Map Namespace (Map PName Names) -> NamingEnv)
-> f (Map Namespace (Map PName Names)) -> f NamingEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map PName Names -> f (Map PName Names))
-> Map Namespace (Map PName Names)
-> f (Map Namespace (Map PName Names))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map Namespace a -> f (Map Namespace b)
traverse ((Names -> f Names) -> Map PName Names -> f (Map PName Names)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Map PName a -> f (Map PName b)
traverse ((Name -> f Name) -> Names -> f Names
forall (f :: * -> *).
Applicative f =>
(Name -> f Name) -> Names -> f Names
travNames Name -> f Name
f)) Map Namespace (Map PName Names)
mp

isEmptyNamingEnv :: NamingEnv -> Bool
isEmptyNamingEnv :: NamingEnv -> Bool
isEmptyNamingEnv (NamingEnv Map Namespace (Map PName Names)
mp) = Map Namespace (Map PName Names) -> Bool
forall k a. Map k a -> Bool
Map.null Map Namespace (Map PName Names)
mp
-- This assumes that we've been normalizing away empty maps, hopefully
-- we've been doing it everywhere.


-- | Compute an unqualified naming environment, containing the various module
-- parameters.
modParamNamesNamingEnv :: T.ModParamNames -> NamingEnv
modParamNamesNamingEnv :: ModParamNames -> NamingEnv
modParamNamesNamingEnv T.ModParamNames { [Located Prop]
Maybe Text
Map Name TySyn
Map Name ModVParam
Map Name ModTParam
mpnTypes :: Map Name ModTParam
mpnTySyn :: Map Name TySyn
mpnConstraints :: [Located Prop]
mpnFuns :: Map Name ModVParam
mpnDoc :: Maybe Text
mpnTypes :: ModParamNames -> Map Name ModTParam
mpnTySyn :: ModParamNames -> Map Name TySyn
mpnConstraints :: ModParamNames -> [Located Prop]
mpnFuns :: ModParamNames -> Map Name ModVParam
mpnDoc :: ModParamNames -> Maybe Text
.. } =
  Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (Map Namespace (Map PName Names) -> NamingEnv)
-> Map Namespace (Map PName Names) -> NamingEnv
forall a b. (a -> b) -> a -> b
$ [(Namespace, Map PName Names)] -> Map Namespace (Map PName Names)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Namespace
NSValue, [(PName, Names)] -> Map PName Names
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PName, Names)] -> Map PName Names)
-> [(PName, Names)] -> Map PName Names
forall a b. (a -> b) -> a -> b
$ (Name -> (PName, Names)) -> [Name] -> [(PName, Names)]
forall a b. (a -> b) -> [a] -> [b]
map Name -> (PName, Names)
fromFu ([Name] -> [(PName, Names)]) -> [Name] -> [(PName, Names)]
forall a b. (a -> b) -> a -> b
$ Map Name ModVParam -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name ModVParam
mpnFuns)
    , (Namespace
NSType,  [(PName, Names)] -> Map PName Names
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PName, Names)] -> Map PName Names)
-> [(PName, Names)] -> Map PName Names
forall a b. (a -> b) -> a -> b
$ (TySyn -> (PName, Names)) -> [TySyn] -> [(PName, Names)]
forall a b. (a -> b) -> [a] -> [b]
map TySyn -> (PName, Names)
fromTS (Map Name TySyn -> [TySyn]
forall k a. Map k a -> [a]
Map.elems Map Name TySyn
mpnTySyn) [(PName, Names)] -> [(PName, Names)] -> [(PName, Names)]
forall a. [a] -> [a] -> [a]
++
                               (ModTParam -> (PName, Names)) -> [ModTParam] -> [(PName, Names)]
forall a b. (a -> b) -> [a] -> [b]
map ModTParam -> (PName, Names)
fromTy (Map Name ModTParam -> [ModTParam]
forall k a. Map k a -> [a]
Map.elems Map Name ModTParam
mpnTypes))
    ]
  where
  toPName :: Name -> PName
toPName Name
n = Ident -> PName
mkUnqual (Name -> Ident
nameIdent Name
n)

  fromTy :: ModTParam -> (PName, Names)
fromTy ModTParam
tp = let nm :: Name
nm = ModTParam -> Name
T.mtpName ModTParam
tp
              in (Name -> PName
toPName Name
nm, Name -> Names
One Name
nm)

  fromFu :: Name -> (PName, Names)
fromFu Name
f  = (Name -> PName
toPName Name
f, Name -> Names
One Name
f)

  fromTS :: TySyn -> (PName, Names)
fromTS TySyn
ts = (Name -> PName
toPName (TySyn -> Name
T.tsName TySyn
ts), Name -> Names
One (TySyn -> Name
T.tsName TySyn
ts))

-- | Compute a naming environment from a module parameter, qualifying it
-- according to 'mpQual'.
modParamNamingEnv :: T.ModParam -> NamingEnv
modParamNamingEnv :: ModParam -> NamingEnv
modParamNamingEnv ModParam
mp = (NamingEnv -> NamingEnv)
-> (ModName -> NamingEnv -> NamingEnv)
-> Maybe ModName
-> NamingEnv
-> NamingEnv
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NamingEnv -> NamingEnv
forall a. a -> a
id ModName -> NamingEnv -> NamingEnv
qualify (ModParam -> Maybe ModName
T.mpQual ModParam
mp) (NamingEnv -> NamingEnv) -> NamingEnv -> NamingEnv
forall a b. (a -> b) -> a -> b
$
  ModParamNames -> NamingEnv
modParamNamesNamingEnv (ModParam -> ModParamNames
T.mpParameters ModParam
mp)

-- | Generate a naming environment from a declaration interface, where none of
-- the names are qualified.
unqualifiedEnv :: IfaceDecls -> NamingEnv
unqualifiedEnv :: IfaceDecls -> NamingEnv
unqualifiedEnv IfaceDecls { Map Name NominalType
Map Name TySyn
Map Name ModParamNames
Map Name IfaceDecl
Map Name (IfaceNames Name)
Map Name (IfaceG Name)
ifTySyns :: Map Name TySyn
ifNominalTypes :: Map Name NominalType
ifDecls :: Map Name IfaceDecl
ifModules :: Map Name (IfaceNames Name)
ifSignatures :: Map Name ModParamNames
ifFunctors :: Map Name (IfaceG Name)
ifTySyns :: IfaceDecls -> Map Name TySyn
ifNominalTypes :: IfaceDecls -> Map Name NominalType
ifDecls :: IfaceDecls -> Map Name IfaceDecl
ifModules :: IfaceDecls -> Map Name (IfaceNames Name)
ifSignatures :: IfaceDecls -> Map Name ModParamNames
ifFunctors :: IfaceDecls -> Map Name (IfaceG Name)
.. } =
  [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
exprs, NamingEnv
tySyns, NamingEnv
ntTypes, NamingEnv
ntExprs, NamingEnv
mods, NamingEnv
sigs ]
  where
  toPName :: Name -> PName
toPName Name
n = Ident -> PName
mkUnqual (Name -> Ident
nameIdent Name
n)

  exprs :: NamingEnv
exprs   = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSValue (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- Map Name IfaceDecl -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name IfaceDecl
ifDecls ]

  tySyns :: NamingEnv
tySyns  = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSType (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- Map Name TySyn -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name TySyn
ifTySyns ]

  ntTypes :: NamingEnv
ntTypes = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
n
                    | NominalType
nt <- Map Name NominalType -> [NominalType]
forall k a. Map k a -> [a]
Map.elems Map Name NominalType
ifNominalTypes
                    , let tname :: Name
tname  = NominalType -> Name
T.ntName NominalType
nt
                    , NamingEnv
n  <- Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSType (Name -> PName
toPName Name
tname) Name
tname
                          NamingEnv -> [NamingEnv] -> [NamingEnv]
forall a. a -> [a] -> [a]
: [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSValue (Name -> PName
toPName Name
cname) Name
cname
                            | Name
cname <-((Name, Schema) -> Name) -> [(Name, Schema)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Schema) -> Name
forall a b. (a, b) -> a
fst (NominalType -> [(Name, Schema)]
T.nominalTypeConTypes NominalType
nt)
                            ]
                    ]

  ntExprs :: NamingEnv
ntExprs = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSValue (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- Map Name NominalType -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name NominalType
ifNominalTypes ]

  mods :: NamingEnv
mods    = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSModule (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- Map Name (IfaceNames Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (IfaceNames Name)
ifModules ]

  sigs :: NamingEnv
sigs    = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSModule (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- Map Name ModParamNames -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name ModParamNames
ifSignatures ]


-- | Adapt the things exported by something to the specific import/open.
interpImportEnv :: ImportG name  {- ^ The import declarations -} ->
                NamingEnv     {- ^ All public things coming in -} ->
                NamingEnv
interpImportEnv :: forall name. ImportG name -> NamingEnv -> NamingEnv
interpImportEnv ImportG name
imp NamingEnv
public = NamingEnv
qualified
  where

  -- optionally qualify names based on the import
  qualified :: NamingEnv
qualified | Just ModName
pfx <- ImportG name -> Maybe ModName
forall mname. ImportG mname -> Maybe ModName
iAs ImportG name
imp = ModName -> NamingEnv -> NamingEnv
qualify ModName
pfx NamingEnv
restricted
            | Bool
otherwise           =             NamingEnv
restricted

  -- restrict or hide imported symbols
  restricted :: NamingEnv
restricted
    | Just (Hiding [Ident]
ns) <- ImportG name -> Maybe ImportSpec
forall mname. ImportG mname -> Maybe ImportSpec
iSpec ImportG name
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
filterPNames (\PName
qn -> Bool -> Bool
not (PName -> Ident
getIdent PName
qn Ident -> [Ident] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
ns)) NamingEnv
public

    | Just (Only [Ident]
ns) <- ImportG name -> Maybe ImportSpec
forall mname. ImportG mname -> Maybe ImportSpec
iSpec ImportG name
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
filterPNames (\PName
qn -> PName -> Ident
getIdent PName
qn Ident -> [Ident] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
ns) NamingEnv
public

    | Bool
otherwise = NamingEnv
public