module System.Console.Haskeline.Command.Completion(
                            CompletionFunc,
                            Completion,
                            CompletionType(..),
                            completionCmd
                            ) where

import System.Console.Haskeline.Backend.WCWidth (gsWidth)
import System.Console.Haskeline.Command
import System.Console.Haskeline.Command.Undo
import System.Console.Haskeline.Key
import System.Console.Haskeline.Term (Layout(..), CommandMonad(..))
import System.Console.Haskeline.LineState
import System.Console.Haskeline.Prefs
import System.Console.Haskeline.Completion
import System.Console.Haskeline.Monads

import Data.List(transpose, unfoldr)

useCompletion :: InsertMode -> Completion -> InsertMode
useCompletion :: InsertMode -> Completion -> InsertMode
useCompletion InsertMode
im Completion
c = String -> InsertMode -> InsertMode
insertString String
r InsertMode
im
    where r :: String
r | Completion -> Bool
isFinished Completion
c = Completion -> String
replacement Completion
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
            | Bool
otherwise = Completion -> String
replacement Completion
c

askIMCompletions :: CommandMonad m =>
            Command m InsertMode (InsertMode, [Completion])
askIMCompletions :: forall (m :: * -> *).
CommandMonad m =>
Command m InsertMode (InsertMode, [Completion])
askIMCompletions (IMode [Grapheme]
xs [Grapheme]
ys) = do
    (String
rest, [Completion]
completions) <- m (String, [Completion]) -> CmdM m (String, [Completion])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (String, [Completion]) -> CmdM m (String, [Completion]))
-> m (String, [Completion]) -> CmdM m (String, [Completion])
forall a b. (a -> b) -> a -> b
$ (String, String) -> m (String, [Completion])
forall (m :: * -> *).
CommandMonad m =>
(String, String) -> m (String, [Completion])
runCompletion (([Grapheme] -> String) -> [Grapheme] -> String
forall a b. ([a] -> [b]) -> [a] -> [b]
withRev [Grapheme] -> String
graphemesToString [Grapheme]
xs,
                                            [Grapheme] -> String
graphemesToString [Grapheme]
ys)
    (InsertMode, [Completion]) -> CmdM m (InsertMode, [Completion])
forall (m :: * -> *) a. Monad m => a -> m a
return ([Grapheme] -> [Grapheme] -> InsertMode
IMode ((String -> [Grapheme]) -> String -> [Grapheme]
forall a b. ([a] -> [b]) -> [a] -> [b]
withRev String -> [Grapheme]
stringToGraphemes String
rest) [Grapheme]
ys, [Completion]
completions)
  where
    withRev :: ([a] -> [b]) -> [a] -> [b]
    withRev :: forall a b. ([a] -> [b]) -> [a] -> [b]
