-- |
-- 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 #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}
-- See Note [-Wincomplete-uni-patterns and irrefutable patterns] in Cryptol.TypeCheck.TypePat
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module Cryptol.ModuleSystem.NamingEnv where

import Data.List (nub)
import Data.Maybe (fromMaybe,mapMaybe,maybeToList)
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import Data.Semigroup
import MonadLib (runId,Id,StateT,runStateT,lift,sets_,forM_)

import GHC.Generics (Generic)
import Control.DeepSeq

import Prelude ()
import Prelude.Compat

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


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

-- | The 'NamingEnv' is used by the renamer to determine what
-- identifiers refer to.
newtype NamingEnv = NamingEnv (Map Namespace (Map PName [Name]))
  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)

-- | All names mentioned in the environment
namingEnvNames :: NamingEnv -> Set Name
namingEnvNames :: NamingEnv -> Set Name
namingEnvNames (NamingEnv Map Namespace (Map PName [Name])
xs) =
  [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList ([Name] -> Set Name) -> [Name] -> Set Name
forall a b. (a -> b) -> a -> b
$ (Map PName [Name] -> [Name]) -> [Map PName [Name]] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Name]] -> [Name]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Name]] -> [Name])
-> (Map PName [Name] -> [[Name]]) -> Map PName [Name] -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PName [Name] -> [[Name]]
forall k a. Map k a -> [a]
Map.elems) ([Map PName [Name]] -> [Name]) -> [Map PName [Name]] -> [Name]
forall a b. (a -> b) -> a -> b
$ Map Namespace (Map PName [Name]) -> [Map PName [Name]]
forall k a. Map k a -> [a]
Map.elems Map Namespace (Map PName [Name])
xs


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

-- | Resolve a name in the given namespace.
lookupNS :: Namespace -> PName -> NamingEnv -> [Name]
lookupNS :: Namespace -> PName -> NamingEnv -> [Name]
lookupNS Namespace
ns PName
x = [Name] -> PName -> Map PName [Name] -> [Name]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PName
x (Map PName [Name] -> [Name])
-> (NamingEnv -> Map PName [Name]) -> NamingEnv -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> NamingEnv -> Map PName [Name]
namespaceMap Namespace
ns

-- | Return a list of value-level names to which this parsed name may refer.
lookupValNames :: PName -> NamingEnv -> [Name]
lookupValNames :: PName -> NamingEnv -> [Name]
lookupValNames = Namespace -> PName -> NamingEnv -> [Name]
lookupNS Namespace
NSValue

-- | Return a list of type-level names to which this parsed name may refer.
lookupTypeNames :: PName -> NamingEnv -> [Name]
lookupTypeNames :: PName -> NamingEnv -> [Name]
lookupTypeNames = Namespace -> PName -> NamingEnv -> [Name]
lookupNS Namespace
NSType

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

-- | Singleton expression renaming environment.
singletonE :: PName -> Name -> NamingEnv
singletonE :: PName -> Name -> NamingEnv
singletonE = Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSValue

-- | Singleton type renaming environment.
singletonT :: PName -> Name -> NamingEnv
singletonT :: PName -> Name -> NamingEnv
singletonT = Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSType


namingEnvRename :: (Name -> Name) -> NamingEnv -> NamingEnv
namingEnvRename :: (Name -> Name) -> NamingEnv -> NamingEnv
namingEnvRename Name -> Name
f (NamingEnv Map Namespace (Map PName [Name])
mp) = Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv (Map PName [Name] -> Map PName [Name]
forall (f :: * -> *). Functor f => f [Name] -> f [Name]
ren (Map PName [Name] -> Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName [Name])
mp)
  where
  ren :: f [Name] -> f [Name]
ren f [Name]
nsm = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Name
f ([Name] -> [Name]) -> f [Name] -> f [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [Name]
nsm


instance Semigroup NamingEnv where
  NamingEnv Map Namespace (Map PName [Name])
l <> :: NamingEnv -> NamingEnv -> NamingEnv
<> NamingEnv Map Namespace (Map PName [Name])
r =
      Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv ((Map PName [Name] -> Map PName [Name] -> Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (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])
-> 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) Map Namespace (Map PName [Name])
l Map Namespace (Map PName [Name])
r)

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


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

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

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

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


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


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

