Copy fused-effects-readline in.

cabal.project

@@ -1,7 +1,2 @@
 packages: .
 tests: True
-
-source-repository-package
-  type: git
-  location: https://github.com/fused-effects/fused-effects-readline.git
-  tag: d8a35005ae28e827c92b4fe122f62d015a9a8e24

facet.cabal

@@ -57,12 +57,14 @@ library
     Facet.Algebra
     Facet.Carrier.Error.Lens
     Facet.Carrier.Parser.Church
+    Facet.Carrier.Readline.Haskeline
     Facet.Carrier.State.Lens
     Facet.Carrier.Throw.Inject
     Facet.CLI
     Facet.Context
     Facet.Core
     Facet.Effect.Parser
+    Facet.Effect.Readline
     Facet.Elab
     Facet.Env
     Facet.Eval
@@ -95,10 +97,11 @@ library
     , colour
     , containers
     , directory
+    , exceptions ^>= 0.10
     , filepath
     , fused-effects
     , fused-effects-lens
-    , fused-effects-readline
+    , haskeline ^>= 0.8.1
     , lens
     , optparse-applicative
     , parsers

src/Facet/Carrier/Readline/Haskeline.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Facet.Carrier.Readline.Haskeline
+( -- * Readline carrier
+  runReadline
+, runReadlineWithHistory
+, ReadlineC(ReadlineC)
+  -- * Readline effect
+, module Facet.Effect.Readline
+) where
+
+import Control.Algebra
+import Control.Monad.Catch (MonadMask(..))
+import Control.Monad.Fix (MonadFix)
+import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Facet.Effect.Readline
+import System.Console.Haskeline as H
+import System.Directory
+import System.Environment
+import System.FilePath
+
+runReadline :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> ReadlineC m a -> m a
+runReadline prefs settings (ReadlineC m) = runInputTWithPrefs prefs settings m
+
+runReadlineWithHistory :: (MonadIO m, MonadMask m) => ReadlineC m a -> m a
+runReadlineWithHistory block = do
+  (prefs, settings) <- liftIO $ do
+    homeDir <- getHomeDirectory
+    prefs   <- readPrefs (homeDir </> ".haskeline")
+    prog    <- getExecutablePath
+    let settingsDir = homeDir </> ".local" </> dropExtension (takeFileName prog)
+        settings = Settings
+          { complete       = noCompletion
+          , historyFile    = Just (settingsDir </> "repl_history")
+          , autoAddHistory = True
+          }
+    createDirectoryIfMissing True settingsDir
+    pure (prefs, settings)
+
+  runReadline prefs settings block
+
+newtype ReadlineC m a = ReadlineC { runReadlineC :: InputT m a }
+  deriving (Applicative, Functor, Monad, MonadFix, MonadIO, MonadTrans)
+
+instance (Algebra sig m, MonadIO m, MonadMask m) => Algebra (Readline :+: sig) (ReadlineC m) where
+  alg hdl sig ctx = case sig of
+    L readline -> case readline of
+      GetInputLine prompt               -> (<$ ctx) <$> ReadlineC (H.getInputLine prompt)
+      GetInputLineWithInitial prompt lr -> (<$ ctx) <$> ReadlineC (H.getInputLineWithInitial prompt lr)
+      GetInputChar prompt               -> (<$ ctx) <$> ReadlineC (H.getInputChar prompt)
+      GetPassword c prompt              -> (<$ ctx) <$> ReadlineC (H.getPassword c prompt)
+      WaitForAnyKey prompt              -> (<$ ctx) <$> ReadlineC (H.waitForAnyKey prompt)
+      OutputStr s                       -> (<$ ctx) <$> ReadlineC (H.outputStr s)
+      WithInterrupt m                   -> ReadlineC (H.withInterrupt (runReadlineC (hdl (m <$ ctx))))
+      HandleInterrupt h m               -> ReadlineC (H.handleInterrupt (runReadlineC (hdl (h <$ ctx))) (runReadlineC (hdl (m <$ ctx))))
+    R other -> ReadlineC $ H.withRunInBase $ \ run -> alg (run . runReadlineC . hdl) other ctx

src/Facet/Effect/Readline.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE GADTs #-}
+module Facet.Effect.Readline
+( -- * Readline effect
+  Readline(..)
+, getInputLine
+, getInputLineWithInitial
+, getInputChar
+, getPassword
+, waitForAnyKey
+, outputStr
+, outputStrLn
+, withInterrupt
+, handleInterrupt
+  -- * Re-exports
+, Algebra
+, Has
+, run
+) where
+
+import Control.Algebra
+
+getInputLine :: Has Readline sig m => String -> m (Maybe String)
+getInputLine p = send (GetInputLine p)
+
+getInputLineWithInitial :: Has Readline sig m => String -> (String, String) -> m (Maybe String)
+getInputLineWithInitial p lr = send (GetInputLineWithInitial p lr)
+
+getInputChar :: Has Readline sig m => String -> m (Maybe Char)
+getInputChar p = send (GetInputChar p)
+
+getPassword :: Has Readline sig m => Maybe Char -> String -> m (Maybe String)
+getPassword c s = send (GetPassword c s)
+
+waitForAnyKey :: Has Readline sig m => String -> m Bool
+waitForAnyKey p = send (WaitForAnyKey p)
+
+outputStr :: Has Readline sig m => String -> m ()
+outputStr s = send (OutputStr s)
+
+outputStrLn :: Has Readline sig m => String -> m ()
+outputStrLn s = outputStr (s <> "\n")
+
+withInterrupt :: Has Readline sig m => m a -> m a
+withInterrupt m = send (WithInterrupt m)
+
+handleInterrupt :: Has Readline sig m => m a -> m a -> m a
+handleInterrupt h m = send (HandleInterrupt h m)
+
+data Readline m k where
+  GetInputLine :: String -> Readline m (Maybe String)
+  GetInputLineWithInitial :: String -> (String, String) -> Readline m (Maybe String)
+  GetInputChar :: String -> Readline m (Maybe Char)
+  GetPassword :: Maybe Char -> String -> Readline m (Maybe String)
+  WaitForAnyKey :: String -> Readline m Bool
+  OutputStr :: String -> Readline m ()
+  WithInterrupt :: m a -> Readline m a
+  HandleInterrupt :: m a -> m a -> Readline m a

src/Facet/REPL.hs

@@ -8,7 +8,6 @@ import           Control.Carrier.Empty.Church
 import           Control.Carrier.Error.Church
 import           Control.Carrier.Fresh.Church
 import           Control.Carrier.Reader
-import           Control.Carrier.Readline.Haskeline
 import           Control.Carrier.State.Church
 import           Control.Effect.Lens (use, (%=), (.=))
 import           Control.Lens (Getting, Lens', at, lens)
@@ -24,6 +23,7 @@ import qualified Data.Text as TS
 import           Data.Text.Lazy (unpack)
 import           Facet.Algebra hiding (Algebra)
 import           Facet.Carrier.Parser.Church
+import           Facet.Carrier.Readline.Haskeline
 import qualified Facet.Carrier.State.Lens as L
 import qualified Facet.Carrier.Throw.Inject as I
 import           Facet.Core