withRev [a] -> [b]
f = [b] -> [b]
forall a. [a] -> [a]
reverse ([b] -> [b]) -> ([a] -> [b]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [b]
f ([a] -> [b]) -> ([a] -> [a]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse

-- | Create a 'Command' for word completion.
completionCmd :: (MonadState Undo m, CommandMonad m)
                => Key -> KeyCommand m InsertMode InsertMode
completionCmd :: forall (m :: * -> *).
(MonadState Undo m, CommandMonad m) =>
Key -> KeyCommand m InsertMode InsertMode
completionCmd Key
k = Key
k Key
-> Command m InsertMode InsertMode
-> KeyMap (Command m InsertMode InsertMode)
forall a. Key -> a -> KeyMap a
+> Command m InsertMode InsertMode
forall s (m :: * -> *).
(Save s, MonadState Undo m) =>
Command m s s
saveForUndo Command m InsertMode InsertMode
-> Command m InsertMode InsertMode
-> Command m InsertMode InsertMode
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> \InsertMode
oldIM -> do
    (InsertMode
rest,[Completion]
cs) <- Command m InsertMode (InsertMode, [Completion])
forall (m :: * -> *).
CommandMonad m =>
Command m InsertMode (InsertMode, [Completion])
askIMCompletions InsertMode
oldIM
    case [Completion]
cs of
        [] -> Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect Effect
RingBell CmdM m () -> CmdM m InsertMode -> CmdM m InsertMode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Command m InsertMode InsertMode
forall (m :: * -> *) a. Monad m => a -> m a
return InsertMode
oldIM
        [Completion
c] -> Command m InsertMode InsertMode
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState Command m InsertMode InsertMode -> Command m InsertMode InsertMode
forall a b. (a -> b) -> a -> b
$ InsertMode -> Completion -> InsertMode
useCompletion InsertMode
rest Completion
c
        [Completion]
_ -> Key
-> InsertMode -> InsertMode -> [Completion] -> CmdM m InsertMode
forall (m :: * -> *).
(MonadReader Prefs m, MonadReader Layout m) =>
Key
-> InsertMode -> InsertMode -> [Completion] -> CmdM m InsertMode
presentCompletions Key
k InsertMode
oldIM InsertMode
rest [Completion]
cs

presentCompletions :: (MonadReader Prefs m, MonadReader Layout m)
        => Key -> InsertMode -> InsertMode
            -> [Completion] -> CmdM m InsertMode
presentCompletions :: forall (m :: * -> *).
(MonadReader Prefs m, MonadReader Layout m) =>
Key
-> InsertMode -> InsertMode -> [Completion] -> CmdM m InsertMode
presentCompletions Key
k InsertMode
oldIM InsertMode
rest [Completion]
cs = do
    Prefs
prefs <- CmdM m Prefs
forall r (m :: * -> *). MonadReader r m => m r
ask
    case Prefs -> CompletionType
completionType Prefs
prefs of
        CompletionType
MenuCompletion -> Key -> [InsertMode] -> Command m InsertMode InsertMode
forall (m :: * -> *).
Monad m =>
Key -> [InsertMode] -> Command m InsertMode InsertMode
menuCompletion Key
k ((Completion -> InsertMode) -> [Completion] -> [InsertMode]
forall a b. (a -> b) -> [a] -> [b]
map (InsertMode -> Completion -> InsertMode
useCompletion InsertMode
rest) [Completion]
cs) InsertMode
oldIM
        CompletionType
ListCompletion -> do
            InsertMode
withPartial <- Command m InsertMode InsertMode
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState Command m InsertMode InsertMode -> Command m InsertMode InsertMode
forall a b. (a -> b) -> a -> b
$ InsertMode -> [Completion] -> InsertMode
makePartialCompletion InsertMode
rest [Completion]
cs
            if InsertMode
withPartial InsertMode -> InsertMode -> Bool
forall a. Eq a => a -> a -> Bool
/= InsertMode
oldIM
                then Command m InsertMode InsertMode
forall (m :: * -> *) a. Monad m => a -> m a
return InsertMode
withPartial
                else Key -> Prefs -> [Completion] -> Command m InsertMode InsertMode
forall (m :: * -> *).
MonadReader Layout m =>
Key -> Prefs -> [Completion] -> Command m InsertMode InsertMode
pagingCompletion Key
k Prefs
prefs [Completion]
cs InsertMode
withPartial

menuCompletion :: Monad m => Key -> [InsertMode] -> Command m InsertMode InsertMode
menuCompletion :: forall (m :: * -> *).
Monad m =>
Key -> [InsertMode] -> Command m InsertMode InsertMode
menuCompletion Key
k = [InsertMode] -> Command m InsertMode InsertMode
forall {m :: * -> *} {s}.
(Monad m, LineState s) =>
[s] -> Command m s s
loop
    where
        loop :: [s] -> Command m s s
loop [] = Command m s s
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState
        loop (s
c:[s]
cs) = (s -> s) -> Command m s s
forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change (s -> s -> s
forall a b. a -> b -> a
const s
c) Command m s s -> Command m s s -> Command m s s
forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> KeyCommand m s s -> Command m s s
forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Key
k Key -> Command m s s -> KeyCommand m s s
forall a. Key -> a -> KeyMap a
+> [s] -> Command m s s
loop [s]
cs)

makePartialCompletion :: InsertMode -> [Completion] -> InsertMode
makePartialCompletion :: InsertMode -> [Completion] -> InsertMode
makePartialCompletion InsertMode
im [Completion]
completions = String -> InsertMode -> InsertMode
insertString String
partial InsertMode
im
  where
    partial :: String
partial = (String -> String -> String) -> [String] -> String
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> String -> String
commonPrefix ((Completion -> String) -> [Completion] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Completion -> String
replacement [Completion]
completions)
    commonPrefix :: String -> String -> String
commonPrefix (Char
c:String
cs) (Char
d:String
ds) | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
d = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String -> String
commonPrefix String
cs String
ds
    commonPrefix String
_ String
_ = String
""

pagingCompletion :: MonadReader Layout m => Key -> Prefs
                -> [Completion] -> Command m InsertMode InsertMode
pagingCompletion :: forall (m :: * -> *).
MonadReader Layout m =>
Key -> Prefs -> [Completion] -> Command m InsertMode InsertMode
pagingCompletion Key
k Prefs
prefs [Completion]
completions = \InsertMode
im -> do
        [String]
ls <- (Layout -> [String]) -> CmdM m [String]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Layout -> [String]) -> CmdM m [String])
-> (Layout -> [String]) -> CmdM m [String]
forall a b. (a -> b) -> a -> b
$ [String] -> Layout -> [String]
makeLines ((Completion -> String) -> [Completion] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Completion -> String
display [Completion]
completions)
        let pageAction :: CmdM m InsertMode
