-- |
-- 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 #-}
{-# Language OverloadedStrings #-}
module Cryptol.ModuleSystem.Renamer.Monad where

import Data.List(sort,foldl')
import           Data.Set(Set)
import qualified Data.Set as Set
import           Data.Map.Strict ( Map )
import qualified Data.Map.Strict as Map
import qualified Data.Semigroup as S
import           MonadLib hiding (mapM, mapM_)

import Prelude ()
import Prelude.Compat

import Cryptol.Utils.PP(pp)
import Cryptol.Utils.Panic(panic)
import Cryptol.Utils.Ident(modPathCommon,OrigName(..),OrigSource(..))
import Cryptol.ModuleSystem.Name
import Cryptol.ModuleSystem.NamingEnv
import Cryptol.ModuleSystem.Binds
import Cryptol.ModuleSystem.Interface
import Cryptol.Parser.AST
import Cryptol.TypeCheck.AST(ModParamNames)
import Cryptol.Parser.Position

import Cryptol.ModuleSystem.Renamer.Error
import Cryptol.ModuleSystem.Renamer.Imports
  (ResolvedLocal,rmodKind,rmodDefines,rmodNested)

-- | 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 -> Map ModName (Either ModParamNames Iface)
renIfaces   :: Map ModName (Either ModParamNames Iface)
    -- ^ External modules
  }

newtype RenameM a = RenameM { forall a. 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 -> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
roExternal  :: Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
    -- ^ Externally loaded modules. `Mod` is defined in 'Cryptol.Renamer.Binds'.

  , RO -> ModPath
roCurMod    :: ModPath               -- ^ Current module we are working on

  , RO -> Map ModPath Name
roNestedMods :: Map ModPath Name
    {- ^ Maps module paths to the actual name for it.   This is used
         for dependency tracking, to find the name of a containing module.
         See the note on `addDep`. -}

  , RO -> Map (ImpName Name) ResolvedLocal
roResolvedModules :: Map (ImpName Name) ResolvedLocal
    -- ^ Info about locally defined modules

  , RO -> Map Ident RenModParam
roModParams :: Map Ident RenModParam
    {- ^ Module parameters.  These are used when rename the module parameters,
       and only refer to the parameters of the current module (i.e., no
       outer parameters as those are not needed) -}

  , RO -> Map Name DepName
roFromModParam :: Map Name DepName
    -- ^ Keeps track of which names were introduce by module parameters
    -- and which one.  The `DepName` is always a `ModParamName`.
  }

data RW = RW
  { RW -> [RenamerWarning]
rwWarnings      :: ![RenamerWarning]
  , RW -> Set RenamerError
rwErrors        :: !(Set 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, from external modules
  }



data RenModParam = RenModParam
  { RenModParam -> Ident
renModParamName      :: Ident
  , RenModParam -> Range
renModParamRange     :: Range
  , RenModParam -> ImpName Name
renModParamSig       :: ImpName Name
  , RenModParam -> Map Name Name
renModParamInstance  :: Map Name Name
    {- ^ Maps names that come into scope through this parameter
         to the names in the *module interface*.
         This is for functors, NOT functor instantantiations. -}
  }




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 a. 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 a. 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 :: forall a b. (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 a b.
(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 :: forall a. 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 a. a -> ReaderT RO (StateT RW Lift) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x)

  {-# INLINE (<*>) #-}
  RenameM (a -> b)
l <*> :: forall a b. 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 a b.
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 :: forall a. a -> RenameM a
return        = a -> RenameM a
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  {-# INLINE (>>=) #-}
  RenameM a
m >>= :: forall a b. 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 a b.
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 :: forall a. (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)
Set Name
Set RenamerError
Supply
IfaceDecls
rwWarnings :: RW -> [RenamerWarning]
rwErrors :: RW -> Set RenamerError
rwSupply :: RW -> Supply
rwNameUseCount :: RW -> Map Name Int
rwCurrentDeps :: RW -> Set Name
rwDepGraph :: RW -> Map DepName (Set Name)
rwExternalDeps :: RW -> IfaceDecls
rwWarnings :: [RenamerWarning]
rwErrors :: Set RenamerError
rwSupply :: Supply
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
.. } ->
    let (a
a,Supply
s') = Supply -> (a, Supply)
f Supply
rwSupply
        rw' :: RW
rw'    = RW { rwSupply :: Supply
rwSupply = Supply
s', [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Set Name
Set RenamerError
IfaceDecls
rwWarnings :: [RenamerWarning]
rwErrors :: Set RenamerError
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
rwWarnings :: [RenamerWarning]
rwErrors :: Set RenamerError
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
.. }
     in a
a a -> (a, RW) -> (a, RW)
forall a b. a -> b -> b
`seq` RW
rw' RW -> (a, RW) -> (a, RW)
forall a b. a -> b -> b
`seq` (a
a, RW
rw')


runRenamer :: RenamerInfo -> RenameM a
           -> ( Either [RenamerError] (a,Supply)
              , [RenamerWarning]
              )
runRenamer :: forall a.
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 { rwErrors :: Set RenamerError
rwErrors   = Set RenamerError
forall a. Set a
Set.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 { roLoc :: Range
roLoc   = Range
emptyRange
          , roNames :: NamingEnv
roNames = RenamerInfo -> NamingEnv
renEnv RenamerInfo
info
          , roExternal :: Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
roExternal = (ModName
 -> Either ModParamNames Iface
 -> (Maybe Iface, Map (ImpName Name) (Mod ())))
-> Map ModName (Either ModParamNames Iface)
-> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey ModName
-> Either ModParamNames Iface
-> (Maybe Iface, Map (ImpName Name) (Mod ()))
forall {name}.
ModName
-> Either ModParamNames (IfaceG name)
-> (Maybe (IfaceG name), Map (ImpName Name) (Mod ()))
toModMap (RenamerInfo -> Map ModName (Either ModParamNames 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
          , roResolvedModules :: Map (ImpName Name) ResolvedLocal
roResolvedModules = Map (ImpName Name) ResolvedLocal
forall a. Monoid a => a
mempty
          , roModParams :: Map Ident RenModParam
roModParams = Map Ident RenModParam
forall a. Monoid a => a
mempty
          , roFromModParam :: Map Name DepName
roFromModParam = Map Name DepName
forall a. Monoid a => a
mempty
          }

  res :: Either [RenamerError] (a, Supply)
res | Set RenamerError -> Bool
forall a. Set a -> Bool
Set.null (RW -> Set 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 (Set RenamerError -> [RenamerError]
forall a. Set a -> [a]
Set.toList (RW -> Set RenamerError
rwErrors RW
rw))

  toModMap :: ModName
-> Either ModParamNames (IfaceG name)
-> (Maybe (IfaceG name), Map (ImpName Name) (Mod ()))
toModMap ModName
t Either ModParamNames (IfaceG name)
ent =
    case Either ModParamNames (IfaceG name)
ent of
      Left ModParamNames
ps -> (Maybe (IfaceG name)
forall a. Maybe a
Nothing, ImpName Name -> Mod () -> Map (ImpName Name) (Mod ())
forall k a. k -> a -> Map k a
Map.singleton (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
t) (ModParamNames -> Mod ()
ifaceSigToMod ModParamNames
ps))
      Right IfaceG name
i -> (IfaceG name -> Maybe (IfaceG name)
forall a. a -> Maybe a
Just IfaceG name
i, ImpName Name
-> Mod ()
-> Map (ImpName Name) (Mod ())
-> Map (ImpName Name) (Mod ())
modToMap (ModName -> ImpName Name
forall name. ModName -> ImpName name
ImpTop ModName
t) (IfaceG name -> Mod ()
forall name. IfaceG name -> Mod ()
ifaceToMod IfaceG name
i) Map (ImpName Name) (Mod ())
forall a. Monoid a => a
mempty)



setCurMod :: ModPath -> RenameM a -> RenameM a
setCurMod :: forall a. 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 = 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)

setResolvedLocals :: Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a
setResolvedLocals :: forall a.
Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a
setResolvedLocals Map (ImpName Name) ResolvedLocal
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 { roResolvedModules = mp }) ReaderT RO (StateT RW Lift) a
m

lookupResolved :: ImpName Name -> RenameM ResolvedLocal
lookupResolved :: ImpName Name -> RenameM ResolvedLocal
lookupResolved ImpName Name
nm =
  do Map (ImpName Name) ResolvedLocal
mp <- ReaderT RO (StateT RW Lift) (Map (ImpName Name) ResolvedLocal)
-> RenameM (Map (ImpName Name) ResolvedLocal)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> Map (ImpName Name) ResolvedLocal
roResolvedModules (RO -> Map (ImpName Name) ResolvedLocal)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) (Map (ImpName Name) ResolvedLocal)
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)
     ResolvedLocal -> RenameM ResolvedLocal
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case ImpName Name
-> Map (ImpName Name) ResolvedLocal -> Maybe ResolvedLocal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ImpName Name
nm Map (ImpName Name) ResolvedLocal
mp of
            Just ResolvedLocal
r  -> ResolvedLocal
r

            -- XXX: could this happen because we couldn't resolve a module?
            Maybe ResolvedLocal
Nothing -> [Char] -> [[Char]] -> ResolvedLocal
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"lookupResolved"
                        [ [Char]
"Missing module: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ImpName Name -> [Char]
forall a. Show a => a -> [Char]
show ImpName Name
nm ]

setModParams :: [RenModParam] -> RenameM a -> RenameM a
setModParams :: forall a. [RenModParam] -> RenameM a -> RenameM a
setModParams [RenModParam]
ps (RenameM ReaderT RO (StateT RW Lift) a
m) =
  do let pmap :: Map Ident RenModParam
pmap = [(Ident, RenModParam)] -> Map Ident RenModParam
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (RenModParam -> Ident
renModParamName RenModParam
p, RenModParam
p) | RenModParam
p <- [RenModParam]
ps ]

         newFrom :: Map Name DepName
newFrom =
           [RenModParam]
-> Map Name DepName
-> (RenModParam -> Map Name DepName -> Map Name DepName)
-> Map Name DepName
forall a b. [a] -> b -> (a -> b -> b) -> b
foldLoop [RenModParam]
ps Map Name DepName
forall a. Monoid a => a
mempty \RenModParam
p Map Name DepName
mp ->
             let nm :: DepName
nm = Range -> Ident -> DepName
ModParamName (RenModParam -> Range
renModParamRange RenModParam
p) (RenModParam -> Ident
renModParamName RenModParam
p)
             in [Name]
-> Map Name DepName
-> (Name -> Map Name DepName -> Map Name DepName)
-> Map Name DepName
forall a b. [a] -> b -> (a -> b -> b) -> b
foldLoop (Map Name Name -> [Name]
forall k a. Map k a -> [k]
Map.keys (RenModParam -> Map Name Name
renModParamInstance RenModParam
p)) Map Name DepName
mp \Name
x ->
                  Name -> DepName -> Map Name DepName -> Map Name DepName
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Name
x DepName
nm

         upd :: RO -> RO
upd RO
ro = RO
ro { roModParams    = pmap
                     , roFromModParam = newFrom <> roFromModParam ro
                     }

     ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ((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
upd ReaderT RO (StateT RW Lift) a
m)


foldLoop :: [a] -> b -> (a -> b -> b) -> b
foldLoop :: forall a b. [a] -> b -> (a -> b -> b) -> b
foldLoop [a]
xs b
b a -> b -> b
f = (b -> a -> b) -> b -> [a] -> b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((a -> b -> b) -> b -> a -> b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> b
f) b
b [a]
xs

getModParam :: Ident -> RenameM RenModParam
getModParam :: Ident -> RenameM RenModParam
getModParam Ident
p =
  do Map Ident RenModParam
ps <- ReaderT RO (StateT RW Lift) (Map Ident RenModParam)
-> RenameM (Map Ident RenModParam)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> Map Ident RenModParam
roModParams (RO -> Map Ident RenModParam)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) (Map Ident RenModParam)
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)
     case Ident -> Map Ident RenModParam -> Maybe RenModParam
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ident
p Map Ident RenModParam
ps of
       Just RenModParam
r  -> RenModParam -> RenameM RenModParam
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RenModParam
r
       Maybe RenModParam
Nothing -> [Char] -> [[Char]] -> RenameM RenModParam
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"getModParam" [ [Char]
"Missing module paramter", Ident -> [Char]
forall a. Show a => a -> [Char]
show Ident
p ]

getNamesFromModParams :: RenameM (Map Name DepName)
getNamesFromModParams :: RenameM (Map Name DepName)
getNamesFromModParams = ReaderT RO (StateT RW Lift) (Map Name DepName)
-> RenameM (Map Name DepName)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> Map Name DepName
roFromModParam (RO -> Map Name DepName)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) (Map Name DepName)
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)

getLocalModParamDeps :: RenameM (Map Ident DepName)
getLocalModParamDeps :: RenameM (Map Ident DepName)
getLocalModParamDeps =
  do Map Ident RenModParam
ps <- ReaderT RO (StateT RW Lift) (Map Ident RenModParam)
-> RenameM (Map Ident RenModParam)
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> Map Ident RenModParam
roModParams (RO -> Map Ident RenModParam)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) (Map Ident RenModParam)
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 toName :: RenModParam -> DepName
toName RenModParam
mp = Range -> Ident -> DepName
ModParamName (RenModParam -> Range
renModParamRange RenModParam
mp) (RenModParam -> Ident
renModParamName RenModParam
mp)
     Map Ident DepName -> RenameM (Map Ident DepName)
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RenModParam -> DepName
toName (RenModParam -> DepName)
-> Map Ident RenModParam -> Map Ident DepName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map Ident RenModParam
ps)


setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a
setNestedModule :: forall a. 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 = 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.
recordError :: RenamerError -> RenameM ()
recordError :: RenamerError -> RenameM ()
recordError 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)
Set Name
Set RenamerError
Supply
IfaceDecls
rwWarnings :: RW -> [RenamerWarning]
rwErrors :: RW -> Set RenamerError
rwSupply :: RW -> Supply
rwNameUseCount :: RW -> Map Name Int
rwCurrentDeps :: RW -> Set Name
rwDepGraph :: RW -> Map DepName (Set Name)
rwExternalDeps :: RW -> IfaceDecls
rwWarnings :: [RenamerWarning]
rwErrors :: Set RenamerError
rwSupply :: Supply
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
.. } <- 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 { rwErrors :: Set RenamerError
rwErrors = RenamerError -> Set RenamerError -> Set RenamerError
forall a. Ord a => a -> Set a -> Set a
Set.insert RenamerError
f Set RenamerError
rwErrors, [RenamerWarning]
Map Name Int
Map DepName (Set Name)
Set Name
Supply
IfaceDecls
rwWarnings :: [RenamerWarning]
rwSupply :: Supply
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
rwWarnings :: [RenamerWarning]
rwSupply :: Supply
rwNameUseCount :: Map Name Int
rwCurrentDeps :: Set Name
rwDepGraph :: Map DepName (Set Name)
rwExternalDeps :: IfaceDecls
.. }

