Repline.hs

{-# LANGUAGE KindSignatures #-}
{-# 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 (
  HaskelineT,
  runHaskelineT,

  Cmd,
  Options,
  WordCompleter,
  LineCompleter,
  CompleterStyle(..),
  Command,

  CompletionFunc, -- re-export

  wordCompleter,
  listCompleter,
  fileCompleter,
  listWordCompleter,

  runMatcher,
  evalRepl,
  abort,
  tryAction,
  dontCrash,

  trimComplete,
) 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 { unHaskeline :: H.InputT m a }
 deriving (Monad, Functor, Applicative, MonadIO, MonadException, MonadTrans, MonadHaskeline)

runHaskelineT :: MonadException m => H.Settings m -> HaskelineT m a -> m a
runHaskelineT s m = H.runInputT s (H.withInterrupt (unHaskeline 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 = H.getInputLine
  getInputChar = H.getInputChar
  outputStr    = H.outputStr
  outputStrLn  = H.outputStrLn

instance Fail.MonadFail m => Fail.MonadFail (HaskelineT m) where
  fail = lift . Fail.fail

instance MonadState s m => MonadState s (HaskelineT m) where
  get = lift get
  put = lift . put

instance MonadReader r m => MonadReader r (HaskelineT m) where
  ask                    = lift ask
  local f (HaskelineT m) = HaskelineT $ H.mapInputT (local f) m

instance (MonadHaskeline m) => MonadHaskeline (StateT s m) where
  getInputLine = lift . getInputLine
  getInputChar = lift . getInputChar
  outputStr    = lift . outputStr
  outputStrLn  = lift . outputStrLn

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

type Cmd m = [String] -> m ()
type Options m = [(String, Cmd m)]
type Command m = String -> m ()

type WordCompleter m = (String -> m [String])
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 f) = HaskelineT (H.withInterrupt loop)
    where loop = handle (\H.Interrupt -> loop) f

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

-- | Abort the current REPL loop, and continue.
abort :: MonadIO m => HaskelineT m a
abort = throwIO H.Interrupt

-- | Completion loop.
replLoop :: (Functor m, MonadException m)
         => HaskelineT m String
         -> Command (HaskelineT m)
         -> Options (HaskelineT m)
         -> Maybe Char
         -> HaskelineT m ()
replLoop banner cmdM opts optsPrefix = loop
  where
    loop = do
      prefix <- banner
      minput <- H.handleInterrupt (return (Just "")) $ getInputLine prefix
      case minput of
        Nothing -> outputStrLn "Goodbye."
        Just "" -> loop
        Just (prefix: cmds)
          | null cmds -> handleInput [prefix] >> loop
          | Just prefix == optsPrefix ->
            case words cmds of
              [] -> loop
              (cmd:args) -> do
                let optAction = optMatcher cmd opts args
                result <- H.handleInterrupt (return Nothing) $ Just <$> optAction
                maybe exit (const loop) result
        Just input -> do
          handleInput input
          loop

    handleInput input = H.handleInterrupt exit $ cmdM input
    exit = return ()

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

-- | 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                 -- ^ Initializer
         -> m ()
evalRepl banner cmd opts optsPrefix comp initz = runHaskelineT _readline (initz >> monad)
  where
    monad = replLoop banner cmd opts optsPrefix
    _readline = H.Settings
      { H.complete       = mkCompleter comp
      , H.historyFile    = Just ".history"
      , H.autoAddHistory = True
      }

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

--type CompletionFunc m = (String, String) -> m (String, [Completion])

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.

mkCompleter :: MonadIO m => CompleterStyle m -> CompletionFunc m
mkCompleter (Word f)          = completeWord (Just '\\') " \t()[]" (_simpleComplete f)
mkCompleter (Word0 f)         = completeWord (Just '\\') " \t()[]" (_simpleCompleteNoSpace f)
mkCompleter (Cursor f)        = completeWordWithPrev (Just '\\') " \t()[]" (unRev0 f)
mkCompleter File              = completeFilename
mkCompleter (Prefix def opts) = runMatcher opts def

-- haskeline takes the first argument as the reversed string, don't know why
unRev0 :: LineCompleter m -> LineCompleter m
unRev0 f x y = f (reverse x) y

trimComplete :: String -> Completion -> Completion
trimComplete prefix (Completion a b c) = Completion (drop (length prefix) a) b c

_simpleComplete :: (Monad m) => (String -> m [String]) -> String -> m [Completion]
_simpleComplete f word = f word >>= return . map simpleCompletion

_simpleCompleteNoSpace :: (Monad m) => (String -> m [String]) -> String -> m [Completion]
_simpleCompleteNoSpace f word = f word >>= return . map completionNoSpace

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

wordCompleter :: Monad m => WordCompleter m -> CompletionFunc m
wordCompleter f (start, n) = completeWord (Just '\\') " \t()[]" (_simpleComplete f) (start, n)

listCompleter :: Monad m => [String] -> CompletionFunc m
listCompleter names (start, n) = completeWord (Just '\\') " \t()[]" (_simpleComplete (complete_aux names)) (start, n)

listWordCompleter :: Monad m => [String] -> WordCompleter m
listWordCompleter = complete_aux

fileCompleter :: MonadIO m => CompletionFunc m
fileCompleter = completeFilename

complete_aux :: Monad m => [String] -> WordCompleter m
complete_aux names n = return $ filter (isPrefixOf n) names

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

runMatcher :: Monad m => [(String, CompletionFunc m)]
                      -> CompletionFunc m
                      -> CompletionFunc m
runMatcher opts def (start, n) =
  completeMatcher def (n ++ reverse start) opts (start, n)