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

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
module Cryptol.ModuleSystem.NamingEnv where

import Cryptol.ModuleSystem.Interface
import Cryptol.ModuleSystem.Name
import Cryptol.Parser.AST
import Cryptol.Parser.Name(isGeneratedName)
import Cryptol.Parser.Position
import qualified Cryptol.TypeCheck.AST as T
import Cryptol.Utils.PP
import Cryptol.Utils.Panic (panic)

import Data.List (nub)
import Data.Maybe (fromMaybe)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Semigroup
import MonadLib (runId,Id)

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat


-- Naming Environment ----------------------------------------------------------

-- | The 'NamingEnv' is used by the renamer to determine what
-- identifiers refer to.
data NamingEnv = NamingEnv { NamingEnv -> Map PName [Name]
neExprs :: !(Map.Map PName [Name])
                             -- ^ Expr renaming environment
                           , NamingEnv -> Map PName [Name]
neTypes :: !(Map.Map PName [Name])
                             -- ^ Type renaming environment
                           } deriving (Int -> NamingEnv -> ShowS
[NamingEnv] -> ShowS
NamingEnv -> String
(Int -> NamingEnv -> ShowS)
-> (NamingEnv -> String)
-> ([NamingEnv] -> ShowS)
-> Show NamingEnv
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. NamingEnv -> Rep NamingEnv x)
-> (forall x. Rep NamingEnv x -> NamingEnv) -> Generic NamingEnv
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 -> ()
(NamingEnv -> ()) -> NFData NamingEnv
forall a. (a -> ()) -> NFData a
rnf :: NamingEnv -> ()
$crnf :: NamingEnv -> ()
NFData)

-- | Return a list of value-level names to which this parsed name may refer.
lookupValNames :: PName -> NamingEnv -> [Name]
lookupValNames :: PName -> NamingEnv -> [Name]
lookupValNames PName
qn NamingEnv
ro = [Name] -> PName -> Map PName [Name] -> [Name]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PName
qn (NamingEnv -> Map PName [Name]
neExprs NamingEnv
ro)

-- | Return a list of type-level names to which this parsed name may refer.
lookupTypeNames :: PName -> NamingEnv -> [Name]
lookupTypeNames :: PName -> NamingEnv -> [Name]
lookupTypeNames PName
qn NamingEnv
ro = [Name] -> PName -> Map PName [Name] -> [Name]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PName
qn (NamingEnv -> Map PName [Name]
neTypes NamingEnv
ro)



instance Semigroup NamingEnv where
  NamingEnv
l <> :: NamingEnv -> NamingEnv -> NamingEnv
<> NamingEnv
r   =
    NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs  = ([Name] -> [Name] -> [Name])
-> Map PName [Name] -> Map PName [Name] -> Map PName [Name]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [Name] -> [Name] -> [Name]
merge (NamingEnv -> Map PName [Name]
neExprs  NamingEnv
l) (NamingEnv -> Map PName [Name]
neExprs  NamingEnv
r)
              , neTypes :: Map PName [Name]
neTypes  = ([Name] -> [Name] -> [Name])
-> Map PName [Name] -> Map PName [Name] -> Map PName [Name]
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith [Name] -> [Name] -> [Name]
merge (NamingEnv -> Map PName [Name]
neTypes  NamingEnv
l) (NamingEnv -> Map PName [Name]
neTypes  NamingEnv
r) }

instance Monoid NamingEnv where
  mempty :: NamingEnv
mempty        =
    NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs  = Map PName [Name]
forall k a. Map k a
Map.empty
              , neTypes :: Map PName [Name]
neTypes  = Map PName [Name]
forall k a. Map k a
Map.empty }

  mappend :: NamingEnv -> NamingEnv -> NamingEnv
mappend NamingEnv
l NamingEnv
r   = NamingEnv
l NamingEnv -> NamingEnv -> NamingEnv
forall a. Semigroup a => a -> a -> a
<> NamingEnv
r

  mconcat :: [NamingEnv] -> NamingEnv
mconcat [NamingEnv]
envs  =
    NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs  = ([Name] -> [Name] -> [Name])
-> [Map PName [Name]] -> Map PName [Name]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [Name] -> [Name] -> [Name]
merge ((NamingEnv -> Map PName [Name])
-> [NamingEnv] -> [Map PName [Name]]
forall a b. (a -> b) -> [a] -> [b]
map NamingEnv -> Map PName [Name]
neExprs  [NamingEnv]
envs)
              , neTypes :: Map PName [Name]
