-- |
-- Module      :  REPL.Haskeline
-- Copyright   :  (c) 2013-2016 Galois, Inc.
-- License     :  BSD3
-- Maintainer  :  cryptol@galois.com
-- Stability   :  provisional
-- Portability :  portable

{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module REPL.Haskeline where

import qualified Cryptol.Project as Project
import           Cryptol.REPL.Command
import           Cryptol.REPL.Monad
import           Cryptol.REPL.Trie
import           Cryptol.Utils.PP hiding ((</>))
import           Cryptol.Utils.Logger(stdoutLogger)
import           Cryptol.Utils.Ident(modNameToText, interactiveName)

import qualified Control.Exception as X
import           Control.Monad (guard, join)
import qualified Control.Monad.Trans.Class as MTL
#if !MIN_VERSION_haskeline(0,8,0)
import           Control.Monad.Trans.Control
#endif
import           Data.Char (isAlphaNum, isSpace)
import           Data.Function (on)
import           Data.List (isPrefixOf,nub,sortBy,sort)
import qualified Data.Set as Set
import qualified Data.Text as T (unpack)
import           System.Console.ANSI (setTitle, hSupportsANSI)
import           System.Console.Haskeline
import           System.Directory ( doesFileExist
                                  , getHomeDirectory
                                  , getCurrentDirectory)
import           System.FilePath ((</>))
import           System.IO (stdout)

import           Prelude ()
import           Prelude.Compat
import Cryptol.Project.Monad (LoadProjectMode)


data ReplMode
  = InteractiveRepl -- ^ Interactive terminal session
  | Batch FilePath  -- ^ Execute from a batch file
  | InteractiveBatch FilePath
     -- ^ Execute from a batch file, but behave as though
     --   lines are entered in an interactive session.
 deriving (Int -> ReplMode -> ShowS
[ReplMode] -> ShowS
ReplMode -> String
(Int -> ReplMode -> ShowS)
-> (ReplMode -> String) -> ([ReplMode] -> ShowS) -> Show ReplMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReplMode -> ShowS
showsPrec :: Int -> ReplMode -> ShowS
$cshow :: ReplMode -> String
show :: ReplMode -> String
$cshowList :: [ReplMode] -> ShowS
showList :: [ReplMode] -> ShowS
Show, ReplMode -> ReplMode -> Bool
(ReplMode -> ReplMode -> Bool)
-> (ReplMode -> ReplMode -> Bool) -> Eq ReplMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReplMode -> ReplMode -> Bool
== :: ReplMode -> ReplMode -> Bool
$c/= :: ReplMode -> ReplMode -> Bool
/= :: ReplMode -> ReplMode -> Bool
Eq)

-- | One REPL invocation, either from a file or from the terminal.
crySession :: ReplMode -> Bool -> REPL CommandResult
crySession :: ReplMode -> Bool -> REPL CommandResult
crySession ReplMode
replMode Bool
stopOnError =
  do Settings REPL
settings <- IO (Settings REPL) -> REPL (Settings REPL)
forall a. IO a -> REPL a
io (Settings REPL -> IO (Settings REPL)
setHistoryFile (Bool -> Settings REPL
replSettings Bool
isBatch))
     let act :: REPL CommandResult
act = Behavior
-> Settings REPL -> InputT REPL CommandResult -> REPL CommandResult
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Behavior -> Settings m -> InputT m a -> m a
runInputTBehavior Behavior
behavior Settings REPL
settings (InputT REPL CommandResult -> InputT REPL CommandResult
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
withInterrupt (Bool -> Int -> InputT REPL CommandResult
loop Bool
True Int
1))
     if Bool
isBatch then REPL CommandResult -> REPL CommandResult
forall a. REPL a -> REPL a
asBatch REPL CommandResult
act else REPL CommandResult
act
  where
  (Bool
isBatch,Behavior
behavior) = case ReplMode
replMode of
    ReplMode
InteractiveRepl       -> (Bool
False, Behavior
defaultBehavior)
    Batch String
path            -> (Bool
True,  String -> Behavior
useFile String
path)
    InteractiveBatch String
path -> (Bool
False, String -> Behavior
useFile String
path)

  loop :: Bool -> Int -> InputT REPL CommandResult
  loop :: Bool -> Int -> InputT REPL CommandResult
loop !Bool
success !Int
lineNum =
    do NextLine
ln <- String -> InputT REPL NextLine
getInputLines (String -> InputT REPL NextLine)
-> InputT REPL String -> InputT REPL NextLine
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< REPL String -> InputT REPL String
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MTL.lift REPL String
getPrompt
       case NextLine
ln of
         NextLine
NoMoreLines -> CommandResult -> InputT REPL CommandResult
forall a. a -> InputT REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult { crSuccess = success }
         NextLine
Interrupted
           | Bool
isBatch Bool -> Bool -> Bool
&& Bool
stopOnError -> CommandResult -> InputT REPL CommandResult
forall a. a -> InputT REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult { crSuccess = False }
           | Bool
otherwise -> Bool -> Int -> InputT REPL CommandResult
loop Bool
success Int
lineNum
         NextLine [String]
ls
           | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace) [String]
