{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# 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.Carrier.Lift
import Control.Carrier.Reader
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 Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import System.Console.Haskeline
import System.Console.Terminal.Size as Size
import System.Directory
import System.Environment
import System.FilePath
import System.IO (stdout)

#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 :: Prefs -> Settings m -> ReadlineC m a -> m a
runReadline Prefs
prefs Settings m
settings (ReadlineC ReaderC Line (LiftC (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 (LiftC (InputT m) a -> InputT m a
forall (m :: * -> *) a. LiftC m a -> m a
runM (Line -> ReaderC Line (LiftC (InputT m)) a -> LiftC (InputT m) a
forall r (m :: * -> *) a. r -> ReaderC r m a -> m a
runReader (Int -> Line
Line Int
0) ReaderC Line (LiftC (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 :: ReadlineC m a -> m a
runReadlineWithHistory ReadlineC m a
block = do
  FilePath
homeDir <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getHomeDirectory
  Prefs
prefs   <- IO Prefs -> m Prefs
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Prefs -> m Prefs) -> IO Prefs -> m Prefs
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Prefs
readPrefs (FilePath
homeDir FilePath -> FilePath -> FilePath
</> FilePath
".haskeline")
  FilePath
prog    <- IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
  let settingsDir :: FilePath
settingsDir = FilePath
homeDir FilePath -> FilePath -> FilePath
</> FilePath
".local" FilePath -> FilePath -> FilePath
</> FilePath -> FilePath
dropExtension (FilePath -> FilePath
takeFileName FilePath
prog)
      settings :: Settings m
settings = Settings :: forall (m :: * -> *).
CompletionFunc m -> Maybe FilePath -> Bool -> Settings m
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
        }
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
settingsDir

  Prefs -> Settings m -> ReadlineC m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Prefs -> Settings m -> ReadlineC m a -> m a
runReadline Prefs
prefs Settings m
settings ReadlineC m a
block

newtype ReadlineC m a = ReadlineC (ReaderC Line (LiftC (InputT m)) a)
  deriving (Functor (ReadlineC m)
a -> ReadlineC m a
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)
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
ReadlineC m a -> ReadlineC m b -> ReadlineC m a
ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
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
<* :: ReadlineC m a -> ReadlineC m b -> ReadlineC m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m a
*> :: ReadlineC m a -> ReadlineC m b -> ReadlineC m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
liftA2 :: (a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> ReadlineC m a -> ReadlineC m b -> ReadlineC m c
<*> :: ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
ReadlineC m (a -> b) -> ReadlineC m a -> ReadlineC m b
pure :: a -> ReadlineC m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> ReadlineC m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (ReadlineC m)
Applicative, a -> ReadlineC m b -> ReadlineC m a
(a -> b) -> ReadlineC m a -> ReadlineC m b
(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
<$ :: a -> ReadlineC m b -> ReadlineC m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ReadlineC m b -> ReadlineC m a
fmap :: (a -> b) -> ReadlineC m a -> ReadlineC m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ReadlineC m a -> ReadlineC m b
Functor, Applicative (ReadlineC m)
a -> ReadlineC m a
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)
ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
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
return :: a -> ReadlineC m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ReadlineC m a
>> :: ReadlineC m a -> ReadlineC m b -> ReadlineC m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> ReadlineC m b -> ReadlineC m b
>>= :: ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ReadlineC m a -> (a -> ReadlineC m b) -> ReadlineC m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (ReadlineC m)
Monad, Monad (ReadlineC m)
Monad (ReadlineC m)
-> (forall a. (a -> ReadlineC m a) -> ReadlineC m a)
-> MonadFix (ReadlineC m)
(a -> ReadlineC m a) -> ReadlineC m a
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
mfix :: (a -> ReadlineC m a) -> ReadlineC m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> ReadlineC m a) -> ReadlineC m a
$cp1MonadFix :: forall (m :: * -> *). MonadFix m => Monad (ReadlineC m)
MonadFix, Monad (ReadlineC m)
Monad (ReadlineC m)
-> (forall a. IO a -> ReadlineC m a) -> MonadIO (ReadlineC m)
IO a -> ReadlineC m a
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
liftIO :: IO a -> ReadlineC m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> ReadlineC m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (ReadlineC m)
MonadIO)

instance MonadTrans ReadlineC where
  lift :: m a -> ReadlineC m a
lift = ReaderC Line (LiftC (InputT m)) a -> ReadlineC m a
forall (m :: * -> *) a.
ReaderC Line (LiftC (InputT m)) a -> ReadlineC m a
ReadlineC (ReaderC Line (LiftC (InputT m)) a -> ReadlineC m a)
-> (m a -> ReaderC Line (LiftC (InputT m)) a)
-> m a
-> ReadlineC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LiftC (InputT m) a -> ReaderC Line (LiftC (InputT m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LiftC (InputT m) a -> ReaderC Line (LiftC (InputT m)) a)
-> (m a -> LiftC (InputT m) a)
-> m a
-> ReaderC Line (LiftC (InputT m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT m a -> LiftC (InputT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT m a -> LiftC (InputT m) a)
-> (m a -> InputT m a) -> m a -> LiftC (InputT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

#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 :: Handler ctx n (ReadlineC m)
-> Readline n a -> ctx () -> ReadlineC m (ctx a)
alg Handler ctx n (ReadlineC m)
_ Readline n a
sig ctx ()
ctx = case Readline n a
sig of
    Prompt FilePath
prompt -> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
-> ReadlineC m (ctx (Int, Maybe FilePath))
forall (m :: * -> *) a.
ReaderC Line (LiftC (InputT m)) a -> ReadlineC m a
ReadlineC (ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
 -> ReadlineC m (ctx (Int, Maybe FilePath)))
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
-> ReadlineC m (ctx (Int, Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ do
      Maybe FilePath
str <- InputT m (Maybe FilePath)
-> ReaderC Line (LiftC (InputT m)) (Maybe FilePath)
forall (n :: * -> *) (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
(Has (Lift n) sig m, Functor n) =>
n a -> m a
sendM (FilePath -> InputT m (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe FilePath)
getInputLine @m (FilePath
cyan FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
prompt FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
plain))
      Line Int
line <- ReaderC Line (LiftC (InputT m)) Line
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Reader r) sig m =>
m r
ask
      (Line -> Line)
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local Line -> Line
increment (ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
 -> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath)))
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
forall a b. (a -> b) -> a -> b
$ ctx (Int, Maybe FilePath)
-> ReaderC Line (LiftC (InputT m)) (ctx (Int, Maybe FilePath))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
line, Maybe FilePath
str) (Int, Maybe FilePath) -> ctx () -> ctx (Int, Maybe FilePath)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx)
      where cyan :: FilePath
cyan = FilePath
"\ESC[1;36m\STX"
            plain :: FilePath
plain = FilePath
"\ESC[0m\STX"
    Print Doc AnsiStyle
doc -> do
      Int
s <- Int -> (Window Int -> Int) -> Maybe (Window Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
80 Window Int -> Int
forall a. Window a -> a
Size.width (Maybe (Window Int) -> Int)
-> ReadlineC m (Maybe (Window Int)) -> ReadlineC m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (Window Int)) -> ReadlineC m (Maybe (Window Int))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
size
      let docstream :: SimpleDocStream AnsiStyle
docstream = LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart (Int -> LayoutOptions
layoutOptions Int
s) (Doc AnsiStyle
doc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line)
      (() -> ctx () -> ctx ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (() -> ctx ()) -> ReadlineC m () -> ReadlineC m (ctx ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO () -> ReadlineC m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReadlineC m ())
-> (SimpleDocStream AnsiStyle -> IO ())
-> SimpleDocStream AnsiStyle
-> ReadlineC m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
stdout (SimpleDocStream AnsiStyle -> ReadlineC m ())
-> SimpleDocStream AnsiStyle -> ReadlineC m ()
forall a b. (a -> b) -> a -> b
$ SimpleDocStream AnsiStyle
docstream)
      where layoutOptions :: Int -> LayoutOptions
layoutOptions Int
s = LayoutOptions
defaultLayoutOptions { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine Int
s Double
0.8 }


newtype Line = Line Int

increment :: Line -> Line
increment :: Line -> Line
increment (Line Int
n) = Int -> Line
Line (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)