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

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
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 GHC.Generics (Generic)
import Control.DeepSeq(NFData)

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


-- | The 'NamingEnv' is used by the renamer to determine what
-- identifiers refer to.
newtype NamingEnv = NamingEnv (Map Namespace (Map PName Names))
  deriving (Int -> NamingEnv -> ShowS
[NamingEnv] -> ShowS
NamingEnv -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamingEnv] -> ShowS
$cshowList :: [NamingEnv] -> ShowS
show :: NamingEnv -> String
$cshow :: NamingEnv -> String
showsPrec :: Int -> NamingEnv -> ShowS
$cshowsPrec :: Int -> NamingEnv -> ShowS
Show,forall x. Rep NamingEnv x -> NamingEnv
forall x. NamingEnv -> Rep NamingEnv x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NamingEnv x -> NamingEnv
$cfrom :: forall x. NamingEnv -> Rep NamingEnv x
Generic,NamingEnv -> ()
forall a. (a -> ()) -> NFData a
rnf :: NamingEnv -> ()
$crnf :: NamingEnv -> ()
NFData)

instance Monoid NamingEnv where
  mempty :: NamingEnv
mempty = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv forall k a. Map k a
Map.empty
  {-# INLINE mempty #-}

instance Semigroup NamingEnv where
  NamingEnv Map Namespace (Map PName Names)
l <> :: NamingEnv -> NamingEnv -> NamingEnv
<> NamingEnv Map Namespace (Map PName Names)
r =
    Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>)) Map Namespace (Map PName Names)
l Map Namespace (Map PName Names)
r)

instance PP NamingEnv where
  ppPrec :: Int -> NamingEnv -> Doc
ppPrec Int
_ (NamingEnv Map Namespace (Map PName Names)
mps)   = [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (PP a, PP a) => (a, Map a Names) -> Doc
ppNS forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Namespace (Map PName Names)
mps
    where ppNS :: (a, Map a Names) -> Doc
ppNS (a
ns,Map a Names
xs) = Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat (forall a. PP a => a -> Doc
pp a
ns forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}. PP a => (a, Names) -> Doc
ppNm (forall k a. Map k a -> [(k, a)]
Map.toList Map a Names
xs)))
          ppNm :: (a, Names) -> Doc
ppNm (a
x,Names
as)  = forall a. PP a => a -> Doc
pp a
x Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> [Doc] -> Doc
commaSep (forall a b. (a -> b) -> [a] -> [b]
map forall a. PP a => a -> Doc
pp (Names -> [Name]
namesToList Names
as))


{- | 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) = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ 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 = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall k a. Map k a -> [a]
Map.elems (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 = 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     = forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith 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 = 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 forall k a. Map k a -> Bool
Map.null Map k Names
c then forall a. Maybe a
Nothing else 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 (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Names] -> Maybe Names
unionManyNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems) (forall k a. Map k a -> [a]
Map.elems Map Namespace (Map PName Names)
xs)) of
    Maybe Names
Nothing -> forall a. Set a
Set.empty
    Just (One Name
x) -> forall a. a -> Set a
Set.singleton Name
x
    Just (Ambig Set Name
as) -> Set Name
as

-- | Get a unqualified naming environment for the given names
namingEnvFromNames :: Set Name -> NamingEnv
namingEnvFromNames :: Set Name -> NamingEnv
namingEnvFromNames Set Name
xs = Map Namespace (Map PName Names) -> NamingEnv
NamingEnv (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 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
                 txt :: Ident
txt = Name -> Ident
nameIdent Name
x
             in forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith forall a. Semigroup a => a -> a -> a
(<>))
                               Namespace
