module System.Console.Haskeline.Completion(
                            CompletionFunc,
                            Completion(..),
                            noCompletion,
                            simpleCompletion,
                            fallbackCompletion,
                            -- * Word completion
                            completeWord,
                            completeWord',
                            completeWordWithPrev,
                            completeWordWithPrev',
                            completeQuotedWord,
                            -- * Filename completion
                            completeFilename,
                            listFiles,
                            filenameWordBreakChars
                        ) where


import System.FilePath
import Data.List(isPrefixOf)
import Control.Monad(forM)

import System.Console.Haskeline.Directory
import System.Console.Haskeline.Monads

-- | Performs completions from the given line state.
--
-- The first 'String' argument is the contents of the line to the left of the cursor,
-- reversed.
-- The second 'String' argument is the contents of the line to the right of the cursor.
--
-- The output 'String' is the unused portion of the left half of the line, reversed.
type CompletionFunc m = (String,String) -> m (String, [Completion])


data Completion = Completion {Completion -> String
replacement  :: String, -- ^ Text to insert in line.
                        Completion -> String
display  :: String,
                                -- ^ Text to display when listing
                                -- alternatives.
                        Completion -> Bool
isFinished :: Bool
                            -- ^ Whether this word should be followed by a
                            -- space, end quote, etc.
                            }
                    deriving (Completion -> Completion -> Bool
(Completion -> Completion -> Bool)
-> (Completion -> Completion -> Bool) -> Eq Completion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Completion -> Completion -> Bool
$c/= :: Completion -> Completion -> Bool
== :: Completion -> Completion -> Bool
$c== :: Completion -> Completion -> Bool
Eq, Eq Completion
Eq Completion
-> (Completion -> Completion -> Ordering)
-> (Completion -> Completion -> Bool)
-> (Completion -> Completion -> Bool)
-> (Completion -> Completion -> Bool)
-> (Completion -> Completion -> Bool)
-> (Completion -> Completion -> Completion)
-> (Completion -> Completion -> Completion)
-> Ord Completion
Completion -> Completion -> Bool
Completion -> Completion -> Ordering
Completion -> Completion -> Completion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Completion -> Completion -> Completion
$cmin :: Completion -> Completion -> Completion
max :: Completion -> Completion -> Completion
$cmax :: Completion -> Completion -> Completion
>= :: Completion -> Completion -> Bool
$c>= :: Completion -> Completion -> Bool
> :: Completion -> Completion -> Bool
$c> :: Completion -> Completion -> Bool
<= :: Completion -> Completion -> Bool
$c<= :: Completion -> Completion -> Bool
< :: Completion -> Completion -> Bool
$c< :: Completion -> Completion -> Bool
compare :: Completion -> Completion -> Ordering
$ccompare :: Completion -> Completion -> Ordering
$cp1Ord :: Eq Completion
Ord, Int -> Completion -> ShowS
[Completion] -> ShowS
Completion -> String
(Int -> Completion -> ShowS)
-> (Completion -> String)
-> ([Completion] -> ShowS)
-> Show Completion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Completion] -> ShowS
$cshowList :: [Completion] -> ShowS
show :: Completion -> String
$cshow :: Completion -> String
showsPrec :: Int -> Completion -> ShowS
$cshowsPrec :: Int -> Completion -> ShowS
Show)

-- | Disable completion altogether.
noCompletion :: Monad m => CompletionFunc m
noCompletion :: CompletionFunc m
noCompletion (String
s,String
_) = (String, [Completion]) -> m (String, [Completion])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
s,[])

--------------
-- Word break functions

-- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor.
--
-- A word begins either at the start of the line or after an unescaped whitespace character.
completeWord :: Monad m => Maybe Char
        -- ^ An optional escape character
        -> [Char]-- ^ Characters which count as whitespace
        -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions
        -> CompletionFunc m
completeWord :: Maybe Char
-> String -> (String -> m [Completion]) -> CompletionFunc m
completeWord Maybe Char
esc String
ws = Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev Maybe Char
esc String
ws ((String -> String -> m [Completion]) -> CompletionFunc m)
-> ((String -> m [Completion])
    -> String -> String -> m [Completion])
-> (String -> m [Completion])
-> CompletionFunc m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> m [Completion]) -> String -> String -> m [Completion]
forall a b. a -> b -> a
const

-- | The same as 'completeWord' but takes a predicate for the whitespace characters
completeWord' :: Monad m => Maybe Char
        -- ^ An optional escape character
        -> (Char -> Bool) -- ^ Characters which count as whitespace
        -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions
        -> CompletionFunc m