-- | Qualify all symbols in a 'NamingEnv' with the given prefix.
qualify :: ModName -> NamingEnv -> NamingEnv
qualify :: ModName -> NamingEnv -> NamingEnv
qualify ModName
pfx (NamingEnv Map Namespace (Map PName [Name])
env) = Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv ((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] -> Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName [Name])
env)
  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 Namespace (Map PName [Name])
env) = Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv ((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 p. PName -> p -> Bool
check (Map PName [Name] -> Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Namespace (Map PName [Name])
env)
  where check :: PName -> p -> Bool
check PName
n p
_ = PName -> Bool
p PName
n


-- | Like mappend, but when merging, prefer values on the lhs.
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing :: NamingEnv -> NamingEnv -> NamingEnv
shadowing (NamingEnv Map Namespace (Map PName [Name])
l) (NamingEnv Map Namespace (Map PName [Name])
r) = Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv ((Map PName [Name] -> Map PName [Name] -> Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
-> Map Namespace (Map PName [Name])
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith 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 Map Namespace (Map PName [Name])
l Map Namespace (Map PName [Name])
r)

travNamingEnv :: Applicative f => (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv :: (Name -> f Name) -> NamingEnv -> f NamingEnv
travNamingEnv Name -> f Name
f (NamingEnv Map Namespace (Map PName [Name])
mp) =
  Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv (Map Namespace (Map PName [Name]) -> NamingEnv)
-> f (Map Namespace (Map PName [Name])) -> f NamingEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Map PName [Name] -> f (Map PName [Name]))
-> Map Namespace (Map PName [Name])
-> f (Map Namespace (Map PName [Name]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (([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)) Map Namespace (Map PName [Name])
mp


{- | Do somethign in context.  If `Nothing` than we are working with
a local declaration. Otherwise we are at the top-level of the
given module. -}
data InModule a = InModule (Maybe ModPath) 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)


newTop ::
  FreshM m => Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop :: Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
ns ModPath
m PName
thing Maybe Fixity
fx Range
rng =
  (Supply -> (Name, Supply)) -> m Name
forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (Namespace
-> ModPath
-> NameSource
-> Ident
-> Maybe Fixity
-> Range
-> Supply
-> (Name, Supply)
mkDeclared Namespace
ns ModPath
m 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 => Namespace -> PName -> Range -> m Name
newLocal :: Namespace -> PName -> Range -> m Name
newLocal Namespace
ns PName
thing Range
rng = (Supply -> (Name, Supply)) -> m Name
forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (Namespace -> Ident -> Range -> Supply -> (Name, Supply)
mkParameter Namespace
ns (PName -> Ident
getIdent PName
thing) Range
rng)

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


buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv,Supply)
buildNamingEnv :: BuildNamingEnv -> Supply -> (NamingEnv, Supply)
buildNamingEnv BuildNamingEnv
b Supply
supply = Id (NamingEnv, Supply) -> (NamingEnv, Supply)
forall a. Id a -> a
runId (Id (NamingEnv, Supply) -> (NamingEnv, Supply))
-> Id (NamingEnv, Supply) -> (NamingEnv, Supply)
forall a b. (a -> b) -> a -> b
$ Supply -> SupplyT Id NamingEnv -> Id (NamingEnv, Supply)
forall (m :: * -> *) a.
Monad m =>
Supply -> SupplyT m a -> m (a, Supply)
runSupplyT Supply
supply (SupplyT Id NamingEnv -> Id (NamingEnv, Supply))
-> SupplyT Id NamingEnv -> Id (NamingEnv, Supply)
forall a b. (a -> b) -> a -> b
$ BuildNamingEnv -> SupplyT Id NamingEnv
runBuild BuildNamingEnv
b

-- | Generate a 'NamingEnv' using an explicit supply.
defsOf :: BindsNames a => a -> Supply -> (NamingEnv,Supply)
defsOf :: a -> Supply -> (NamingEnv, Supply)
defsOf = BuildNamingEnv -> Supply -> (NamingEnv, Supply)
buildNamingEnv (BuildNamingEnv -> Supply -> (NamingEnv, Supply))
-> (a -> BuildNamingEnv) -> a -> Supply -> (NamingEnv, Supply)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv


--------------------------------------------------------------------------------
-- Collect definitions of nested modules

type NestedMods = Map Name NamingEnv
type CollectM   = StateT NestedMods (SupplyT Id)

collectNestedModules ::
  NamingEnv -> Module PName -> Supply -> (NestedMods, Supply)
collectNestedModules :: NamingEnv -> Module PName -> Supply -> (NestedMods, Supply)
collectNestedModules NamingEnv
env Module PName
m =
  NamingEnv
-> ModName -> [TopDecl PName] -> Supply -> (NestedMods, Supply)
collectNestedModulesDecls NamingEnv
env (Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
mName Module PName
m)) (Module PName -> [TopDecl PName]
forall mname name. ModuleG mname name -> [TopDecl name]
mDecls Module PName
m)

collectNestedModulesDecls ::
  NamingEnv -> ModName -> [TopDecl PName] -> Supply -> (NestedMods, Supply)
collectNestedModulesDecls :: NamingEnv
-> ModName -> [TopDecl PName] -> Supply -> (NestedMods, Supply)
collectNestedModulesDecls NamingEnv
env ModName
m [TopDecl PName]
ds Supply
sup = (NestedMods
mp,Supply
newS)
  where
  s0 :: Map k a
s0            = Map k a
forall k a. Map k a
Map.empty
  mpath :: ModPath
mpath         = ModName -> ModPath
TopModule ModName
m
  ((()
_,NestedMods
mp),Supply
newS) = Id (((), NestedMods), Supply) -> (((), NestedMods), Supply)
forall a. Id a -> a
runId (Id (((), NestedMods), Supply) -> (((), NestedMods), Supply))
-> Id (((), NestedMods), Supply) -> (((), NestedMods), Supply)
forall a b. (a -> b) -> a -> b
$ Supply
-> SupplyT Id ((), NestedMods) -> Id (((), NestedMods), Supply)
forall (m :: * -> *) a.
Monad m =>
Supply -> SupplyT m a -> m (a, Supply)
runSupplyT Supply
sup (SupplyT Id ((), NestedMods) -> Id (((), NestedMods), Supply))
-> SupplyT Id ((), NestedMods) -> Id (((), NestedMods), Supply)
forall a b. (a -> b) -> a -> b
$ NestedMods
-> StateT NestedMods (SupplyT Id) () -> SupplyT Id ((), NestedMods)
forall i (m :: * -> *) a. i -> StateT i m a -> m (a, i)
runStateT NestedMods
forall k a. Map k a
s0 (StateT NestedMods (SupplyT Id) () -> SupplyT Id ((), NestedMods))
-> StateT NestedMods (SupplyT Id) () -> SupplyT Id ((), NestedMods)
forall a b. (a -> b) -> a -> b
$
                  ModPath
-> NamingEnv
-> [TopDecl PName]
-> StateT NestedMods (SupplyT Id) ()
collectNestedModulesDs ModPath
mpath NamingEnv
env [TopDecl PName]
ds

collectNestedModulesDs :: ModPath -> NamingEnv -> [TopDecl PName] -> CollectM ()
collectNestedModulesDs :: ModPath
-> NamingEnv
-> [TopDecl PName]
-> StateT NestedMods (SupplyT Id) ()
collectNestedModulesDs ModPath
mpath NamingEnv
env [TopDecl PName]
ds =
  [NestedModule PName]
-> (NestedModule PName -> StateT NestedMods (SupplyT Id) ())
-> StateT NestedMods (SupplyT Id) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ TopLevel (NestedModule PName) -> NestedModule PName
forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
nm | DModule TopLevel (NestedModule PName)
nm <- [TopDecl PName]
ds ] \(NestedModule ModuleG PName PName
nested) ->
    do let pname :: PName
pname = Located PName -> PName
forall a. Located a -> a
thing (ModuleG PName PName -> Located PName
forall mname name. ModuleG mname name -> Located mname
mName ModuleG PName PName
nested)
           name :: Name
name  = case Namespace -> PName -> NamingEnv -> [Name]
lookupNS Namespace
NSModule PName
pname NamingEnv
env of
                     Name
n : [Name]
_ -> Name
n -- if a name is ambiguous we may get
                                -- multiple answers, but we just pick one.
                                -- This should be OK, as the error should be
                                -- caught during actual renaming.
                     [Name]
_   -> String -> [String] -> Name
forall a. HasCallStack => String -> [String] -> a
panic String
"collectedNestedModulesDs"
                             [ String
"Missing definition for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PName -> String
forall a. Show a => a -> String
show PName
pname ]
       NamingEnv
newEnv <- SupplyT Id NamingEnv -> StateT NestedMods (SupplyT Id) NamingEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadT t, Monad m) =>
m a -> t m a
lift (BuildNamingEnv -> SupplyT Id NamingEnv
runBuild (ModPath -> ModuleG PName PName -> BuildNamingEnv
forall mname. ModPath -> ModuleG mname PName -> BuildNamingEnv
moduleDefs (ModPath -> Ident -> ModPath
Nested ModPath
mpath (Name -> Ident
nameIdent Name
name)) ModuleG PName PName
nested))
       (NestedMods -> NestedMods) -> StateT NestedMods (SupplyT Id) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ (Name -> NamingEnv -> NestedMods -> NestedMods
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
name NamingEnv
newEnv)
       let newMPath :: ModPath
newMPath = ModPath -> Ident -> ModPath
Nested ModPath
mpath (Name -> Ident
nameIdent Name
name)
       ModPath
-> NamingEnv
-> [TopDecl PName]
-> StateT NestedMods (SupplyT Id) ()
collectNestedModulesDs ModPath
newMPath NamingEnv
newEnv (ModuleG PName PName -> [TopDecl PName]
forall mname name. ModuleG mname name -> [TopDecl name]
mDecls ModuleG PName PName
nested)

--------------------------------------------------------------------------------




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



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

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

  -- restrict or hide imported symbols
  restricted :: NamingEnv
restricted
    | Just (Hiding [Ident]
ns) <- ImportG name -> Maybe ImportSpec
forall mname. ImportG mname -> Maybe ImportSpec
iSpec ImportG name
imp =
       (PName -> Bool) -> NamingEnv -> NamingEnv
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) <- ImportG name -> Maybe ImportSpec
forall mname. ImportG mname -> Maybe ImportSpec
iSpec ImportG name
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



-- | Interpret an import in the context of an interface, to produce a name
-- environment for the renamer, and a 'NameDisp' for pretty-printing.
interpImportIface :: Import     {- ^ The import declarations -} ->
                IfaceDecls {- ^ Declarations of imported module -} ->
                NamingEnv
interpImportIface :: Import -> IfaceDecls -> NamingEnv
interpImportIface Import
imp = Import -> NamingEnv -> NamingEnv
forall name. ImportG name -> NamingEnv -> NamingEnv
interpImportEnv Import
imp (NamingEnv -> NamingEnv)
-> (IfaceDecls -> NamingEnv) -> IfaceDecls -> NamingEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceDecls -> NamingEnv
unqualifiedEnv


-- | 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
Map Name (IfaceG Name)
ifModules :: IfaceDecls -> Map Name (IfaceG Name)
ifDecls :: IfaceDecls -> Map Name IfaceDecl
ifAbstractTypes :: IfaceDecls -> Map Name IfaceAbstractType
ifNewtypes :: IfaceDecls -> Map Name IfaceNewtype
ifTySyns :: IfaceDecls -> Map Name IfaceTySyn
ifModules :: Map Name (IfaceG Name)
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, NamingEnv
mods ]
  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 ]
  mods :: NamingEnv
