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

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

-- | Indicates if a name is in a binding poisition or a use site
data NameType = NameBind | NameUse

-- | Information needed to do some renaming.
data RenamerInfo = RenamerInfo
  { RenamerInfo -> Supply
renSupply   :: Supply     -- ^ Use to make new names
  , RenamerInfo -> ModPath
renContext  :: ModPath    -- ^ We are renaming things in here
  , RenamerInfo -> NamingEnv
renEnv      :: NamingEnv  -- ^ This is what's in scope
  , 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           -- ^ Current module we are working on
  , 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)
    -- ^ How many times did we refer to each name.
    -- Used to generate warnings for unused definitions.

  , RW -> Set Name
rwCurrentDeps     :: Set Name
    -- ^ keeps track of names *used* by something.
    -- see 'depsOf'

  , RW -> Map DepName (Set Name)
rwDepGraph        :: Map DepName (Set Name)
    -- ^ keeps track of the dependencies for things.
    -- see 'depsOf'

  , RW -> IfaceDecls
rwExternalDeps  :: !IfaceDecls
    -- ^ Info about imported things
  }



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 an error.  XXX: use a better name
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)

-- |  Rename something.  All name uses in the sub-computation are assumed
-- to be dependenices of the thing.
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

-- | This is used when renaming a group of things.  The result contains
-- dependencies between names defines and the group, and is intended to
-- be used to order the group members in dependency order.
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)

-- | Get the source range for wahtever we are currently renaming.
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)

-- | Annotate something with the current range.
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
.. }

-- | Do the given computation using the source code range from `loc` if any.
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


-- | Shadow the current naming environment with some more names.
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     -- ^ Check for overlap and shadowing
              | CheckOverlap -- ^ Only check for overlap
              | CheckNone    -- ^ Don't check the environment
                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)

-- | Shadow the current naming environment with some more names.
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)

-- | Generate warnings when the left environment shadows things defined in
-- the right.  Additionally, generate errors when two names overlap in the
-- left environment.
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  -- lenv 1 ns at a time
  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

  -- namespace, current state, k : parse name, xs : possible entities for k
  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]
                              -- we've already reported an overlap error,
                              -- so resolve arbitrarily to  the first entry
                      )
    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
      }

-- | Check the RHS of a single name rewrite for conflicting sources.
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) }
  {- NOTE: we don't distinguish between bindings and uses here, because
  the situation is complicated by the pattern signatures where the first
  "use" site is actually the binding site.  Instead we just count them all, and
  something is considered unused if it is used only once (i.e, just the
  binding site) -}

-- | Mark something as a dependency. This is similar but different from
-- `recordUse`, in particular:
--    * We only record use sites, not bindings
--    * We record all namespaces, not just types
--    * We only keep track of actual uses mentioned in the code.
--      Otoh, `recordUse` also considers exported entities to be used.
--    * If we depend on a name from a sibling submodule we add a dependency on
--      the module in our common ancestor.  Examples:
--      - @A::B::x@ depends on @A::B::C::D::y@, @x@ depends on @A::B::C@
--      - @A::B::x@ depends on @A::P::Q::y@@,   @x@ depends on @A::P@

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

-- | Get the exported declarations in a module
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