Put everything in terms of FreeT and ExceptT

docs/Architecture.md

@@ -139,7 +139,7 @@ data GhcRequest m = forall a. GhcRequest
   , pinDocVer    :: Maybe (J.Uri, Int)
   , pinLspReqId  :: Maybe J.LspId
   , pinCallback  :: RequestCallback m a
-  , pinReq       :: IdeGhcM (IdeResult a)
+  , pinReq       :: IDErring IdeGhcM a
   }
 
 data IdeRequest m = forall a. IdeRequest

haskell-ide-engine.cabal

@@ -58,6 +58,7 @@ library
                      , data-default
                      , directory
                      , filepath
+                     , free
                      , ghc >= 8.0.1
                      , ghc-exactprint
                      , ghc-mod >= 5.9.0.0
@@ -73,6 +74,7 @@ library
                      , hsimport
                      , hslogger
                      , lens >= 4.15.2
+                     , mmorph
                      , monad-control
                      , monoid-subclasses > 0.4
                      , mtl
@@ -163,12 +165,14 @@ test-suite unit-test
                      , containers
                      , directory
                      , filepath
+                     , free
                      , haskell-lsp
                      , haskell-ide-engine
                      -- , hie-test-utils
                      , hie-plugin-api
                      , hoogle > 5.0.11
                      , hspec
+                     , mtl
                      , quickcheck-instances
                      , text
                      , unordered-containers
@@ -178,6 +182,7 @@ test-suite unit-test
                      , hie-plugin-api
                      , ghc-mod-core
                      , hslogger
+                     , mmorph
                      , yaml
 
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
@@ -211,6 +216,7 @@ test-suite dispatcher-test
                      , hie-plugin-api
                      , ghc-mod-core
                      , hslogger
+                     , mmorph
                      , unordered-containers
                      , yaml
   ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall -Wredundant-constraints
@@ -282,6 +288,7 @@ test-suite func-test
                      , hie-plugin-api
                      , ghc-mod-core
                      , hslogger
+                     , mmorph
                      , unordered-containers
                      , yaml
                      , haskell-lsp

hie-plugin-api/Haskell/Ide/Engine/ModuleCache.hs

