-- |
-- 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 ----------------------------------------------------------

-- XXX The fixity environment should be removed, and Name should include fixity
-- information.
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 qn :: PName
qn ro :: 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 qn :: PName
qn ro :: 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
  l :: NamingEnv
l <> :: NamingEnv -> NamingEnv -> NamingEnv
<> r :: NamingEnv
r   =
    $WNamingEnv :: 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        =
    $WNamingEnv :: 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 l :: NamingEnv
l r :: NamingEnv
r   = NamingEnv
l NamingEnv -> NamingEnv -> NamingEnv
forall a. Semigroup a => a -> a -> a
<> NamingEnv
r

  mconcat :: [NamingEnv] -> NamingEnv
mconcat envs :: [NamingEnv]
envs  =
    $WNamingEnv :: 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 xs :: [Name]
xs ys :: [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 'Ident' to 'Name' for a given naming environment.
toPrimMap :: NamingEnv -> PrimMap
toPrimMap :: NamingEnv -> PrimMap
toPrimMap NamingEnv { .. } = PrimMap :: Map Ident Name -> Map Ident Name -> PrimMap
PrimMap { .. }
  where
  primDecls :: Map Ident Name
primDecls = [(Ident, Name)] -> Map Ident Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name -> Ident
nameIdent Name
n,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 Ident Name
primTypes = [(Ident, Name)] -> Map Ident Name
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (Name -> Ident
nameIdent Name
n,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 { .. } = (ModName -> Ident -> Maybe NameFormat) -> NameDisp
NameDisp ModName -> Ident -> Maybe NameFormat
display
  where
  display :: ModName -> Ident -> Maybe NameFormat
display mn :: ModName
mn ident :: 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
$ [ PName -> ModName -> Ident -> ((ModName, Ident), NameFormat)
forall a b. PName -> a -> b -> ((a, b), NameFormat)
mkEntry PName
pn ModName
mn (Name -> Ident
nameIdent Name
n) | (pn :: PName
pn,ns :: [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 mn :: ModName
mn _ <- [Name -> NameInfo
nameInfo Name
n] ]

    [((ModName, Ident), NameFormat)]
-> [((ModName, Ident), NameFormat)]
-> [((ModName, Ident), NameFormat)]
forall a. [a] -> [a] -> [a]
++ [ PName -> ModName -> Ident -> ((ModName, Ident), NameFormat)
forall a b. PName -> a -> b -> ((a, b), NameFormat)
mkEntry PName
pn ModName
mn (Name -> Ident
nameIdent Name
n) | (pn :: PName
pn,ns :: [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 mn :: ModName
mn _ <- [Name -> NameInfo
nameInfo Name
n] ]

  mkEntry :: PName -> a -> b -> ((a, b), NameFormat)
mkEntry pn :: PName
pn mn :: a
mn i :: b
i = ((a
mn,b
i),NameFormat
fmt)
    where
    fmt :: NameFormat
fmt = case PName -> Maybe ModName
getModName PName
pn of
            Just ns :: ModName
ns -> ModName -> NameFormat
Qualified ModName
ns
            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 { .. } = (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 | [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 | [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 pfx :: ModName
pfx NamingEnv { .. } =
  $WNamingEnv :: 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 _ n :: Ident
n)  = ModName -> Ident -> PName
Qual ModName
pfx Ident
n
  toQual (UnQual n :: 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 p :: PName -> Bool
p NamingEnv { .. } =
  $WNamingEnv :: 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 n :: PName
n _ = PName -> Bool
p PName
n


-- | Singleton type renaming environment.
singletonT :: PName -> Name -> NamingEnv
singletonT :: PName -> Name -> NamingEnv
singletonT qn :: PName
qn tn :: 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 qn :: PName
qn en :: 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 l :: NamingEnv
l r :: NamingEnv
r = $WNamingEnv :: 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 f :: Name -> f Name
f ne :: 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
a supply :: 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 ns :: ModName
ns thing :: PName
thing fx :: Maybe Fixity
fx rng :: 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 thing :: PName
thing rng :: 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 a :: SupplyT Id NamingEnv
a <> :: BuildNamingEnv -> BuildNamingEnv -> BuildNamingEnv
<> BuildNamingEnv b :: 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 bs :: [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 env :: 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 ps :: [TParam PName]
ps _ _ _) = (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 -> IfaceDecls -> NamingEnv
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport imp :: Import
imp publicDecls :: IfaceDecls
publicDecls = NamingEnv
qualified
  where

  -- optionally qualify names based on the import
  qualified :: NamingEnv
qualified | Just pfx :: 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 ns :: [Ident]
ns) <- Import -> Maybe ImportSpec
iSpec Import
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames (\qn :: 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 ns :: [Ident]
ns) <- Import -> Maybe ImportSpec
iSpec Import
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
filterNames (\qn :: 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 { .. } =
  [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ NamingEnv
exprs, NamingEnv
tySyns, NamingEnv
ntTypes, NamingEnv
absTys, NamingEnv
ntExprs ]
  where
  toPName :: Name -> PName
toPName n :: 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 { .. } =
  $WNamingEnv :: 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 n :: Name
n = Ident -> PName
mkUnqual (Name -> Ident
nameIdent Name
n)

  fromTy :: ModTParam -> (PName, [Name])
fromTy tp :: 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 f :: 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 imp :: Import
imp Iface { .. }) = 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 ns :: ModName
ns b :: 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 { .. } = 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 { .. } = 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 { .. } = (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 ns :: ModName
ns td :: TopDecl PName
td) =
    case TopDecl PName
td of
      Decl d :: 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 d :: 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 d :: 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 d :: 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  d :: 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 _   -> BuildNamingEnv
forall a. Monoid a => a
mempty

instance BindsNames (InModule (PrimType PName)) where
  namingEnv :: InModule (PrimType PName) -> BuildNamingEnv
namingEnv (InModule ns :: ModName
ns PrimType { .. }) =
    SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
      do let Located { .. } = 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 ns :: ModName
ns ParameterFun { .. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let Located { .. } = 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 ns :: ModName
ns ParameterType { .. }) = 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 { .. } = 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 ns :: ModName
ns Newtype { .. }) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let Located { .. } = 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 pfx :: ModName
pfx d :: Decl PName
d) = case Decl PName
d of
    DBind b :: 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 ns :: [Located PName]
ns _sig :: 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 ns :: [Located PName]
ns _p :: 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 syn :: 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 syn :: 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 d' :: 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
pfx Decl PName
d')
    DPatBind _pat :: Pattern PName
_pat _e :: Expr PName
_e        -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic "ModuleSystem" ["Unexpected pattern binding"]
    DFixity{}               -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic "ModuleSystem" ["Unexpected fixity declaration"]

    where

    mkName :: Located PName -> Maybe Fixity -> m Name
mkName ln :: Located PName
ln fx :: 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 ln :: 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 ln :: Located PName
ln f :: 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)