ls -> Bool -> Int -> InputT REPL CommandResult
loop Bool
success (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls)
           | Bool
otherwise            -> Bool -> Int -> [String] -> InputT REPL CommandResult
doCommand Bool
success Int
lineNum [String]
ls

  run :: Int -> Command -> REPL CommandResult
run Int
lineNum Command
cmd =
    case ReplMode
replMode of
      ReplMode
InteractiveRepl    -> Int -> Maybe String -> Command -> REPL CommandResult
runCommand Int
lineNum Maybe String
forall a. Maybe a
Nothing Command
cmd
      InteractiveBatch String
_ -> Int -> Maybe String -> Command -> REPL CommandResult
runCommand Int
lineNum Maybe String
forall a. Maybe a
Nothing Command
cmd
      Batch String
path         -> Int -> Maybe String -> Command -> REPL CommandResult
runCommand Int
lineNum (String -> Maybe String
forall a. a -> Maybe a
Just String
path) Command
cmd

  doCommand :: Bool -> Int -> [String] -> InputT REPL CommandResult
doCommand Bool
success Int
lineNum [String]
txt =
    case (String -> [CommandDescr]) -> String -> Maybe Command
parseCommand String -> [CommandDescr]
findCommandExact ([String] -> String
unlines [String]
txt) of
      Maybe Command
Nothing | Bool
isBatch Bool -> Bool -> Bool
&& Bool
stopOnError -> CommandResult -> InputT REPL CommandResult
forall a. a -> InputT REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult { crSuccess = False }
              | Bool
otherwise -> Bool -> Int -> InputT REPL CommandResult
loop Bool
False (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
txt)  -- say somtething?
      Just Command
cmd -> InputT REPL (InputT REPL CommandResult)
-> InputT REPL CommandResult
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (InputT REPL (InputT REPL CommandResult)
 -> InputT REPL CommandResult)
-> InputT REPL (InputT REPL CommandResult)
-> InputT REPL CommandResult
forall a b. (a -> b) -> a -> b
$ REPL (InputT REPL CommandResult)
-> InputT REPL (InputT REPL CommandResult)
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MTL.lift (REPL (InputT REPL CommandResult)
 -> InputT REPL (InputT REPL CommandResult))
-> REPL (InputT REPL CommandResult)
-> InputT REPL (InputT REPL CommandResult)
forall a b. (a -> b) -> a -> b
$
        do CommandResult
status <- REPL CommandResult -> REPL CommandResult -> REPL CommandResult
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
handleInterrupt (CommandResult -> REPL CommandResult
forall a. a -> REPL a
handleCtrlC CommandResult
emptyCommandResult { crSuccess = False }) (Int -> Command -> REPL CommandResult
run Int
lineNum Command
cmd)
           case CommandResult -> Bool
crSuccess CommandResult
status of
             Bool