completeWord' :: Maybe Char
-> (Char -> Bool) -> (String -> m [Completion]) -> CompletionFunc m
completeWord' Maybe Char
esc Char -> Bool
ws = Maybe Char
-> (Char -> Bool)
-> (String -> String -> m [Completion])
-> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> (Char -> Bool)
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev' Maybe Char
esc Char -> Bool
ws ((String -> String -> m [Completion]) -> CompletionFunc m)
-> ((String -> m [Completion])
    -> String -> String -> m [Completion])
-> (String -> m [Completion])
-> CompletionFunc m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> m [Completion]) -> String -> String -> m [Completion]
forall a b. a -> b -> a
const

-- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor,
-- and takes into account the line contents to the left of the word.
--
-- A word begins either at the start of the line or after an unescaped whitespace character.
completeWordWithPrev :: Monad m => Maybe Char
        -- ^ An optional escape character
        -> [Char]-- ^ Characters which count as whitespace
        -> (String ->  String -> m [Completion])
            -- ^ Function to produce a list of possible completions.  The first argument is the
            -- line contents to the left of the word, reversed.  The second argument is the word
            -- to be completed.
        -> CompletionFunc m
completeWordWithPrev :: Maybe Char
-> String
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev Maybe Char
esc String
ws = Maybe Char
-> (Char -> Bool)
-> (String -> String -> m [Completion])
-> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> (Char -> Bool)
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev' Maybe Char
esc (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
ws)

-- | The same as 'completeWordWithPrev' but takes a predicate for the whitespace characters
completeWordWithPrev' :: Monad m => Maybe Char
        -- ^ An optional escape character
        -> (Char -> Bool) -- ^ Characters which count as whitespace
        -> (String ->  String -> m [Completion])
            -- ^ Function to produce a list of possible completions.  The first argument is the
            -- line contents to the left of the word, reversed.  The second argument is the word
            -- to be completed.
        -> CompletionFunc m
completeWordWithPrev' :: Maybe Char
-> (Char -> Bool)
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev' Maybe Char
esc Char -> Bool
wpred String -> String -> m [Completion]
f (String
line, String
_) = do
    let (String
word,String
rest) = case Maybe Char
esc of
                        Maybe Char
Nothing -> (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
wpred String
line
                        Just Char
e -> Char -> String -> (String, String)
escapedBreak Char
e String
line
    [Completion]
completions <- String -> String -> m [Completion]
f String
rest (ShowS
forall a. [a] -> [a]
reverse String
word)
    (String, [Completion]) -> m (String, [Completion])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
rest,(Completion -> Completion) -> [Completion] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Char -> (Char -> Bool) -> Completion -> Completion
escapeReplacement Maybe Char
esc Char -> Bool
wpred) [Completion]
completions)
  where
    escapedBreak :: Char -> String -> (String, String)
escapedBreak Char
e (Char
c:Char
d:String
cs) | Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
e Bool -> Bool -> Bool
&& (Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
e Bool -> Bool -> Bool
|| Char -> Bool
wpred Char
c)
            = let (String
xs,String
ys) = Char -> String -> (String, String)
escapedBreak Char
e String
cs in (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs,String
ys)
    escapedBreak Char
e (Char
c:String
cs) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
wpred Char
c
            = let (String
xs,String
ys) = Char -> String -> (String, String)
escapedBreak Char
e String
cs in (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
xs,String
ys)
    escapedBreak Char
_ String
cs = (String
"",String
cs)

-- | Create a finished completion out of the given word.
simpleCompletion :: String -> Completion
simpleCompletion :: String -> Completion
simpleCompletion = String -> Completion
completion

-- NOTE: this is the same as for readline, except that I took out the '\\'
-- so they can be used as a path separator.
filenameWordBreakChars :: String
filenameWordBreakChars :: String
filenameWordBreakChars = String
" \t\n`@$><=;|&{("

-- A completion command for file and folder names.
completeFilename :: MonadIO m => CompletionFunc m
completeFilename :: CompletionFunc m
completeFilename  = Maybe Char
-> String
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
forall (m :: * -> *).
Monad m =>
Maybe Char
-> String
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
completeQuotedWord (Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'\\') String
"\"'" String -> m [Completion]
forall (m :: * -> *). MonadIO m => String -> m [Completion]
listFiles
                        (CompletionFunc m -> CompletionFunc m)
-> CompletionFunc m -> CompletionFunc m
forall a b. (a -> b) -> a -> b
$ 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 Char
'\\') (String
"\"\'" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filenameWordBreakChars)
                                String -> m [Completion]
