System/Console/Haskeline/Command/Completion.hs

    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

    -- | Create a 'Command' for word completion.
    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

    -----------------------------------------------
    -- Splitting the list of completions into lines for paging.
    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

    -- Add spaces to the end of each word so that it takes up the given length.
    -- Don't padd 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 _ [x] = x
    padWords _ [] = ""
    padWords len (x:xs) = x ++ replicate (len - glength x) ' '
                            ++ padWords len xs
        where
            -- kludge: compute the length in graphemes, not chars.
            -- but don't use graphemes for the max length, since I'm not convinced
            -- that would work correctly. (This way, the worst that can happen is
            -- that columns are longer than necessary.)
            glength = length . 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 n xs = transpose $ unfoldr f xs
        where
            f [] = Nothing
            f ys = Just (splitAt k ys)
            k = ceilDiv (length xs) n

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