neTypes  = ([Name] -> [Name] -> [Name])
-> [Map PName [Name]] -> Map PName [Name]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith [Name] -> [Name] -> [Name]
merge ((NamingEnv -> Map PName [Name])
-> [NamingEnv] -> [Map PName [Name]]
forall a b. (a -> b) -> [a] -> [b]
map NamingEnv -> Map PName [Name]
neTypes  [NamingEnv]
envs) }

  {-# INLINE mempty #-}
  {-# INLINE mappend #-}
  {-# INLINE mconcat #-}


-- | Merge two name maps, collapsing cases where the entries are the same, and
-- producing conflicts otherwise.
merge :: [Name] -> [Name] -> [Name]
merge :: [Name] -> [Name] -> [Name]
merge [Name]
xs [Name]
ys | [Name]
xs [Name] -> [Name] -> Bool
forall a. Eq a => a -> a -> Bool
== [Name]
ys  = [Name]
xs
            | Bool
otherwise = [Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name]
xs [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
ys)

-- | Generate a mapping from 'PrimIdent' to 'Name' for a
-- given naming environment.
toPrimMap :: NamingEnv -> PrimMap
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv { Map PName [Name]
neTypes :: Map PName [Name]
neExprs :: Map PName [Name]
neTypes :: NamingEnv -> Map PName [Name]
neExprs :: NamingEnv -> Map PName [Name]
.. } = PrimMap :: Map PrimIdent Name -> Map PrimIdent Name -> PrimMap
PrimMap { Map PrimIdent Name
primTypes :: Map PrimIdent Name
primDecls :: Map PrimIdent Name
primTypes :: Map PrimIdent Name
primDecls :: Map PrimIdent Name
.. }
  where
  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
                                           ]

  primDecls :: Map PrimIdent Name
primDecls = [(PrimIdent, Name)] -> Map PrimIdent Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ Name -> (PrimIdent, Name)
entry Name
n | [Name]
ns <- Map PName [Name] -> [[Name]]
forall k a. Map k a -> [a]
Map.elems Map PName [Name]
neExprs, Name
n  <- [Name]
ns ]
  primTypes :: Map PrimIdent Name
primTypes = [(PrimIdent, Name)] -> Map PrimIdent Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ Name -> (PrimIdent, Name)
entry Name
n | [Name]
ns <- Map PName [Name] -> [[Name]]
forall k a. Map k a -> [a]
Map.elems Map PName [Name]
neTypes, Name
n  <- [Name]
ns ]

-- | Generate a display format based on a naming environment.
toNameDisp :: NamingEnv -> NameDisp
toNameDisp :: NamingEnv -> NameDisp
toNameDisp NamingEnv { Map PName [Name]
neTypes :: Map PName [Name]
neExprs :: Map PName [Name]
neTypes :: NamingEnv -> Map PName [Name]
neExprs :: NamingEnv -> Map PName [Name]
.. } = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp ModName -> Ident -> Maybe NameFormat
display
  where
  display :: ModName -> Ident -> Maybe NameFormat
display ModName
mn Ident
ident = (ModName, Ident)
-> Map (ModName, Ident) NameFormat -> Maybe NameFormat
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ModName
mn,Ident
ident) Map (ModName, Ident) NameFormat
names

  -- only format declared names, as parameters don't need any special
  -- formatting.
  names :: Map (ModName, Ident) NameFormat
names = [((ModName, Ident), NameFormat)] -> Map (ModName, Ident) NameFormat
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
     ([((ModName, Ident), NameFormat)]
 -> Map (ModName, Ident) NameFormat)
-> [((ModName, Ident), NameFormat)]
-> Map (ModName, Ident) NameFormat
forall a b. (a -> b) -> a -> b
$ [ (ModName, Ident) -> PName -> ((ModName, Ident), NameFormat)
forall a. a -> PName -> (a, NameFormat)
mkEntry (ModName
mn, Name -> Ident
nameIdent Name
n) PName
pn | (PName
pn,[Name]
ns)       <- Map PName [Name] -> [(PName, [Name])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Name]
neExprs
                                      , Name
n             <- [Name]
ns
                                      , Declared ModName
mn NameSource
_ <- [Name -> NameInfo
nameInfo Name
n] ]

    [((ModName, Ident), NameFormat)]
