{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, MultiParamTypeClasses, ScopedTypeVariables, TypeApplications #-}
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
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Coerce (coerce)
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)

runReadline :: MonadException m => Prefs -> Settings m -> ReadlineC m a -> m a
runReadline :: Prefs -> Settings m -> ReadlineC m a -> m a
runReadline prefs :: Prefs
prefs settings :: Settings m
settings (ReadlineC m :: ReaderC Line (LiftC (InputT m)) a
m) = Prefs -> Settings m -> InputT m a -> m a
forall (m :: * -> *) a.
MonadException m =>
Prefs -> Settings m -> InputT m a -> m a
runInputTWithPrefs Prefs
prefs (Settings m -> Settings m
forall a b. Coercible a b => a -> b
coerce 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 0) ReaderC Line (LiftC (InputT m)) a
m))

runReadlineWithHistory :: MonadException m => ReadlineC m a -> m a
runReadlineWithHistory :: ReadlineC m a -> m a
runReadlineWithHistory block :: 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
</> ".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
</> ".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
</> "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.
MonadException m =>
Prefs -> Settings m -> ReadlineC m a -> m a
runReadline Prefs
prefs Settings m
settings ReadlineC m a
block

newtype ReadlineC m a = ReadlineC { ReadlineC m a -> ReaderC Line (LiftC (InputT m)) a
runReadlineC :: 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

instance MonadException m => Algebra Readline (ReadlineC m) where
  alg :: Readline (ReadlineC m) a -> ReadlineC m a
alg = \case
    Prompt prompt :: FilePath
prompt k :: Int -> Maybe FilePath -> ReadlineC m a
k -> 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)
-> ReaderC Line (LiftC (InputT m)) a -> ReadlineC m a
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 :: * -> *).
MonadException 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 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)) a
-> ReaderC Line (LiftC (InputT m)) a
forall r (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Reader r) sig m =>
(r -> r) -> m a -> m a
local Line -> Line
increment (ReadlineC m a -> ReaderC Line (LiftC (InputT m)) a
forall (m :: * -> *) a.
ReadlineC m a -> ReaderC Line (LiftC (InputT m)) a
runReadlineC (Int -> Maybe FilePath -> ReadlineC m a
k Int
line Maybe FilePath
str))
      where cyan :: FilePath
cyan = "\ESC[1;36m\STX"
            plain :: FilePath
plain = "\ESC[0m\STX"
    Print doc :: Doc AnsiStyle
doc k :: ReadlineC m a
k -> do
      Int
s <- Int -> (Window Int -> Int) -> Maybe (Window Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 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
      IO () -> ReadlineC m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> SimpleDocStream AnsiStyle -> IO ()
renderIO Handle
stdout (LayoutOptions -> Doc AnsiStyle -> SimpleDocStream AnsiStyle
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutSmart LayoutOptions
defaultLayoutOptions { layoutPageWidth :: PageWidth
layoutPageWidth = Int -> Double -> PageWidth
AvailablePerLine Int
s 0.8 } (Doc AnsiStyle
doc Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
line)))
      ReadlineC m a
k


newtype Line = Line Int

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