Monad.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Cryptol.Project.Monad
  ( LoadM, Err, NoErr
  , ScanStatus(..), ChangeStatus(..), InvalidStatus(..), Parsed
  , LoadProjectMode(..)
  , runLoadM
  , doModule
  , doModuleNonFail
  , doIO
  , tryLoadM
  , liftCallback
  , addFingerprint
  , addScanned
  , getModulePathLabel
  , getCachedFingerprint
  , findModule'
  , getStatus
  , getFingerprint
  , lPutStrLn
  , getOldDocstringResults
  ) where

import           Data.Map.Strict                  (Map)
import qualified Data.Map.Strict                  as Map
import           Control.Monad.Reader
import           Control.Monad.State
import           Control.Monad.Except hiding (tryError)
import           System.Directory
import           System.FilePath                  (makeRelative)

import           Cryptol.Utils.Ident
import           Cryptol.Parser.AST               (Module,PName)
import           Cryptol.ModuleSystem.Base        as M
import           Cryptol.ModuleSystem.Monad       as M
import           Cryptol.ModuleSystem.Env
import           Cryptol.Utils.Logger             (logPutStrLn)

import           Cryptol.Project.Config
import           Cryptol.Project.Cache

newtype LoadM err a =
  LoadM (ReaderT LoadConfig (ExceptT ModuleError (StateT LoadState ModuleM)) a)
  deriving (Functor,Applicative,Monad)

-- | Computations may raise an error
data Err

-- | Computations may not raise errors
data NoErr

type Parsed = [ (Module PName, [(ImportSource, ModulePath)]) ]

data ScanStatus =
    Scanned ChangeStatus FullFingerprint Parsed
  | Invalid InvalidStatus
  deriving Show

data ChangeStatus =
    Changed       -- ^ The module, or one of its dependencies changed.
  | Unchanged     -- ^ The module did not change.
  deriving (Eq, Show)

data InvalidStatus =
    InvalidModule ModuleError
    -- ^ Error in one of the modules in this file

  | InvalidDep ImportSource ModulePath
    -- ^ Error in one of our dependencies
  deriving Show


data LoadState = LoadState
  { findModuleCache :: Map (ModName, [FilePath]) ModulePath
    -- ^ Map (module name, search path) -> module path

  , fingerprints    :: Map CacheModulePath FullFingerprint
    -- ^ Hashes of known things.

  , scanned         :: Map ModulePath ScanStatus
    -- ^ Information about the proccessed top-level modules.
  }


-- | Information about the current project.
data LoadConfig = LoadConfig
  { canonRoot :: FilePath
    -- ^ Path to the project root, cannoicalized.

  , loadCache :: LoadCache
    -- ^ The state of the cache before we started loading the project.
  }


-- | Do an operation in the module monad.
doModuleNonFail :: M.ModuleM a -> LoadM any a
doModuleNonFail m =
  do mb <- LoadM (lift (lift (lift (M.tryModule m))))
     case mb of
       Left err -> LoadM (throwError err)
       Right a  -> pure a

-- | Do an operation in the module monad.
doModule :: M.ModuleM a -> LoadM Err a
doModule = doModuleNonFail

-- | Do an operation in the IO monad
doIO :: IO a -> LoadM Err a
doIO m = doModule (M.io m)

tryLoadM :: LoadM Err a -> LoadM any (Either M.ModuleError a)
tryLoadM (LoadM m) = LoadM (tryError m)

-- Introduced in mtl-2.3.1 which we can't rely upon yet
tryError :: MonadError e m => m a -> m (Either e a)
tryError action = (Right <$> action) `catchError` (pure . Left)

-- | Print a line
lPutStrLn :: String -> LoadM any ()
lPutStrLn msg = doModuleNonFail (withLogger logPutStrLn msg)

-- | Lift a module level operation to the LoadM monad.
liftCallback :: (forall a. ModuleM a -> ModuleM a) -> LoadM any b -> LoadM Err b
liftCallback f (LoadM m) =
  do r <- LoadM ask
     s <- LoadM get
     (mb,s1) <- doModule (f (runStateT (runExceptT (runReaderT m r)) s))
     LoadM (put s1)
     case mb of
       Left err -> LoadM (throwError err)
       Right a  -> pure a

-- | Run a LoadM computation using the given configuration.
runLoadM ::
  LoadProjectMode {- ^ force a refresh -} ->
  Config ->
  LoadM NoErr a ->
  M.ModuleM (Map CacheModulePath FullFingerprint, Map ModulePath ScanStatus, Either ModuleError a)
runLoadM mode cfg (LoadM m) =
  do loadCfg <-
       M.io
         do path  <- canonicalizePath (root cfg)
            cache <- case mode of
                       RefreshMode  -> pure emptyLoadCache
                       UntestedMode -> loadLoadCache
                       ModifiedMode -> loadLoadCache
            pure LoadConfig { canonRoot = path
                            , loadCache = cache
                            }
     let loadState = LoadState { findModuleCache = mempty
                               , fingerprints = mempty
                               , scanned = mempty
                               }
     (result, s) <- runStateT (runExceptT (runReaderT m loadCfg)) loadState
     pure (fingerprints s, scanned s, result)

addFingerprint :: ModulePath -> FullFingerprint -> LoadM any ()
addFingerprint mpath fp =
  LoadM
    (modify' \ls -> ls { fingerprints = Map.insert (toCacheModulePath mpath) fp (fingerprints ls) })


-- | Add information about the status of a module path.
addScanned :: ModulePath -> ScanStatus -> LoadM any ScanStatus
addScanned mpath status =
  do LoadM
       (modify' \ls -> ls { scanned = Map.insert mpath status (scanned ls) })
     pure status


-- | Get a label for the given module path.
-- Typically used for output.
getModulePathLabel :: ModulePath -> LoadM any String
getModulePathLabel mpath =
  case mpath of
    InFile p  -> LoadM (asks ((`makeRelative` p) . canonRoot))
    InMem l _ -> pure l


-- | Get the fingerprint for the given module path.
getCachedFingerprint :: ModulePath -> LoadM any (Maybe FullFingerprint)
getCachedFingerprint mpath =
  LoadM (asks (fmap cacheFingerprint . Map.lookup (toCacheModulePath mpath) . cacheModules . loadCache))


-- | Module path for the given import
findModule' :: ImportSource -> LoadM Err ModulePath
findModule' isrc =
  do ls <- LoadM get
     let mname = modNameToNormalModName (importedModule isrc)
     searchPath <- doModule M.getSearchPath
     case Map.lookup (mname, searchPath) (findModuleCache ls) of
       Just mpath -> pure mpath
       Nothing ->
         do modLoc <- doModule (findModule mname)
            mpath  <- case modLoc of
                        InFile path -> InFile <$> doIO (canonicalizePath path)
                        InMem l c   -> pure (InMem l c)
            LoadM $ put ls { findModuleCache = Map.insert (mname, searchPath)
                                                  mpath (findModuleCache ls) }
            pure mpath

-- | Check if the given file has beein processed.
getStatus :: ModulePath -> LoadM any (Maybe ScanStatus)
getStatus mpath = LoadM (gets (Map.lookup mpath . scanned))

-- | Get the fingerpint for the ginve path, if any.
getFingerprint :: ModulePath -> LoadM any (Maybe FullFingerprint)
getFingerprint mpath = LoadM (gets (Map.lookup (toCacheModulePath mpath) . fingerprints))

getOldDocstringResults :: LoadM any (Map CacheModulePath (Maybe Bool))
getOldDocstringResults =
  LoadM (asks (fmap cacheDocstringResult . cacheModules . loadCache))