{-# Language RecordWildCards #-}
{-# Language FlexibleContexts #-}
{-# Language BlockArguments #-}
module Cryptol.ModuleSystem.Renamer.Monad where
import Data.List(sort)
import Data.Set(Set)
import qualified Data.Set as Set
import qualified Data.Foldable as F
import Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Semigroup as S
import MonadLib hiding (mapM, mapM_)
import Prelude ()
import Prelude.Compat
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.NamingEnv
import Cryptol.ModuleSystem.Interface
import Cryptol.Parser.AST
import Cryptol.Parser.Position
import Cryptol.Utils.Panic (panic)
import Cryptol.Utils.Ident(modPathCommon)
import Cryptol.ModuleSystem.Renamer.Error
data NameType = NameBind | NameUse
data RenamerInfo = RenamerInfo
{ RenamerInfo -> Supply
renSupply :: Supply
, RenamerInfo -> ModPath
renContext :: ModPath
, RenamerInfo -> NamingEnv
renEnv :: NamingEnv
, RenamerInfo -> ModName -> Iface
renIfaces :: ModName -> Iface
}
newtype RenameM a = RenameM { RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM :: ReaderT RO (StateT RW Lift) a }
data RO = RO
{ RO -> Range
roLoc :: Range
, RO -> NamingEnv
roNames :: NamingEnv
, RO -> ModName -> Iface
roIfaces :: ModName -> Iface
, RO -> ModPath
roCurMod :: ModPath
, RO -> Map ModPath Name
roNestedMods :: Map ModPath Name
}
data RW = RW
{ RW -> [RenamerWarning]
rwWarnings :: ![RenamerWarning]
, RW -> Seq RenamerError
rwErrors :: !(Seq.Seq RenamerError)
, RW -> Supply
rwSupply :: !Supply
, RW -> Map Name Int
rwNameUseCount :: !(Map Name Int)
, RW -> Set Name
rwCurrentDeps :: Set Name
, RW -> Map DepName (Set Name)
rwDepGraph :: Map DepName (Set Name)
, RW -> IfaceDecls
rwExternalDeps :: !IfaceDecls
}
instance S.Semigroup a => S.Semigroup (RenameM a) where
{-# INLINE (<>) #-}
RenameM a
a <> :: RenameM a -> RenameM a -> RenameM a
<> RenameM a
b =
do a
x <- RenameM a
a
a
y <- RenameM a
b
a -> RenameM a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
S.<> a
y)
instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where
{-# INLINE mempty #-}
mempty :: RenameM a
mempty = a -> RenameM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
forall a. Monoid a => a
mempty
{-# INLINE mappend #-}
mappend :: RenameM a -> RenameM a -> RenameM a
mappend = RenameM a -> RenameM a -> RenameM a
forall a. Semigroup a => a -> a -> a
(S.<>)
instance Functor RenameM where
{-# INLINE fmap #-}
fmap :: (a -> b) -> RenameM a -> RenameM b
fmap a -> b
f RenameM a
m = ReaderT RO (StateT RW Lift) b -> RenameM b
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ((a -> b)
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m))
instance Applicative RenameM where
{-# INLINE pure #-}
pure :: a -> RenameM a
pure a
x = ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (a -> ReaderT RO (StateT RW Lift) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)
{-# INLINE (<*>) #-}
RenameM (a -> b)
l <*> :: RenameM (a -> b) -> RenameM a -> RenameM b
<*> RenameM a
r = ReaderT RO (StateT RW Lift) b -> RenameM b
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RenameM (a -> b) -> ReaderT RO (StateT RW Lift) (a -> b)
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM (a -> b)
l ReaderT RO (StateT RW Lift) (a -> b)
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
r)
instance Monad RenameM where
{-# INLINE return #-}
return :: a -> RenameM a
return = a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
{-# INLINE (>>=) #-}
RenameM a
m >>= :: RenameM a -> (a -> RenameM b) -> RenameM b
>>= a -> RenameM b
k = ReaderT RO (StateT RW Lift) b -> RenameM b
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m ReaderT RO (StateT RW Lift) a
-> (a -> ReaderT RO (StateT RW Lift) b)
-> ReaderT RO (StateT RW Lift) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RenameM b -> ReaderT RO (StateT RW Lift) b
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM (RenameM b -> ReaderT RO (StateT RW Lift) b)
-> (a -> RenameM b) -> a -> ReaderT RO (StateT RW Lift) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RenameM b
k)
instance FreshM RenameM where
liftSupply :: (Supply -> (a, Supply)) -> RenameM a
liftSupply Supply -> (a, Supply)
f = ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) a -> RenameM a)
-> ReaderT RO (StateT RW Lift) a -> RenameM a
forall a b. (a -> b) -> a -> b
$ (RW -> (a, RW)) -> ReaderT RO (StateT RW Lift) a
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets ((RW -> (a, RW)) -> ReaderT RO (StateT RW Lift) a)
-> (RW -> (a, RW)) -> ReaderT RO (StateT RW Lift) a
forall a b. (a -> b) -> a -> b
$ \ RW { [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Seq RenamerError
Set Name
Supply
IfaceDecls
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwSupply :: Supply
rwErrors :: Seq RenamerError
rwWarnings :: [RenamerWarning]
rwExternalDeps :: RW -> IfaceDecls
rwDepGraph :: RW -> Map DepName (Set Name)
rwCurrentDeps :: RW -> Set Name
rwNameUseCount :: RW -> Map Name Int
rwSupply :: RW -> Supply
rwErrors :: RW -> Seq RenamerError
rwWarnings :: RW -> [RenamerWarning]
.. } ->
let (a
a,Supply
s') = Supply -> (a, Supply)
f Supply
rwSupply
rw' :: RW
rw' = RW :: [RenamerWarning]
-> Seq RenamerError
-> Supply
-> Map Name Int
-> Set Name
-> Map DepName (Set Name)
-> IfaceDecls
-> RW
RW { rwSupply :: Supply
rwSupply = Supply
s', [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Seq RenamerError
Set Name
IfaceDecls
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwErrors :: Seq RenamerError
rwWarnings :: [RenamerWarning]
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwErrors :: Seq RenamerError
rwWarnings :: [RenamerWarning]
.. }
in a
a a -> (a, RW) -> (a, RW)
`seq` RW
rw' RW -> (a, RW) -> (a, RW)
`seq` (a
a, RW
rw')
runRenamer :: RenamerInfo -> RenameM a
-> ( Either [RenamerError] (a,Supply)
, [RenamerWarning]
)
runRenamer :: RenamerInfo
-> RenameM a
-> (Either [RenamerError] (a, Supply), [RenamerWarning])
runRenamer RenamerInfo
info RenameM a
m = (Either [RenamerError] (a, Supply)
res, [RenamerWarning]
warns)
where
warns :: [RenamerWarning]
warns = [RenamerWarning] -> [RenamerWarning]
forall a. Ord a => [a] -> [a]
sort (RW -> [RenamerWarning]
rwWarnings RW
rw [RenamerWarning] -> [RenamerWarning] -> [RenamerWarning]
forall a. [a] -> [a] -> [a]
++ ModPath -> NamingEnv -> RW -> [RenamerWarning]
warnUnused (RenamerInfo -> ModPath
renContext RenamerInfo
info) (RenamerInfo -> NamingEnv
renEnv RenamerInfo
info) RW
rw)
(a
a,RW
rw) = ReaderT RO (StateT RW Lift) a -> RO -> RW -> (a, RW)
forall (m :: * -> *) a r. RunM m a r => m a -> r
runM (RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m) RO
ro
RW :: [RenamerWarning]
-> Seq RenamerError
-> Supply
-> Map Name Int
-> Set Name
-> Map DepName (Set Name)
-> IfaceDecls
-> RW
RW { rwErrors :: Seq RenamerError
rwErrors = Seq RenamerError
forall a. Seq a
Seq.empty
, rwWarnings :: [RenamerWarning]
rwWarnings = []
, rwSupply :: Supply
rwSupply = RenamerInfo -> Supply
renSupply RenamerInfo
info
, rwNameUseCount :: Map Name Int
rwNameUseCount = Map Name Int
forall k a. Map k a
Map.empty
, rwExternalDeps :: IfaceDecls
rwExternalDeps = IfaceDecls
forall a. Monoid a => a
mempty
, rwCurrentDeps :: Set Name
rwCurrentDeps = Set Name
forall a. Set a
Set.empty
, rwDepGraph :: Map DepName (Set Name)
rwDepGraph = Map DepName (Set Name)
forall k a. Map k a
Map.empty
}
ro :: RO
ro = RO :: Range
-> NamingEnv
-> (ModName -> Iface)
-> ModPath
-> Map ModPath Name
-> RO
RO { roLoc :: Range
roLoc = Range
emptyRange
, roNames :: NamingEnv
roNames = RenamerInfo -> NamingEnv
renEnv RenamerInfo
info
, roIfaces :: ModName -> Iface
roIfaces = RenamerInfo -> ModName -> Iface
renIfaces RenamerInfo
info
, roCurMod :: ModPath
roCurMod = RenamerInfo -> ModPath
renContext RenamerInfo
info
, roNestedMods :: Map ModPath Name
roNestedMods = Map ModPath Name
forall k a. Map k a
Map.empty
}
res :: Either [RenamerError] (a, Supply)
res | Seq RenamerError -> Bool
forall a. Seq a -> Bool
Seq.null (RW -> Seq RenamerError
rwErrors RW
rw) = (a, Supply) -> Either [RenamerError] (a, Supply)
forall a b. b -> Either a b
Right (a
a,RW -> Supply
rwSupply RW
rw)
| Bool
otherwise = [RenamerError] -> Either [RenamerError] (a, Supply)
forall a b. a -> Either a b
Left (Seq RenamerError -> [RenamerError]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (RW -> Seq RenamerError
rwErrors RW
rw))
setCurMod :: ModPath -> RenameM a -> RenameM a
setCurMod :: ModPath -> RenameM a -> RenameM a
setCurMod ModPath
mpath (RenameM ReaderT RO (StateT RW Lift) a
m) =
ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) a -> RenameM a)
-> ReaderT RO (StateT RW Lift) a -> RenameM a
forall a b. (a -> b) -> a -> b
$ (RO -> RO)
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) a
forall (m :: * -> *) r a. RunReaderM m r => (r -> r) -> m a -> m a
mapReader (\RO
ro -> RO
ro { roCurMod :: ModPath
roCurMod = ModPath
mpath }) ReaderT RO (StateT RW Lift) a
m
getCurMod :: RenameM ModPath
getCurMod :: RenameM ModPath
getCurMod = ReaderT RO (StateT RW Lift) ModPath -> RenameM ModPath
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) ModPath -> RenameM ModPath)
-> ReaderT RO (StateT RW Lift) ModPath -> RenameM ModPath
forall a b. (a -> b) -> a -> b
$ (RO -> ModPath) -> ReaderT RO (StateT RW Lift) ModPath
forall (m :: * -> *) r a. ReaderM m r => (r -> a) -> m a
asks RO -> ModPath
roCurMod
getNamingEnv :: RenameM NamingEnv
getNamingEnv :: RenameM NamingEnv
getNamingEnv = ReaderT RO (StateT RW Lift) NamingEnv -> RenameM NamingEnv
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ((RO -> NamingEnv) -> ReaderT RO (StateT RW Lift) NamingEnv
forall (m :: * -> *) r a. ReaderM m r => (r -> a) -> m a
asks RO -> NamingEnv
roNames)
setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a
setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a
setNestedModule Map ModPath Name
mp (RenameM ReaderT RO (StateT RW Lift) a
m) =
ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) a -> RenameM a)
-> ReaderT RO (StateT RW Lift) a -> RenameM a
forall a b. (a -> b) -> a -> b
$ (RO -> RO)
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) a
forall (m :: * -> *) r a. RunReaderM m r => (r -> r) -> m a -> m a
mapReader (\RO
ro -> RO
ro { roNestedMods :: Map ModPath Name
roNestedMods = Map ModPath Name
mp }) ReaderT RO (StateT RW Lift) a
m
nestedModuleOrig :: ModPath -> RenameM (Maybe Name)
nestedModuleOrig :: ModPath -> RenameM (Maybe Name)
nestedModuleOrig ModPath
x = ReaderT RO (StateT RW Lift) (Maybe Name) -> RenameM (Maybe Name)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ((RO -> Maybe Name) -> ReaderT RO (StateT RW Lift) (Maybe Name)
forall (m :: * -> *) r a. ReaderM m r => (r -> a) -> m a
asks (ModPath -> Map ModPath Name -> Maybe Name
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModPath
x (Map ModPath Name -> Maybe Name)
-> (RO -> Map ModPath Name) -> RO -> Maybe Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RO -> Map ModPath Name
roNestedMods))
record :: RenamerError -> RenameM ()
record :: RenamerError -> RenameM ()
record RenamerError
f = ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) () -> RenameM ())
-> ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a b. (a -> b) -> a -> b
$
do RW { [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Seq RenamerError
Set Name
Supply
IfaceDecls
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwSupply :: Supply
rwErrors :: Seq RenamerError
rwWarnings :: [RenamerWarning]
rwExternalDeps :: RW -> IfaceDecls
rwDepGraph :: RW -> Map DepName (Set Name)
rwCurrentDeps :: RW -> Set Name
rwNameUseCount :: RW -> Map Name Int
rwSupply :: RW -> Supply
rwErrors :: RW -> Seq RenamerError
rwWarnings :: RW -> [RenamerWarning]
.. } <- ReaderT RO (StateT RW Lift) RW
forall (m :: * -> *) i. StateM m i => m i
get
RW -> ReaderT RO (StateT RW Lift) ()
forall (m :: * -> *) i. StateM m i => i -> m ()
set RW :: [RenamerWarning]
-> Seq RenamerError
-> Supply
-> Map Name Int
-> Set Name
-> Map DepName (Set Name)
-> IfaceDecls
-> RW
RW { rwErrors :: Seq RenamerError
rwErrors = Seq RenamerError
rwErrors Seq RenamerError -> RenamerError -> Seq RenamerError
forall a. Seq a -> a -> Seq a
Seq.|> RenamerError
f, [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Set Name
Supply
IfaceDecls
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwSupply :: Supply
rwWarnings :: [RenamerWarning]
rwExternalDeps :: IfaceDecls
rwDepGraph :: Map DepName (Set Name)
rwCurrentDeps :: Set Name
rwNameUseCount :: Map Name Int
rwSupply :: Supply
rwWarnings :: [RenamerWarning]
.. }
collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls,a)
collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls, a)
collectIfaceDeps (RenameM ReaderT RO (StateT RW Lift) a
m) =
ReaderT RO (StateT RW Lift) (IfaceDecls, a)
-> RenameM (IfaceDecls, a)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM
do IfaceDecls
ds <- (RW -> (IfaceDecls, RW)) -> ReaderT RO (StateT RW Lift) IfaceDecls
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets \RW
s -> (RW -> IfaceDecls
rwExternalDeps RW
s, RW
s { rwExternalDeps :: IfaceDecls
rwExternalDeps = IfaceDecls
forall a. Monoid a => a
mempty })
a
a <- ReaderT RO (StateT RW Lift) a
m
IfaceDecls
ds' <- (RW -> (IfaceDecls, RW)) -> ReaderT RO (StateT RW Lift) IfaceDecls
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets \RW
s -> (RW -> IfaceDecls
rwExternalDeps RW
s, RW
s { rwExternalDeps :: IfaceDecls
rwExternalDeps = IfaceDecls
ds })
(IfaceDecls, a) -> ReaderT RO (StateT RW Lift) (IfaceDecls, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IfaceDecls
ds',a
a)
depsOf :: DepName -> RenameM a -> RenameM a
depsOf :: DepName -> RenameM a -> RenameM a
depsOf DepName
x (RenameM ReaderT RO (StateT RW Lift) a
m) = ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM
do Set Name
ds <- (RW -> (Set Name, RW)) -> ReaderT RO (StateT RW Lift) (Set Name)
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets \RW
rw -> (RW -> Set Name
rwCurrentDeps RW
rw, RW
rw { rwCurrentDeps :: Set Name
rwCurrentDeps = Set Name
forall a. Set a
Set.empty })
a
a <- ReaderT RO (StateT RW Lift) a
m
(RW -> RW) -> ReaderT RO (StateT RW Lift) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ \RW
rw ->
RW
rw { rwCurrentDeps :: Set Name
rwCurrentDeps = Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union (RW -> Set Name
rwCurrentDeps RW
rw) Set Name
ds
, rwDepGraph :: Map DepName (Set Name)
rwDepGraph = DepName
-> Set Name -> Map DepName (Set Name) -> Map DepName (Set Name)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DepName
x (RW -> Set Name
rwCurrentDeps RW
rw) (RW -> Map DepName (Set Name)
rwDepGraph RW
rw)
}
a -> ReaderT RO (StateT RW Lift) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
depGroup :: RenameM a -> RenameM (a, Map DepName (Set Name))
depGroup :: RenameM a -> RenameM (a, Map DepName (Set Name))
depGroup (RenameM ReaderT RO (StateT RW Lift) a
m) = ReaderT RO (StateT RW Lift) (a, Map DepName (Set Name))
-> RenameM (a, Map DepName (Set Name))
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM
do Map DepName (Set Name)
ds <- (RW -> (Map DepName (Set Name), RW))
-> ReaderT RO (StateT RW Lift) (Map DepName (Set Name))
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets \RW
rw -> (RW -> Map DepName (Set Name)
rwDepGraph RW
rw, RW
rw { rwDepGraph :: Map DepName (Set Name)
rwDepGraph = Map DepName (Set Name)
forall k a. Map k a
Map.empty })
a
a <- ReaderT RO (StateT RW Lift) a
m
Map DepName (Set Name)
ds1 <- (RW -> (Map DepName (Set Name), RW))
-> ReaderT RO (StateT RW Lift) (Map DepName (Set Name))
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets \RW
rw -> (RW -> Map DepName (Set Name)
rwDepGraph RW
rw, RW
rw { rwDepGraph :: Map DepName (Set Name)
rwDepGraph = Map DepName (Set Name)
ds })
(a, Map DepName (Set Name))
-> ReaderT RO (StateT RW Lift) (a, Map DepName (Set Name))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a,Map DepName (Set Name)
ds1)
curLoc :: RenameM Range
curLoc :: RenameM Range
curLoc = ReaderT RO (StateT RW Lift) Range -> RenameM Range
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> Range
roLoc (RO -> Range)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) Range
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask)
located :: a -> RenameM (Located a)
located :: a -> RenameM (Located a)
located a
thing =
do Range
srcRange <- RenameM Range
curLoc
Located a -> RenameM (Located a)
forall (m :: * -> *) a. Monad m => a -> m a
return Located :: forall a. Range -> a -> Located a
Located { a
Range
thing :: a
srcRange :: Range
srcRange :: Range
thing :: a
.. }
withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a
withLoc :: loc -> RenameM a -> RenameM a
withLoc loc
loc RenameM a
m = ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) a -> RenameM a)
-> ReaderT RO (StateT RW Lift) a -> RenameM a
forall a b. (a -> b) -> a -> b
$ case loc -> Maybe Range
forall t. HasLoc t => t -> Maybe Range
getLoc loc
loc of
Just Range
range -> do
RO
ro <- ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
RO
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local RO
ro { roLoc :: Range
roLoc = Range
range } (RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m)
Maybe Range
Nothing -> RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m
shadowNames :: BindsNames env => env -> RenameM a -> RenameM a
shadowNames :: env -> RenameM a -> RenameM a
shadowNames = EnvCheck -> env -> RenameM a -> RenameM a
forall env a.
BindsNames env =>
EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' EnvCheck
CheckAll
data EnvCheck = CheckAll
| CheckOverlap
| CheckNone
deriving (EnvCheck -> EnvCheck -> Bool
(EnvCheck -> EnvCheck -> Bool)
-> (EnvCheck -> EnvCheck -> Bool) -> Eq EnvCheck
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnvCheck -> EnvCheck -> Bool
$c/= :: EnvCheck -> EnvCheck -> Bool
== :: EnvCheck -> EnvCheck -> Bool
$c== :: EnvCheck -> EnvCheck -> Bool
Eq,Int -> EnvCheck -> ShowS
[EnvCheck] -> ShowS
EnvCheck -> String
(Int -> EnvCheck -> ShowS)
-> (EnvCheck -> String) -> ([EnvCheck] -> ShowS) -> Show EnvCheck
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnvCheck] -> ShowS
$cshowList :: [EnvCheck] -> ShowS
show :: EnvCheck -> String
$cshow :: EnvCheck -> String
showsPrec :: Int -> EnvCheck -> ShowS
$cshowsPrec :: Int -> EnvCheck -> ShowS
Show)
shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' :: EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' EnvCheck
check env
names RenameM a
m = do
do NamingEnv
env <- (Supply -> (NamingEnv, Supply)) -> RenameM NamingEnv
forall (m :: * -> *) a. FreshM m => (Supply -> (a, Supply)) -> m a
liftSupply (env -> Supply -> (NamingEnv, Supply)
forall a. BindsNames a => a -> Supply -> (NamingEnv, Supply)
defsOf env
names)
ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) a -> RenameM a)
-> ReaderT RO (StateT RW Lift) a -> RenameM a
forall a b. (a -> b) -> a -> b
$
do RO
ro <- ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
NamingEnv
env' <- (RW -> (NamingEnv, RW)) -> ReaderT RO (StateT RW Lift) NamingEnv
forall (m :: * -> *) s a. StateM m s => (s -> (a, s)) -> m a
sets (EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv, RW)
checkEnv EnvCheck
check NamingEnv
env (RO -> NamingEnv
roNames RO
ro))
let ro' :: RO
ro' = RO
ro { roNames :: NamingEnv
roNames = NamingEnv
env' NamingEnv -> NamingEnv -> NamingEnv
`shadowing` RO -> NamingEnv
roNames RO
ro }
RO
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) a
forall (m :: * -> *) i a. RunReaderM m i => i -> m a -> m a
local RO
ro' (RenameM a -> ReaderT RO (StateT RW Lift) a
forall a. RenameM a -> ReaderT RO (StateT RW Lift) a
unRenameM RenameM a
m)
checkEnv :: EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv,RW)
checkEnv :: EnvCheck -> NamingEnv -> NamingEnv -> RW -> (NamingEnv, RW)
checkEnv EnvCheck
check (NamingEnv Map Namespace (Map PName [Name])
lenv) NamingEnv
r RW
rw0
| EnvCheck
check EnvCheck -> EnvCheck -> Bool
forall a. Eq a => a -> a -> Bool
== EnvCheck
CheckNone = (NamingEnv
newEnv,RW
rw0)
| Bool
otherwise = (NamingEnv
newEnv,RW
rwFin)
where
newEnv :: NamingEnv
newEnv = Map Namespace (Map PName [Name]) -> NamingEnv
NamingEnv Map Namespace (Map PName [Name])
newMap
(RW
rwFin,Map Namespace (Map PName [Name])
newMap) = (RW -> Namespace -> Map PName [Name] -> (RW, Map PName [Name]))
-> RW
-> Map Namespace (Map PName [Name])
-> (RW, Map Namespace (Map PName [Name]))
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumWithKey RW -> Namespace -> Map PName [Name] -> (RW, Map PName [Name])
doNS RW
rw0 Map Namespace (Map PName [Name])
lenv
doNS :: RW -> Namespace -> Map PName [Name] -> (RW, Map PName [Name])
doNS RW
rw Namespace
ns = (RW -> PName -> [Name] -> (RW, [Name]))
-> RW -> Map PName [Name] -> (RW, Map PName [Name])
forall a k b c.
(a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)
Map.mapAccumWithKey (Namespace -> RW -> PName -> [Name] -> (RW, [Name])
step Namespace
ns) RW
rw
step :: Namespace -> RW -> PName -> [Name] -> (RW, [Name])
step Namespace
ns RW
acc PName
k [Name]
xs = (RW
acc', case EnvCheck
check of
EnvCheck
CheckNone -> [Name]
xs
EnvCheck
_ -> [[Name] -> Name
forall a. [a] -> a
head [Name]
xs]
)
where
acc' :: RW
acc' = RW
acc
{ rwWarnings :: [RenamerWarning]
rwWarnings =
if EnvCheck
check EnvCheck -> EnvCheck -> Bool
forall a. Eq a => a -> a -> Bool
== EnvCheck
CheckAll
then case PName -> Map PName [Name] -> Maybe [Name]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PName
k (Namespace -> NamingEnv -> Map PName [Name]
namespaceMap Namespace
ns NamingEnv
r) of
Just [Name]
os | [x] <- [Name]
xs
, let os' :: [Name]
os' = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/=Name
x) [Name]
os
, Bool -> Bool
not ([Name] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
os') ->
PName -> Name -> [Name] -> RenamerWarning
SymbolShadowed PName
k Name
x [Name]
os' RenamerWarning -> [RenamerWarning] -> [RenamerWarning]
forall a. a -> [a] -> [a]
: RW -> [RenamerWarning]
rwWarnings RW
acc
Maybe [Name]
_ -> RW -> [RenamerWarning]
rwWarnings RW
acc
else RW -> [RenamerWarning]
rwWarnings RW
acc
, rwErrors :: Seq RenamerError
rwErrors = RW -> Seq RenamerError
rwErrors RW
acc Seq RenamerError -> Seq RenamerError -> Seq RenamerError
forall a. Seq a -> Seq a -> Seq a
Seq.>< [Name] -> Seq RenamerError
containsOverlap [Name]
xs
}
containsOverlap :: [Name] -> Seq.Seq RenamerError
containsOverlap :: [Name] -> Seq RenamerError
containsOverlap [Name
_] = Seq RenamerError
forall a. Seq a
Seq.empty
containsOverlap [] = String -> [String] -> Seq RenamerError
forall a. HasCallStack => String -> [String] -> a
panic String
"Renamer" [String
"Invalid naming environment"]
containsOverlap [Name]
ns = RenamerError -> Seq RenamerError
forall a. a -> Seq a
Seq.singleton ([Name] -> RenamerError
OverlappingSyms [Name]
ns)
recordUse :: Name -> RenameM ()
recordUse :: Name -> RenameM ()
recordUse Name
x = ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) () -> RenameM ())
-> ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a b. (a -> b) -> a -> b
$ (RW -> RW) -> ReaderT RO (StateT RW Lift) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ ((RW -> RW) -> ReaderT RO (StateT RW Lift) ())
-> (RW -> RW) -> ReaderT RO (StateT RW Lift) ()
forall a b. (a -> b) -> a -> b
$ \RW
rw ->
RW
rw { rwNameUseCount :: Map Name Int
rwNameUseCount = (Int -> Int -> Int) -> Name -> Int -> Map Name Int -> Map Name Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Name
x Int
1 (RW -> Map Name Int
rwNameUseCount RW
rw) }
addDep :: Name -> RenameM ()
addDep :: Name -> RenameM ()
addDep Name
x =
do ModPath
cur <- RenameM ModPath
getCurMod
Set Name
deps <- case Name -> NameInfo
nameInfo Name
x of
Declared ModPath
m NameSource
_ | Just (ModPath
c,[Ident]
_,Ident
i:[Ident]
_) <- ModPath -> ModPath -> Maybe (ModPath, [Ident], [Ident])
modPathCommon ModPath
cur ModPath
m ->
do Maybe Name
mb <- ModPath -> RenameM (Maybe Name)
nestedModuleOrig (ModPath -> Ident -> ModPath
Nested ModPath
c Ident
i)
Set Name -> RenameM (Set Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure case Maybe Name
mb of
Just Name
y -> [Name] -> Set Name
forall a. Ord a => [a] -> Set a
Set.fromList [Name
x,Name
y]
Maybe Name
Nothing -> Name -> Set Name
forall a. a -> Set a
Set.singleton Name
x
NameInfo
_ -> Set Name -> RenameM (Set Name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Set Name
forall a. a -> Set a
Set.singleton Name
x)
ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) () -> RenameM ())
-> ReaderT RO (StateT RW Lift) () -> RenameM ()
forall a b. (a -> b) -> a -> b
$
(RW -> RW) -> ReaderT RO (StateT RW Lift) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ \RW
rw -> RW
rw { rwCurrentDeps :: Set Name
rwCurrentDeps = Set Name -> Set Name -> Set Name
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Name
deps (RW -> Set Name
rwCurrentDeps RW
rw) }
warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning]
warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning]
warnUnused ModPath
m0 NamingEnv
env RW
rw =
(Name -> RenamerWarning) -> [Name] -> [RenamerWarning]
forall a b. (a -> b) -> [a] -> [b]
map Name -> RenamerWarning
warn
([Name] -> [RenamerWarning]) -> [Name] -> [RenamerWarning]
forall a b. (a -> b) -> a -> b
$ Map Name Int -> [Name]
forall k a. Map k a -> [k]
Map.keys
(Map Name Int -> [Name]) -> Map Name Int -> [Name]
forall a b. (a -> b) -> a -> b
$ (Name -> Int -> Bool) -> Map Name Int -> Map Name Int
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey Name -> Int -> Bool
forall a. (Eq a, Num a) => Name -> a -> Bool
keep
(Map Name Int -> Map Name Int) -> Map Name Int -> Map Name Int
forall a b. (a -> b) -> a -> b
$ RW -> Map Name Int
rwNameUseCount RW
rw
where
warn :: Name -> RenamerWarning
warn Name
x = Name -> RenamerWarning
UnusedName Name
x
keep :: Name -> a -> Bool
keep Name
nm a
count = a
count a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 Bool -> Bool -> Bool
&& Name -> Bool
isLocal Name
nm
oldNames :: Set Name
oldNames = Set Name -> Namespace -> Map Namespace (Set Name) -> Set Name
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Set Name
forall a. Set a
Set.empty Namespace
NSType (NamingEnv -> Map Namespace (Set Name)
visibleNames NamingEnv
env)
isLocal :: Name -> Bool
isLocal Name
nm = case Name -> NameInfo
nameInfo Name
nm of
Declared ModPath
m NameSource
sys -> NameSource
sys NameSource -> NameSource -> Bool
forall a. Eq a => a -> a -> Bool
== NameSource
UserName Bool -> Bool -> Bool
&&
ModPath
m ModPath -> ModPath -> Bool
forall a. Eq a => a -> a -> Bool
== ModPath
m0 Bool -> Bool -> Bool
&& Name
nm Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
oldNames
NameInfo
Parameter -> Bool
True
lookupImport :: Import -> RenameM IfaceDecls
lookupImport :: Import -> RenameM IfaceDecls
lookupImport Import
imp = ReaderT RO (StateT RW Lift) IfaceDecls -> RenameM IfaceDecls
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (ReaderT RO (StateT RW Lift) IfaceDecls -> RenameM IfaceDecls)
-> ReaderT RO (StateT RW Lift) IfaceDecls -> RenameM IfaceDecls
forall a b. (a -> b) -> a -> b
$
do ModName -> Iface
getIf <- RO -> ModName -> Iface
roIfaces (RO -> ModName -> Iface)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) (ModName -> Iface)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
let ifs :: IfaceDecls
ifs = Iface -> IfaceDecls
forall mname. IfaceG mname -> IfaceDecls
ifPublic (ModName -> Iface
getIf (Import -> ModName
forall mname. ImportG mname -> mname
iModule Import
imp))
(RW -> RW) -> ReaderT RO (StateT RW Lift) ()
forall (m :: * -> *) s. StateM m s => (s -> s) -> m ()
sets_ \RW
s -> RW
s { rwExternalDeps :: IfaceDecls
rwExternalDeps = IfaceDecls
ifs IfaceDecls -> IfaceDecls -> IfaceDecls
forall a. Semigroup a => a -> a -> a
<> RW -> IfaceDecls
rwExternalDeps RW
s }
IfaceDecls -> ReaderT RO (StateT RW Lift) IfaceDecls
forall (f :: * -> *) a. Applicative f => a -> f a
pure IfaceDecls
ifs