recordWarning :: RenamerWarning -> RenameM ()
recordWarning :: RenamerWarning -> RenameM ()
recordWarning RenamerWarning
w =
  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 { rwWarnings = w : rwWarnings rw }

collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls,a)
collectIfaceDeps :: forall a. 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 = 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 = ds })
     (IfaceDecls, a) -> ReaderT RO (StateT RW Lift) (IfaceDecls, a)
forall a. a -> ReaderT RO (StateT RW Lift) 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 :: forall a. 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.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.union (rwCurrentDeps rw) ds
           , rwDepGraph = Map.insert x (rwCurrentDeps rw) (rwDepGraph rw)
           }
     a -> ReaderT RO (StateT RW Lift) a
forall a. 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 defined in 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 :: forall a. 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.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 = ds })
     (a, Map DepName (Set Name))
-> ReaderT RO (StateT RW Lift) (a, Map DepName (Set Name))
forall a. a -> ReaderT RO (StateT RW Lift) a
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 a b.
(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` 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 :: forall a. a -> RenameM (Located a)
located a
thing =
  do Range
srcRange <- RenameM Range
curLoc
     Located a -> RenameM (Located a)
forall a. a -> RenameM a
forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: forall loc a. HasLoc loc => 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 a.
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 } (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 :: forall env a. BindsNames env => 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
$c== :: EnvCheck -> EnvCheck -> Bool
== :: EnvCheck -> EnvCheck -> Bool
$c/= :: EnvCheck -> EnvCheck -> Bool
/= :: EnvCheck -> EnvCheck -> Bool
Eq,Int -> EnvCheck -> [Char] -> [Char]
[EnvCheck] -> [Char] -> [Char]
EnvCheck -> [Char]
(Int -> EnvCheck -> [Char] -> [Char])
-> (EnvCheck -> [Char])
-> ([EnvCheck] -> [Char] -> [Char])
-> Show EnvCheck
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> EnvCheck -> [Char] -> [Char]
showsPrec :: Int -> EnvCheck -> [Char] -> [Char]
$cshow :: EnvCheck -> [Char]
show :: EnvCheck -> [Char]
$cshowList :: [EnvCheck] -> [Char] -> [Char]
showList :: [EnvCheck] -> [Char] -> [Char]
Show)

-- | Report errors if the given naming environemnt contains multiple
-- definitions for the same symbol
checkOverlap :: NamingEnv -> RenameM NamingEnv
checkOverlap :: NamingEnv -> RenameM NamingEnv
checkOverlap NamingEnv
env =
  case NamingEnv -> [[Name]]
findAmbig NamingEnv
env of
    []    -> NamingEnv -> RenameM NamingEnv
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamingEnv
env
    [[Name]]
ambig -> do (RenamerError -> RenameM ()) -> [RenamerError] -> RenameM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RenamerError -> RenameM ()
recordError [ [Name] -> RenamerError
OverlappingSyms [Name]
xs | [Name]
xs <- [[Name]]
ambig ]
                NamingEnv -> RenameM NamingEnv
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NamingEnv -> NamingEnv
forceUnambig NamingEnv
env)

-- | Issue warnings if entries in the first environment would
-- shadow something in the second.
checkShadowing :: NamingEnv -> NamingEnv -> RenameM ()
checkShadowing :: NamingEnv -> NamingEnv -> RenameM ()
checkShadowing NamingEnv
envNew NamingEnv
envOld =
  (RenamerWarning -> RenameM ()) -> [RenamerWarning] -> RenameM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RenamerWarning -> RenameM ()
recordWarning
    [ PName -> Name -> [Name] -> RenamerWarning
SymbolShadowed PName
p Name
x [Name]
xs | (PName
p,Name
x,[Name]
xs) <- NamingEnv -> NamingEnv -> [(PName, Name, [Name])]
findShadowing NamingEnv
envNew NamingEnv
envOld ]


-- | Shadow the current naming environment with some more names.
-- XXX: The checks are really confusing
shadowNames' :: BindsNames env => EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' :: forall env a.
BindsNames env =>
EnvCheck -> env -> RenameM a -> RenameM a
shadowNames' EnvCheck
check env
names RenameM a
m = do
  do NamingEnv
env    <- (Supply -> (NamingEnv, Supply)) -> RenameM NamingEnv
forall a. (Supply -> (a, Supply)) -> RenameM a
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)
     NamingEnv
envOld <- ReaderT RO (StateT RW Lift) NamingEnv -> RenameM NamingEnv
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM (RO -> NamingEnv
roNames (RO -> NamingEnv)
-> ReaderT RO (StateT RW Lift) RO
-> ReaderT RO (StateT RW Lift) NamingEnv
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)
     NamingEnv
env1   <- case EnvCheck
check of
                 EnvCheck
CheckNone    -> NamingEnv -> RenameM NamingEnv
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamingEnv
env
                 EnvCheck
CheckOverlap -> NamingEnv -> RenameM NamingEnv
checkOverlap NamingEnv
env
                 EnvCheck
CheckAll     -> do NamingEnv -> NamingEnv -> RenameM ()
checkShadowing NamingEnv
env NamingEnv
envOld
                                    NamingEnv -> RenameM NamingEnv
checkOverlap NamingEnv
env
     ReaderT RO (StateT RW Lift) a -> RenameM a
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM
       do RO
ro  <- ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
          let ro' :: RO
ro' = RO
ro { roNames = env1 `shadowing` envOld }
          RO
-> ReaderT RO (StateT RW Lift) a -> ReaderT RO (StateT RW Lift) a
forall a.
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)

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.insertWith (+) x 1 (rwNameUseCount 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
               GlobalName NameSource
_ OrigName { ogModule :: OrigName -> ModPath
ogModule = ModPath
m }
                 | 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 a. a -> RenameM a
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 a. a -> RenameM a
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.union deps (rwCurrentDeps 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
UnusedName
  ([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
  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)

  -- returns true iff the name comes from a definition in a nested module,
  -- including the current module
  isNestd :: OrigName -> Bool
isNestd OrigName
og = case ModPath -> ModPath -> Maybe (ModPath, [Ident], [Ident])
modPathCommon ModPath
m0 (OrigName -> ModPath
ogModule OrigName
og) of
                 Just (ModPath
_,[],[Ident]
_) | OrigSource
FromDefinition <- OrigName -> OrigSource
ogSource OrigName
og -> Bool
True
                 Maybe (ModPath, [Ident], [Ident])
_ -> Bool
False

  isLocal :: Name -> Bool
isLocal Name
nm = case Name -> NameInfo
nameInfo Name
nm of
                 GlobalName NameSource
sys OrigName
og ->
                   NameSource
sys NameSource -> NameSource -> Bool
forall a. Eq a => a -> a -> Bool
== NameSource
UserName Bool -> Bool -> Bool
&& OrigName -> Bool
isNestd OrigName
og Bool -> Bool -> Bool
&& Name
nm Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Name
oldNames
                 LocalName {} -> Bool
True


getExternal :: RenameM (ImpName Name -> Mod ())
getExternal :: RenameM (ImpName Name -> Mod ())
getExternal =
  do Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
mp <- RO -> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
roExternal (RO -> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ())))
-> RenameM RO
-> RenameM (Map ModName (Maybe Iface, Map (ImpName Name) (Mod ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RO (StateT RW Lift) RO -> RenameM RO
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     (ImpName Name -> Mod ()) -> RenameM (ImpName Name -> Mod ())
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure \ImpName Name
nm -> let mb :: Maybe (Mod ())
mb = do ModName
t   <- case ImpName Name
nm of
                                      ImpTop ModName
t  -> ModName -> Maybe ModName
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModName
t
                                      ImpNested Name
x -> Name -> Maybe ModName
nameTopModuleMaybe Name
x
                             (Maybe Iface
_,Map (ImpName Name) (Mod ())
mp1) <- ModName
-> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
-> Maybe (Maybe Iface, Map (ImpName Name) (Mod ()))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModName
t Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
mp
                             ImpName Name -> Map (ImpName Name) (Mod ()) -> Maybe (Mod ())
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ImpName Name
nm Map (ImpName Name) (Mod ())
mp1
                 in case Maybe (Mod ())
mb of
                      Just Mod ()
m -> Mod ()
m
                      Maybe (Mod ())
Nothing -> [Char] -> [[Char]] -> Mod ()
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"getExternal"
                                    [[Char]
"Missing external name", Doc -> [Char]
forall a. Show a => a -> [Char]
show (ImpName Name -> Doc
forall a. PP a => a -> Doc
pp ImpName Name
nm) ]

getExternalMod :: ImpName Name -> RenameM (Mod ())
getExternalMod :: ImpName Name -> RenameM (Mod ())
getExternalMod ImpName Name
nm = ((ImpName Name -> Mod ()) -> ImpName Name -> Mod ()
forall a b. (a -> b) -> a -> b
$ ImpName Name
nm) ((ImpName Name -> Mod ()) -> Mod ())
-> RenameM (ImpName Name -> Mod ()) -> RenameM (Mod ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RenameM (ImpName Name -> Mod ())
getExternal

-- | Returns `Nothing` if the name does not refer to a module (i.e., it is a sig)
getTopModuleIface :: ImpName Name -> RenameM (Maybe Iface)
getTopModuleIface :: ImpName Name -> RenameM (Maybe Iface)
getTopModuleIface ImpName Name
nm =
  do Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
mp <- RO -> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
roExternal (RO -> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ())))
-> RenameM RO
-> RenameM (Map ModName (Maybe Iface, Map (ImpName Name) (Mod ())))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT RO (StateT RW Lift) RO -> RenameM RO
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     let t :: ModName
t = case ImpName Name
nm of
               ImpTop ModName
t' -> ModName
t'
               ImpNested Name
x -> Name -> ModName
nameTopModule Name
x
     case ModName
-> Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
-> Maybe (Maybe Iface, Map (ImpName Name) (Mod ()))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModName
t Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
mp of
       Just (Maybe Iface
mb, Map (ImpName Name) (Mod ())
_) -> Maybe Iface -> RenameM (Maybe Iface)
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Iface
mb
       Maybe (Maybe Iface, Map (ImpName Name) (Mod ()))
Nothing -> [Char] -> [[Char]] -> RenameM (Maybe Iface)
forall a. HasCallStack => [Char] -> [[Char]] -> a
panic [Char]
"getTopModuleIface"
                                [[Char]
"Missing external module", Doc -> [Char]
forall a. Show a => a -> [Char]
show (ImpName Name -> Doc
forall a. PP a => a -> Doc
pp ImpName Name
nm) ]

{- | Record an import:
      * record external dependency if the name refers to an external import
      * record an error if the imported thing is a functor
-}
recordImport :: Range -> ImpName Name -> RenameM ()
recordImport :: Range -> ImpName Name -> RenameM ()
recordImport Range
r ImpName Name
i =
  do RO
ro <- ReaderT RO (StateT RW Lift) RO -> RenameM RO
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     case ImpName Name
-> Map (ImpName Name) ResolvedLocal -> Maybe ResolvedLocal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ImpName Name
i (RO -> Map (ImpName Name) ResolvedLocal
roResolvedModules RO
ro) of
       Just ResolvedLocal
loc ->
         case ResolvedLocal -> ModKind
forall imps. ResolvedModule imps -> ModKind
rmodKind ResolvedLocal
loc of
           ModKind
AModule -> () -> RenameM ()
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
           ModKind
k       -> RenamerError -> RenameM ()
recordError (Range -> ImpName Name -> ModKind -> ModKind -> RenamerError
ModuleKindMismatch Range
r ImpName Name
i ModKind
AModule ModKind
k)
       Maybe ResolvedLocal
Nothing ->
        do Maybe Iface
mb <- ImpName Name -> RenameM (Maybe Iface)
getTopModuleIface ImpName Name
i
           case Maybe Iface
mb of
             Maybe Iface
Nothing -> RenamerError -> RenameM ()
recordError (Range -> ImpName Name -> ModKind -> ModKind -> RenamerError
ModuleKindMismatch Range
r ImpName Name
i ModKind
AModule ModKind
ASignature)
             Just Iface
iface
               | Iface -> Bool
forall name. IfaceG name -> Bool
ifaceIsFunctor Iface
iface ->
                       RenamerError -> RenameM ()
recordError (Range -> ImpName Name -> ModKind -> ModKind -> RenamerError
ModuleKindMismatch Range
r ImpName Name
i ModKind
AModule ModKind
AFunctor)
               | Bool
otherwise ->
                 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
s -> RW
s { rwExternalDeps = ifDefines iface <>
                                                            rwExternalDeps s }


-- | Lookup a name either in the locally resolved thing or in an external module
lookupModuleThing :: ImpName Name -> RenameM (Either ResolvedLocal (Mod ()))
lookupModuleThing :: ImpName Name -> RenameM (Either ResolvedLocal (Mod ()))
lookupModuleThing ImpName Name
nm =
  do RO
ro <- ReaderT RO (StateT RW Lift) RO -> RenameM RO
forall a. ReaderT RO (StateT RW Lift) a -> RenameM a
RenameM ReaderT RO (StateT RW Lift) RO
forall (m :: * -> *) i. ReaderM m i => m i
ask
     case ImpName Name
-> Map (ImpName Name) ResolvedLocal -> Maybe ResolvedLocal
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ImpName Name
nm (RO -> Map (ImpName Name) ResolvedLocal
roResolvedModules RO
ro) of
       Just ResolvedLocal
loc -> Either ResolvedLocal (Mod ())
-> RenameM (Either ResolvedLocal (Mod ()))
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedLocal -> Either ResolvedLocal (Mod ())
forall a b. a -> Either a b
Left ResolvedLocal
loc)
       Maybe ResolvedLocal
Nothing  -> Mod () -> Either ResolvedLocal (Mod ())
forall a b. b -> Either a b
Right (Mod () -> Either ResolvedLocal (Mod ()))
-> RenameM (Mod ()) -> RenameM (Either ResolvedLocal (Mod ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpName Name -> RenameM (Mod ())
getExternalMod ImpName Name
nm

lookupDefines :: ImpName Name -> RenameM NamingEnv
lookupDefines :: ImpName Name -> RenameM NamingEnv
lookupDefines ImpName Name
nm =
  do Either ResolvedLocal (Mod ())
thing <- ImpName Name -> RenameM (Either ResolvedLocal (Mod ()))
lookupModuleThing ImpName Name
nm
     NamingEnv -> RenameM NamingEnv
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case Either ResolvedLocal (Mod ())
thing of
            Left ResolvedLocal
loc -> ResolvedLocal -> NamingEnv
forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedLocal
loc
            Right Mod ()
e  -> Mod () -> NamingEnv
forall a. Mod a -> NamingEnv
modDefines Mod ()
e

checkIsModule :: Range -> ImpName Name -> ModKind -> RenameM ()
checkIsModule :: Range -> ImpName Name -> ModKind -> RenameM ()
checkIsModule Range
r ImpName Name
nm ModKind
expect =
  do Either ResolvedLocal (Mod ())
thing <- ImpName Name -> RenameM (Either ResolvedLocal (Mod ()))
lookupModuleThing ImpName Name
nm
     let actual :: ModKind
actual = case Either ResolvedLocal (Mod ())
thing of
                    Left ResolvedLocal
rmod -> ResolvedLocal -> ModKind
forall imps. ResolvedModule imps -> ModKind
rmodKind ResolvedLocal
rmod
                    Right Mod ()
mo  -> Mod () -> ModKind
forall a. Mod a -> ModKind
modKind Mod ()
mo
     Bool -> RenameM () -> RenameM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ModKind
actual ModKind -> ModKind -> Bool
forall a. Eq a => a -> a -> Bool
== ModKind
expect)
        (RenamerError -> RenameM ()
recordError (Range -> ImpName Name -> ModKind -> ModKind -> RenamerError
ModuleKindMismatch Range
r ImpName Name
nm ModKind
expect ModKind
actual))

lookupDefinesAndSubs :: ImpName Name -> RenameM (NamingEnv, Set Name)
lookupDefinesAndSubs :: ImpName Name -> RenameM (NamingEnv, Set Name)
lookupDefinesAndSubs ImpName Name
nm =
  do Either ResolvedLocal (Mod ())
thing <- ImpName Name -> RenameM (Either ResolvedLocal (Mod ()))
lookupModuleThing ImpName Name
nm
     (NamingEnv, Set Name) -> RenameM (NamingEnv, Set Name)
forall a. a -> RenameM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure case Either ResolvedLocal (Mod ())
thing of
            Left ResolvedLocal
rmod -> ( ResolvedLocal -> NamingEnv
forall imps. ResolvedModule imps -> NamingEnv
rmodDefines ResolvedLocal
rmod, ResolvedLocal -> Set Name
forall imps. ResolvedModule imps -> Set Name
rmodNested ResolvedLocal
rmod)
            Right Mod ()
m ->
              ( Mod () -> NamingEnv
forall a. Mod a -> NamingEnv
modDefines Mod ()
m
              , [Set Name] -> Set Name
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Map Name (Mod ()) -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Mod () -> Map Name (Mod ())
forall a. Mod a -> Map Name (Mod a)
modMods Mod ()
m)
                           , Map Name (ImpName PName, ModuleInstanceArgs PName) -> Set Name
forall k a. Map k a -> Set k
Map.keysSet (Mod () -> Map Name (ImpName PName, ModuleInstanceArgs PName)
forall a.
Mod a -> Map Name (ImpName PName, ModuleInstanceArgs PName)
modInstances Mod ()
m)
                           ]
              )