{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

{- |

Repline exposes an additional monad transformer on top of Haskeline called 'HaskelineT'. It simplifies several
aspects of composing Haskeline with State and Exception monads in modern versions of mtl.

> type Repl a = HaskelineT IO a

The evaluator 'evalRepl' evaluates a 'HaskelineT' monad transformer by constructing a shell with several
custom functions and evaluating it inside of IO:

  * Commands: Handled on ordinary input.

  * Completions: Handled when tab key is pressed.

  * Options: Handled when a command prefixed by a prefix character is entered.

  * Command prefix character: Optional command prefix ( passing Nothing ignores the Options argument ).

  * Banner: Text Displayed at initialization.

  * Initializer: Run at initialization.

A simple evaluation function might simply echo the output back to the screen.

> -- Evaluation : handle each line user inputs
> cmd :: String -> Repl ()
> cmd input = liftIO $ print input

Several tab completion options are available, the most common is the 'WordCompleter' which completes on single
words separated by spaces from a list of matches. The internal logic can be whatever is required and can also
access a StateT instance to query application state.

> -- Tab Completion: return a completion for partial words entered
> completer :: Monad m => WordCompleter m
> completer n = do
>   let names = ["kirk", "spock", "mccoy"]
>   return $ filter (isPrefixOf n) names

Input which is prefixed by a colon (commands like \":type\" and \":help\") queries an association list of
functions which map to custom logic. The function takes a space-separated list of augments in it's first
argument. If the entire line is desired then the 'unwords' function can be used to concatenate.

> -- Commands
> help :: [String] -> Repl ()
> help args = liftIO $ print $ "Help: " ++ show args
>
> say :: [String] -> Repl ()
> say args = do
>   _ <- liftIO $ system $ "cowsay" ++ " " ++ (unwords args)
>   return ()

Now we need only map these functions to their commands.

> options :: [(String, [String] -> Repl ())]
> options = [
>     ("help", help)  -- :help
>   , ("say", say)    -- :say
>   ]

The banner function is simply an IO action that is called at the start of the shell.

> ini :: Repl ()
> ini = liftIO $ putStrLn "Welcome!"

Putting it all together we have a little shell.

> main :: IO ()
> main = evalRepl (pure ">>> ") cmd options (Just ':') (Word completer) ini

Putting this in a file we can test out our cow-trek shell.

> $ runhaskell Main.hs
> Welcome!
> >>> <TAB>
> kirk spock mccoy
>
> >>> k<TAB>
> kirk
>
> >>> spam
> "spam"
>
> >>> :say Hello Haskell
>  _______________
> < Hello Haskell >
>  ---------------
>         \   ^__^
>          \  (oo)\_______
>             (__)\       )\/\
>                 ||----w |
>                 ||     ||

See <https://github.com/sdiehl/repline> for more examples.

-}

module System.Console.Repline (
  -- * Repline Monad
  HaskelineT,
  runHaskelineT,

  -- * Toplevel
  evalRepl,
  ReplOpts(..),
  evalReplOpts,

  -- * Repline Types
  Cmd,
  Options,
  WordCompleter,
  LineCompleter,
  CompleterStyle(..),
  Command,

  -- * Completers
  CompletionFunc, -- re-export

  wordCompleter,
  listCompleter,
  fileCompleter,
  listWordCompleter,
  runMatcher,
  trimComplete,

  -- * Utilities
  abort,
  tryAction,
  dontCrash,
) where

import System.Console.Haskeline.Completion
import System.Console.Haskeline.MonadException
import qualified System.Console.Haskeline as H

import Data.List (isPrefixOf)
import Control.Applicative
import Control.Monad.Fail as Fail
import Control.Monad.State.Strict
import Control.Monad.Reader

-------------------------------------------------------------------------------
-- Haskeline Transformer
-------------------------------------------------------------------------------

newtype HaskelineT (m :: * -> *) a = HaskelineT { HaskelineT m a -> InputT m a
unHaskeline :: H.InputT m a }
 deriving (Applicative (HaskelineT m)
a -> HaskelineT m a
Applicative (HaskelineT m) =>
(forall a b.
 HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT m b)
-> (forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m b)
-> (forall a. a -> HaskelineT m a)
-> Monad (HaskelineT m)
HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT m b
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
forall a. a -> HaskelineT m a
forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m b
forall a b.
HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT m b
forall (m :: * -> *). Monad m => Applicative (HaskelineT m)
forall (m :: * -> *) a. Monad m => a -> HaskelineT m a
forall (m :: * -> *) a b.
Monad m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
forall (m :: * -> *) a b.
Monad m =>
HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT 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 -> HaskelineT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> HaskelineT m a
>> :: HaskelineT m a -> HaskelineT m b -> HaskelineT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
>>= :: HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
HaskelineT m a -> (a -> HaskelineT m b) -> HaskelineT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (HaskelineT m)
Monad, a -> HaskelineT m b -> HaskelineT m a
(a -> b) -> HaskelineT m a -> HaskelineT m b
(forall a b. (a -> b) -> HaskelineT m a -> HaskelineT m b)
-> (forall a b. a -> HaskelineT m b -> HaskelineT m a)
-> Functor (HaskelineT m)
forall a b. a -> HaskelineT m b -> HaskelineT m a
forall a b. (a -> b) -> HaskelineT m a -> HaskelineT m b
forall (m :: * -> *) a b.
Functor m =>
a -> HaskelineT m b -> HaskelineT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HaskelineT m a -> HaskelineT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> HaskelineT m b -> HaskelineT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> HaskelineT m b -> HaskelineT m a
fmap :: (a -> b) -> HaskelineT m a -> HaskelineT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> HaskelineT m a -> HaskelineT m b
Functor, Functor (HaskelineT m)
a -> HaskelineT m a
Functor (HaskelineT m) =>
(forall a. a -> HaskelineT m a)
-> (forall a b.
    HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b)
-> (forall a b c.
    (a -> b -> c)
    -> HaskelineT m a -> HaskelineT m b -> HaskelineT m c)
-> (forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m b)
-> (forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m a)
-> Applicative (HaskelineT m)
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
HaskelineT m a -> HaskelineT m b -> HaskelineT m a
HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b
(a -> b -> c) -> HaskelineT m a -> HaskelineT m b -> HaskelineT m c
forall a. a -> HaskelineT m a
forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m a
forall a b. HaskelineT m a -> HaskelineT m b -> HaskelineT m b
forall a b.
HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b
forall a b c.
(a -> b -> c) -> HaskelineT m a -> HaskelineT m b -> HaskelineT 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 (HaskelineT m)
forall (m :: * -> *) a. Applicative m => a -> HaskelineT m a
forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m a
forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HaskelineT m a -> HaskelineT m b -> HaskelineT m c
<* :: HaskelineT m a -> HaskelineT m b -> HaskelineT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m a
*> :: HaskelineT m a -> HaskelineT m b -> HaskelineT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m a -> HaskelineT m b -> HaskelineT m b
liftA2 :: (a -> b -> c) -> HaskelineT m a -> HaskelineT m b -> HaskelineT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> HaskelineT m a -> HaskelineT m b -> HaskelineT m c
<*> :: HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
HaskelineT m (a -> b) -> HaskelineT m a -> HaskelineT m b
pure :: a -> HaskelineT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> HaskelineT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (HaskelineT m)
Applicative, Monad (HaskelineT m)
Monad (HaskelineT m) =>
(forall a. IO a -> HaskelineT m a) -> MonadIO (HaskelineT m)
IO a -> HaskelineT m a
forall a. IO a -> HaskelineT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (HaskelineT m)
forall (m :: * -> *) a. MonadIO m => IO a -> HaskelineT m a
liftIO :: IO a -> HaskelineT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> HaskelineT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (HaskelineT m)
MonadIO, MonadIO (HaskelineT m)
MonadIO (HaskelineT m) =>
(forall a.
 (RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a)
-> MonadException (HaskelineT m)
(RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a
forall a.
(RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a
forall (m :: * -> *).
MonadIO m =>
(forall a. (RunIO m -> IO (m a)) -> m a) -> MonadException m
forall (m :: * -> *). MonadException m => MonadIO (HaskelineT m)
forall (m :: * -> *) a.
MonadException m =>
(RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a
controlIO :: (RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a
$ccontrolIO :: forall (m :: * -> *) a.
MonadException m =>
(RunIO (HaskelineT m) -> IO (HaskelineT m a)) -> HaskelineT m a
$cp1MonadException :: forall (m :: * -> *). MonadException m => MonadIO (HaskelineT m)
MonadException, m a -> HaskelineT m a
(forall (m :: * -> *) a. Monad m => m a -> HaskelineT m a)
-> MonadTrans HaskelineT
forall (m :: * -> *) a. Monad m => m a -> HaskelineT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> HaskelineT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> HaskelineT m a
MonadTrans, MonadException (HaskelineT m)
String -> HaskelineT m (Maybe Char)
String -> HaskelineT m (Maybe String)
String -> HaskelineT m ()
MonadException (HaskelineT m) =>
(String -> HaskelineT m (Maybe String))
-> (String -> HaskelineT m (Maybe Char))
-> (String -> HaskelineT m ())
-> (String -> HaskelineT m ())
-> MonadHaskeline (HaskelineT m)
forall (m :: * -> *).
MonadException m =>
MonadException (HaskelineT m)
forall (m :: * -> *).
MonadException m =>
String -> HaskelineT m (Maybe Char)
forall (m :: * -> *).
MonadException m =>
String -> HaskelineT m (Maybe String)
forall (m :: * -> *). MonadException m => String -> HaskelineT m ()
forall (m :: * -> *).
MonadException m =>
(String -> m (Maybe String))
-> (String -> m (Maybe Char))
-> (String -> m ())
-> (String -> m ())
-> MonadHaskeline m
outputStrLn :: String -> HaskelineT m ()
$coutputStrLn :: forall (m :: * -> *). MonadException m => String -> HaskelineT m ()
outputStr :: String -> HaskelineT m ()
$coutputStr :: forall (m :: * -> *). MonadException m => String -> HaskelineT m ()
getInputChar :: String -> HaskelineT m (Maybe Char)
$cgetInputChar :: forall (m :: * -> *).
MonadException m =>
String -> HaskelineT m (Maybe Char)
getInputLine :: String -> HaskelineT m (Maybe String)
$cgetInputLine :: forall (m :: * -> *).
MonadException m =>
String -> HaskelineT m (Maybe String)
$cp1MonadHaskeline :: forall (m :: * -> *).
MonadException m =>
MonadException (HaskelineT m)
MonadHaskeline)

-- | Run HaskelineT monad
runHaskelineT :: MonadException m => H.Settings m -> HaskelineT m a -> m a
runHaskelineT :: Settings m -> HaskelineT m a -> m a
runHaskelineT s :: Settings m
s m :: HaskelineT m a
m = Settings m -> InputT m a -> m a
forall (m :: * -> *) a.
MonadException m =>
Settings m -> InputT m a -> m a
H.runInputT Settings m
s (InputT m a -> InputT m a
forall (m :: * -> *) a.
MonadException m =>
InputT m a -> InputT m a
H.withInterrupt (HaskelineT m a -> InputT m a
forall (m :: * -> *) a. HaskelineT m a -> InputT m a
unHaskeline HaskelineT m a
m))

class MonadException m => MonadHaskeline m where
  getInputLine :: String -> m (Maybe String)
  getInputChar :: String -> m (Maybe Char)
  outputStr    :: String -> m ()
  outputStrLn  :: String -> m ()

instance MonadException m => MonadHaskeline (H.InputT m) where
  getInputLine :: String -> InputT m (Maybe String)
getInputLine = String -> InputT m (Maybe String)
forall (m :: * -> *).
MonadException m =>
String -> InputT m (Maybe String)
H.getInputLine
  getInputChar :: String -> InputT m (Maybe Char)
getInputChar = String -> InputT m (Maybe Char)
forall (m :: * -> *).
MonadException m =>
String -> InputT m (Maybe Char)
H.getInputChar
  outputStr :: String -> InputT m ()
outputStr    = String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
H.outputStr
  outputStrLn :: String -> InputT m ()
outputStrLn  = String -> InputT m ()
forall (m :: * -> *). MonadIO m => String -> InputT m ()
H.outputStrLn

instance Fail.MonadFail m => Fail.MonadFail (HaskelineT m) where
  fail :: String -> HaskelineT m a
fail = m a -> HaskelineT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> HaskelineT m a)
-> (String -> m a) -> String -> HaskelineT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail

instance MonadState s m => MonadState s (HaskelineT m) where
  get :: HaskelineT m s
get = m s -> HaskelineT m s
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m s
forall s (m :: * -> *). MonadState s m => m s
get
  put :: s -> HaskelineT m ()
put = m () -> HaskelineT m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> HaskelineT m ()) -> (s -> m ()) -> s -> HaskelineT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put

instance MonadReader r m => MonadReader r (HaskelineT m) where
  ask :: HaskelineT m r
ask                    = m r -> HaskelineT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
  local :: (r -> r) -> HaskelineT m a -> HaskelineT m a
local f :: r -> r
f (HaskelineT m :: InputT m a
m) = InputT m a -> HaskelineT m a
forall (m :: * -> *) a. InputT m a -> HaskelineT m a
HaskelineT (InputT m a -> HaskelineT m a) -> InputT m a -> HaskelineT m a
forall a b. (a -> b) -> a -> b
$ (forall b. m b -> m b) -> InputT m a -> InputT m a
forall (m :: * -> *) a.
(forall b. m b -> m b) -> InputT m a -> InputT m a
H.mapInputT ((r -> r) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f) InputT m a
m

instance (MonadHaskeline m) => MonadHaskeline (StateT s m) where
  getInputLine :: String -> StateT s m (Maybe String)
getInputLine = m (Maybe String) -> StateT s m (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe String) -> StateT s m (Maybe String))
-> (String -> m (Maybe String))
-> String
-> StateT s m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe String)
forall (m :: * -> *).
MonadHaskeline m =>
String -> m (Maybe String)
getInputLine
  getInputChar :: String -> StateT s m (Maybe Char)
getInputChar = m (Maybe Char) -> StateT s m (Maybe Char)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe Char) -> StateT s m (Maybe Char))
-> (String -> m (Maybe Char)) -> String -> StateT s m (Maybe Char)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m (Maybe Char)
forall (m :: * -> *). MonadHaskeline m => String -> m (Maybe Char)
getInputChar
  outputStr :: String -> StateT s m ()
