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) <- 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