{-# 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
data NamingEnv = NamingEnv { NamingEnv -> Map PName [Name]
neExprs :: !(Map.Map PName [Name])
, NamingEnv -> Map PName [Name]
neTypes :: !(Map.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)
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)
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 :: [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)
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 ]
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
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
visibleNames :: NamingEnv -> ( Set.Set Name
, 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 :: 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
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
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] }
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] }
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)
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)
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 #-}
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 #-}
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport :: Import -> IfaceDecls -> NamingEnv
interpImport imp :: Import
imp publicDecls :: IfaceDecls
publicDecls = NamingEnv
qualified
where
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
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
public :: NamingEnv
public = IfaceDecls -> NamingEnv
unqualifiedEnv IfaceDecls
publicDecls
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 ]
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
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 #-}
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)
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)
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
$
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)
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)
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)