{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Control.Carrier.Readline.Haskeline
( -- * Readline carrier
  runReadline
, runReadlineWithHistory
, ReadlineC(ReadlineC)
  -- * Readline effect
, module Control.Effect.Readline
) where

import Control.Algebra
import Control.Effect.Readline
#if MIN_VERSION_haskeline(0, 8, 0)
import Control.Monad.Catch (MonadMask(..))
#endif
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import System.Console.Haskeline as H
import System.Directory
import System.Environment
import System.FilePath

#if MIN_VERSION_haskeline(0, 8, 0)
runReadline :: (MonadIO m, MonadMask m) => Prefs -> Settings m -> ReadlineC m a -> m a
#else
runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
#endif
runReadline :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> ReadlineC m a -> m a
runReadline Prefs
prefs Settings m
settings (ReadlineC InputT m a
m) = Prefs -> Settings m -> InputT m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs Prefs
prefs Settings m
settings InputT m a
m

#if MIN_VERSION_haskeline(0, 8, 0)
runReadlineWithHistory :: (MonadIO m, MonadMask m) => ReadlineC m a -> m a
#else
runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
#endif
runReadlineWithHistory :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ReadlineC m a -> m a
runReadlineWithHistory ReadlineC m a
block = do
  (prefs, settings) <- IO (Prefs, Settings m) -> m (Prefs, Settings m)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Prefs, Settings m) -> m (Prefs, Settings m))
-> IO (Prefs, Settings m) -> m (Prefs, Settings m)
forall a b. (a -> b) -> a -> b
$ do
    homeDir <- IO FilePath
getHomeDirectory
    prefs   <- readPrefs (homeDir </> ".haskeline")
    prog    <- getExecutablePath
    let settingsDir = FilePath
homeDir FilePath -> FilePath -> FilePath
</> FilePath
".local" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropExtension (FilePath -> FilePath
takeFileName FilePath
prog)
        settings = Settings
          { complete :: CompletionFunc m
complete       = CompletionFunc m
forall (m :: * -> *). Monad m => CompletionFunc m
noCompletion
          , historyFile :: Maybe FilePath
historyFile    = FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath
settingsDir FilePath -> FilePath -> FilePath
</> FilePath
"repl_history")
          , autoAddHistory :: Bool
autoAddHistory = Bool
True
          }
    createDirectoryIfMissing True settingsDir
    pure (prefs, settings)

  runReadline prefs settings block

newtype ReadlineC m a = ReadlineC { forall (m :: * -> *) a. ReadlineC m a -> InputT m a
runReadlineC :: InputT m a }
  deriving (Functor (ReadlineC m)
Functor (ReadlineC m) =>
(forall a. a -> ReadlineC m a)
-> (forall a b.
    ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b)
-> (forall a b c.
    (a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c)
-> (forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b)
-> (forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m a)
-> Applicative (ReadlineC m)
forall a. a -> ReadlineC m a
forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m a
forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b
forall a b. ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
forall a b c.
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (ReadlineC m)
forall (m :: * -> *) a. Applicative m => a -> ReadlineC m a
forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m a
forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ReadlineC m a
pure :: forall a. a -> ReadlineC m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
<*> :: forall a b. ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
liftA2 :: forall a b c.
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
*> :: forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m a
<* :: forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m a
Applicative, (forall a b. (a -> b) -> ReadlineC m a -> ReadlineC m b)
-> (forall a b. a -> ReadlineC m b -> ReadlineC m a)
-> Functor (ReadlineC m)
forall a b. a -> ReadlineC m b -> ReadlineC m a
forall a b. (a -> b) -> ReadlineC m a -> ReadlineC m b
forall (m :: * -> *) a b.
Functor m =>
a -> ReadlineC m b -> ReadlineC m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReadlineC m a -> ReadlineC m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReadlineC m a -> ReadlineC m b
fmap :: forall a b. (a -> b) -> ReadlineC m a -> ReadlineC m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ReadlineC m b -> ReadlineC m a
<$ :: forall a b. a -> ReadlineC m b -> ReadlineC m a
Functor, Applicative (ReadlineC m)
Applicative (ReadlineC m) =>
(forall a b.
 ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b)
-> (forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b)
-> (forall a. a -> ReadlineC m a)
-> Monad (ReadlineC m)
forall a. a -> ReadlineC m a
forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b
forall a b. ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
forall (m :: * -> *). Monad m => Applicative (ReadlineC m)
forall (m :: * -> *) a. Monad m => a -> ReadlineC m a
forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
>>= :: forall a b. ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
>> :: forall a b. ReadlineC m a -> ReadlineC m b -> ReadlineC m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> ReadlineC m a
return :: forall a. a -> ReadlineC m a
Monad, Monad (ReadlineC m)
Monad (ReadlineC m) =>
(forall a. (a -> ReadlineC m a) -> ReadlineC m a)
-> MonadFix (ReadlineC m)
forall a. (a -> ReadlineC m a) -> ReadlineC m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (ReadlineC m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> ReadlineC m a) -> ReadlineC m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> ReadlineC m a) -> ReadlineC m a
mfix :: forall a. (a -> ReadlineC m a) -> ReadlineC m a
MonadFix, Monad (ReadlineC m)
Monad (ReadlineC m) =>
(forall a. IO a -> ReadlineC m a) -> MonadIO (ReadlineC m)
forall a. IO a -> ReadlineC m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (ReadlineC m)
forall (m :: * -> *) a. MonadIO m => IO a -> ReadlineC m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> ReadlineC m a
liftIO :: forall a. IO a -> ReadlineC m a
MonadIO, (forall (m :: * -> *). Monad m => Monad (ReadlineC m)) =>
(forall (m :: * -> *) a. Monad m => m a -> ReadlineC m a)
-> MonadTrans ReadlineC
forall (m :: * -> *). Monad m => Monad (ReadlineC m)
forall (m :: * -> *) a. Monad m => m a -> ReadlineC m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> ReadlineC m a
lift :: forall (m :: * -> *) a. Monad m => m a -> ReadlineC m a
MonadTrans)