pageAction = do
                Prefs -> Int -> CmdM m () -> CmdM m ()
forall (m :: * -> *).
Monad m =>
Prefs -> Int -> CmdM m () -> CmdM m ()
askFirst Prefs
prefs ([Completion] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Completion]
completions) (CmdM m () -> CmdM m ()) -> CmdM m () -> CmdM m ()
forall a b. (a -> b) -> a -> b
$
                            if Prefs -> Bool
completionPaging Prefs
prefs
                                then [String] -> CmdM m ()
forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
printPage [String]
ls
                                else Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect ([String] -> Effect
PrintLines [String]
ls)
                InsertMode -> CmdM m InsertMode
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState InsertMode
im
        if Prefs -> Bool
listCompletionsImmediately Prefs
prefs
            then CmdM m InsertMode
pageAction
            else Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect Effect
RingBell CmdM m () -> CmdM m InsertMode -> CmdM m InsertMode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> KeyCommand m InsertMode InsertMode
-> InsertMode -> CmdM m InsertMode
forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Key
k Key
-> (InsertMode -> CmdM m InsertMode)
-> KeyCommand m InsertMode InsertMode
forall a. Key -> a -> KeyMap a
+> CmdM m InsertMode -> InsertMode -> CmdM m InsertMode
forall a b. a -> b -> a
const CmdM m InsertMode
pageAction) InsertMode
im

askFirst :: Monad m => Prefs -> Int -> CmdM m ()
            -> CmdM m ()
askFirst :: forall (m :: * -> *).
Monad m =>
Prefs -> Int -> CmdM m () -> CmdM m ()
askFirst Prefs
prefs Int
n CmdM m ()
cmd
    | Bool -> (Int -> Bool) -> Maybe Int -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n) (Prefs -> Maybe Int
completionPromptLimit Prefs
prefs) = do
        Message
_ <- Command m Message Message
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (String -> Message
Message (String -> Message) -> String -> Message
forall a b. (a -> b) -> a -> b
$ String
"Display all " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" possibilities? (y or n)")
        [KeyMap (CmdM m ())] -> CmdM m ()
forall (m :: * -> *) a. [KeyMap (CmdM m a)] -> CmdM m a
keyChoiceCmdM [
            Char -> Key
simpleChar Char
'y' Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> CmdM m ()
cmd
            , Char -> Key
simpleChar Char
'n' Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> () -> CmdM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ]
    | Bool
otherwise = CmdM m ()
cmd

pageCompletions :: MonadReader Layout m => [String] -> CmdM m ()
pageCompletions :: forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
pageCompletions [] = () -> CmdM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
pageCompletions wws :: [String]
wws@(String
w:[String]
ws) = do
    Message
_ <- Command m Message Message
forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState Command m Message Message -> Command m Message Message
forall a b. (a -> b) -> a -> b
$ String -> Message
Message String
"----More----"
    [KeyMap (CmdM m ())] -> CmdM m ()
forall (m :: * -> *) a. [KeyMap (CmdM m a)] -> CmdM m a
keyChoiceCmdM [
        Char -> Key
simpleChar Char
'\n' Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> CmdM m ()
oneLine
        , BaseKey -> Key
simpleKey BaseKey
DownKey Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> CmdM m ()
oneLine
        , Char -> Key
simpleChar Char
'q' Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> () -> CmdM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , Char -> Key
simpleChar Char
' ' Key -> CmdM m () -> KeyMap (CmdM m ())
forall a. Key -> a -> KeyMap a
+> (CmdM m ()
forall {m :: * -> *}. CmdM m ()
clearMessage CmdM m () -> CmdM m () -> CmdM m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> CmdM m ()
forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
printPage [String]
wws)
        ]
  where
    oneLine :: CmdM m ()
oneLine = CmdM m ()
forall {m :: * -> *}. CmdM m ()
clearMessage CmdM m () -> CmdM m () -> CmdM m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect ([String] -> Effect
PrintLines [String
w]) CmdM m () -> CmdM m () -> CmdM m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> CmdM m ()
forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
pageCompletions [String]
ws
    clearMessage :: CmdM m ()