forall (m :: * -> *). MonadIO m => String -> m [Completion]
listFiles

completion :: String -> Completion
completion :: String -> Completion
completion String
str = String -> String -> Bool -> Completion
Completion String
str String
str Bool
True

setReplacement :: (String -> String) -> Completion -> Completion
setReplacement :: ShowS -> Completion -> Completion
setReplacement ShowS
f Completion
c = Completion
c {replacement :: String
replacement = ShowS
f ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Completion -> String
replacement Completion
c}

escapeReplacement :: Maybe Char -> (Char -> Bool) -> Completion -> Completion
escapeReplacement :: Maybe Char -> (Char -> Bool) -> Completion -> Completion
escapeReplacement Maybe Char
esc Char -> Bool
wpred Completion
f = case Maybe Char
esc of
    Maybe Char
Nothing -> Completion
f
    Just Char
e -> Completion
f {replacement :: String
replacement = Char -> ShowS
escape Char
e (Completion -> String
replacement Completion
f)}
  where
    escape :: Char -> ShowS
escape Char
e (Char
c:String
cs) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
e Bool -> Bool -> Bool
|| Char -> Bool
wpred Char
c = Char
e Char -> ShowS
forall a. a -> [a] -> [a]
: Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Char -> ShowS
escape Char
e String
cs
                    | Bool
otherwise = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: Char -> ShowS
escape Char
e String
cs
    escape Char
_ String
"" = String
""


---------
-- Quoted completion
completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character
                            -> [Char] -- ^ Characters which set off quotes
                            -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions
                            -> CompletionFunc m -- ^ Alternate completion to perform if the
                                            -- cursor is not at a quoted word
                            -> CompletionFunc m
completeQuotedWord :: Maybe Char
-> String
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
completeQuotedWord Maybe Char
esc String
qs String -> m [Completion]
completer CompletionFunc m
alterative line :: (String, String)
line@(String
left,String
_)
  = case Maybe Char -> String -> String -> Maybe (String, String)
splitAtQuote Maybe Char
esc String
qs String
left of
    Just (String
w,String
rest) | Maybe Char -> String -> String -> Bool
isUnquoted Maybe Char
esc String
qs String
rest -> do
        [Completion]
cs <- String -> m [Completion]
completer (ShowS
forall a. [a] -> [a]
reverse String
w)
        (String, [Completion]) -> m (String, [Completion])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
rest, (Completion -> Completion) -> [Completion] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map (Completion -> Completion
addQuotes (Completion -> Completion)
-> (Completion -> Completion) -> Completion -> Completion
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Char -> (Char -> Bool) -> Completion -> Completion
escapeReplacement Maybe Char
esc (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
qs)) [Completion]
cs)
    Maybe (String, String)
_ -> CompletionFunc m
alterative (String, String)
line

addQuotes :: Completion -> Completion
addQuotes :: Completion -> Completion
addQuotes Completion
c = if Completion -> Bool
isFinished Completion
c
    then Completion
c {replacement :: String
replacement = String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Completion -> String
replacement Completion
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\""}
    else Completion
c {replacement :: String
replacement = String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Completion -> String
replacement Completion
c}

splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String)
splitAtQuote :: Maybe Char -> String -> String -> Maybe (String, String)
splitAtQuote Maybe Char
esc String
qs String
line = case String
line of
    Char
c:Char
e:String
cs | Char -> Bool
isEscape Char
e Bool -> Bool -> Bool
&& Char -> Bool
isEscapable Char
c
                        -> do
                            (String
w,String
rest) <- Maybe Char -> String -> String -> Maybe (String, String)
splitAtQuote Maybe Char
esc String
qs String
cs
                            (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
w,String
rest)
    Char
q:String
cs   | Char -> Bool
isQuote Char
q  -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"",String
cs)
    Char
c:String
cs                -> do
                            (String
w,String
rest) <- Maybe Char -> String -> String -> Maybe (String, String)
splitAtQuote Maybe Char
esc String
qs String
cs
                            (String, String) -> Maybe (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
w,String
rest)
    String
""                  -> Maybe (String, String)
forall a. Maybe a
Nothing
  where
    isQuote :: Char -> Bool
isQuote = (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
qs)
    isEscape :: Char -> Bool
isEscape Char
c = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
c Maybe Char -> Maybe Char -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Char
esc
    isEscapable :: Char -> Bool
isEscapable Char
c = Char -> Bool
isEscape Char
c Bool -> Bool -> Bool
|| Char -> Bool
isQuote Char
c