#if MIN_VERSION_haskeline(0, 8, 1)
instance (Algebra sig m, MonadIO m, MonadMask m) => Algebra (Readline :+: sig) (ReadlineC m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (ReadlineC m)
-> (:+:) Readline sig n a -> ctx () -> ReadlineC m (ctx a)
alg Handler ctx n (ReadlineC m)
hdl (:+:) Readline sig n a
sig ctx ()
ctx = case (:+:) Readline sig n a
sig of
    L Readline n a
readline -> case Readline n a
readline of
      GetInputLine FilePath
prompt -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (FilePath -> InputT m (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe FilePath)
H.getInputLine FilePath
prompt)
      GetInputLineWithInitial FilePath
prompt (FilePath, FilePath)
lr -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (FilePath -> (FilePath, FilePath) -> InputT m (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> (FilePath, FilePath) -> InputT m (Maybe FilePath)
H.getInputLineWithInitial FilePath
prompt (FilePath, FilePath)
lr)
      GetInputChar FilePath
prompt -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (FilePath -> InputT m (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe Char)
H.getInputChar FilePath
prompt)
      GetPassword Maybe Char
c FilePath
prompt -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (Maybe Char -> FilePath -> InputT m (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Maybe Char -> FilePath -> InputT m (Maybe FilePath)
H.getPassword Maybe Char
c FilePath
prompt)
      WaitForAnyKey FilePath
prompt -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (FilePath -> InputT m Bool
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m Bool
H.waitForAnyKey FilePath
prompt)
      OutputStr FilePath
s -> (a -> ctx () -> ctx a
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (a -> ctx a) -> ReadlineC m a -> ReadlineC m (ctx a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputT m a -> ReadlineC m a
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (FilePath -> InputT m ()
forall (m :: * -> *). MonadIO m => FilePath -> InputT m ()
H.outputStr FilePath
s)
      WithInterrupt n a
m -> InputT m (ctx a) -> ReadlineC m (ctx a)
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (InputT m (ctx a) -> InputT m (ctx a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
H.withInterrupt (ReadlineC m (ctx a) -> InputT m (ctx a)
forall (m :: * -> *) a. ReadlineC m a -> InputT m a
runReadlineC (ctx (n a) -> ReadlineC m (ctx a)
Handler ctx n (ReadlineC m)
hdl (n a
m n a -> ctx () -> ctx (n a)
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))))
      HandleInterrupt n a
h n a
m -> InputT m (ctx a) -> ReadlineC m (ctx a)
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (InputT m (ctx a) -> InputT m (ctx a) -> InputT m (ctx a)
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
H.handleInterrupt (ReadlineC m (ctx a) -> InputT m (ctx a)
forall (m :: * -> *) a. ReadlineC m a -> InputT m a
runReadlineC (ctx (n a) -> ReadlineC m (ctx a)
Handler ctx n (ReadlineC m)
hdl (n a
h n a -> ctx () -> ctx (n a)
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))) (ReadlineC m (ctx a) -> InputT m (ctx a)
forall (m :: * -> *) a. ReadlineC m a -> InputT m a
runReadlineC (ctx (n a) -> ReadlineC m (ctx a)
Handler ctx n (ReadlineC m)
hdl (n a
m n a -> ctx () -> ctx (n a)
forall a b. a -> ctx b -> ctx a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))))
    R sig n a
other -> InputT m (ctx a) -> ReadlineC m (ctx a)
forall (m :: * -> *) a. InputT m a -> ReadlineC m a
ReadlineC (InputT m (ctx a) -> ReadlineC m (ctx a))
-> InputT m (ctx a) -> ReadlineC m (ctx a)
forall a b. (a -> b) -> a -> b
$ ((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a)
forall (m :: * -> *) b.
Monad m =>
((forall a. InputT m a -> m a) -> m b) -> InputT m b
H.withRunInBase (((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a))
-> ((forall a. InputT m a -> m a) -> m (ctx a)) -> InputT m (ctx a)
forall a b. (a -> b) -> a -> b
$ \ forall a. InputT m a -> m a
run -> Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) (ctx :: * -> *)
       (n :: * -> *) a.
(Algebra sig m, Functor ctx) =>
Handler ctx n m -> sig n a -> ctx () -> m (ctx a)
alg (InputT m (ctx x) -> m (ctx x)
forall a. InputT m a -> m a
run (InputT m (ctx x) -> m (ctx x))
-> (ctx (n x) -> InputT m (ctx x)) -> ctx (n x) -> m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadlineC m (ctx x) -> InputT m (ctx x)
forall (m :: * -> *) a. ReadlineC m a -> InputT m a
runReadlineC (ReadlineC m (ctx x) -> InputT m (ctx x))
-> (ctx (n x) -> ReadlineC m (ctx x))
-> ctx (n x)
-> InputT m (ctx x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx (n x) -> ReadlineC m (ctx x)
Handler ctx n (ReadlineC m)
hdl) sig n a
other ctx ()
ctx
#else
#if MIN_VERSION_haskeline(0, 8, 0)
instance (MonadIO m, MonadMask m) => Algebra Readline (ReadlineC m) where
#else
instance MonadException m => Algebra Readline (ReadlineC m) where
#endif
  alg hdl sig ctx = case sig 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))))
#endif