outputStr    = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). MonadHaskeline m => String -> m ()
outputStr
  outputStrLn :: String -> StateT s m ()
outputStrLn  = m () -> StateT s m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> StateT s m ())
-> (String -> m ()) -> String -> StateT s m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> m ()
forall (m :: * -> *). MonadHaskeline m => String -> m ()
outputStrLn

-------------------------------------------------------------------------------
-- Repl
-------------------------------------------------------------------------------

-- | Command function synonym
type Cmd m = [String] -> m ()

-- | Options function synonym
type Options m = [(String, Cmd m)]

-- | Command function synonym
type Command m = String -> m ()

-- | Word completer
type WordCompleter m = (String -> m [String])

-- | Line completer
type LineCompleter m = (String -> String -> m [Completion])

-- | Wrap a HasklineT action so that if an interrupt is thrown the shell continues as normal.
tryAction :: MonadException m => HaskelineT m a -> HaskelineT m a
tryAction :: HaskelineT m a -> HaskelineT m a
tryAction (HaskelineT f :: InputT m a
f) = InputT m a -> HaskelineT m a
forall (m :: * -> *) a. InputT m a -> HaskelineT m a
HaskelineT (InputT m a -> InputT m a
forall (m :: * -> *) a.
MonadException m =>
InputT m a -> InputT m a
H.withInterrupt InputT m a
loop)
    where loop :: InputT m a