mods    = [NamingEnv] -> NamingEnv
forall a. Monoid a => [a] -> a
mconcat [ Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSModule (Name -> PName
toPName Name
n) Name
n
                                                | Name
n <- Map Name (IfaceG Name) -> [Name]
forall k a. Map k a -> [k]
Map.keys Map Name (IfaceG Name)
ifModules ]

-- | 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
.. } =
  Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv (Map Namespace (Map PName [Name]) -> NamingEnv)
-> Map Namespace (Map PName [Name]) -> NamingEnv
forall a b. (a -> b) -> a -> b
$ [(Namespace, Map PName [Name])] -> Map Namespace (Map PName [Name])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
    [ (Namespace
NSValue, [(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)
    , (Namespace
NSType,  [(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 :: forall mname. IfaceG mname -> IfaceParams
ifPrivate :: forall mname. IfaceG mname -> IfaceDecls
ifPublic :: forall mname. IfaceG mname -> IfaceDecls
ifModName :: forall mname. IfaceG mname -> mname
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
interpImportIface Import
imp IfaceDecls
ifPublic)
  {-# INLINE namingEnv #-}

-- | Introduce the name
instance BindsNames (InModule (Bind PName)) where
  namingEnv :: InModule (Bind PName) -> BuildNamingEnv
namingEnv (InModule Maybe ModPath
mb 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
srcRange :: forall a. Located a -> Range
thing :: PName
srcRange :: Range
thing :: forall a. Located a -> a
.. } = Bind PName -> Located PName
forall name. Bind name -> Located name
bName Bind PName
b
       Name
n <- case Maybe ModPath
mb of
              Just ModPath
m  -> Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSValue ModPath
m PName
thing (Bind PName -> Maybe Fixity
forall name. Bind name -> Maybe Fixity
bFixity Bind PName
b) Range
srcRange
              Maybe ModPath
Nothing -> Namespace -> PName -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> PName -> Range -> m Name
newLocal Namespace
NSValue PName
thing Range
srcRange -- local fixitiies?

       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 <- Namespace -> PName -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> PName -> Range -> m Name
newLocal Namespace
NSType 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 PName
m = ModPath -> Module PName -> BuildNamingEnv
forall mname. ModPath -> ModuleG mname PName -> BuildNamingEnv
moduleDefs (ModName -> ModPath
TopModule (Located ModName -> ModName
forall a. Located a -> a
thing (Module PName -> Located ModName
forall mname name. ModuleG mname name -> Located mname
mName Module PName
m))) Module PName
m


moduleDefs :: ModPath -> ModuleG mname PName -> BuildNamingEnv
moduleDefs :: ModPath -> ModuleG mname PName -> BuildNamingEnv
moduleDefs ModPath
m Module { [TopDecl PName]
Maybe (Located ModName)
Located mname
mInstance :: forall mname name. ModuleG mname name -> Maybe (Located ModName)
mDecls :: [TopDecl PName]
mInstance :: Maybe (Located ModName)
mName :: Located mname
mDecls :: forall mname name. ModuleG mname name -> [TopDecl name]
mName :: forall mname name. ModuleG mname name -> Located mname
.. } = (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
. Maybe ModPath -> TopDecl PName -> InModule (TopDecl PName)
forall a. Maybe ModPath -> a -> InModule a
InModule (ModPath -> Maybe ModPath
forall a. a -> Maybe a
Just ModPath
m)) [TopDecl PName]
mDecls


instance BindsNames (InModule (TopDecl PName)) where
  namingEnv :: InModule (TopDecl PName) -> BuildNamingEnv
namingEnv (InModule Maybe ModPath
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 (Maybe ModPath -> Decl PName -> InModule (Decl PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
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 (Maybe ModPath -> PrimType PName -> InModule (PrimType PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
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 (Maybe ModPath -> Newtype PName -> InModule (Newtype PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
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 (Maybe ModPath
-> ParameterType PName -> InModule (ParameterType PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
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 (Maybe ModPath
-> ParameterFun PName -> InModule (ParameterFun PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
ns ParameterFun PName
d)
      Include Located String
_        -> BuildNamingEnv
forall a. Monoid a => a
mempty
      DImport {}       -> BuildNamingEnv
forall a. Monoid a => a
mempty -- see 'openLoop' in the renamer
      DModule TopLevel (NestedModule PName)
m        -> InModule (NestedModule PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (Maybe ModPath
-> NestedModule PName -> InModule (NestedModule PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
ns (TopLevel (NestedModule PName) -> NestedModule PName
forall a. TopLevel a -> a
tlValue TopLevel (NestedModule PName)
m))


instance BindsNames (InModule (NestedModule PName)) where
  namingEnv :: InModule (NestedModule PName) -> BuildNamingEnv
namingEnv (InModule ~(Just ModPath
m) (NestedModule ModuleG PName PName
mdef)) = SupplyT Id NamingEnv -> BuildNamingEnv
BuildNamingEnv (SupplyT Id NamingEnv -> BuildNamingEnv)
-> SupplyT Id NamingEnv -> BuildNamingEnv
forall a b. (a -> b) -> a -> b
$
    do let pnmame :: Located PName
pnmame = ModuleG PName PName -> Located PName
forall mname name. ModuleG mname name -> Located mname
mName ModuleG PName PName
mdef
       Name
nm   <- Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSModule ModPath
m (Located PName -> PName
forall a. Located a -> a
thing Located PName
pnmame) Maybe Fixity
forall a. Maybe a
Nothing (Located PName -> Range
forall a. Located a -> Range
srcRange Located PName
pnmame)
       NamingEnv -> SupplyT Id NamingEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace -> PName -> Name -> NamingEnv
singletonNS Namespace
NSModule (Located PName -> PName
forall a. Located a -> a
thing Located PName
pnmame) Name
nm)

instance BindsNames (InModule (PrimType PName)) where
  namingEnv :: InModule (PrimType PName) -> BuildNamingEnv
namingEnv (InModule ~(Just ModPath
m) 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
srcRange :: forall a. Located a -> Range
thing :: forall a. Located a -> a
.. } = Located PName
primTName
         Name
nm <- Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSType ModPath
m 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 ~(Just ModPath
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
srcRange :: forall a. Located a -> Range
thing :: forall a. Located a -> a
.. } = Located PName
pfName
       Name
ntName <- Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSValue ModPath
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 ~(Just ModPath
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
srcRange :: forall a. Located a -> Range
thing :: forall a. Located a -> a
.. } = Located PName
ptName
       Name
ntName <- Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSType ModPath
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 ~(Just ModPath
ns) Newtype { [TParam PName]
Located PName
Rec (Type PName)
nBody :: forall name. Newtype name -> Rec (Type name)
nParams :: forall name. Newtype name -> [TParam name]
nName :: forall name. Newtype name -> Located name
nBody :: Rec (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
srcRange :: forall a. Located a -> Range
thing :: forall a. Located a -> a
.. } = Located PName
nName
       Name
ntName <- Namespace
-> ModPath -> PName -> Maybe Fixity -> Range -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
NSType ModPath
ns PName
thing Maybe Fixity
forall a. Maybe a
Nothing Range
srcRange
       -- XXX: the name reuse here is sketchy
       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 Maybe ModPath
pfx Decl PName
d) = case Decl PName
d of
    DBind Bind PName
b                 -> InModule (Bind PName) -> BuildNamingEnv
forall a. BindsNames a => a -> BuildNamingEnv
namingEnv (Maybe ModPath -> Bind PName -> InModule (Bind PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
pfx Bind PName
b)
    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 (Maybe ModPath -> Decl PName -> InModule (Decl PName)
forall a. Maybe ModPath -> a -> InModule a
InModule Maybe ModPath
pfx Decl PName
d')
    DRec {}                 -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic String
"namingEnv" [ String
"DRec" ]
    DPatBind Pattern PName
_pat Expr PName
_e        -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic String
"namingEnv" [String
"Unexpected pattern binding"]
    DFixity{}               -> String -> [String] -> BuildNamingEnv
forall a. HasCallStack => String -> [String] -> a
panic String
"namingEnv" [String
"Unexpected fixity declaration"]

    where

    mkName :: Namespace -> Located PName -> Maybe Fixity -> m Name
mkName Namespace
ns Located PName
ln Maybe Fixity
fx = case Maybe ModPath
pfx of
                        Just ModPath
m  -> Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
forall (m :: * -> *).
FreshM m =>
Namespace -> ModPath -> PName -> Maybe Fixity -> Range -> m Name
newTop Namespace
ns ModPath
m (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)
                        Maybe ModPath
Nothing -> Namespace -> PName -> Range -> m Name
forall (m :: * -> *).
FreshM m =>
Namespace -> PName -> Range -> m Name
newLocal Namespace
ns (Located PName -> PName
forall a. Located a -> a
thing Located PName
ln) (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 <- Namespace -> Located PName -> Maybe Fixity -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> Located PName -> Maybe Fixity -> m Name
mkName Namespace
NSValue 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 <- Namespace -> Located PName -> Maybe Fixity -> SupplyT Id Name
forall (m :: * -> *).
FreshM m =>
Namespace -> Located PName -> Maybe Fixity -> m Name
mkName Namespace
NSType 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)