False | Bool
isBatch Bool -> Bool -> Bool
&& Bool
stopOnError -> InputT REPL CommandResult -> REPL (InputT REPL CommandResult)
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandResult -> InputT REPL CommandResult
forall a. a -> InputT REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
status)
             Bool
_ -> do Bool
goOn <- REPL Bool
shouldContinue
                     InputT REPL CommandResult -> REPL (InputT REPL CommandResult)
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
goOn then Bool -> Int -> InputT REPL CommandResult
loop (CommandResult -> Bool
crSuccess CommandResult
status Bool -> Bool -> Bool
&& Bool
success) (Int
lineNum Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
txt) else CommandResult -> InputT REPL CommandResult
forall a. a -> InputT REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
status)


data NextLine = NextLine [String] | NoMoreLines | Interrupted

getInputLines :: String -> InputT REPL NextLine
getInputLines :: String -> InputT REPL NextLine
getInputLines = InputT REPL NextLine
-> InputT REPL NextLine -> InputT REPL NextLine
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
handleInterrupt (REPL NextLine -> InputT REPL NextLine
forall (m :: * -> *) a. Monad m => m a -> InputT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MTL.lift (NextLine -> REPL NextLine
forall a. a -> REPL a
handleCtrlC NextLine
Interrupted)) (InputT REPL NextLine -> InputT REPL NextLine)
-> (String -> InputT REPL NextLine)
-> String
-> InputT REPL NextLine
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> InputT REPL NextLine
forall {m :: * -> *}.
(MonadIO m, MonadMask m) =>
[String] -> String -> InputT m NextLine
loop []
  where
  loop :: [String] -> String -> InputT m NextLine
loop [String]
ls String
prompt =
    do Maybe String
mb <- ShowS -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')) (Maybe String -> Maybe String)
-> InputT m (Maybe String) -> InputT m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> InputT m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
prompt
       let newPropmpt :: String
newPropmpt = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\Char
_ -> Char
' ') String
prompt
       case Maybe String
mb of
         Maybe String
Nothing -> NextLine -> InputT m NextLine
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return NextLine
NoMoreLines
         Just String
l
           | Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
l) Bool -> Bool -> Bool
&& String -> Char
forall a. HasCallStack => [a] -> a
last String
l Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' -> [String] -> String -> InputT m NextLine
loop (ShowS
forall a. HasCallStack => [a] -> [a]
init String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ls) String
newPropmpt
           | Bool
otherwise -> NextLine -> InputT m NextLine
forall a. a -> InputT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (NextLine -> InputT m NextLine) -> NextLine -> InputT m NextLine
forall a b. (a -> b) -> a -> b
$ [String] -> NextLine
NextLine ([String] -> NextLine) -> [String] -> NextLine
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
l String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ls

loadCryRC :: Cryptolrc -> REPL CommandResult
loadCryRC :: Cryptolrc -> REPL CommandResult
loadCryRC Cryptolrc
cryrc =
  case Cryptolrc
cryrc of
    Cryptolrc
CryrcDisabled   -> CommandResult -> REPL CommandResult
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult
    Cryptolrc
CryrcDefault    -> [IO String] -> REPL CommandResult
check [ IO String
getCurrentDirectory, IO String
getHomeDirectory ]
    CryrcFiles [String]
opts -> [String] -> REPL CommandResult
loadMany [String]
opts
  where
  check :: [IO String] -> REPL CommandResult
check [] = CommandResult -> REPL CommandResult
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult
  check (IO String
place : [IO String]
others) =
    do String
dir <- IO String -> REPL String
forall a. IO a -> REPL a
io IO String
place
       let file :: String
file = String
dir String -> ShowS
</> String
".cryptolrc"
       Bool
present <- IO Bool -> REPL Bool
forall a. IO a -> REPL a
io (String -> IO Bool
doesFileExist String
file)
       if Bool
present
         then ReplMode -> Bool -> REPL CommandResult
crySession (String -> ReplMode
Batch String
file) Bool
True
         else [IO String] -> REPL CommandResult