loop = (Interrupt -> InputT m a) -> InputT m a -> InputT m a
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
(e -> m a) -> m a -> m a
handle (\H.Interrupt -> InputT m a
loop) InputT m a
f

-- | Catch all toplevel failures.
dontCrash :: (MonadIO m, H.MonadException m) => m () -> m ()
dontCrash :: m () -> m ()
dontCrash m :: m ()
m = m () -> (SomeException -> m ()) -> m ()
forall (m :: * -> *) e a.
(MonadException m, Exception e) =>
m a -> (e -> m a) -> m a
H.catch m ()
m ( \ e :: SomeException
e@SomeException{} -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ( String -> IO ()
putStrLn ( SomeException -> String
forall a. Show a => a -> String
show SomeException
e ) ) )

-- | Abort the current REPL loop, and continue.
abort :: MonadIO m => HaskelineT m a
abort :: HaskelineT m a
abort = Interrupt -> HaskelineT m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO Interrupt
H.Interrupt

-- | Completion loop.
replLoop :: (Functor m, MonadException m)
         => HaskelineT m String -- ^ banner function
         -> Command (HaskelineT m) -- ^ command function
         -> Options (HaskelineT m) -- ^ options function
         -> Maybe Char             -- ^ options prefix
         -> HaskelineT m ()
