Remove StateT from Neovim

Author: saep

library/Neovim/API/Parser.hs

@@ -19,7 +19,6 @@ module Neovim.API.Parser
 import           Neovim.Classes
 
 import           Control.Applicative
-import           Control.Exception.Lifted
 import           Control.Monad.Except
 import qualified Data.ByteString              as B
 import           Data.Map                     (Map)
@@ -32,6 +31,8 @@ import           System.Process
 import           Neovim.Compat.Megaparsec     as P
 import           Text.PrettyPrint.ANSI.Leijen (Doc)
 import qualified Text.PrettyPrint.ANSI.Leijen as P
+import           UnliftIO.Exception           (SomeException,
+                                               bracket, catch)
 
 import           Prelude
 

library/Neovim/API/TH.hs

@@ -21,7 +21,7 @@ module Neovim.API.TH
     , autocmd
     , defaultAPITypeToHaskellTypeMap
 
-    , module Control.Exception.Lifted
+    , module UnliftIO.Exception
     , module Neovim.Classes
     , module Data.Data
     , module Data.MessagePack
@@ -44,7 +44,6 @@ import           Control.Applicative
 import           Control.Arrow (first)
 import           Control.Concurrent.STM   (STM)
 import           Control.Exception
-import           Control.Exception.Lifted
 import           Control.Monad
 import           Data.ByteString          (ByteString)
 import           Data.ByteString.UTF8     (fromString)
@@ -58,6 +57,7 @@ import           Data.Monoid
 import qualified Data.Set                 as Set
 import           Data.Text                (Text)
 import           Text.PrettyPrint.ANSI.Leijen (text, (<+>), Doc)
+import           UnliftIO.Exception
 
 import           Prelude
 
@@ -148,8 +148,8 @@ createFunction typeMap nf = do
     let withDeferred | async nf    = appT [t|STM|]
                      | otherwise   = id
 