check [IO String]
others

  loadMany :: [String] -> REPL CommandResult
loadMany []       = CommandResult -> REPL CommandResult
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
emptyCommandResult
  loadMany (String
f : [String]
fs) = do CommandResult
status <- ReplMode -> Bool -> REPL CommandResult
crySession (String -> ReplMode
Batch String
f) Bool
True
                         if CommandResult -> Bool
crSuccess CommandResult
status
                           then [String] -> REPL CommandResult
loadMany [String]
fs
                           else CommandResult -> REPL CommandResult
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
status

-- | Haskeline-specific repl implementation.
repl ::
  Cryptolrc ->
  Maybe Project.Config ->
  LoadProjectMode {- ^ refresh project -} ->
  ReplMode -> Bool -> Bool -> REPL () -> IO CommandResult
repl :: Cryptolrc
-> Maybe Config
-> LoadProjectMode
-> ReplMode
-> Bool
-> Bool
-> REPL ()
-> IO CommandResult
repl Cryptolrc
cryrc Maybe Config
projectConfig LoadProjectMode
loadProjectMode ReplMode
replMode Bool
callStacks Bool
stopOnError REPL ()
begin =
  Bool -> Bool -> Logger -> REPL CommandResult -> IO CommandResult
forall a. Bool -> Bool -> Logger -> REPL a -> IO a
runREPL Bool
isBatch Bool
callStacks Logger
stdoutLogger REPL CommandResult
replAction

 where
  -- this flag is used to suppress the logo and prompts
  isBatch :: Bool
isBatch =
    case Maybe Config
projectConfig of
      Just Config
_ -> Bool
True
      Maybe Config
Nothing ->
        case ReplMode
replMode of
          ReplMode
InteractiveRepl -> Bool
False
          Batch String
_ -> Bool
True
          InteractiveBatch String
_ -> Bool
True

  replAction :: REPL CommandResult
replAction =
    do CommandResult
status <- Cryptolrc -> REPL CommandResult
loadCryRC Cryptolrc
cryrc
       if CommandResult -> Bool
crSuccess CommandResult
status then do
          REPL ()
begin
          case Maybe Config
projectConfig of
            Just Config
config -> LoadProjectMode -> Config -> REPL CommandResult
loadProjectREPL LoadProjectMode
loadProjectMode Config
config
            Maybe Config
Nothing     -> ReplMode -> Bool -> REPL CommandResult
crySession ReplMode
replMode Bool
stopOnError
       else CommandResult -> REPL CommandResult
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return CommandResult
status

-- | Try to set the history file.
setHistoryFile :: Settings REPL -> IO (Settings REPL)
setHistoryFile :: Settings REPL -> IO (Settings REPL)
setHistoryFile Settings REPL
ss =
  do String
dir <- IO String
getHomeDirectory
     Settings REPL -> IO (Settings REPL)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Settings REPL
ss { historyFile = Just (dir </> ".cryptol_history") }
   IO (Settings REPL)
-> (SomeException -> IO (Settings REPL)) -> IO (Settings REPL)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`X.catch` \(X.SomeException {}) -> Settings REPL -> IO (Settings REPL)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Settings REPL
ss

-- | Haskeline settings for the REPL.
replSettings :: Bool -> Settings REPL
replSettings :: Bool -> Settings REPL
replSettings Bool
isBatch = Settings
  { complete :: CompletionFunc REPL
complete       = CompletionFunc REPL
cryptolCommand
  , historyFile :: Maybe String
historyFile    = Maybe String
forall a. Maybe a
Nothing
  , autoAddHistory :: Bool
autoAddHistory = Bool -> Bool
not Bool
isBatch
  }

-- .cryptolrc ------------------------------------------------------------------

