Move the Readline carrier into its own module.

semantic-core/src/Control/Carrier/Readline/Haskeline.hs

@@ -1,2 +1,70 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, OverloadedStrings, RankNTypes, TypeApplications, TypeOperators, UndecidableInstances #-}
 module Control.Carrier.Readline.Haskeline
-() where
+( runReadline
+, runReadlineWithHistory
+, ReadlineC (..)
+, runControlIO
+, ControlIOC (..)
+) where
+
+import Control.Carrier
+import Control.Carrier.Lift
+import Control.Carrier.Reader
+import Control.Effect.Readline
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Data.Text.Prettyprint.Doc.Render.Text
+import System.Console.Haskeline hiding (Handler, handle)
+import System.Directory
+import System.FilePath
+
+runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
+runReadline prefs settings = runInputTWithPrefs prefs settings . runM . runReader (Line 0) . runReadlineC
+
+runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
+runReadlineWithHistory block = do
+  homeDir <- liftIO getHomeDirectory
+  prefs <- liftIO $ readPrefs (homeDir </> ".haskeline")
+  let settingsDir = homeDir </> ".local/semantic-core"
+      settings = Settings
+        { complete = noCompletion
+        , historyFile = Just (settingsDir <> "/repl_history")
+        , autoAddHistory = True
+        }
+  liftIO $ createDirectoryIfMissing True settingsDir
+
+  runReadline prefs settings block
+
+newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+instance (MonadException m, MonadIO m) => Carrier (Readline :+: Lift (InputT m)) (ReadlineC m) where
+  eff (L (Prompt prompt k)) = ReadlineC $ do
+    str <- lift (lift (getInputLine (cyan <> prompt <> plain)))
+    local increment (runReadlineC (k str))
+    where cyan = "\ESC[1;36m\STX"
+          plain = "\ESC[0m\STX"
+  eff (L (Print text k)) = liftIO (putDoc (unAnyDoc text)) *> k
+  eff (L (AskLine k)) = ReadlineC ask >>= k
+  eff (R other) = ReadlineC (eff (R (handleCoercible other)))
+
+
+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.
+newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a }
+  deriving (Applicative, Functor, Monad, MonadIO)
+
+newtype Handler m = Handler (forall x . m x -> IO x)
+
+runHandler :: Handler m -> ControlIOC m a -> IO a
+runHandler h@(Handler handler) = handler . runReader h . runControlIOC
+
+instance Carrier sig m => Carrier sig (ControlIOC m) where
+  eff op = ControlIOC (eff (R (handleCoercible op)))
+
+instance (Carrier sig m, MonadIO m) => MonadException (ControlIOC m) where
+  controlIO f = ControlIOC $ do
+    handler <- ask
+    liftIO (f (RunIO (fmap pure . runHandler handler)) >>= runHandler handler)

semantic-core/src/Control/Effect/Readline.hs

@@ -1,108 +1,46 @@
-{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DeriveGeneric, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, OverloadedStrings, RankNTypes, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleContexts, RankNTypes, TypeApplications #-}
-
 module Control.Effect.Readline
-( Readline (..)
+( Readline(..)
+, AnyDoc(..)
 , prompt
 , print
 , println
 , askLine
-, Line (..)
+, Line(..)
 , increment
-, ReadlineC (..)
-, runReadline
-, runReadlineWithHistory
-, ControlIOC (..)
-, runControlIO
 ) where
 
-import Prelude hiding (print)
+import Control.Carrier
-
-import Control.Effect.Carrier
-import Control.Effect.Lift
-import Control.Effect.Reader
-import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
 import Data.Int
 import Data.String
 import Data.Text.Prettyprint.Doc
-import Data.Text.Prettyprint.Doc.Render.Text
 import GHC.Generics (Generic1)
-import System.Console.Haskeline hiding (Handler, handle)
+import Prelude hiding (print)
-import System.Directory
-import System.FilePath
 
 data Readline m k
   = Prompt String (Maybe String -> m k)
   | Print AnyDoc (m k)
   | AskLine (Line -> m k)
-  deriving stock (Functor, Generic1)
+  deriving (Functor, Generic1)
-  deriving anyclass (Effect, HFunctor)
+
+instance HFunctor Readline
+instance Effect   Readline
 
 newtype AnyDoc = AnyDoc { unAnyDoc :: forall a . Doc a }
 
-prompt :: (IsString str, Member Readline sig, Carrier sig m) => String -> m (Maybe str)
+prompt :: (IsString str, Has Readline sig m) => String -> m (Maybe str)
 prompt p = fmap fromString <$> send (Prompt p pure)
 
-print :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
+print :: (Pretty a, Has Readline sig m) => a -> m ()
 print s = send (Print (AnyDoc (pretty s)) (pure ()))
 
-println :: (Pretty a, Carrier sig m, Member Readline sig) => a -> m ()
+println :: (Pretty a, Has Readline sig m) => a -> m ()
 println s = print s >> print @String "\n"
 
-askLine :: (Carrier sig m, Member Readline sig) => m Line
+askLine :: Has Readline sig m => m Line
 askLine = send (AskLine pure)
 
 newtype Line = Line Int64
 
 increment :: Line -> Line
 increment (Line n) = Line (n + 1)
-
-newtype ReadlineC m a = ReadlineC { runReadlineC :: ReaderC Line (LiftC (InputT m)) a }
-  deriving newtype (Applicative, Functor, Monad, MonadIO)
-
-runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
-runReadline prefs settings = runInputTWithPrefs prefs settings . runM . runReader (Line 0) . runReadlineC
-
-instance (MonadException m, MonadIO m) => Carrier (Readline :+: Lift (InputT m)) (ReadlineC m) where
-  eff (L (Prompt prompt k)) = ReadlineC $ do
-    str <- lift (lift (getInputLine (cyan <> prompt <> plain)))
-    local increment (runReadlineC (k str))
-    where cyan = "\ESC[1;36m\STX"
-          plain = "\ESC[0m\STX"
-  eff (L (Print text k)) = liftIO (putDoc (unAnyDoc text)) *> k
-  eff (L (AskLine k)) = ReadlineC ask >>= k
-  eff (R other) = ReadlineC (eff (R (handleCoercible other)))
-
-runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
-runReadlineWithHistory block = do
-  homeDir <- liftIO getHomeDirectory
-  prefs <- liftIO $ readPrefs (homeDir </> ".haskeline")
-  let settingsDir = homeDir </> ".local/semantic-core"
-      settings = Settings
-        { complete = noCompletion
-        , historyFile = Just (settingsDir <> "/repl_history")
-        , autoAddHistory = True
-        }
-  liftIO $ createDirectoryIfMissing True settingsDir
-
-  runReadline prefs settings block
-
-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.
-newtype ControlIOC m a = ControlIOC { runControlIOC :: ReaderC (Handler m) m a }
-  deriving newtype (Applicative, Functor, Monad, MonadIO)
-
-newtype Handler m = Handler (forall x . m x -> IO x)
-
-runHandler :: Handler m -> ControlIOC m a -> IO a
-runHandler h@(Handler handler) = handler . runReader h . runControlIOC
-
-instance Carrier sig m => Carrier sig (ControlIOC m) where
-  eff op = ControlIOC (eff (R (handleCoercible op)))
-
-instance (Carrier sig m, MonadIO m) => MonadException (ControlIOC m) where
-  controlIO f = ControlIOC $ do
-    handler <- ask
-    liftIO (f (RunIO (fmap pure . runHandler handler)) >>= runHandler handler)