module System.Console.Haskeline.Command.Completion(
CompletionFunc,
Completion,
CompletionType(..),
completionCmd
) where
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 im c = insertString r im
where r | isFinished c = replacement c ++ " "
| otherwise = replacement c
askIMCompletions :: CommandMonad m =>
Command m InsertMode (InsertMode, [Completion])
askIMCompletions (IMode xs ys) = do
(rest, completions) <- lift $ runCompletion (withRev graphemesToString xs,
graphemesToString ys)
return (IMode (withRev stringToGraphemes rest) ys, completions)
where
withRev :: ([a] -> [b]) -> [a] -> [b]
withRev f = reverse . f . reverse
completionCmd :: (MonadState Undo m, CommandMonad m)
=> Key -> KeyCommand m InsertMode InsertMode
completionCmd k = k +> saveForUndo >|> \oldIM -> do
(rest,cs) <- askIMCompletions oldIM
case cs of
[] -> effect RingBell >> return oldIM
[c] -> setState $ useCompletion rest c
_ -> presentCompletions k oldIM rest cs
presentCompletions :: (MonadReader Prefs m, MonadReader Layout m)
=> Key -> InsertMode -> InsertMode
-> [Completion] -> CmdM m InsertMode
presentCompletions k oldIM rest cs = do
prefs <- ask
case completionType prefs of
MenuCompletion -> menuCompletion k (map (useCompletion rest) cs) oldIM
ListCompletion -> do
withPartial <- setState $ makePartialCompletion rest cs
if withPartial /= oldIM
then return withPartial
else pagingCompletion k prefs cs withPartial
menuCompletion :: Monad m => Key -> [InsertMode] -> Command m InsertMode InsertMode
menuCompletion k = loop
where
loop [] = setState
loop (c:cs) = change (const c) >|> try (k +> loop cs)
makePartialCompletion :: InsertMode -> [Completion] -> InsertMode
makePartialCompletion im completions = insertString partial im
where
partial = foldl1 commonPrefix (map replacement completions)
commonPrefix (c:cs) (d:ds) | c == d = c : commonPrefix cs ds
commonPrefix _ _ = ""
pagingCompletion :: MonadReader Layout m => Key -> Prefs
-> [Completion] -> Command m InsertMode InsertMode
pagingCompletion k prefs completions = \im -> do
ls <- asks $ makeLines (map display completions)
let pageAction = do
askFirst prefs (length completions) $
if completionPaging prefs
then printPage ls
else effect (PrintLines ls)
setState im
if listCompletionsImmediately prefs
then pageAction
else effect RingBell >> try (k +> const pageAction) im
askFirst :: Monad m => Prefs -> Int -> CmdM m ()
-> CmdM m ()
askFirst prefs n cmd
| maybe False (< n) (completionPromptLimit prefs) = do
_ <- setState (Message $ "Display all " ++ show n
++ " possibilities? (y or n)")
keyChoiceCmdM [
simpleChar 'y' +> cmd
, simpleChar 'n' +> return ()
]
| otherwise = cmd
pageCompletions :: MonadReader Layout m => [String] -> CmdM m ()
pageCompletions [] = return ()
pageCompletions wws@(w:ws) = do
_ <- setState $ Message "----More----"
keyChoiceCmdM [
simpleChar '\n' +> oneLine
, simpleKey DownKey +> oneLine
, simpleChar 'q' +> return ()
, simpleChar ' ' +> (clearMessage >> printPage wws)
]
where
oneLine = clearMessage >> effect (PrintLines [w]) >> pageCompletions ws
clearMessage = effect $ LineChange $ const ([],[])
printPage :: MonadReader Layout m => [String] -> CmdM m ()
printPage ls = do
layout <- ask
let (ps,rest) = splitAt (height layout - 1) ls
effect $ PrintLines ps
pageCompletions rest
makeLines :: [String] -> Layout -> [String]
makeLines ws layout = let
minColPad = 2
printWidth = width layout
maxLength = min printWidth (maximum (map length ws) + minColPad)
numCols = printWidth `div` maxLength
ls = if maxLength >= printWidth
then map (: []) ws
else splitIntoGroups numCols ws
in map (padWords maxLength) ls
padWords :: Int -> [String] -> String
padWords _ [x] = x
padWords _ [] = ""
padWords len (x:xs) = x ++ replicate (len - glength x) ' '
++ padWords len xs
where
glength = length . stringToGraphemes
splitIntoGroups :: Int -> [a] -> [[a]]
splitIntoGroups n xs = transpose $ unfoldr f xs
where
f [] = Nothing
f ys = Just (splitAt k ys)
k = ceilDiv (length xs) n
ceilDiv :: Integral a => a -> a -> a
ceilDiv m n | m `rem` n == 0 = m `div` n
| otherwise = m `div` n + 1