ns (forall k a. k -> a -> Map k a
Map.singleton (Ident -> PName
mkUnqual Ident
txt) (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) = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault 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 = 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 (forall k a. k -> a -> Map k a
Map.singleton Namespace
ns (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 = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                [ Name -> (PrimIdent, Name)
entry Name
x | Names
xs <- 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 -> forall a. HasCallStack => String -> [String] -> a
panic String
"toPrimMap" [ String
"Not a declared name?"
                                           , 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 (forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map OrigName NameFormat
names)
  where
  names :: Map OrigName NameFormat
names = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (OrigName
og, NameFormat
qn)
              | Namespace
ns            <- [Namespace]
allNamespaces
              , (PName
pn,Names
xs)       <- 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            <- 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) = forall {k}. Map k Names -> Set Name
check 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 = forall a. Ord a => [a] -> Set a
Set.fromList [ Name
a | One Name
a <- 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 (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PName -> PName
toQual 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 (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe 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 = 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 forall k a. Map k a -> Bool
Map.null Map PName a
new then forall a. Maybe a
Nothing else 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 (forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe 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 = 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 forall k a. Map k a -> Bool
Map.null Map k Names
new then forall a. Maybe a
Nothing else 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 Map Namespace (Map PName Names)
ns) =
  [ forall a. Set a -> [a]
Set.toList Set Name
xs
  | Map PName Names
mp <- forall k a. Map k a -> [a]
Map.elems Map Namespace (Map PName Names)
ns
  , Ambig Set Name
xs <- forall k a. Map k a -> [a]
Map.elems Map PName Names
mp
  ]

-- | 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) <- forall k a. Map k a -> [(k, a)]
Map.toList Map Namespace (Map PName Names)
lhs
  , (PName
p,Names
xs) <- 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Names
One forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> Name
anyOne) 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 (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith 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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name -> Name) -> Names -> Names
mapNames Name -> Name
f) 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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) = 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.
modParamsNamingEnv :: T.ModParamNames -> NamingEnv
modParamsNamingEnv :: ModParamNames -> NamingEnv
modParamsNamingEnv T.ModParamNames { [Located Prop]
Maybe Text
Map Name TySyn
Map Name ModVParam
Map Name ModTParam
mpnDoc :: ModParamNames -> Maybe Text
mpnFuns :: ModParamNames -> Map Name ModVParam
mpnConstraints :: ModParamNames -> [Located Prop]
mpnTySyn :: ModParamNames -> Map Name TySyn
mpnTypes :: ModParamNames -> Map Name ModTParam
mpnDoc :: Maybe Text
mpnFuns :: Map Name ModVParam
mpnConstraints :: [Located Prop]
mpnTySyn :: Map Name TySyn
mpnTypes :: Map Name ModTParam
.. } =
  Map Namespace (Map PName Names) -> NamingEnv
NamingEnv forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Namespace
NSValue, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> (PName, Names)
fromFu forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map Name ModVParam
mpnFuns)
    , (Namespace
NSType,  forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map TySyn -> (PName, Names)
fromTS (forall k a. Map k a -> [a]
Map.elems Map Name TySyn
mpnTySyn) forall a. [a] -> [a] -> [a]
++
                               forall a b. (a -> b) -> [a] -> [b]
map ModTParam -> (PName, Names)
fromTy (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))


-- | 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 AbstractType
Map Name Newtype
Map Name TySyn
Map Name ModParamNames
Map Name IfaceDecl
Map Name (IfaceNames Name)
Map Name (IfaceG Name)
ifFunctors :: IfaceDecls -> Map Name (IfaceG Name)
ifSignatures :: IfaceDecls -> Map Name ModParamNames
ifModules :: IfaceDecls -> Map Name (IfaceNames Name)
ifDecls :: IfaceDecls -> Map Name IfaceDecl
ifAbstractTypes :: IfaceDecls -> Map Name AbstractType
ifNewtypes :: IfaceDecls -> Map Name Newtype
ifTySyns :: IfaceDecls -> Map Name TySyn
ifFunctors :: Map Name (IfaceG Name)
ifSignatures :: Map Name ModParamNames
ifModules :: Map Name (IfaceNames Name)
ifDecls :: Map Name IfaceDecl
ifAbstractTypes :: Map Name AbstractType
ifNewtypes :: Map Name Newtype
ifTySyns :: Map Name TySyn
.. } =
  forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
exprs, NamingEnv
tySyns, NamingEnv
ntTypes, NamingEnv
absTys, NamingEnv
ntExprs, NamingEnv
mods, NamingEnv
sigs ]
  where
  toPName :: Name -> PName
toPName Name
n = Ident -> PName
mkUnqual (Name -> Ident
nameIdent Name
n)

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

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

  ntTypes :: NamingEnv
ntTypes = forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
n
                    | Newtype
nt <- forall k a. Map k a -> [a]
Map.elems Map Name Newtype
ifNewtypes
                    , let tname :: Name
tname = Newtype -> Name
T.ntName Newtype
nt
                          cname :: Name
cname = Newtype -> Name
T.ntConName Newtype
nt
                    , NamingEnv
n  <- [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSType (Name -> PName
toPName Name
tname) Name
tname
                            , Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSValue (Name -> PName
toPName Name
cname) Name
cname
                            ]
                    ]

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

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

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

  sigs :: NamingEnv
sigs    = forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSModule (Name -> PName
toPName Name
n) Name
n
                    | Name
n <- 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 <- 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) <- 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
ns)) NamingEnv
public

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

    | Bool
otherwise = NamingEnv
public