-- | Configuration of @.cryptolrc@ file behavior. The default option
-- searches the following locations in order, and evaluates the first
-- file that exists in batch mode on interpreter startup:
--
-- 1. $PWD/.cryptolrc
-- 2. $HOME/.cryptolrc
--
-- If files are specified, they will all be evaluated, but none of the
-- default files will be (unless they are explicitly specified).
--
-- The disabled option inhibits any reading of any .cryptolrc files.
data Cryptolrc =
    CryrcDefault
  | CryrcDisabled
  | CryrcFiles [FilePath]
  deriving (Int -> Cryptolrc -> ShowS
[Cryptolrc] -> ShowS
Cryptolrc -> String
(Int -> Cryptolrc -> ShowS)
-> (Cryptolrc -> String)
-> ([Cryptolrc] -> ShowS)
-> Show Cryptolrc
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Cryptolrc -> ShowS
showsPrec :: Int -> Cryptolrc -> ShowS
$cshow :: Cryptolrc -> String
show :: Cryptolrc -> String
$cshowList :: [Cryptolrc] -> ShowS
showList :: [Cryptolrc] -> ShowS
Show)

-- Utilities -------------------------------------------------------------------

#if !MIN_VERSION_haskeline(0,8,0)
instance MonadException REPL where
  controlIO f = join $ liftBaseWith $ \f' ->
    f $ RunIO $ \m -> restoreM <$> (f' m)
#endif

-- Titles ----------------------------------------------------------------------

mkTitle :: Maybe LoadedModule -> String
mkTitle :: Maybe LoadedModule -> String
mkTitle Maybe LoadedModule
lm = String -> (ModName -> String) -> Maybe ModName -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\ ModName
m -> ModName -> String
forall a. PP a => a -> String
pretty ModName
m String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" - ") (LoadedModule -> Maybe ModName
lName (LoadedModule -> Maybe ModName)
-> Maybe LoadedModule -> Maybe ModName
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe LoadedModule
lm)
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"cryptol"

setREPLTitle :: REPL ()
setREPLTitle :: REPL ()
setREPLTitle = do
  Maybe LoadedModule
lm <- REPL (Maybe LoadedModule)
getLoadedMod
  IO () -> REPL ()
forall a. IO a -> REPL a
io (String -> IO ()
setTitle (Maybe LoadedModule -> String
mkTitle Maybe LoadedModule
lm))

-- | In certain environments like Emacs, we shouldn't set the terminal
-- title. Note: this does not imply we can't use color output. We can
-- use ANSI color sequences in places like Emacs, but not terminal
-- codes.
--
-- This checks that @'stdout'@ is a proper terminal handle, and that the
-- terminal mode is not @dumb@, which is set by Emacs and others.
shouldSetREPLTitle :: REPL Bool
shouldSetREPLTitle :: REPL Bool
shouldSetREPLTitle = IO Bool -> REPL Bool
forall a. IO a -> REPL a
io (Handle -> IO Bool
hSupportsANSI Handle
stdout)

-- | Whether we can display color titles. This checks that @'stdout'@
-- is a proper terminal handle, and that the terminal mode is not
-- @dumb@, which is set by Emacs and others.
canDisplayColor :: REPL Bool
canDisplayColor :: REPL Bool
canDisplayColor = IO Bool -> REPL Bool
forall a. IO a -> REPL a
io (Handle -> IO Bool
hSupportsANSI Handle
stdout)

-- Completion ------------------------------------------------------------------

-- | Completion for cryptol commands.
cryptolCommand :: CompletionFunc REPL
cryptolCommand :: CompletionFunc REPL
cryptolCommand cursor :: (String, String)
cursor@(String
l,String
r)
  | String
":" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
l'
  , Just (Int
_,String
cmd,String
rest) <- String -> Maybe (Int, String, String)
splitCommand String
l' = case [CommandDescr] -> [CommandDescr]
forall a. Eq a => [a] -> [a]
nub (String -> [CommandDescr]
findCommand String
cmd) of

      [CommandDescr
c] | String -> Bool
cursorRightAfterCmd String
rest ->
            (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, String -> CommandDescr -> [Completion]
cmdComp String
cmd CommandDescr
c)
          | Bool
