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 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) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
CommandMonad m =>
(String, String) -> m (String, [Completion])
runCompletion (forall a b. ([a] -> [b]) -> [a] -> [b]
withRev [Grapheme] -> String
graphemesToString [Grapheme]
xs,
                                            [Grapheme] -> String
graphemesToString [Grapheme]
ys)
    forall (m :: * -> *) a. Monad m => a -> m a
return ([Grapheme] -> [Grapheme] -> InsertMode
IMode (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 = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [b]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Key -> a -> KeyMap a
+> forall s (m :: * -> *).
(Save s, MonadState Undo m) =>
Command m s s
saveForUndo 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) <- forall (m :: * -> *).
CommandMonad m =>
Command m InsertMode (InsertMode, [Completion])
askIMCompletions InsertMode
oldIM
    case [Completion]
cs of
        [] -> forall (m :: * -> *). Effect -> CmdM m ()
effect Effect
RingBell forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return InsertMode
oldIM
        [Completion
c] -> forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState forall a b. (a -> b) -> a -> b
$ InsertMode -> Completion -> InsertMode
useCompletion InsertMode
rest Completion
c
        [Completion]
_ -> 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
    case Prefs -> CompletionType
completionType Prefs
prefs of
        CompletionType
MenuCompletion -> forall (m :: * -> *).
Monad m =>
Key -> [InsertMode] -> Command m InsertMode InsertMode
menuCompletion Key
k (forall a b. (a -> b) -> [a] -> [b]
map (InsertMode -> Completion -> InsertMode
useCompletion InsertMode
rest) [Completion]
cs) InsertMode
oldIM
        CompletionType
ListCompletion -> do
            InsertMode
withPartial <- forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState forall a b. (a -> b) -> a -> b
$ InsertMode -> [Completion] -> InsertMode
makePartialCompletion InsertMode
rest [Completion]
cs
            if InsertMode
withPartial forall a. Eq a => a -> a -> Bool
/= InsertMode
oldIM
                then forall (m :: * -> *) a. Monad m => a -> m a
return InsertMode
withPartial
                else 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 = forall {m :: * -> *} {s}.
(Monad m, LineState s) =>
[s] -> Command m s s
loop
    where
        loop :: [s] -> Command m s s
loop [] = forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState
        loop (s
c:[s]
cs) = forall t (m :: * -> *) s.
(LineState t, Monad m) =>
(s -> t) -> Command m s t
change (forall a b. a -> b -> a
const s
c) forall (m :: * -> *) s t u.
Monad m =>
Command m s t -> Command m t u -> Command m s u
>|> forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Key
k 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 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> String -> String
commonPrefix (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 forall a. Eq a => a -> a -> Bool
== Char
d = Char
c 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 <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ [String] -> Layout -> [String]
makeLines (forall a b. (a -> b) -> [a] -> [b]
map Completion -> String
display [Completion]
completions)
        let pageAction :: CmdM m InsertMode
pageAction = do
                forall (m :: * -> *).
Monad m =>
Prefs -> Int -> CmdM m () -> CmdM m ()
askFirst Prefs
prefs (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Completion]
completions) forall a b. (a -> b) -> a -> b
$
                            if Prefs -> Bool
completionPaging Prefs
prefs
                                then forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
printPage [String]
ls
                                else forall (m :: * -> *). Effect -> CmdM m ()
effect ([String] -> Effect
PrintLines [String]
ls)
                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 forall (m :: * -> *). Effect -> CmdM m ()
effect Effect
RingBell forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) s.
Monad m =>
KeyCommand m s s -> Command m s s
try (Key
k forall a. Key -> a -> KeyMap a
+> 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
    | forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Ord a => a -> a -> Bool
< Int
n) (Prefs -> Maybe Int
completionPromptLimit Prefs
prefs) = do
        Message
_ <- forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState (String -> Message
Message forall a b. (a -> b) -> a -> b
$ String
"Display all " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n
                                 forall a. [a] -> [a] -> [a]
++ String
" possibilities? (y or n)")
        forall (m :: * -> *) a. [KeyMap (CmdM m a)] -> CmdM m a
