Monad.hs

-- |
-- 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 #-}
{-# Language MultiParamTypeClasses #-}
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(..),
                           undefinedModName)
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
  { renSupply   :: Supply     -- ^ Use to make new names
  , renContext  :: ModPath    -- ^ We are renaming things in here
  , renEnv      :: NamingEnv  -- ^ This is what's in scope
  , renIfaces   :: Map ModName (Either ModParamNames Iface)
    -- ^ External modules
  }

-- The ExceptionT here is for bailing when a fake value like mkFakeName is
-- encountered. These values have already had an error recorded and are being
-- processed for best-effort error reporting so we do not need a value.
newtype RenameM a = RenameM { unRenameM :: ReaderT RO (ExceptionT () (StateT RW Lift)) a }

data RO = RO
  { roLoc       :: Range
  , roNames     :: NamingEnv
  , roExternal  :: Map ModName (Maybe Iface, Map (ImpName Name) (Mod ()))
    -- ^ Externally loaded modules. `Mod` is defined in 'Cryptol.Renamer.Binds'.

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

  , 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`. -}

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

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

  , 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
  { rwWarnings      :: ![RenamerWarning]
  , rwErrors        :: !(Set RenamerError)
  , rwSupply        :: !Supply
  , rwNameUseCount  :: !(Map Name Int)
    -- ^ How many times did we refer to each name.
    -- Used to generate warnings for unused definitions.

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

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

  , rwExternalDeps  :: !IfaceDecls
    -- ^ Info about imported things, from external modules
  }



data RenModParam = RenModParam
  { renModParamName      :: Ident
  , renModParamRange     :: Range
  , renModParamSig       :: ImpName 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 (<>) #-}
  a <> b =
    do x <- a
       y <- b
       return (x S.<> y)

instance (S.Semigroup a, Monoid a) => Monoid (RenameM a) where
  {-# INLINE mempty #-}
  mempty = return mempty

  {-# INLINE mappend #-}
  mappend = (S.<>)

instance Functor RenameM where
  {-# INLINE fmap #-}
  fmap f m      = RenameM (fmap f (unRenameM m))

instance Applicative RenameM where
  {-# INLINE pure #-}
  pure x        = RenameM (pure x)

  {-# INLINE (<*>) #-}
  l <*> r       = RenameM (unRenameM l <*> unRenameM r)

instance Monad RenameM where
  {-# INLINE return #-}
  return        = pure

  {-# INLINE (>>=) #-}
  m >>= k       = RenameM (unRenameM m >>= unRenameM . k)

instance FreshM RenameM where
  liftSupply f = RenameM $ sets $ \ RW { .. } ->
    let (a,s') = f rwSupply
        rw'    = RW { rwSupply = s', .. }
     in a `seq` rw' `seq` (a, rw')

instance ExceptionM RenameM () where
  {-# INLINE raise #-}
  raise        = RenameM . raise

runRenamer :: RenamerInfo -> RenameM a
           -> ( Either [RenamerError] (a,Supply)
              , [RenamerWarning]
              )
runRenamer info m = (res, warns)
  where
  warns = sort (rwWarnings rw ++ warnUnused (renContext info) (renEnv info) rw)

  (a,rw) = runM (unRenameM m) ro
                              RW { rwErrors   = Set.empty
                                 , rwWarnings = []
                                 , rwSupply   = renSupply info
                                 , rwNameUseCount = Map.empty
                                 , rwExternalDeps = mempty
                                 , rwCurrentDeps = Set.empty
                                 , rwDepGraph = Map.empty
                                 }

  ro = RO { roLoc   = emptyRange
          , roNames = renEnv info
          , roExternal = Map.mapWithKey toModMap (renIfaces info)
          , roCurMod = renContext info
          , roNestedMods = Map.empty
          , roResolvedModules = mempty
          , roModParams = mempty
          , roFromModParam = mempty
          }

  res | Set.null (rwErrors rw) = case a of
          Left _ -> panic "runRenamer" ["No renaming errors, but no output"]
          Right r -> Right (r,rwSupply rw)
      | otherwise              = Left (Set.toList (rwErrors rw))

  toModMap t ent =
    case ent of
      Left ps -> (Nothing, Map.singleton (ImpTop t) (ifaceSigToMod ps))
      Right i -> (Just i, modToMap (ImpTop t) (ifaceToMod i) mempty)



setCurMod :: ModPath -> RenameM a -> RenameM a
setCurMod mpath (RenameM m) =
  RenameM $ mapReader (\ro -> ro { roCurMod = mpath }) m

getCurMod :: RenameM ModPath
getCurMod = RenameM $ asks roCurMod

getNamingEnv :: RenameM NamingEnv
getNamingEnv = RenameM (asks roNames)

setResolvedLocals :: Map (ImpName Name) ResolvedLocal -> RenameM a -> RenameM a
setResolvedLocals mp (RenameM m) =
  RenameM $ mapReader (\ro -> ro { roResolvedModules = mp }) m

lookupResolved :: ImpName Name -> RenameM ResolvedLocal
lookupResolved nm =
  do mp <- RenameM (roResolvedModules <$> ask)
     case Map.lookup nm mp of
       Just r -> pure r
       Nothing | isFakeName nm -> raise ()
       Nothing ->
         panic
           "lookupResolved"
           ["Missing module: " ++ show nm]

setModParams :: [RenModParam] -> RenameM a -> RenameM a
setModParams ps (RenameM m) =
  do let pmap = Map.fromList [ (renModParamName p, p) | p <- ps ]

         newFrom =
           foldLoop ps mempty \p mp ->
             let nm = ModParamName (renModParamRange p) (renModParamName p)
             in foldLoop (Map.keys (renModParamInstance p)) mp \x ->
                  Map.insert x nm

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

     RenameM (mapReader upd m)


foldLoop :: [a] -> b -> (a -> b -> b) -> b
foldLoop xs b f = foldl' (flip f) b xs

getModParam :: Ident -> RenameM RenModParam
getModParam p =
  do ps <- RenameM (roModParams <$> ask)
     case Map.lookup p ps of
       Just r  -> pure r
       Nothing -> panic "getModParam" [ "Missing module paramter", show p ]

getNamesFromModParams :: RenameM (Map Name DepName)
getNamesFromModParams = RenameM (roFromModParam <$> ask)

getLocalModParamDeps :: RenameM (Map Ident DepName)
getLocalModParamDeps =
  do ps <- RenameM (roModParams <$> ask)
     let toName mp = ModParamName (renModParamRange mp) (renModParamName mp)
     pure (toName <$> ps)


setNestedModule :: Map ModPath Name -> RenameM a -> RenameM a
setNestedModule mp (RenameM m) =
  RenameM $ mapReader (\ro -> ro { roNestedMods = mp }) m

nestedModuleOrig :: ModPath -> RenameM (Maybe Name)
nestedModuleOrig x = RenameM (asks (Map.lookup x . roNestedMods))


-- | Record an error.
recordError :: RenamerError -> RenameM ()
recordError f = RenameM $
  do RW { .. } <- get
     set RW { rwErrors = Set.insert f rwErrors, .. }

recordWarning :: RenamerWarning -> RenameM ()
recordWarning w =
  RenameM $ sets_ \rw -> rw { rwWarnings = w : rwWarnings rw }

collectIfaceDeps :: RenameM a -> RenameM (IfaceDecls,a)
collectIfaceDeps (RenameM m) =
  RenameM
  do ds  <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = mempty })
     a   <- m
     ds' <- sets \s -> (rwExternalDeps s, s { rwExternalDeps = ds })
     pure (ds',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 x (RenameM m) = RenameM
  do ds <- sets \rw -> (rwCurrentDeps rw, rw { rwCurrentDeps = Set.empty })
     a  <- m
     sets_ \rw ->
        rw { rwCurrentDeps = Set.union (rwCurrentDeps rw) ds
           , rwDepGraph = Map.insert x (rwCurrentDeps rw) (rwDepGraph rw)
           }
     pure 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 (RenameM m) = RenameM
  do ds  <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = Map.empty })
     a   <- m
     ds1 <- sets \rw -> (rwDepGraph rw, rw { rwDepGraph = ds })
     pure (a,ds1)

-- | Get the source range for wahtever we are currently renaming.
curLoc :: RenameM Range
curLoc  = RenameM (roLoc `fmap` ask)

-- | Annotate something with the current range.
located :: a -> RenameM (Located a)
located thing =
  do srcRange <- curLoc
     return Located { .. }

-- | Do the given computation using the source code range from `loc` if any.
withLoc :: HasLoc loc => loc -> RenameM a -> RenameM a
withLoc loc m = RenameM $ case getLoc loc of

  Just range -> do
    ro <- ask
    local ro { roLoc = range } (unRenameM m)

  Nothing -> unRenameM m


-- | Shadow the current naming environment with some more names.
shadowNames :: BindsNames env => env -> RenameM a -> RenameM a
shadowNames  = shadowNames' CheckAll

data EnvCheck = CheckAll     -- ^ Check for overlap and shadowing
              | CheckOverlap -- ^ Only check for overlap
              | CheckNone    -- ^ Don't check the environment
                deriving (Eq,Show)

-- | Report errors if the given naming environemnt contains multiple
-- definitions for the same symbol
checkOverlap :: NamingEnv -> RenameM NamingEnv
checkOverlap env =
  case findAmbig env of
    []    -> pure env
    ambig -> do mapM_ recordError [ OverlappingSyms xs | xs <- ambig ]
                pure (forceUnambig env)

-- | Issue warnings if entries in the first environment would
-- shadow something in the second.
checkShadowing :: NamingEnv -> NamingEnv -> RenameM ()
checkShadowing envNew envOld =
  mapM_ recordWarning
    [ SymbolShadowed p x xs | (p,x,xs) <- findShadowing envNew 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' check names m = do
  do env    <- liftSupply (defsOf names)
     envOld <- RenameM (roNames <$> ask)
     env1   <- case check of
                 CheckNone    -> pure env
                 CheckOverlap -> checkOverlap env
                 CheckAll     -> do checkShadowing env envOld
                                    checkOverlap env
     RenameM
       do ro  <- ask
          let ro' = ro { roNames = env1 `shadowing` envOld }
          local ro' (unRenameM m)

recordUse :: Name -> RenameM ()
recordUse x = RenameM $ sets_ $ \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 x =
  do cur  <- getCurMod
     deps <- case nameInfo x of
               GlobalName _ OrigName { ogModule = m }
                 | Just (c,_,i:_) <- modPathCommon cur m ->
                 do mb <- nestedModuleOrig (Nested c i)
                    pure case mb of
                           Just y  -> Set.fromList [x,y]
                           Nothing -> Set.singleton x
               _ -> pure (Set.singleton x)
     RenameM $
       sets_ \rw -> rw { rwCurrentDeps = Set.union deps (rwCurrentDeps rw) }


warnUnused :: ModPath -> NamingEnv -> RW -> [RenamerWarning]
warnUnused m0 env rw =
  map UnusedName
  $ Map.keys
  $ Map.filterWithKey keep
  $ rwNameUseCount rw
  where
  keep nm count = count == 1 && isLocal nm
  oldNames = Map.findWithDefault Set.empty NSType (visibleNames env)

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

  isLocal nm = case nameInfo nm of
                 GlobalName sys og ->
                   sys == UserName && isNestd og && nm `Set.notMember` oldNames
                 LocalName {} -> True


getExternal :: RenameM (ImpName Name -> Mod ())
getExternal =
  do mp <- roExternal <$> RenameM ask
     pure \nm -> let mb = do t   <- case nm of
                                      ImpTop t  -> pure t
                                      ImpNested x -> nameTopModuleMaybe x
                             (_,mp1) <- Map.lookup t mp
                             Map.lookup nm mp1
                 in case mb of
                      Just m -> m
                      Nothing -> panic "getExternal"
                                    ["Missing external name", show (pp nm) ]

getExternalMod :: ImpName Name -> RenameM (Mod ())
getExternalMod nm = ($ nm) <$> 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 nm =
  do mp <- roExternal <$> RenameM ask
     let t = case nm of
               ImpTop t' -> t'
               ImpNested x -> nameTopModule x
     case Map.lookup t mp of
       Just (mb, _) -> pure mb
       Nothing -> panic "getTopModuleIface"
                                ["Missing external module", show (pp 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 r i =
  do ro <- RenameM ask
     case Map.lookup i (roResolvedModules ro) of
       Just loc ->
         case rmodKind loc of
           AModule -> pure ()
           k       -> recordError (ModuleKindMismatch r i AModule k)
       Nothing ->
        do mb <- getTopModuleIface i
           case mb of
             Nothing -> recordError (ModuleKindMismatch r i AModule ASignature)
             Just iface
               | ifaceIsFunctor iface ->
                       recordError (ModuleKindMismatch r i AModule AFunctor)
               | otherwise ->
                 RenameM $ sets_ \s -> 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 nm =
  do ro <- RenameM ask
     case Map.lookup nm (roResolvedModules ro) of
       Just loc -> pure (Left loc)
       Nothing  -> Right <$> getExternalMod nm

lookupDefines :: ImpName Name -> RenameM NamingEnv
lookupDefines nm =
  do thing <- lookupModuleThing nm
     pure case thing of
            Left loc -> rmodDefines loc
            Right e  -> modDefines e

checkIsModule :: Range -> ImpName Name -> ModKind -> RenameM ()
checkIsModule r nm expect =
  do thing <- lookupModuleThing nm
     let actual = case thing of
                    Left rmod -> rmodKind rmod
                    Right mo  -> modKind mo
     unless (actual == expect)
        (recordError (ModuleKindMismatch r nm expect actual))

lookupDefinesAndSubs :: ImpName Name -> RenameM (NamingEnv, Set Name)
lookupDefinesAndSubs nm =
  do thing <- lookupModuleThing nm
     pure case thing of
            Left rmod -> ( rmodDefines rmod, rmodNested rmod)
            Right m ->
              ( modDefines m
              , Set.unions [ Map.keysSet (modMods m)
                           , Map.keysSet (modInstances m)
                           ]
              )

isFakeName :: ImpName Name -> Bool
isFakeName m =
  case m of
    ImpTop x -> x == undefinedModName
    ImpNested x ->
      case nameTopModuleMaybe x of
        Just y  -> y == undefinedModName
        Nothing -> False