otherwise ->
            String -> String -> CommandDescr -> REPL (String, [Completion])
completeCmdArgument String
cmd String
rest CommandDescr
c

      [CommandDescr]
cmds
        -- If the command name is a prefix of multiple commands, then as a
        -- special case, check if (1) the name matches one command exactly, and
        -- (2) there is already some input for an argument. If so, proceed to
        -- tab-complete that argument. This ensures that something like
        -- `:check rev` will complete to `:check reverse`, even though the
        -- command name `:check` is a prefix for both the `:check` and
        -- `:check-docstrings` commands (#1781).
        | [CommandDescr
c] <- [CommandDescr] -> [CommandDescr]
forall a. Eq a => [a] -> [a]
nub (String -> [CommandDescr]
findCommandExact String
cmd)
        , Bool -> Bool
not (String -> Bool
cursorRightAfterCmd String
rest) ->
          String -> String -> CommandDescr -> REPL (String, [Completion])
completeCmdArgument String
cmd String
rest CommandDescr
c

        | Bool
otherwise ->
          (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, [[Completion]] -> [Completion]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String -> CommandDescr -> [Completion]
cmdComp String
l' CommandDescr
c | CommandDescr
c <- [CommandDescr]
cmds ])
  -- Complete all : commands when the line is just a :
  | String
":" String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
l' = (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, [[Completion]] -> [Completion]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String -> CommandDescr -> [Completion]
cmdComp String
l' CommandDescr
c | CommandDescr
c <- [CommandDescr] -> [CommandDescr]
forall a. Eq a => [a] -> [a]
nub (String -> [CommandDescr]
findCommand String
":") ])
  | Bool
otherwise = CompletionFunc REPL
completeExpr (String, String)
cursor
  where
  l' :: String
l' = ShowS
sanitize (ShowS
forall a. [a] -> [a]
reverse String
l)

  -- Check if the cursor is positioned immediately after the input for the
  -- command, without any command arguments typed in after the command's name.
  cursorRightAfterCmd ::
    String
      {- The rest of the input after the command. -} ->
    Bool
  cursorRightAfterCmd :: String -> Bool
cursorRightAfterCmd String
rest = String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isSpace String
l')

  -- Perform tab completion for a single argument to a command.
  completeCmdArgument ::
    String
      {- The name of the command as a String. -} ->
    String
      {- The rest of the input after the command. -} ->
    CommandDescr
      {- The description of the command. -} ->
    REPL (String, [Completion])
  completeCmdArgument :: String -> String -> CommandDescr -> REPL (String, [Completion])
completeCmdArgument String
cmd String
rest CommandDescr
c =
    do (String
rest',[Completion]
cs) <- CommandBody -> CompletionFunc REPL
cmdArgument (CommandDescr -> CommandBody
cBody CommandDescr
c) (ShowS
forall a. [a] -> [a]
reverse (ShowS
sanitize String
rest),String
r)
       (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> String
unwords [String
rest', ShowS
forall a. [a] -> [a]
reverse String
cmd],[Completion]
cs)

-- | Generate completions from a REPL command definition.
cmdComp :: String -> CommandDescr -> [Completion]
cmdComp :: String -> CommandDescr -> [Completion]
cmdComp String
prefix CommandDescr
c = do
  String
cName <- CommandDescr -> [String]
cNames CommandDescr
c
  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
prefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
cName)
  Completion -> [Completion]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion -> [Completion]) -> Completion -> [Completion]
forall a b. (a -> b) -> a -> b
$ String -> String -> Completion
nameComp String
prefix String
cName

-- | Dispatch to a completion function based on the kind of completion the
-- command is expecting.
cmdArgument :: CommandBody -> CompletionFunc REPL
cmdArgument :: CommandBody -> CompletionFunc REPL
cmdArgument CommandBody
ct cursor :: (String, String)
cursor@(String
l,String
_) = case CommandBody
ct of
  ExprArg     String -> (Int, Int) -> Maybe String -> REPL CommandResult