-> [((ModName, Ident), NameFormat)]
-> [((ModName, Ident), NameFormat)]
forall a. [a] -> [a] -> [a]
++ [ (ModName, Ident) -> PName -> ((ModName, Ident), NameFormat)
forall a. a -> PName -> (a, NameFormat)
mkEntry (ModName
mn, Name -> Ident
nameIdent Name
n) PName
pn | (PName
pn,[Name]
ns)       <- Map PName [Name] -> [(PName, [Name])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PName [Name]
neTypes
                                      , Name
n             <- [Name]
ns
                                      , Declared ModName
mn NameSource
_ <- [Name -> NameInfo
nameInfo Name
n] ]

  mkEntry :: a -> PName -> (a, NameFormat)
mkEntry a
key PName
pn = (a
key,NameFormat
fmt)
    where fmt :: NameFormat
fmt = case PName -> Maybe ModName
getModName PName
pn of
                  Just ModName
ns -> ModName -> NameFormat
Qualified ModName
ns
                  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 -> ({- types -} Set.Set Name
                             ,{- decls -} Set.Set Name)

visibleNames :: NamingEnv -> (Set Name, Set Name)
visibleNames NamingEnv { Map PName [Name]
neTypes :: Map PName [Name]
neExprs :: Map PName [Name]
neTypes :: NamingEnv -> Map PName [Name]
neExprs :: NamingEnv -> Map PName [Name]
.. } = (Set Name
types,Set Name
decls)
  where
  types :: Set Name
types = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [ Name
n | [Name
n] <- Map PName [Name] -> [[Name]]
forall k a. Map k a -> [a]
Map.elems Map PName [Name]
neTypes ]
  decls :: Set Name
decls = [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [ Name
n | [Name
n] <- Map PName [Name] -> [[Name]]
forall k a. Map k a -> [a]
Map.elems Map PName [Name]
neExprs ]

-- | Qualify all symbols in a 'NamingEnv' with the given prefix.
qualify :: ModName -> NamingEnv -> NamingEnv
qualify :: ModName -> NamingEnv -> NamingEnv
qualify ModName
pfx NamingEnv { Map PName [Name]
neTypes :: Map PName [Name]
neExprs :: Map PName [Name]
neTypes :: NamingEnv -> Map PName [Name]
neExprs :: NamingEnv -> Map PName [Name]
.. } =
  NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs = (PName -> PName) -> Map PName [Name] -> Map PName [Name]
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PName -> PName
toQual Map PName [Name]
neExprs
            , neTypes :: Map PName [Name]
neTypes = (PName -> PName) -> Map PName [Name] -> Map PName [Name]
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys PName -> PName
toQual Map PName [Name]
neTypes
            }

  where
  -- XXX we don't currently qualify fresh names
  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

filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames :: (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames PName -> Bool
p NamingEnv { Map PName [Name]
neTypes :: Map PName [Name]
neExprs :: Map PName [Name]
neTypes :: NamingEnv -> Map PName [Name]
neExprs :: NamingEnv -> Map PName [Name]
.. } =
  NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs = (PName -> [Name] -> Bool) -> Map PName [Name] -> Map PName [Name]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PName -> [Name] -> Bool
forall a. PName -> a -> Bool
check Map PName [Name]
neExprs
            , neTypes :: Map PName [Name]
neTypes = (PName -> [Name] -> Bool) -> Map PName [Name] -> Map PName [Name]
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PName -> [Name] -> Bool
forall a. PName -> a -> Bool
check Map PName [Name]
neTypes
            }
  where
  check :: PName -> a -> Bool
  check :: PName -> a -> Bool
check PName
n a
_ = PName -> Bool
p PName
n


-- | Singleton type renaming environment.
singletonT :: PName -> Name -> NamingEnv
singletonT :: PName -> Name -> NamingEnv
singletonT PName
qn Name
tn = NamingEnv
forall a. Monoid a => a
mempty { neTypes :: Map PName [Name]
neTypes = PName -> [Name] -> Map PName [Name]
forall k a. k -> a -> Map k a
Map.singleton PName
qn [Name
tn] }

-- | Singleton expression renaming environment.
singletonE :: PName -> Name -> NamingEnv
singletonE :: PName -> Name -> NamingEnv
singletonE PName
qn Name
en = NamingEnv
forall a. Monoid a => a
mempty { neExprs :: Map PName [Name]
neExprs = PName -> [Name] -> Map PName [Name]
forall k a. k -> a -> Map k a
Map.singleton PName
qn [Name
en] }

-- | Like mappend, but when merging, prefer values on the lhs.
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing NamingEnv
l NamingEnv
r = NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv
  { neExprs :: Map PName [Name]
neExprs  = Map PName [Name] -> Map PName [Name] -> Map PName [Name]
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (NamingEnv -> Map PName [Name]
neExprs  NamingEnv
l) (NamingEnv -> Map PName [Name]
neExprs  NamingEnv
r)
  , neTypes :: Map PName [Name]
neTypes  = Map PName [Name] -> Map PName [Name] -> Map PName [Name]
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (NamingEnv -> Map PName [Name]
neTypes  NamingEnv
l) (NamingEnv -> Map PName [Name]
neTypes  NamingEnv
r) }

travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv :: (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv Name -> f Name
f NamingEnv
ne = Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv (Map PName [Name] -> Map PName [Name] -> NamingEnv)
-> f (Map PName [Name]) -> f (Map PName [Name] -> NamingEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Map PName [Name])
neExprs' f (Map PName [Name] -> NamingEnv)
-> f (Map PName [Name]) -> f NamingEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (Map PName [Name])
neTypes'
  where
    neExprs' :: f (Map PName [Name])
neExprs' = ([Name] -> f [Name]) -> Map PName [Name] -> f (Map PName [Name])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name -> f Name) -> [Name] -> f [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> f Name
f) (NamingEnv -> Map PName [Name]
neExprs NamingEnv
ne)
    neTypes' :: f (Map PName [Name])
neTypes' = ([Name] -> f [Name]) -> Map PName [Name] -> f (Map PName [Name])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Name -> f Name) -> [Name] -> f [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Name -> f Name
f) (NamingEnv -> Map PName [Name]
neTypes NamingEnv
ne)