replLoop :: HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> HaskelineT m ()
replLoop banner :: HaskelineT m String
banner cmdM :: Command (HaskelineT m)
cmdM opts :: Options (HaskelineT m)
opts optsPrefix :: Maybe Char
optsPrefix = HaskelineT m ()
loop
  where
    loop :: HaskelineT m ()
loop = do
      String
prefix <- HaskelineT m String
banner
      Maybe String
minput <- HaskelineT m (Maybe String)
-> HaskelineT m (Maybe String) -> HaskelineT m (Maybe String)
forall (m :: * -> *) a. MonadException m => m a -> m a -> m a
H.handleInterrupt (Maybe String -> HaskelineT m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe String
forall a. a -> Maybe a
Just "")) (HaskelineT m (Maybe String) -> HaskelineT m (Maybe String))
-> HaskelineT m (Maybe String) -> HaskelineT m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> HaskelineT m (Maybe String)
forall (m :: * -> *).
MonadHaskeline m =>
String -> m (Maybe String)
getInputLine String
prefix
      case Maybe String
minput of
        Nothing -> Command (HaskelineT m)
forall (m :: * -> *). MonadHaskeline m => String -> m ()
outputStrLn "Goodbye."
        Just "" -> HaskelineT m ()
loop
        Just (prefix :: Char
prefix: cmds :: String
cmds)
          | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