isUnquoted :: Maybe Char -> String -> String -> Bool
isUnquoted :: Maybe Char -> String -> String -> Bool
isUnquoted Maybe Char
esc String
qs String
s = case Maybe Char -> String -> String -> Maybe (String, String)
splitAtQuote Maybe Char
esc String
qs String
s of
    Just (String
_,String
s') -> Bool -> Bool
not (Maybe Char -> String -> String -> Bool
isUnquoted Maybe Char
esc String
qs String
s')
    Maybe (String, String)
_ -> Bool
True


-- | List all of the files or folders beginning with this path.
listFiles :: MonadIO m => FilePath -> m [Completion]
listFiles :: String -> m [Completion]
listFiles String
path = IO [Completion] -> m [Completion]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Completion] -> m [Completion])
-> IO [Completion] -> m [Completion]
forall a b. (a -> b) -> a -> b
$ do
    String
fixedDir <- String -> IO String
fixPath String
dir
    Bool
dirExists <- String -> IO Bool
doesDirectoryExist String
fixedDir
    -- get all of the files in that directory, as basenames
    [Completion]
allFiles <- if Bool -> Bool
not Bool
dirExists
                    then [Completion] -> IO [Completion]
forall (m :: * -> *) a. Monad m => a -> m a
return []
                    else ([String] -> [Completion]) -> IO [String] -> IO [Completion]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Completion) -> [String] -> [Completion]
forall a b. (a -> b) -> [a] -> [b]
map String -> Completion
completion ([String] -> [Completion])
-> ([String] -> [String]) -> [String] -> [Completion]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
filterPrefix)
                            (IO [String] -> IO [Completion]) -> IO [String] -> IO [Completion]
forall a b. (a -> b) -> a -> b
$ String -> IO [String]
getDirectoryContents String
fixedDir
    -- The replacement text should include the directory part, and also
    -- have a trailing slash if it's itself a directory.
    [Completion] -> (Completion -> IO Completion) -> IO [Completion]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Completion]
allFiles ((Completion -> IO Completion) -> IO [Completion])
-> (Completion -> IO Completion) -> IO [Completion]
forall a b. (a -> b) -> a -> b
$ \Completion
c -> do
            Bool
isDir <- String -> IO Bool
doesDirectoryExist (String
fixedDir String -> ShowS
</> Completion -> String
replacement Completion
c)
            Completion -> IO Completion
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion -> IO Completion) -> Completion -> IO Completion
forall a b. (a -> b) -> a -> b
$ ShowS -> Completion -> Completion
setReplacement ShowS
fullName (Completion -> Completion) -> Completion -> Completion
forall a b. (a -> b) -> a -> b
$ Bool -> Completion -> Completion
alterIfDir Bool
isDir Completion
c
  where
    (String
dir, String
file) = String -> (String, String)
splitFileName String
path
    filterPrefix :: [String] -> [String]
filterPrefix = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (\String
f -> String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
f [String
".",String
".."]
                                        Bool -> Bool -> Bool
&& String
file String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
f)
    alterIfDir :: Bool -> Completion -> Completion
alterIfDir Bool
False Completion
c = Completion
c
    alterIfDir Bool
True Completion
c = Completion
c {replacement :: String
replacement = ShowS
addTrailingPathSeparator (Completion -> String
replacement Completion
c),
                            isFinished :: Bool
isFinished = Bool
False}
    fullName :: ShowS
fullName = String -> ShowS
replaceFileName String
path

-- turn a user-visible path into an internal version useable by System.FilePath.
fixPath :: String -> IO String
-- For versions of filepath < 1.2
fixPath :: String -> IO String
fixPath String
"" = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"."
fixPath (Char
'~':Char
c:String
path) | Char -> Bool
isPathSeparator Char
c = do
    String
home <- IO String
getHomeDirectory
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
home String -> ShowS
</> String
path)
fixPath String
path = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
path

-- | If the first completer produces no suggestions, fallback to the second
-- completer's output.
fallbackCompletion :: Monad m => CompletionFunc m -> CompletionFunc m -> CompletionFunc m
fallbackCompletion :: CompletionFunc m -> CompletionFunc m -> CompletionFunc m
fallbackCompletion CompletionFunc m
a CompletionFunc m
b (String, String)
input = do
    (String, [Completion])
aCompletions <- CompletionFunc m
a (String, String)
input
    if [Completion] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((String, [Completion]) -> [Completion]
forall a b. (a, b) -> b
snd (String, [Completion])
aCompletions)
        then CompletionFunc m
b (String, String)
input
        else (String, [Completion]) -> m (String, [Completion])
forall (m :: * -> *) a. Monad m => a -> m a
return (String, [Completion])
aCompletions