data InModule a = InModule !ModName a
                  deriving (a -> InModule b -> InModule a
(a -> b) -> InModule a -> InModule b
(forall a b. (a -> b) -> InModule a -> InModule b)
-> (forall a b. a -> InModule b -> InModule a) -> Functor InModule
forall a b. a -> InModule b -> InModule a
forall a b. (a -> b) -> InModule a -> InModule b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> InModule b -> InModule a
$c<$ :: forall a b. a -> InModule b -> InModule a
fmap :: (a -> b) -> InModule a -> InModule b
$cfmap :: forall a b. (a -> b) -> InModule a -> InModule b
Functor,Functor InModule
Foldable InModule
Functor InModule
-> Foldable InModule
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> InModule a -> f (InModule b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    InModule (f a) -> f (InModule a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> InModule a -> m (InModule b))
-> (forall (m :: * -> *) a.
    Monad m =>
    InModule (m a) -> m (InModule a))
-> Traversable InModule
(a -> f b) -> InModule a -> f (InModule b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => InModule (m a) -> m (InModule a)
forall (f :: * -> *) a.
Applicative f =>
InModule (f a) -> f (InModule a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InModule a -> m (InModule b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InModule a -> f (InModule b)
sequence :: InModule (m a) -> m (InModule a)
$csequence :: forall (m :: * -> *) a. Monad m => InModule (m a) -> m (InModule a)
mapM :: (a -> m b) -> InModule a -> m (InModule b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> InModule a -> m (InModule b)
sequenceA :: InModule (f a) -> f (InModule a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
InModule (f a) -> f (InModule a)
traverse :: (a -> f b) -> InModule a -> f (InModule b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> InModule a -> f (InModule b)
$cp2Traversable :: Foldable InModule
$cp1Traversable :: Functor InModule
Traversable,InModule a -> Bool
(a -> m) -> InModule a -> m
(a -> b -> b) -> b -> InModule a -> b
(forall m. Monoid m => InModule m -> m)
-> (forall m a. Monoid m => (a -> m) -> InModule a -> m)
-> (forall m a. Monoid m => (a -> m) -> InModule a -> m)
-> (forall a b. (a -> b -> b) -> b -> InModule a -> b)
-> (forall a b. (a -> b -> b) -> b -> InModule a -> b)
-> (forall b a. (b -> a -> b) -> b -> InModule a -> b)
-> (forall b a. (b -> a -> b) -> b -> InModule a -> b)
-> (forall a. (a -> a -> a) -> InModule a -> a)
-> (forall a. (a -> a -> a) -> InModule a -> a)
-> (forall a. InModule a -> [a])
-> (forall a. InModule a -> Bool)
-> (forall a. InModule a -> Int)
-> (forall a. Eq a => a -> InModule a -> Bool)
-> (forall a. Ord a => InModule a -> a)
-> (forall a. Ord a => InModule a -> a)
-> (forall a. Num a => InModule a -> a)
-> (forall a. Num a => InModule a -> a)
-> Foldable InModule
forall a. Eq a => a -> InModule a -> Bool
forall a. Num a => InModule a -> a
forall a. Ord a => InModule a -> a
forall m. Monoid m => InModule m -> m
forall a. InModule a -> Bool
forall a. InModule a -> Int
forall a. InModule a -> [a]
forall a. (a -> a -> a) -> InModule a -> a
forall m a. Monoid m => (a -> m) -> InModule a -> m
forall b a. (b -> a -> b) -> b -> InModule a -> b
forall a b. (a -> b -> b) -> b -> InModule a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: InModule a -> a
$cproduct :: forall a. Num a => InModule a -> a
sum :: InModule a -> a
$csum :: forall a. Num a => InModule a -> a
minimum :: InModule a -> a
$cminimum :: forall a. Ord a => InModule a -> a
maximum :: InModule a -> a
$cmaximum :: forall a. Ord a => InModule a -> a
elem :: a -> InModule a -> Bool
$celem :: forall a. Eq a => a -> InModule a -> Bool
length :: InModule a -> Int
$clength :: forall a. InModule a -> Int
null :: InModule a -> Bool
$cnull :: forall a. InModule a -> Bool
toList :: InModule a -> [a]
$ctoList :: forall a. InModule a -> [a]
foldl1 :: (a -> a -> a) -> InModule a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> InModule a -> a
foldr1 :: (a -> a -> a) -> InModule a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> InModule a -> a
foldl' :: (b -> a -> b) -> b -> InModule a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> InModule a -> b
foldl :: (b -> a -> b) -> b -> InModule a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> InModule a -> b
foldr' :: (a -> b -> b) -> b -> InModule a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> InModule a -> b
foldr :: (a -> b -> b) -> b -> InModule a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> InModule a -> b
foldMap' :: (a -> m) -> InModule a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> InModule a -> m
foldMap :: (a -> m) -> InModule a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> InModule a -> m
fold :: InModule m -> m
$cfold :: forall m. Monoid m => InModule m -> m
Foldable,Int -> InModule a -> ShowS
[InModule a] -> ShowS
InModule a -> String
(Int -> InModule a -> ShowS)
-> (InModule a -> String)
-> ([InModule a] -> ShowS)
-> Show (InModule a)
forall a. Show a => Int -> InModule a -> ShowS
forall a. Show a => [InModule a] -> ShowS
forall a. Show a => InModule a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InModule a] -> ShowS
$cshowList :: forall a. Show a => [InModule a] -> ShowS
show :: InModule a -> String
$cshow :: forall a. Show a => InModule a -> String
showsPrec :: Int -> InModule a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> InModule a -> ShowS
Show)


-- | Generate a 'NamingEnv' using an explicit supply.
namingEnv' :: BindsNames a => a -> Supply -> (NamingEnv,Supply)
namingEnv' :: a -> Supply -> (NamingEnv, Supply)
namingEnv' a
a Supply
supply = Id (NamingEnv, Supply) -> (NamingEnv, Supply)
forall a. Id a -> a
runId (Supply -> SupplyT Id NamingEnv -> Id (NamingEnv, Supply)
forall (m :: * -> *) a.
Monad m =>
Supply -> SupplyT m a -> m (a, Supply)
runSupplyT Supply
supply (BuildNamingEnv -> SupplyT Id NamingEnv
runBuild (a -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv a
a)))

newTop :: FreshM m => ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop :: ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing Maybe Fixity
fx Range
rng = (Supply -> (Name, Supply)) -> m Name
forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (ModName
-> NameSource
-> Ident
-> Maybe Fixity
-> Range
-> Supply
-> (Name, Supply)
mkDeclared ModName
ns NameSource
src (PName -> Ident
getIdent PName
thing) Maybe Fixity
fx Range
rng)
  where src :: NameSource
src = if PName -> Bool
isGeneratedName PName
thing then NameSource
SystemName else NameSource
UserName

newLocal :: FreshM m => PName -> Range -> m Name
newLocal :: PName -> Range -> m Name
newLocal PName
thing Range
rng = (Supply -> (Name, Supply)) -> m Name
forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (Ident -> Range -> Supply -> (Name, Supply)
mkParameter (PName -> Ident
getIdent PName
thing) Range
rng)

newtype BuildNamingEnv = BuildNamingEnv { BuildNamingEnv -> SupplyT Id NamingEnv
runBuild :: SupplyT Id NamingEnv }

instance Semigroup BuildNamingEnv where
  BuildNamingEnv SupplyT Id NamingEnv
a <> :: BuildNamingEnv -> BuildNamingEnv -> BuildNamingEnv
<> BuildNamingEnv SupplyT Id NamingEnv
b = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do NamingEnv
x <- SupplyT Id NamingEnv
a
       NamingEnv
y <- SupplyT Id NamingEnv
b
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (NamingEnv -> NamingEnv -> NamingEnv
forall a. Monoid a => a -> a -> a
mappend NamingEnv
x NamingEnv
y)

instance Monoid BuildNamingEnv where
  mempty :: BuildNamingEnv
mempty = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (NamingEnv -> SupplyT Id NamingEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamingEnv
forall a. Monoid a => a
mempty)

  mappend :: BuildNamingEnv -> BuildNamingEnv -> BuildNamingEnv
mappend = BuildNamingEnv -> BuildNamingEnv -> BuildNamingEnv
forall a. Semigroup a => a -> a -> a
(<>)

  mconcat :: [BuildNamingEnv] -> BuildNamingEnv
mconcat [BuildNamingEnv]
bs = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do [NamingEnv]
ns <- [SupplyT Id NamingEnv] -> SupplyT Id [NamingEnv]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ((BuildNamingEnv -> SupplyT Id NamingEnv)
-> [BuildNamingEnv] -> [SupplyT Id NamingEnv]
forall a b. (a -> b) -> [a] -> [b]
map BuildNamingEnv -> SupplyT Id NamingEnv
runBuild [BuildNamingEnv]
bs)
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [NamingEnv]
ns)

-- | Things that define exported names.
class BindsNames a where
  namingEnv :: a -> BuildNamingEnv

instance BindsNames NamingEnv where
  namingEnv :: NamingEnv -> BuildNamingEnv
namingEnv NamingEnv
env = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return NamingEnv
env)
  {-# INLINE namingEnv #-}

instance BindsNames a => BindsNames (Maybe a) where
  namingEnv :: Maybe a -> BuildNamingEnv
namingEnv = (a -> BuildNamingEnv) -> Maybe a -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv
  {-# INLINE namingEnv #-}

instance BindsNames a => BindsNames [a] where
  namingEnv :: [a] -> BuildNamingEnv
namingEnv = (a -> BuildNamingEnv) -> [a] -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv
  {-# INLINE namingEnv #-}

-- | Generate a type renaming environment from the parameters that are bound by
-- this schema.
instance BindsNames (Schema PName) where
  namingEnv :: Schema PName -> BuildNamingEnv
namingEnv (Forall [TParam PName]
ps [Prop PName]
_ Type PName
_ Maybe Range
_) = (TParam PName -> BuildNamingEnv)
-> [TParam PName] -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TParam PName -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv [TParam PName]
ps
  {-# INLINE namingEnv #-}


-- | Interpret an import in the context of an interface, to produce a name
-- environment for the renamer, and a 'NameDisp' for pretty-printing.
interpImport :: Import     {- ^ The import declarations -} ->
                IfaceDecls {- ^ Declarations of imported module -} ->
                NamingEnv
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport Import
imp IfaceDecls
publicDecls = NamingEnv
qualified
  where

  -- optionally qualify names based on the import
  qualified :: NamingEnv
qualified | Just ModName
pfx <- Import -> Maybe ModName
iAs Import
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) <- Import -> Maybe ImportSpec
iSpec Import
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames (\PName
qn -> Bool -> Bool
not (PName -> Ident
getIdent PName
qn Ident -> [Ident] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Ident]
ns)) NamingEnv
public

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

    | Bool
otherwise = NamingEnv
public

  -- generate the initial environment from the public interface, where no names
  -- are qualified
  public :: NamingEnv
public = IfaceDecls -> NamingEnv
unqualifiedEnv IfaceDecls
publicDecls


-- | 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 IfaceAbstractType
Map Name IfaceNewtype
Map Name IfaceTySyn
Map Name IfaceDecl
ifDecls :: IfaceDecls -> Map Name IfaceDecl
ifAbstractTypes :: IfaceDecls -> Map Name IfaceAbstractType
ifNewtypes :: IfaceDecls -> Map Name IfaceNewtype
ifTySyns :: IfaceDecls -> Map Name IfaceTySyn
ifDecls :: Map Name IfaceDecl
ifAbstractTypes :: Map Name IfaceAbstractType
ifNewtypes :: Map Name IfaceNewtype
ifTySyns :: Map Name IfaceTySyn
.. } =
  [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
exprs, NamingEnv
tySyns, NamingEnv
ntTypes, NamingEnv
absTys, NamingEnv
ntExprs ]
  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 [ PName -> Name -> NamingEnv
singletonE (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 [ PName -> Name -> NamingEnv
singletonT (Name -> PName
toPName Name
n) Name
n | Name
n <- Map Name IfaceTySyn -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name IfaceTySyn
ifTySyns ]
  ntTypes :: NamingEnv
ntTypes = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ PName -> Name -> NamingEnv
singletonT (Name -> PName
toPName Name
n) Name
n | Name
n <- Map Name IfaceNewtype -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name IfaceNewtype
ifNewtypes ]
  absTys :: NamingEnv
absTys  = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ PName -> Name -> NamingEnv
singletonT (Name -> PName
toPName Name
n) Name
n | Name
n <- Map Name IfaceAbstractType -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name IfaceAbstractType
ifAbstractTypes ]
  ntExprs :: NamingEnv
ntExprs = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ PName -> Name -> NamingEnv
singletonE (Name -> PName
toPName Name
n) Name
n | Name
n <- Map Name IfaceNewtype -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name IfaceNewtype
ifNewtypes ]


-- | Compute an unqualified naming environment, containing the various module
-- parameters.
modParamsNamingEnv :: IfaceParams -> NamingEnv
modParamsNamingEnv :: IfaceParams -> NamingEnv
modParamsNamingEnv IfaceParams { [Located Prop]
Map Name ModVParam
Map Name ModTParam
ifParamFuns :: IfaceParams -> Map Name ModVParam
ifParamConstraints :: IfaceParams -> [Located Prop]
ifParamTypes :: IfaceParams -> Map Name ModTParam
ifParamFuns :: Map Name ModVParam
ifParamConstraints :: [Located Prop]
ifParamTypes :: Map Name ModTParam
.. } =
  NamingEnv :: Map PName [Name] -> Map PName [Name] -> NamingEnv
NamingEnv { neExprs :: Map PName [Name]
neExprs = [(PName, [Name])] -> Map PName [Name]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PName, [Name])] -> Map PName [Name])
-> [(PName, [Name])] -> Map PName [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> (PName, [Name])) -> [Name] -> [(PName, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map Name -> (PName, [Name])
fromFu ([Name] -> [(PName, [Name])]) -> [Name] -> [(PName, [Name])]
forall a b. (a -> b) -> a -> b
$ Map Name ModVParam -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name ModVParam
ifParamFuns
            , neTypes :: Map PName [Name]
neTypes = [(PName, [Name])] -> Map PName [Name]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PName, [Name])] -> Map PName [Name])
-> [(PName, [Name])] -> Map PName [Name]
forall a b. (a -> b) -> a -> b
$ (ModTParam -> (PName, [Name])) -> [ModTParam] -> [(PName, [Name])]
forall a b. (a -> b) -> [a] -> [b]
map ModTParam -> (PName, [Name])
fromTy ([ModTParam] -> [(PName, [Name])])
-> [ModTParam] -> [(PName, [Name])]
forall a b. (a -> b) -> a -> b
$ Map Name ModTParam -> [ModTParam]
forall k a. Map k a -> [a]
Map.elems Map Name ModTParam
ifParamTypes
            }

  where
  toPName :: Name -> PName