keyChoiceCmdM [
            Char -> Key
simpleChar Char
'y' forall a. Key -> a -> KeyMap a
+> CmdM m ()
cmd
            , Char -> Key
simpleChar Char
'n' forall a. Key -> a -> KeyMap a
+> 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 [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
pageCompletions wws :: [String]
wws@(String
w:[String]
ws) = do
    Message
_ <- forall (m :: * -> *) s. (Monad m, LineState s) => Command m s s
setState forall a b. (a -> b) -> a -> b
$ String -> Message
Message String
"----More----"
    forall (m :: * -> *) a. [KeyMap (CmdM m a)] -> CmdM m a
keyChoiceCmdM [
        Char -> Key
simpleChar Char
'\n' forall a. Key -> a -> KeyMap a
+> CmdM m ()
oneLine
        , BaseKey -> Key
simpleKey BaseKey
DownKey forall a. Key -> a -> KeyMap a
+> CmdM m ()
oneLine
        , Char -> Key
simpleChar Char
'q' forall a. Key -> a -> KeyMap a
+> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        , Char -> Key
simpleChar Char
' ' forall a. Key -> a -> KeyMap a
+> (forall {m :: * -> *}. CmdM m ()
clearMessage forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
printPage [String]
wws)
        ]
  where
    oneLine :: CmdM m ()
oneLine = forall {m :: * -> *}. CmdM m ()
clearMessage forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Effect -> CmdM m ()
effect ([String] -> Effect
PrintLines [String
w]) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadReader Layout m => [String] -> CmdM m ()
pageCompletions [String]
ws
    clearMessage :: CmdM m ()
clearMessage = forall (m :: * -> *). Effect -> CmdM m ()
effect forall a b. (a -> b) -> a -> b
$ ([Grapheme] -> LineChars) -> Effect
LineChange forall a b. (a -> b) -> a -> b
$ 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let ([String]
ps,[String]
rest) = forall a. Int -> [a] -> ([a], [a])
splitAt (Layout -> Int
height Layout
layout forall a. Num a => a -> a -> a
- Int
1) [String]
ls
    forall (m :: * -> *). Effect -> CmdM m ()
effect forall a b. (a -> b) -> a -> b
$ [String] -> Effect
PrintLines [String]
ps
    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 = forall a. Ord a => a -> a -> a
min Int
printWidth (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map ([Grapheme] -> Int
gsWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Grapheme]
stringToGraphemes) [String]
ws) forall a. Num a => a -> a -> a
+ Int
minColPad)
    numCols :: Int
numCols = Int
printWidth forall a. Integral a => a -> a -> a
`div` Int
maxWidth
    ls :: [[String]]
ls = if Int
maxWidth forall a. Ord a => a -> a -> Bool
>= Int
printWidth
                    then forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> [a] -> [a]
: []) [String]
ws
                    else forall a. Int -> [a] -> [[a]]
splitIntoGroups Int
numCols [String]
ws
    in 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 forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
wid forall a. Num a => a -> a -> a
- String -> Int
widthOf String
x) Char
' '
                        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 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 = forall a. [[a]] -> [[a]]
transpose forall a b. (a -> b) -> a -> b
$ forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr forall {a}. [a] -> Maybe ([a], [a])
f [a]
xs
    where
        f :: [a] -> Maybe ([a], [a])
f [] = forall a. Maybe a
Nothing
        f [a]
ys = forall a. a -> Maybe a
Just (forall a. Int -> [a] -> ([a], [a])
splitAt Int
k [a]
ys)
        k :: Int
k = forall a. Integral a => a -> a -> a
ceilDiv (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 forall a. Integral a => a -> a -> a
`rem` a
n forall a. Eq a => a -> a -> Bool
== a
0    =  a
m forall a. Integral a => a -> a -> a
`div` a
n
            | Bool
otherwise         =  a
m forall a. Integral a => a -> a -> a
`div` a
n forall a. Num a => a -> a -> a
+ a
1