_ -> CompletionFunc REPL
completeExpr (String, String)
cursor
  DeclsArg    String -> REPL CommandResult
_ -> (CompletionFunc REPL
completeExpr CompletionFunc REPL -> CompletionFunc REPL -> CompletionFunc REPL
+++ CompletionFunc REPL
completeType) (String, String)
cursor
  ExprTypeArg String -> REPL CommandResult
_ -> (CompletionFunc REPL
completeExpr CompletionFunc REPL -> CompletionFunc REPL -> CompletionFunc REPL
+++ CompletionFunc REPL
completeType) (String, String)
cursor
  ModNameArg String -> REPL CommandResult
_  -> CompletionFunc REPL
completeModName (String, String)
cursor
  FilenameArg String -> REPL CommandResult
_ -> CompletionFunc REPL
forall (m :: * -> *). MonadIO m => CompletionFunc m
completeFilename (String, String)
cursor
  ShellArg String -> REPL CommandResult
_    -> CompletionFunc REPL
forall (m :: * -> *). MonadIO m => CompletionFunc m
completeFilename (String, String)
cursor
  OptionArg String -> REPL CommandResult
_   -> CompletionFunc REPL
completeOption (String, String)
cursor
  HelpArg     String -> REPL CommandResult
_ -> CompletionFunc REPL
completeHelp (String, String)
cursor
  NoArg       REPL CommandResult
_ -> (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l,[])
  FileExprArg String
-> String -> (Int, Int) -> Maybe String -> REPL CommandResult
_ -> CompletionFunc REPL
completeExpr (String, String)
cursor

-- | Additional keywords to suggest in the REPL
--   autocompletion list.
keywords :: [String]
keywords :: [String]
keywords =
  [ String
"else"
  , String
"if"
  , String
"let"
  , String
"then"
  , String
"where"
  ]

-- | Complete a name from the expression environment.
completeExpr :: CompletionFunc REPL
completeExpr :: CompletionFunc REPL
completeExpr (String
l,String
_) = do
  [String]
ns <- ([String]
keywords[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> REPL [String] -> REPL [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> REPL [String]
getExprNames
  let n :: String
n    = ShowS
forall a. [a] -> [a]
reverse (ShowS
takeIdent String
l)
      vars :: [String]
vars = [String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
n String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ns
  (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l,(String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Completion
nameComp String
n) [String]
vars)

-- | Complete a name from the type synonym environment.
completeType :: CompletionFunc REPL
completeType :: CompletionFunc REPL
completeType (String
l,String
_) = do
  [String]
ns <- REPL [String]
getTypeNames
  let n :: String
n    = ShowS
forall a. [a] -> [a]
reverse (ShowS
takeIdent String
l)
      vars :: [String]
vars = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
n String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ns
  (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l,(String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Completion
nameComp String
n) [String]
vars)

-- | Complete a name for which we can show REPL help documentation.
completeHelp :: CompletionFunc REPL
completeHelp :: CompletionFunc REPL
completeHelp (String
l, String
_) = do
  [String]
ns1 <- REPL [String]
getExprNames
  [String]
ns2 <- REPL [String]
getTypeNames
  let ns3 :: [String]
ns3 = (CommandDescr -> [String]) -> [CommandDescr] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CommandDescr -> [String]
cNames ([CommandDescr] -> [CommandDescr]
forall a. Eq a => [a] -> [a]
nub (String -> [CommandDescr]
findCommand String
":"))
  let ns :: [String]
ns = Set String -> [String]
forall a. Set a -> [a]
Set.toAscList ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String]
ns1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ns2)) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ns3
  let n :: String
n    = ShowS
forall a. [a] -> [a]
reverse String
l
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace String
n of
    (String
":set", Char
_ : String
n') ->
      do let n'' :: String
n'' = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
n'
         let vars :: [String]
vars = (OptionDescr -> String) -> [OptionDescr] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map OptionDescr -> String
optName (String -> Trie OptionDescr -> [OptionDescr]
forall a. String -> Trie a -> [a]
lookupTrie ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
n') Trie OptionDescr
userOptions)
         (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Completion
nameComp String
n'') [String]
vars)
    (String, String)
_                ->
      do let vars :: [String]
vars = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
n String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ns
         (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Completion
nameComp String
n) [String]
vars)