toPName Name
n = Ident -> PName
mkUnqual (Name -> Ident
nameIdent Name
n)

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

  fromFu :: Name -> (PName, [Name])
fromFu Name
f  = (Name -> PName
toPName Name
f, [Name
f])



data ImportIface = ImportIface Import Iface

-- | Produce a naming environment from an interface file, that contains a
-- mapping only from unqualified names to qualified ones.
instance BindsNames ImportIface where
  namingEnv :: ImportIface -> BuildNamingEnv
namingEnv (ImportIface Import
imp Iface { ModName
IfaceDecls
IfaceParams
ifParams :: Iface -> IfaceParams
ifPrivate :: Iface -> IfaceDecls
ifPublic :: Iface -> IfaceDecls
ifModName :: Iface -> ModName
ifParams :: IfaceParams
ifPrivate :: IfaceDecls
ifPublic :: IfaceDecls
ifModName :: ModName
.. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (Import -> IfaceDecls -> NamingEnv
interpImport Import
imp IfaceDecls
ifPublic)
  {-# INLINE namingEnv #-}

-- | Introduce the name
instance BindsNames (InModule (Bind PName)) where
  namingEnv :: InModule (Bind PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns Bind PName
b) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let Located { Range
PName
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
thing :: PName
srcRange :: Range
.. } = Bind PName -> Located PName
forall name. Bind name -> Located name
bName Bind PName
b
       Name
n <- ModName -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing (Bind PName -> Maybe Fixity
forall name. Bind name -> Maybe Fixity
bFixity Bind PName
b) Range
srcRange

       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonE PName
thing Name
n)

-- | Generate the naming environment for a type parameter.
instance BindsNames (TParam PName) where
  namingEnv :: TParam PName -> BuildNamingEnv
namingEnv TParam { Maybe Range
Maybe Kind
PName
tpRange :: forall n. TParam n -> Maybe Range
tpKind :: forall n. TParam n -> Maybe Kind
tpName :: forall n. TParam n -> n
tpRange :: Maybe Range
tpKind :: Maybe Kind
tpName :: PName
.. } = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let range :: Range
range = Range -> Maybe Range -> Range
forall a. a -> Maybe a -> a
fromMaybe Range
emptyRange Maybe Range
tpRange
       Name
n <- PName -> Range -> SupplyT Id Name
forall (m :: * -> *). FreshM m => PName -> Range -> m Name
newLocal PName
tpName Range
range
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonT PName
tpName Name
n)

-- | The naming environment for a single module.  This is the mapping from
-- unqualified names to fully qualified names with uniques.
instance BindsNames (Module PName) where
  namingEnv :: Module PName -> BuildNamingEnv
namingEnv Module { [Located Import]
[TopDecl PName]
Maybe (Located ModName)
Located ModName
mDecls :: forall name. Module name -> [TopDecl name]
mImports :: forall name. Module name -> [Located Import]
mInstance :: forall name. Module name -> Maybe (Located ModName)
mName :: forall name. Module name -> Located ModName
mDecls :: [TopDecl PName]
mImports :: [Located Import]
mInstance :: Maybe (Located ModName)
mName :: Located ModName
.. } = (TopDecl PName -> BuildNamingEnv)
-> [TopDecl PName] -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (InModule (TopDecl PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (InModule (TopDecl PName) -> BuildNamingEnv)
-> (TopDecl PName -> InModule (TopDecl PName))
-> TopDecl PName
-> BuildNamingEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> TopDecl PName -> InModule (TopDecl PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns) [TopDecl PName]
mDecls
    where
    ns :: ModName
ns = Located ModName -> ModName
forall a. Located a -> a
thing Located ModName
mName

instance BindsNames (InModule (TopDecl PName)) where
  namingEnv :: InModule (TopDecl PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns TopDecl PName
td) =
    case TopDecl PName
td of
      Decl TopLevel (Decl PName)
d           -> InModule (Decl PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> Decl PName -> InModule (Decl PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns (TopLevel (Decl PName) -> Decl PName
forall a. TopLevel a -> a
tlValue TopLevel (Decl PName)
d))
      DPrimType TopLevel (PrimType PName)
d      -> InModule (PrimType PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> PrimType PName -> InModule (PrimType PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns (TopLevel (PrimType PName) -> PrimType PName
forall a. TopLevel a -> a
tlValue TopLevel (PrimType PName)
d))
      TDNewtype TopLevel (Newtype PName)
d      -> InModule (Newtype PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> Newtype PName -> InModule (Newtype PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns (TopLevel (Newtype PName) -> Newtype PName
forall a. TopLevel a -> a
tlValue TopLevel (Newtype PName)
d))
      DParameterType ParameterType PName
d -> InModule (ParameterType PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> ParameterType PName -> InModule (ParameterType PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns ParameterType PName
d)
      DParameterConstraint {} -> BuildNamingEnv
forall a. Monoid a => a
mempty
      DParameterFun  ParameterFun PName
d -> InModule (ParameterFun PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> ParameterFun PName -> InModule (ParameterFun PName)
forall a. ModName -> a -> InModule a
InModule ModName
ns ParameterFun PName
d)
      Include Located String
_   -> BuildNamingEnv
forall a. Monoid a => a
mempty

instance BindsNames (InModule (PrimType PName)) where
  namingEnv :: InModule (PrimType PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns PrimType { Maybe Fixity
([TParam PName], [Prop PName])
Located PName
Located Kind
primTFixity :: forall name. PrimType name -> Maybe Fixity
primTCts :: forall name. PrimType name -> ([TParam name], [Prop name])
primTKind :: forall name. PrimType name -> Located Kind
primTName :: forall name. PrimType name -> Located name
primTFixity :: Maybe Fixity
primTCts :: ([TParam PName], [Prop PName])
primTKind :: Located Kind
primTName :: Located PName
.. }) =
    SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
      do let Located { Range
PName
thing :: PName
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = Located PName
primTName
         Name
nm <- ModName -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing Maybe Fixity
primTFixity Range
srcRange
         NamingEnv -> SupplyT Id NamingEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PName -> Name -> NamingEnv
singletonT PName
thing Name
nm)

instance BindsNames (InModule (ParameterFun PName)) where
  namingEnv :: InModule (ParameterFun PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns ParameterFun { Maybe Text
Maybe Fixity
Located PName
Schema PName
pfFixity :: forall name. ParameterFun name -> Maybe Fixity
pfDoc :: forall name. ParameterFun name -> Maybe Text
pfSchema :: forall name. ParameterFun name -> Schema name
pfName :: forall name. ParameterFun name -> Located name
pfFixity :: Maybe Fixity
pfDoc :: Maybe Text
pfSchema :: Schema PName
pfName :: Located PName
.. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let Located { Range
PName
thing :: PName
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = Located PName
pfName
       Name
ntName <- ModName -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing Maybe Fixity
pfFixity Range
srcRange
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonE PName
thing Name
ntName)

instance BindsNames (InModule (ParameterType PName)) where
  namingEnv :: InModule (ParameterType PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns ParameterType { Int
Maybe Text
Maybe Fixity
Located PName
Kind
ptNumber :: forall name. ParameterType name -> Int
ptFixity :: forall name. ParameterType name -> Maybe Fixity
ptDoc :: forall name. ParameterType name -> Maybe Text
ptKind :: forall name. ParameterType name -> Kind
ptName :: forall name. ParameterType name -> Located name
ptNumber :: Int
ptFixity :: Maybe Fixity
ptDoc :: Maybe Text
ptKind :: Kind
ptName :: Located PName
.. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    -- XXX: we don't seem to have a fixity environment at the type level
    do let Located { Range
PName
thing :: PName
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = Located PName
ptName
       Name
ntName <- ModName -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing Maybe Fixity
forall a. Maybe a
Nothing Range
srcRange
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonT PName
thing Name
ntName)

-- NOTE: we use the same name at the type and expression level, as there's only
-- ever one name introduced in the declaration. The names are only ever used in
-- different namespaces, so there's no ambiguity.
instance BindsNames (InModule (Newtype PName)) where
  namingEnv :: InModule (Newtype PName) -> BuildNamingEnv
namingEnv (InModule ModName
ns Newtype { [TParam PName]
[Named (Type PName)]
Located PName
nBody :: forall name. Newtype name -> [Named (Type name)]
nParams :: forall name. Newtype name -> [TParam name]
nName :: forall name. Newtype name -> Located name
nBody :: [Named (Type PName)]
nParams :: [TParam PName]
nName :: Located PName
.. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let Located { Range
PName
thing :: PName
srcRange :: Range
thing :: forall a. Located a -> a
srcRange :: forall a. Located a -> Range
.. } = Located PName
nName
       Name
ntName <- ModName -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
ns PName
thing Maybe Fixity
forall a. Maybe a
Nothing Range
srcRange
       NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonT PName
thing Name
ntName NamingEnv -> NamingEnv -> NamingEnv
forall a. Monoid a => a -> a -> a
`mappend` PName -> Name -> NamingEnv
singletonE PName
thing Name
ntName)

-- | The naming environment for a single declaration.
instance BindsNames (InModule (Decl PName)) where
  namingEnv :: InModule (Decl PName) -> BuildNamingEnv
namingEnv (InModule ModName
pfx Decl PName
d) = case Decl PName
d of
    DBind Bind PName
b -> SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
      do Name
n <- Located PName -> Maybe Fixity -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Located PName -> Maybe Fixity -> m Name
mkName (Bind PName -> Located PName
forall name. Bind name -> Located name
bName Bind PName
b) (Bind PName -> Maybe Fixity
forall name. Bind name -> Maybe Fixity
bFixity Bind PName
b)
         NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonE (Located PName -> PName
forall a. Located a -> a
thing (Bind PName -> Located PName
forall name. Bind name -> Located name
bName Bind PName
b)) Name
n)

    DSignature [Located PName]
ns Schema PName
_sig      -> (Located PName -> BuildNamingEnv)
-> [Located PName] -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Located PName -> BuildNamingEnv
qualBind [Located PName]
ns
    DPragma [Located PName]
ns Pragma
_p           -> (Located PName -> BuildNamingEnv)
-> [Located PName] -> BuildNamingEnv
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Located PName -> BuildNamingEnv
qualBind [Located PName]
ns
    DType TySyn PName
syn               -> Located PName -> Maybe Fixity -> BuildNamingEnv
qualType (TySyn PName -> Located PName
forall name. TySyn name -> Located name
tsName TySyn PName
syn) (TySyn PName -> Maybe Fixity
forall name. TySyn name -> Maybe Fixity
tsFixity TySyn PName
syn)
    DProp PropSyn PName
syn               -> Located PName -> Maybe Fixity -> BuildNamingEnv
qualType (PropSyn PName -> Located PName
forall name. PropSyn name -> Located name
psName PropSyn PName
syn) (PropSyn PName -> Maybe Fixity
forall name. PropSyn name -> Maybe Fixity
psFixity PropSyn PName
syn)
    DLocated Decl PName
d' Range
_           -> InModule (Decl PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (ModName -> Decl PName -> InModule (Decl PName)
forall a. ModName -> a -> InModule a
InModule ModName
pfx Decl PName
d')
    DPatBind Pattern PName
_pat Expr PName
_e        -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic String
"ModuleSystem" [String
"Unexpected pattern binding"]
    DFixity{}               -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic String
"ModuleSystem" [String
"Unexpected fixity declaration"]

    where

    mkName :: Located PName -> Maybe Fixity -> m Name
mkName Located PName
ln Maybe Fixity
fx = ModName -> PName -> Maybe Fixity -> Range -> m Name
forall (m :: * -> *).
FreshM m =>
ModName -> PName -> Maybe Fixity -> Range -> m Name
newTop ModName
pfx (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln) Maybe Fixity
fx (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
ln)

    qualBind :: Located PName -> BuildNamingEnv
qualBind Located PName
ln = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
      do Name
n <- Located PName -> Maybe Fixity -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Located PName -> Maybe Fixity -> m Name
mkName Located PName
ln Maybe Fixity
forall a. Maybe a
Nothing
         NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonE (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln) Name
n)

    qualType :: Located PName -> Maybe Fixity -> BuildNamingEnv
qualType Located PName
ln Maybe Fixity
f = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
      do Name
n <- Located PName -> Maybe Fixity -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Located PName -> Maybe Fixity -> m Name
mkName Located PName
ln Maybe Fixity
f
         NamingEnv -> SupplyT Id NamingEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (PName -> Name -> NamingEnv
singletonT (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln) Name
n)