cmds -> Command (HaskelineT m)
handleInput [Char
prefix] HaskelineT m () -> HaskelineT m () -> HaskelineT m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HaskelineT m ()
loop
          | Char -> Maybe Char
forall a. a -> Maybe a
Just Char
prefix Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Char
optsPrefix ->
            case String -> [String]
words String
cmds of
              [] -> HaskelineT m ()
loop
              (cmd :: String
cmd:args :: [String]
args) -> do
                let optAction :: HaskelineT m ()
optAction = String -> Options (HaskelineT m) -> [String] -> HaskelineT m ()
forall (m :: * -> *).
MonadHaskeline m =>
String -> Options m -> [String] -> m ()
optMatcher String
cmd Options (HaskelineT m)
opts [String]
args
                Maybe ()
result <- HaskelineT m (Maybe ())
-> HaskelineT m (Maybe ()) -> HaskelineT m (Maybe ())
forall (m :: * -> *) a. MonadException m => m a -> m a -> m a
H.handleInterrupt (Maybe () -> HaskelineT m (Maybe ())
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ()
forall a. Maybe a
Nothing) (HaskelineT m (Maybe ()) -> HaskelineT m (Maybe ()))
-> HaskelineT m (Maybe ()) -> HaskelineT m (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ()) -> HaskelineT m () -> HaskelineT m (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HaskelineT m ()
optAction
                HaskelineT m ()
-> (() -> HaskelineT m ()) -> Maybe () -> HaskelineT m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HaskelineT m ()
forall (m :: * -> *). Monad m => m ()
exit (HaskelineT m () -> () -> HaskelineT m ()
forall a b. a -> b -> a
const HaskelineT m ()
loop) Maybe ()
result
        Just input :: String
input -> do
          Command (HaskelineT m)
handleInput String
input
          HaskelineT m ()
loop

    handleInput :: Command (HaskelineT m)
handleInput input :: String
input = HaskelineT m () -> HaskelineT m () -> HaskelineT m ()
forall (m :: * -> *) a. MonadException m => m a -> m a -> m a
H.handleInterrupt HaskelineT m ()
forall (m :: * -> *). Monad m => m ()
exit (HaskelineT m () -> HaskelineT m ())
-> HaskelineT m () -> HaskelineT m ()
forall a b. (a -> b) -> a -> b
$ Command (HaskelineT m)
cmdM String
input
    exit :: m ()
exit = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Match the options.
optMatcher :: MonadHaskeline m => String -> Options m -> [String] -> m ()
optMatcher :: String -> Options m -> [String] -> m ()
optMatcher s :: String
s [] _ = String -> m ()
forall (m :: * -> *). MonadHaskeline m => String -> m ()
outputStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "No such command :" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
optMatcher s :: String
s ((x :: String
x, m :: [String] -> m ()
m):xs :: Options m
xs) args :: [String]
args
  | String
s String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x = [String] -> m ()
m [String]
args
  | Bool
otherwise = String -> Options m -> [String] -> m ()
forall (m :: * -> *).
MonadHaskeline m =>
String -> Options m -> [String] -> m ()
optMatcher String
s Options m
xs [String]
args

-------------------------------------------------------------------------------
-- Toplevel
-------------------------------------------------------------------------------

-- | REPL Options datatype
data ReplOpts m = ReplOpts {
          :: HaskelineT m String    -- ^ Banner
  , ReplOpts m -> Command (HaskelineT m)
command     :: Command (HaskelineT m) -- ^ Command function
  , ReplOpts m -> Options (HaskelineT m)
options     :: Options (HaskelineT m) -- ^ Options list and commands
  , ReplOpts m -> Maybe Char
prefix      :: Maybe Char             -- ^ Optional command prefix ( passing Nothing ignores the Options argument )
  , ReplOpts m -> CompleterStyle m
tabComplete :: CompleterStyle m       -- ^ Tab completion function
  , ReplOpts m -> HaskelineT m ()
initialiser :: HaskelineT m ()        -- ^ Initialiser
  }

-- | Evaluate the REPL logic into a MonadException context from the ReplOpts
-- configuration.
evalReplOpts :: (Functor m, MonadException m) => ReplOpts m -> m ()
evalReplOpts :: ReplOpts m -> m ()
evalReplOpts (ReplOpts {..}) = HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> CompleterStyle m
-> HaskelineT m ()
-> m ()
forall (m :: * -> *) a.
(Functor m, MonadException m) =>
HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> CompleterStyle m
-> HaskelineT m a
-> m ()
evalRepl
  HaskelineT m String
banner
  Command (HaskelineT m)
command
  Options (HaskelineT m)
options
  Maybe Char
prefix
  CompleterStyle m
tabComplete
  HaskelineT m ()
initialiser

-- | Evaluate the REPL logic into a MonadException context.
evalRepl :: (Functor m, MonadException m)  -- Terminal monad ( often IO ).
         => HaskelineT m String            -- ^ Banner
         -> Command (HaskelineT m)         -- ^ Command function
         -> Options (HaskelineT m)         -- ^ Options list and commands
         -> Maybe Char                     -- ^ Optional command prefix ( passing Nothing ignores the Options argument )
         -> CompleterStyle m               -- ^ Tab completion function
         -> HaskelineT m a                 -- ^ Initialiser
         -> m ()
evalRepl :: HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> CompleterStyle m
-> HaskelineT m a
-> m ()
evalRepl banner :: HaskelineT m String
banner cmd :: Command (HaskelineT m)
cmd opts :: Options (HaskelineT m)
opts optsPrefix :: Maybe Char
optsPrefix comp :: CompleterStyle m
comp initz :: HaskelineT m a
initz = Settings m -> HaskelineT m () -> m ()
forall (m :: * -> *) a.
MonadException m =>
Settings m -> HaskelineT m a -> m a
runHaskelineT Settings m
_readline (HaskelineT m a
initz HaskelineT m a -> HaskelineT m () -> HaskelineT m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HaskelineT m ()
monad)
  where
    monad :: HaskelineT m ()
monad = HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> HaskelineT m ()
forall (m :: * -> *).
(Functor m, MonadException m) =>
HaskelineT m String
-> Command (HaskelineT m)
-> Options (HaskelineT m)
-> Maybe Char
-> HaskelineT m ()
replLoop HaskelineT m String
banner Command (HaskelineT m)
cmd Options (HaskelineT m)
opts Maybe Char
optsPrefix
    _readline :: Settings m
_readline = Settings :: forall (m :: * -> *).
CompletionFunc m -> Maybe String -> Bool -> Settings m
H.Settings
      { complete :: CompletionFunc m
H.complete       = CompleterStyle m -> CompletionFunc m
forall (m :: * -> *).
MonadIO m =>
CompleterStyle m -> CompletionFunc m
mkCompleter CompleterStyle m
comp
      , historyFile :: Maybe String
H.historyFile    = String -> Maybe String
forall a. a -> Maybe a
Just ".history"
      , autoAddHistory :: Bool
H.autoAddHistory = Bool
True
      }

-------------------------------------------------------------------------------
-- Completions
-------------------------------------------------------------------------------

data CompleterStyle m
  = Word (WordCompleter m)       -- ^ Completion function takes single word.
  | Word0 (WordCompleter m)      -- ^ Completion function takes single word ( no space ).
  | Cursor (LineCompleter m)     -- ^ Completion function takes tuple of full line.
  | File                         -- ^ Completion function completes files in CWD.
  | Prefix
      (CompletionFunc m)
      [(String, CompletionFunc m)] -- ^ Conditional tab completion based on prefix.

-- | Make a completer function from a completion type
mkCompleter :: MonadIO m => CompleterStyle m -> CompletionFunc m
mkCompleter :: CompleterStyle m -> CompletionFunc m
mkCompleter (Word f :: WordCompleter m
f)          = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord (Char -> Maybe Char
forall a. a -> Maybe a
Just '\\') " \t()[]" (WordCompleter m -> String -> m [Completion]
forall (m :: * -> *).
Monad m =>
(String -> m [String]) -> String -> m [Completion]
_simpleComplete WordCompleter m
f)
mkCompleter (Word0 f :: WordCompleter m
f)         = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord (Char -> Maybe Char
forall a. a -> Maybe a
Just '\\') " \t()[]" (WordCompleter m -> String -> m [Completion]
forall (m :: * -> *).
Monad m =>
(String -> m [String]) -> String -> m [Completion]
_simpleCompleteNoSpace WordCompleter m
f)
mkCompleter (Cursor f :: LineCompleter m
f)        = Maybe Char -> String -> LineCompleter m -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev (Char -> Maybe Char
forall a. a -> Maybe a
Just '\\') " \t()[]" (LineCompleter m -> LineCompleter m
forall (m :: * -> *). LineCompleter m -> LineCompleter m
unRev0 LineCompleter m
f)
mkCompleter File              = CompletionFunc m
forall (m :: * -> *). MonadIO m => CompletionFunc m
completeFilename
mkCompleter (Prefix def :: CompletionFunc m
def opts :: [(String, CompletionFunc m)]
opts) = [(String, CompletionFunc m)]
-> CompletionFunc m -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
[(String, CompletionFunc m)]
-> CompletionFunc m -> CompletionFunc m
runMatcher [(String, CompletionFunc m)]
opts CompletionFunc m
def

-- haskeline takes the first argument as the reversed string, don't know why
unRev0 :: LineCompleter m -> LineCompleter m
unRev0 :: LineCompleter m -> LineCompleter m
unRev0 f :: LineCompleter m
f x :: String
x = LineCompleter m
f (String -> String
forall a. [a] -> [a]
reverse String
x)

trimComplete :: String -> Completion -> Completion
trimComplete :: String -> Completion -> Completion
trimComplete prefix :: String
prefix (Completion a :: String
a b :: String
b c :: Bool
c) = String -> String -> Bool -> Completion
Completion (Int -> String -> String
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
a) String
b Bool
c

_simpleComplete :: (Monad m) => (String -> m [String]) -> String -> m [Completion]
_simpleComplete :: (String -> m [String]) -> String -> m [Completion]
_simpleComplete f :: String -> m [String]
f word :: String
word = String -> m [String]
f String
word m [String] -> ([String] -> m [Completion]) -> m [Completion]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Completion] -> m [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Completion] -> m [Completion])
-> ([String] -> [Completion]) -> [String] -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
simpleCompletion