-        withException | canFail nf = appT [t|Either NeovimException|]
-                      | otherwise  = id
+        withException' | canFail nf = appT [t|Either NeovimException|]
+                       | otherwise  = id
 
         callFns | async nf && canFail nf = [ [|acall|] ]
                 | async nf               = [ [|acall'|] ]
@@ -160,13 +160,13 @@ createFunction typeMap nf = do
         toObjVar v = [|toObject $(varE v)|]
 
 
-    retTypes <- let (r,st) = (mkName "r", mkName "st")
+    retTypes <- let env = (mkName "env")
                     createSig retTypeFun =
-                        forallT [PlainTV r, PlainTV st] (return [])
-                        . appT ([t|Neovim $(varT r) $(varT st) |])
+                        forallT [PlainTV env] (return [])
+                        . appT ([t|Neovim $(varT env) |])
                         . withDeferred . retTypeFun
                         . apiTypeToHaskellType typeMap $ returnType nf
-                in mapM createSig [ withException, id ]
+                in mapM createSig [ withException', id ]
 
     vars <- mapM (\(t,n) -> (,) <$> apiTypeToHaskellType typeMap t
                                 <*> newName n)

library/Neovim/Classes.hs

@@ -36,9 +36,7 @@ import           Neovim.Exceptions                 (NeovimException(..))
 import           Control.Applicative
 import           Control.Arrow
 import           Control.DeepSeq
-import           Control.Exception.Lifted     (throwIO)
 import           Control.Monad.Except
-import           Control.Monad.Base           (MonadBase(..))
 import           Data.ByteString              (ByteString)
 import           Data.Int                     (Int16, Int32, Int64, Int8)
 import qualified Data.Map.Strict              as SMap
@@ -55,6 +53,7 @@ import qualified Text.PrettyPrint.ANSI.Leijen as P
 
 import qualified Data.ByteString.UTF8         as UTF8 (fromString, toString)
 import           Data.Text.Encoding           (decodeUtf8, encodeUtf8)
+import           UnliftIO.Exception           (throwIO)
 
 import           Prelude
 
@@ -101,7 +100,7 @@ class NFData o => NvimObject o where
     fromObject :: Object -> Either Doc o
     fromObject = return . fromObjectUnsafe
 
-    fromObject' :: (MonadBase IO io) => Object -> io o
+    fromObject' :: (MonadIO io) => Object -> io o
     fromObject' = either (throwIO . ErrorMessage) return . fromObject
 
 

library/Neovim/Config.hs

@@ -23,7 +23,7 @@ import           System.Log             (Priority (..))
 -- the fields' documentation for what you possibly want to change. Also, the
 -- tutorial in the "Neovim" module should get you started.
 data NeovimConfig = Config
-    { plugins      :: [Neovim (StartupConfig NeovimConfig) () NeovimPlugin]
+    { plugins      :: [Neovim (StartupConfig NeovimConfig) NeovimPlugin]
     -- ^ The list of plugins. The IO type inside the list allows the plugin
     -- author to run some arbitrary startup code before creating a value of
     -- type 'NeovimPlugin'.

library/Neovim/Context.hs

@@ -65,13 +65,13 @@ import           Text.PrettyPrint.ANSI.Leijen (Pretty (..))
 
 
 -- | @'throw'@ specialized to a 'Pretty' value.
-err :: Pretty err => err ->  Neovim r st a
+err :: Pretty err => err ->  Neovim env a
 err = throw . ErrorMessage . pretty
 
 
 errOnInvalidResult :: (NvimObject o)
-                   => Neovim r st (Either NeovimException Object)
-                   -> Neovim r st o
+                   => Neovim env (Either NeovimException Object)
+                   -> Neovim env o
 errOnInvalidResult a = a >>= \case
     Left o ->
         (err . show) o
@@ -85,11 +85,11 @@ errOnInvalidResult a = a >>= \case
 
 
 -- | Initiate a restart of the plugin provider.
-restart :: Neovim r st ()
+restart :: Neovim env ()
 restart = liftIO . flip putMVar Internal.Restart =<< Internal.asks' Internal.transitionTo
 
 
 -- | Initiate the termination of the plugin provider.
-quit :: Neovim r st ()
+quit :: Neovim env ()
 quit = liftIO . flip putMVar Internal.Quit =<< Internal.asks' Internal.transitionTo
 

library/Neovim/Context/Internal.hs

@@ -26,23 +26,19 @@ import           Neovim.Plugin.Classes
 import           Neovim.Plugin.IPC            (SomeMessage)
 
 import           Control.Applicative
-import           Control.Concurrent           (ThreadId, forkIO)
-import           Control.Concurrent           (MVar, newEmptyMVar)
-import           Control.Concurrent.STM
+import           Control.Concurrent           (MVar, ThreadId, forkIO)
 import           Control.Exception            (ArithException, ArrayException,
                                                ErrorCall, PatternMatchFail)
-import           Control.Monad.Base
-import           Control.Monad.Catch
 import           Control.Monad.Except
 import           Control.Monad.Reader
-import           Control.Monad.State
 import           Control.Monad.Trans.Resource
 import qualified Data.ByteString.UTF8         as U (fromString)
 import           Data.Map                     (Map)
 import qualified Data.Map                     as Map
 import           Data.MessagePack             (Object)
 import           System.Log.Logger
 import           Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+import           UnliftIO
 
 import           Prelude
 
@@ -56,38 +52,40 @@ import           Prelude
 -- good practice to factor them out. This allows you to write tests and spot
 -- errors easier. Essentially, you should treat this similar to 'IO' in general
 -- haskell programs.
-newtype Neovim r st a = Neovim
-    { unNeovim :: ResourceT (StateT st (ReaderT (Config r st) IO)) a }
+newtype Neovim env a = Neovim
+    { unNeovim :: ResourceT (ReaderT (Config env) IO) a }
 
-  deriving (Functor, Applicative, Monad, MonadIO, MonadState st
-           , MonadThrow, MonadCatch, MonadMask, MonadResource)
-
-
-instance MonadBase IO (Neovim r st) where
-    liftBase = liftIO
+  deriving (Functor, Applicative, Monad, MonadIO
+           , MonadThrow, MonadResource)
 
 
 -- | User facing instance declaration for the reader state.
-instance MonadReader r (Neovim r st) where
+instance MonadReader env (Neovim env) where
     ask = Neovim $ asks customConfig
     local f (Neovim a) = do
-        r <- Neovim $ ask
-        s <- get
-        fmap fst . liftIO $ runReaderT (runStateT (runResourceT a) s)
+        r <- Neovim ask
+        liftIO $ runReaderT (runResourceT a)
                     (r { customConfig = f (customConfig r)})
 
 
+
+-- newtype UnliftIO m = UnliftIO { unliftIO :: forall a. m a -> IO a	}
+
+instance MonadUnliftIO (Neovim env) where
+    askUnliftIO = Neovim . withUnliftIO $ \x ->
+        return (UnliftIO (unliftIO x . unNeovim))
+
 -- | Same as 'ask' for the 'InternalConfig'.
-ask' :: Neovim r st (Config r st)
-ask' = Neovim $ ask
+ask' :: Neovim env (Config env)
+ask' = Neovim ask
 
 
 -- | Same as 'asks' for the 'InternalConfig'.
-asks' :: (Config r st -> a) -> Neovim r st a
+asks' :: (Config env -> a) -> Neovim env a
 asks' = Neovim . asks
 
 -- | Convenience alias for @'Neovim' () ()@.
-type Neovim' = Neovim () ()
+type Neovim' = Neovim ()
 
 exceptionHandlers :: [Handler IO (Either Doc a)]
 exceptionHandlers =
@@ -102,19 +100,17 @@ exceptionHandlers =
 
 -- | Initialize a 'Neovim' context by supplying an 'InternalEnvironment'.
 runNeovim :: NFData a
-          => Config r st
-          -> st
-          -> Neovim r st a
-          -> IO (Either Doc (a, st))
-runNeovim = runNeovimInternal (\(a,st) -> a `deepseq` return (a, st))
-
-runNeovimInternal :: ((a, st) -> IO (a, st))
-                  -> Config r st
-                  -> st
-                  -> Neovim r st a
-                  -> IO (Either Doc (a, st))
-runNeovimInternal f r st (Neovim a) =
-    (try . runReaderT (runStateT (runResourceT a) st)) r >>= \case
+          => Config env
+          -> Neovim env a
+          -> IO (Either Doc a)
+runNeovim = runNeovimInternal (\a -> a `deepseq` return a)
+
+runNeovimInternal :: (a -> IO a)
+                  -> Config env
+                  -> Neovim env a
+                  -> IO (Either Doc a)
+runNeovimInternal f r (Neovim a) =
+    (try . runReaderT (runResourceT a)) r >>= \case
         Left e -> case fromException e of
             Just e' ->
                 return . Left . pretty $ (e' :: NeovimException)
@@ -131,19 +127,19 @@ runNeovimInternal f r st (Neovim a) =
 -- returend immediately.
 -- FIXME This function is pretty much unused and mayhave undesired effects,
 --       namely that you cannot register autocmds in the forked thread.
-forkNeovim :: NFData a => ir -> ist -> Neovim ir ist a -> Neovim r st ThreadId
-forkNeovim r st a = do
+forkNeovim :: NFData a => iEnv -> Neovim iEnv a -> Neovim env ThreadId
+forkNeovim r a = do
     cfg <- ask'
     let threadConfig = cfg
             { pluginSettings = Nothing -- <- slightly problematic
             , customConfig = r
             }
-    liftIO . forkIO . void $ runNeovim threadConfig st a
+    liftIO . forkIO . void $ runNeovim threadConfig a
 
 
 -- | Create a new unique function name. To prevent possible name clashes, digits
 -- are stripped from the given suffix.
-newUniqueFunctionName :: Neovim r st FunctionName
+newUniqueFunctionName :: Neovim env FunctionName
 newUniqueFunctionName = do
     tu <- asks' uniqueCounter
     -- reverseing the integer string should distribute the first character more
@@ -200,7 +196,7 @@ mkFunctionMap = Map.fromList . map (\e -> (name (fst e), e))
 --
 -- Note that you most probably do not want to change the fields prefixed with an
 -- underscore.
-data Config r st = Config
+data Config env = Config
     -- Global settings; initialized once
     { eventQueue        :: TQueue SomeMessage
     -- ^ A queue of messages that the event handler will propagate to
@@ -229,11 +225,11 @@ data Config r st = Config
     -- it's appropriate targets.
 
     -- Local settings; intialized for each stateful component
-    , pluginSettings    :: Maybe (PluginSettings r st)
+    , pluginSettings    :: Maybe (PluginSettings env)
     -- ^ In a registered functionality this field contains a function (and
     -- possibly some context dependent values) to register new functionality.
 
-    , customConfig      :: r
+    , customConfig      :: env
     -- ^ Plugin author supplyable custom configuration. Queried on the
     -- user-facing side with 'ask' or 'asks'.
     }
@@ -243,38 +239,38 @@ data Config r st = Config
 -- config.
 --
 -- Sets the 'pluginSettings' field to 'Nothing'.
-retypeConfig :: r -> st -> Config anotherR anotherSt -> Config r st
-retypeConfig r _ cfg = cfg { pluginSettings = Nothing, customConfig = r }
+retypeConfig :: env -> Config anotherEnv -> Config env
+retypeConfig r cfg = cfg { pluginSettings = Nothing, customConfig = r }
 
 
 -- | This GADT is used to share information between stateless and stateful
 -- plugin threads since they work fundamentally in the same way. They both
 -- contain a function to register some functionality in the plugin provider
 -- as well as some values which are specific to the one or the other context.
-data PluginSettings r st where
+data PluginSettings env where
     StatelessSettings
         :: (FunctionalityDescription
             -> ([Object] -> Neovim' Object)
             -> Neovim' (Maybe FunctionMapEntry))
-        -> PluginSettings () ()
+        -> PluginSettings ()
 
     StatefulSettings
         :: (FunctionalityDescription
-            -> ([Object] -> Neovim r st Object)
+            -> ([Object] -> Neovim env Object)
             -> TQueue SomeMessage
-            -> TVar (Map FunctionName ([Object] -> Neovim r st Object))
-            -> Neovim r st (Maybe FunctionMapEntry))
+            -> TVar (Map FunctionName ([Object] -> Neovim env Object))
+            -> Neovim env (Maybe FunctionMapEntry))
         -> TQueue SomeMessage
-        -> TVar (Map FunctionName ([Object] -> Neovim r st Object))
-        -> PluginSettings r st
+        -> TVar (Map FunctionName ([Object] -> Neovim env Object))
+        -> PluginSettings env
 
 
 -- | Create a new 'InternalConfig' object by providing the minimal amount of
 -- necessary information.
 --
 -- This function should only be called once per /nvim-hs/ session since the
 -- arguments are shared across processes.
-newConfig :: IO (Maybe String) -> IO r -> IO (Config r context)
+newConfig :: IO (Maybe String) -> IO env -> IO (Config env)
 newConfig ioProviderName r = Config
     <$> newTQueueIO
     <*> newEmptyMVar