@@ -3,9 +3,9 @@
 {-# LANGUAGE FlexibleContexts #-}
 module Haskell.Ide.Engine.ModuleCache where
 
-import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Control
+import           Control.Monad.State
 import qualified Data.Aeson as J
 import           Data.Dynamic (toDyn, fromDynamic)
 import           Data.Generics (Proxy(..), typeRep, typeOf)
@@ -16,12 +16,13 @@ import           Data.Typeable (Typeable)
 import           Exception (ExceptionMonad)
 import           System.Directory
 import           System.FilePath
+import           Control.Lens
+import           Data.Foldable
 
 import qualified GhcMod.Cradle as GM
 import qualified GhcMod.Monad  as GM
 import qualified GhcMod.Types  as GM
 
-import           Haskell.Ide.Engine.MultiThreadState
 import           Haskell.Ide.Engine.PluginsIdeMonads
 import           Haskell.Ide.Engine.GhcModuleCache
 
@@ -87,14 +88,14 @@ data CachedModuleResult = ModuleLoading
 type IsStale = Bool
 
 -- | looks up a CachedModule for a given URI
-getCachedModule :: (GM.MonadIO m, HasGhcModuleCache m)
+getCachedModule :: (MonadIO m, HasGhcModuleCache m)
                 => FilePath -> m CachedModuleResult
 getCachedModule uri = do
   uri' <- liftIO $ canonicalizePath uri
   maybeUriCache <- fmap (Map.lookup uri' . uriCaches) getModuleCache
   return $ case maybeUriCache of
     Nothing -> ModuleLoading
-    Just uriCache@(UriCache {}) -> ModuleCached (cachedModule uriCache) (isStale uriCache)
+    Just uriCache@UriCache {} -> ModuleCached (cachedModule uriCache) (isStale uriCache)
     Just (UriCacheFailed err) -> ModuleFailed err
 
 -- | Returns true if there is a CachedModule for a given URI
@@ -108,22 +109,20 @@ isCached uri = do
 
 -- | Version of `withCachedModuleAndData` that doesn't provide
 -- any extra cached data.
-withCachedModule :: FilePath -> (CachedModule -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b)
-withCachedModule uri callback = withCachedModuleDefault uri Nothing callback
+withCachedModule :: FilePath -> (CachedModule -> IdeResponseT b) -> IdeResponseT b
+withCachedModule uri = withCachedModuleDefault uri Nothing
 
 -- | Version of `withCachedModuleAndData` that doesn't provide
 -- any extra cached data.
-withCachedModuleDefault :: FilePath -> Maybe (IdeResponse b)
-                        -> (CachedModule -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b)
+withCachedModuleDefault :: FilePath -> Maybe (IdeResponseT b)
+                        -> (CachedModule -> IdeResponseT b) -> IdeResponseT b
 withCachedModuleDefault uri mdef callback = do
   mcm <- getCachedModule uri
   uri' <- liftIO $ canonicalizePath uri
   case mcm of
     ModuleCached cm _ -> callback cm
-    ModuleLoading -> return $ IdeResponseDeferred uri' callback
-    ModuleFailed err -> case mdef of
-      Nothing -> return $ IdeResponseFail (IdeError NoModuleAvailable err J.Null)
-      Just def -> return def
+    ModuleLoading -> defer uri' callback
+    ModuleFailed err -> flip fromMaybe mdef $ ideError NoModuleAvailable err J.Null
 
 -- | Calls its argument with the CachedModule for a given URI
 -- along with any data that might be stored in the ModuleCache.
@@ -134,21 +133,21 @@ withCachedModuleDefault uri mdef callback = do
 -- If the data doesn't exist in the cache, new data is generated
 -- using by calling the `cacheDataProducer` function.
 withCachedModuleAndData :: forall a b. ModuleCache a
-                        => FilePath -> (CachedModule -> a -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b)
-withCachedModuleAndData uri callback = withCachedModuleAndDataDefault uri Nothing callback
+                        => FilePath -> (CachedModule -> a -> IdeResponseT b) -> IdeResponseT b
+withCachedModuleAndData uri = withCachedModuleAndDataDefault uri Nothing
 
 withCachedModuleAndDataDefault :: forall a b. ModuleCache a
-                        => FilePath -> Maybe (IdeResponse b)
-                        -> (CachedModule -> a -> IdeM (IdeResponse b)) -> IdeM (IdeResponse b)
+                        => FilePath -> Maybe (IdeResponseT b)
+                        -> (CachedModule -> a -> IdeResponseT b) -> IdeResponseT b
 withCachedModuleAndDataDefault uri mdef callback = do
   uri' <- liftIO $ canonicalizePath uri
   mcache <- getModuleCache
   let mc = (Map.lookup uri' . uriCaches) mcache
   case mc of
-    Nothing -> return $ IdeResponseDeferred uri' $ \_ -> withCachedModuleAndData uri callback
+    Nothing -> defer uri' $ \_ -> withCachedModuleAndData uri callback
     Just (UriCacheFailed err) -> case mdef of
-      Nothing -> return $ IdeResponseFail (IdeError NoModuleAvailable err J.Null)
-      Just def -> return def
+      Nothing -> ideError NoModuleAvailable err J.Null
+      Just def -> def
     Just UriCache{cachedModule = cm, cachedData = dat} -> do
       let proxy :: Proxy a
           proxy = Proxy
@@ -205,12 +204,9 @@ failModule fp err = do
 
 
 runDeferredActions :: FilePath -> Either T.Text CachedModule -> IdeGhcM ()
-runDeferredActions uri cached = do
-      actions <- fmap (fromMaybe [] . Map.lookup uri) (requestQueue <$> readMTS)
-      liftToGhc $ forM_ actions (\a -> a cached)
-
-      -- remove queued actions
-      modifyMTS $ \s -> s { requestQueue = Map.delete uri (requestQueue s) }
+runDeferredActions uri cached = liftIde $ do
+  actions <- requestQueue . at uri . non' _Empty <<.= []
+  traverse_ (\a -> a cached) actions
 
 -- | Saves a module to the cache without clearing the associated cache data - use only if you are
 -- sure that the cached data associated with the module doesn't change
@@ -256,7 +252,7 @@ markCacheStale uri = do
 -- TODO: this name is confusing, given GhcModuleCache. Change it
 class Typeable a => ModuleCache a where
     -- | Defines an initial value for the state extension
-    cacheDataProducer :: (GM.MonadIO m, MonadMTState IdeState m)
+    cacheDataProducer :: (GM.MonadIO m, MonadState IdeState m)
                       => CachedModule -> m a
 
 instance ModuleCache () where

hie-plugin-api/Haskell/Ide/Engine/Monad.hs

@@ -11,7 +11,7 @@ import           Language.Haskell.LSP.Types.Capabilities
 -- ---------------------------------------------------------------------
 
 -- | runIdeGhcM with Cradle found from the current directory
-runIdeGhcM :: GM.Options -> ClientCapabilities -> IdeState -> IdeGhcM a -> IO a
+runIdeGhcM :: GM.Options -> ClientCapabilities -> IdeState -> GM.GhcModT (ReaderT ClientCapabilities (MultiThreadState IdeState)) a -> IO a
 runIdeGhcM ghcModOptions caps s0 f = do
     (eres, _) <- flip runMTState s0 $ flip runReaderT caps $ GM.runGhcModT ghcModOptions f
     case eres of

hie-plugin-api/Haskell/Ide/Engine/MonadFunctions.hs

@@ -21,8 +21,9 @@ import System.Log.Logger
 import Data.Typeable
 import Data.Dynamic
 import qualified Data.Map as Map
+import qualified Control.Monad.State as MS
+import Control.Lens
 
-import Haskell.Ide.Engine.MultiThreadState
 import Haskell.Ide.Engine.PluginsIdeMonads
 
 -- ---------------------------------------------------------------------
@@ -104,34 +105,33 @@ class Typeable a => ExtensionClass a where
 --
 
 -- | Modify the map of state extensions by applying the given function.
-modifyStateExts :: MonadMTState IdeState m => (Map.Map TypeRep Dynamic -> Map.Map TypeRep Dynamic) -> m ()
-modifyStateExts f = modifyMTS $ \st -> st { extensibleState = f (extensibleState st) }
+modifyStateExts :: MS.MonadState IdeState m => (Map.Map TypeRep Dynamic -> Map.Map TypeRep Dynamic) -> m ()
+modifyStateExts f = extensibleState %= f
 
 -- | Apply a function to a stored value of the matching type or the initial value if there
 -- is none.
-modify :: (MonadMTState IdeState m, ExtensionClass a) => (a -> a) -> m ()
+modify :: (MS.MonadState IdeState m, ExtensionClass a) => (a -> a) -> m ()
 modify f = put . f =<< get
 
 -- | Add a value to the extensible state field. A previously stored value with the same
 -- type will be overwritten. (More precisely: A value whose string representation of its type
 -- is equal to the new one's)
-put :: (MonadMTState IdeState m, ExtensionClass a) => a -> m ()
+put :: (MS.MonadState IdeState m, ExtensionClass a) => a -> m ()
 put v = modifyStateExts . Map.insert (typeOf v) . toDyn $ v
 
 -- | Try to retrieve a value of the requested type, return an initial value if there is no such value.
-get :: forall a m. (MonadMTState IdeState m, ExtensionClass a) => m a
+get :: forall a m. (MS.MonadState IdeState m, ExtensionClass a) => m a
 get = do
-  mc <- readMTS
-  let v = (Map.lookup (typeRep (Proxy :: Proxy a)) . extensibleState) mc
+  v <- use $ extensibleState . at (typeRep (Proxy :: Proxy a))
   case v of
     Just dyn -> return $ fromDyn dyn initialValue
     _        -> return initialValue
 
-gets :: (MonadMTState IdeState m, ExtensionClass a) => (a -> b) -> m b
+gets :: (MS.MonadState IdeState m, ExtensionClass a) => (a -> b) -> m b
 gets = flip fmap get
 
 -- | Remove the value from the extensible state field that has the same type as the supplied argument
-remove :: (MonadMTState IdeState m, ExtensionClass a) => proxy a -> m ()
+remove :: (MS.MonadState IdeState m, ExtensionClass a) => proxy a -> m ()
 remove wit = modifyStateExts $ Map.delete (typeRep $ wit)
 
 -- ---------------------------------------------------------------------

hie-plugin-api/Haskell/Ide/Engine/MultiThreadState.hs

@@ -2,40 +2,41 @@
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
 module Haskell.Ide.Engine.MultiThreadState
-  ( MultiThreadState
-  , readMTState
-  , modifyMTState
+  ( MultiThreadState(..)
   , runMTState
-  , MonadMTState(..)
   ) where
 
 import Control.Concurrent.STM
 import Control.Monad.Reader
+import Control.Monad.State
+import qualified GhcMod.Monad as GM
+import Control.Monad.Trans.Control
+import Control.Monad.Base
+import Exception
 
 -- ---------------------------------------------------------------------
 
-type MultiThreadState s = ReaderT (TVar s) IO
+newtype MultiThreadState s a = MTState { getMTState :: ReaderT (TVar s) IO a }
+  deriving (Functor, Applicative, Monad, GM.MonadIO, MonadIO, MonadReader (TVar s), MonadBase IO, ExceptionMonad)
 
-readMTState :: MultiThreadState s s
-readMTState = ask >>= liftIO . readTVarIO
-
-modifyMTState :: (s -> s) -> MultiThreadState s ()
-modifyMTState f = do
-  tvar <- ask
-  liftIO $ atomically $ modifyTVar' tvar f
+instance MonadBaseControl IO (MultiThreadState s) where
+  type StM (MultiThreadState s) a = a 
+  liftBaseWith f = MTState $ liftBaseWith $ \q -> f (q . getMTState)
+  restoreM = MTState . restoreM 
 
 runMTState :: MultiThreadState s a -> s -> IO a
 runMTState m s = do
   tv <- newTVarIO s
-  runReaderT m tv
-
-class MonadIO m => MonadMTState s m | m -> s where
-  readMTS :: m s
-  modifyMTS :: (s -> s) -> m ()
-  writeMTS :: s -> m ()
-  writeMTS s = modifyMTS (const s)
-
-instance MonadMTState s (MultiThreadState s) where
-  readMTS = readMTState
-  modifyMTS = modifyMTState
+  runReaderT (getMTState m) tv
+
+instance MonadState s (MultiThreadState s) where
+  state f = do
+    tvar <- ask
+    liftIO $ atomically $ do
+      s <- readTVar tvar
+      let (a, s') = f s
+      writeTVar tvar s'
+      return a

hie-plugin-api/Haskell/Ide/Engine/PluginDescriptor.hs

@@ -12,7 +12,6 @@ module Haskell.Ide.Engine.PluginDescriptor
   , toDynJSON
   ) where
 
-import           Control.Monad.State.Strict
 import           Data.Aeson
 import           Data.List
 import qualified Data.Map                        as Map
@@ -22,8 +21,8 @@ import           Data.Monoid
 import qualified Data.Text                       as T
 import qualified Data.ConstrainedDynamic         as CD
 import           Data.Typeable
-import           Haskell.Ide.Engine.IdeFunctions
 import           Haskell.Ide.Engine.MonadTypes
+import           Control.Lens
 
 pluginDescToIdePlugins :: [(PluginId,PluginDescriptor)] -> IdePlugins
 pluginDescToIdePlugins plugins = IdePlugins $ Map.fromList plugins
@@ -41,18 +40,16 @@ toDynJSON = CD.toDyn
 
 -- | Runs a plugin command given a PluginId, CommandName and
 -- arguments in the form of a JSON object.
-runPluginCommand :: PluginId -> CommandName -> Value -> IdeGhcM (IdeResult DynamicJSON)
+runPluginCommand :: PluginId -> CommandName -> Value -> IDErring IdeGhcM DynamicJSON
 runPluginCommand p com arg = do
-  (IdePlugins m) <- lift . lift $ getPlugins
-  case Map.lookup p m of
-    Nothing -> return $
-      IdeResultFail $ IdeError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null
-    Just (PluginDescriptor { pluginCommands = xs }) -> case find ((com ==) . commandName) xs of
-      Nothing -> return $ IdeResultFail $
-        IdeError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null
-      Just (PluginCommand _ _ (CmdSync f)) -> case fromJSON arg of
-        Error err -> return $ IdeResultFail $
-          IdeError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null
-        Success a -> do
-            res <- f a
-            return $ fmap toDynJSON res
+  IdePlugins m <- liftIde $ use idePlugins
+  PluginDescriptor { pluginCommands = xs } <- case Map.lookup p m of
+    Nothing -> ideError UnknownPlugin ("Plugin " <> p <> " doesn't exist") Null
+    Just x -> return x
+  PluginCommand _ _ (CmdSync f) <- case find ((com ==) . commandName) xs of
+    Nothing -> ideError UnknownCommand ("Command " <> com <> " isn't defined for plugin " <> p <> ". Legal commands are: " <> T.pack(show $ map commandName xs)) Null
+    Just x -> return x
+  a <- case fromJSON arg of
+    Error err -> ideError ParameterError ("error while parsing args for " <> com <> " in plugin " <> p <> ": " <> T.pack err) Null
+    Success x -> return x
+  toDynJSON <$> f a