_simpleCompleteNoSpace :: (Monad m) => (String -> m [String]) -> String -> m [Completion]
_simpleCompleteNoSpace :: (String -> m [String]) -> String -> m [Completion]
_simpleCompleteNoSpace f :: String -> m [String]
f word :: String
word = String -> m [String]
f String
word m [String] -> ([String] -> m [Completion]) -> m [Completion]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Completion] -> m [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Completion] -> m [Completion])
-> ([String] -> [Completion]) -> [String] -> m [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
completionNoSpace

completionNoSpace :: String -> Completion
completionNoSpace :: String -> Completion
completionNoSpace str :: String
str = String -> String -> Bool -> Completion
Completion String
str String
str Bool
False

-- | Word completer function
wordCompleter :: Monad m => WordCompleter m -> CompletionFunc m
wordCompleter :: WordCompleter m -> CompletionFunc m
wordCompleter f :: WordCompleter m
f (start :: String
start, n :: String
n) = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord (Char -> Maybe Char
forall a. a -> Maybe a
Just '\\') " \t()[]" (WordCompleter m -> String -> m [Completion]
forall (m :: * -> *).
Monad m =>
(String -> m [String]) -> String -> m [Completion]
_simpleComplete WordCompleter m
f) (String
start, String
n)

-- | List completer function
listCompleter :: Monad m => [String] -> CompletionFunc m
listCompleter :: [String] -> CompletionFunc m
listCompleter names :: [String]
names (start :: String
start, n :: String
n) = Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord (Char -> Maybe Char
forall a. a -> Maybe a
Just '\\') " \t()[]" ((String -> m [String]) -> String -> m [Completion]
forall (m :: * -> *).
Monad m =>
(String -> m [String]) -> String -> m [Completion]
_simpleComplete ([String] -> String -> m [String]
forall (m :: * -> *). Monad m => [String] -> WordCompleter m
complete_aux [String]
names)) (String
start, String
n)

listWordCompleter :: Monad m => [String] -> WordCompleter m
listWordCompleter :: [String] -> WordCompleter m
listWordCompleter = [String] -> WordCompleter m
forall (m :: * -> *). Monad m => [String] -> WordCompleter m
complete_aux

-- | File completer function
fileCompleter :: MonadIO m => CompletionFunc m
fileCompleter :: CompletionFunc m
fileCompleter = CompletionFunc m
forall (m :: * -> *). MonadIO m => CompletionFunc m
completeFilename

complete_aux :: Monad m => [String] -> WordCompleter m
complete_aux :: [String] -> WordCompleter m
complete_aux names :: [String]
names n :: String
n = [String] -> m [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> m [String]) -> [String] -> m [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
n) [String]
names

completeMatcher :: (Monad m) => CompletionFunc m -> String
                             -> [(String, CompletionFunc m)]
                             -> CompletionFunc m
completeMatcher :: CompletionFunc m
-> String -> [(String, CompletionFunc m)] -> CompletionFunc m
completeMatcher def :: CompletionFunc m
def _ [] args :: (String, String)
args = CompletionFunc m
def (String, String)
args
completeMatcher def :: CompletionFunc m
def [] _ args :: (String, String)
args = CompletionFunc m
def (String, String)
args
completeMatcher def :: CompletionFunc m
def s :: String
s ((x :: String
x, f :: CompletionFunc m
f):xs :: [(String, CompletionFunc m)]
xs) args :: (String, String)
args
  | String
x String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s = CompletionFunc m
f (String, String)
args
  | Bool
otherwise = CompletionFunc m
-> String -> [(String, CompletionFunc m)] -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
CompletionFunc m
-> String -> [(String, CompletionFunc m)] -> CompletionFunc m
completeMatcher CompletionFunc m
def String
s [(String, CompletionFunc m)]
xs (String, String)
args

-- | Return a completion function a line fragment
runMatcher
  :: Monad m => [(String, CompletionFunc m)]
  -> CompletionFunc m
  -> CompletionFunc m
runMatcher :: [(String, CompletionFunc m)]
-> CompletionFunc m -> CompletionFunc m
runMatcher opts :: [(String, CompletionFunc m)]
opts def :: CompletionFunc m
def (start :: String
start, n :: String
n) =
  CompletionFunc m
-> String -> [(String, CompletionFunc m)] -> CompletionFunc m
forall (m :: * -> *).
Monad m =>
CompletionFunc m
-> String -> [(String, CompletionFunc m)] -> CompletionFunc m
completeMatcher CompletionFunc m
def (String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. [a] -> [a]
reverse String
start) [(String, CompletionFunc m)]
opts (String
start, String
n)