clearMessage = Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect (Effect -> CmdM m ()) -> Effect -> CmdM m ()
forall a b. (a -> b) -> a -> b
$ ([Grapheme] -> LineChars) -> Effect
LineChange (([Grapheme] -> LineChars) -> Effect)
-> ([Grapheme] -> LineChars) -> Effect
forall a b. (a -> b) -> a -> b
$ LineChars -> [Grapheme] -> LineChars
forall a b. a -> b -> a
const ([],[])

printPage :: MonadReader Layout m => [String] -> CmdM m ()
printPage :: forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
printPage [String]
ls = do
    Layout
layout <- CmdM m Layout
forall r (m :: * -> *). MonadReader r m => m r
ask
    let ([String]
ps,[String]
rest) = Int -> [String] -> ([String], [String])
forall a. Int -> [a] -> ([a], [a])
splitAt (Layout -> Int
height Layout
layout Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [String]
ls
    Effect -> CmdM m ()
forall (m :: * -> *). Effect -> CmdM m ()
effect (Effect -> CmdM m ()) -> Effect -> CmdM m ()
forall a b. (a -> b) -> a -> b
$ [String] -> Effect
PrintLines [String]
ps
    [String] -> CmdM m ()
forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
pageCompletions [String]
rest

-----------------------------------------------
-- Splitting the list of completions into lines for paging.
makeLines :: [String] -> Layout -> [String]
makeLines :: [String] -> Layout -> [String]
makeLines [String]
ws Layout
layout = let
    minColPad :: Int
minColPad = Int
2
    printWidth :: Int
printWidth = Layout -> Int
width Layout
layout
    maxWidth :: Int
maxWidth = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
printWidth ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ([Grapheme] -> Int
gsWidth ([Grapheme] -> Int) -> (String -> [Grapheme]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Grapheme]
stringToGraphemes) [String]
ws) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
minColPad)
    numCols :: Int
numCols = Int
printWidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
maxWidth
    ls :: [[String]]
ls = if Int
maxWidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
printWidth
                    then (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> [String]
forall a. a -> [a] -> [a]
: []) [String]
ws
                    else Int -> [String] -> [[String]]
forall a. Int -> [a] -> [[a]]
splitIntoGroups Int
numCols [String]
ws
    in ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> [String] -> String
padWords Int
maxWidth) [[String]]
ls

-- Add spaces to the end of each word so that it takes up the given visual width.
-- Don't pad the word in the last column, since printing a space in the last column
-- causes a line wrap on some terminals.
padWords :: Int -> [String] -> String
padWords :: Int -> [String] -> String
padWords Int
_ [String
x] = String
x
padWords Int
_ [] = String
""
padWords Int
wid (String
x:[String]
xs) = String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
wid Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
widthOf String
x) Char
' '
                        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> [String] -> String
padWords Int
wid [String]
xs
    where
        -- kludge: compute the width in graphemes, not chars.
        -- also use graphemes for the max width so that multi-width characters
        -- such as CJK letters are aligned correctly.
        widthOf :: String -> Int
widthOf = [Grapheme] -> Int
gsWidth ([Grapheme] -> Int) -> (String -> [Grapheme]) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Grapheme]
stringToGraphemes

-- Split xs into rows of length n,
-- such that the list increases incrementally along the columns.
-- e.g.: splitIntoGroups 4 [1..11] ==
-- [[1,4,7,10]
-- ,[2,5,8,11]
-- ,[3,6,9]]
splitIntoGroups :: Int -> [a] -> [[a]]
splitIntoGroups :: forall a. Int -> [a] -> [[a]]
splitIntoGroups Int
n [a]
xs = [[a]] -> [[a]]
forall a. [[a]] -> [[a]]
transpose ([[a]] -> [[a]]) -> [[a]] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> Maybe ([a], [a])) -> [a] -> [[a]]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr [a] -> Maybe ([a], [a])
forall {a}. [a] -> Maybe ([a], [a])
f [a]
xs
    where
        f :: [a] -> Maybe ([a], [a])
f [] = Maybe ([a], [a])
forall a. Maybe a
Nothing
        f [a]
ys = ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just (Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
k [a]
ys)
        k :: Int
k = Int -> Int -> Int
forall a. Integral a => a -> a -> a
ceilDiv ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Int
n

-- ceilDiv m n is the smallest k such that k * n >= m.
ceilDiv :: Integral a => a -> a -> a
ceilDiv :: forall a. Integral a => a -> a -> a
ceilDiv a
m a
n | a
m a -> a -> a
forall a. Integral a => a -> a -> a
`rem` a
n a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0    =  a
m a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
n
            | Bool
otherwise         =  a
m a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
n a -> a -> a
forall a. Num a => a -> a -> a
+ a
1