github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-26 08:25:19 +03:00
Code Issues Projects Releases Wiki Activity

Simplify runControlIO to use MonadUnliftIO.

Browse Source
This commit is contained in:
Rob Rix 2019-10-10 15:47:43 -04:00
parent c2954ae963
commit c6b12ef710
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
2 changed files with 10 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic-core/semantic-core.cabal
View File

@ -72,6 +72,7 @@ library
, text ^>= 1.2.3.1 , text ^>= 1.2.3.1
, transformers ^>= 0.5.6 , transformers ^>= 0.5.6
, trifecta ^>= 2 , trifecta ^>= 2
, unliftio-core ^>= 0.1.2
, unordered-containers ^>= 0.2.10 , unordered-containers ^>= 0.2.10
test-suite doctest test-suite doctest

27
semantic-core/src/Control/Carrier/Readline/Haskeline.hs
View File

@ -6,7 +6,6 @@ module Control.Carrier.Readline.Haskeline
, runReadline , runReadline
, runReadlineWithHistory , runReadlineWithHistory
, ReadlineC (..) , ReadlineC (..)
, runControlIO
, ControlIOC (..) , ControlIOC (..)
-- * Re-exports -- * Re-exports
, Carrier , Carrier
@ -20,7 +19,7 @@ import Control.Effect.Carrier
import Control.Effect.Lift import Control.Effect.Lift
import Control.Effect.Reader import Control.Effect.Reader
import Control.Effect.Readline hiding (Carrier) import Control.Effect.Readline hiding (Carrier)
import Control.Monad.IO.Class import Control.Monad.IO.Unlift
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Data.Text.Prettyprint.Doc.Render.Text import Data.Text.Prettyprint.Doc.Render.Text
import System.Console.Haskeline hiding (Handler, handle) import System.Console.Haskeline hiding (Handler, handle)
@ -58,26 +57,18 @@ instance (MonadException m, MonadIO m) => Carrier (Readline :+: Lift (InputT m))
eff (R other) = ReadlineC (eff (R (handleCoercible other))) eff (R other) = ReadlineC (eff (R (handleCoercible other)))
runHandler :: Handler m -> ControlIOC m a -> IO a
runHandler h@(Handler handler) = handler . runReader h . runControlIOC
newtype Handler m = Handler (forall x . m x -> IO x)
runControlIO :: (forall x . m x -> IO x) -> ControlIOC m a -> m a
runControlIO handler = runReader (Handler handler) . runControlIOC
-- | This exists to work around the 'MonadException' constraint that haskeline entails. -- | This exists to work around the 'MonadException' constraint that haskeline entails.
newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a } newtype ControlIOC m a = ControlIOC { runControlIO :: m a }
deriving (Applicative, Functor, Monad, MonadIO) deriving (Applicative, Functor, Monad, MonadIO)
instance Carrier sig m => Carrier sig (ControlIOC m) where instance MonadUnliftIO m => MonadUnliftIO (ControlIOC m) where
eff op = ControlIOC (eff (R (handleCoercible op))) withRunInIO inner = ControlIOC $ withRunInIO $ \ go -> inner (go . runControlIO)
instance (Carrier sig m, MonadIO m) => MonadException (ControlIOC m) where instance Carrier sig m => Carrier sig (ControlIOC m) where
controlIO f = ControlIOC $ do eff op = ControlIOC (eff (handleCoercible op))
handler <- ask
liftIO (f (RunIO (fmap pure . runHandler handler)) >>= runHandler handler) instance (Carrier sig m, MonadUnliftIO m) => MonadException (ControlIOC m) where
controlIO f = withRunInIO (\ runInIO -> f (RunIO (fmap pure . runInIO)) >>= runInIO)
newtype Line = Line Int newtype Line = Line Int