-- | Complete a name from the list of loaded modules.
completeModName :: CompletionFunc REPL
completeModName :: CompletionFunc REPL
completeModName (String
l, String
_) = do
  [ModName]
ms <- REPL [ModName]
getModNames
  let ns :: [String]
ns   = (ModName -> String) -> [ModName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> String
T.unpack (Text -> String) -> (ModName -> Text) -> ModName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModName -> Text
modNameToText) (ModName
interactiveName ModName -> [ModName] -> [ModName]
forall a. a -> [a] -> [a]
: [ModName]
ms)
      n :: String
n    = ShowS
forall a. [a] -> [a]
reverse ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
l)
      vars :: [String]
vars = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String
n String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) [String]
ns
  (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
l, (String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Completion
nameComp String
n) [String]
vars)

-- | Generate a completion from a prefix and a name.
nameComp :: String -> String -> Completion
nameComp :: String -> String -> Completion
nameComp String
prefix String
c = Completion
  { replacement :: String
replacement = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
prefix) String
c
  , display :: String
display     = String
c
  , isFinished :: Bool
isFinished  = Bool
True
  }

-- | Return longest identifier (possibly a qualified name) that is a
-- prefix of the given string
takeIdent :: String -> String
takeIdent :: ShowS
takeIdent (Char
c : String
cs) | Char -> Bool
isIdentChar Char
c = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
takeIdent String
cs
takeIdent (Char
':' : Char
':' : String
cs) = Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
takeIdent String
cs
takeIdent String
_ = []

isIdentChar :: Char -> Bool
isIdentChar :: Char -> Bool
isIdentChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"_\'"

-- | Join two completion functions together, merging and sorting their results.
(+++) :: CompletionFunc REPL -> CompletionFunc REPL -> CompletionFunc REPL
(CompletionFunc REPL
as +++ :: CompletionFunc REPL -> CompletionFunc REPL -> CompletionFunc REPL
+++ CompletionFunc REPL
bs) (String, String)
cursor = do
  (String
_,[Completion]
acs) <- CompletionFunc REPL
as (String, String)
cursor
  (String
_,[Completion]
bcs) <- CompletionFunc REPL
bs (String, String)
cursor
  (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
cursor, (Completion -> Completion -> Ordering)
-> [Completion] -> [Completion]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (String -> String -> Ordering)
-> (Completion -> String) -> Completion -> Completion -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Completion -> String
replacement) ([Completion]
acs [Completion] -> [Completion] -> [Completion]
forall a. [a] -> [a] -> [a]
++ [Completion]
bcs))


-- | Complete an option from the options environment.
--
-- XXX this can do better, as it has access to the expected form of the value
completeOption :: CompletionFunc REPL
completeOption :: CompletionFunc REPL
completeOption cursor :: (String, String)
cursor@(String
l,String
_) = (String, [Completion]) -> REPL (String, [Completion])
forall a. a -> REPL a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> String
forall a b. (a, b) -> a
fst (String, String)
cursor, (OptionDescr -> Completion) -> [OptionDescr] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map OptionDescr -> Completion
comp [OptionDescr]
opts)
  where
  n :: String
n        = ShowS
forall a. [a] -> [a]
reverse String
l
  opts :: [OptionDescr]
opts     = String -> Trie OptionDescr -> [OptionDescr]
forall a. String -> Trie a -> [a]
lookupTrie String
n Trie OptionDescr
userOptions
  comp :: OptionDescr -> Completion
comp OptionDescr
opt = Completion
    { replacement :: String
replacement = Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
n) (OptionDescr -> String
optName OptionDescr
opt)
    , display :: String
display     = OptionDescr -> String
optName OptionDescr
opt
    , isFinished :: Bool
isFinished  = Bool
False
    }