1module System.Console.Haskeline.Command.Completion(
2                            CompletionFunc,
3                            Completion,
4                            CompletionType(..),
5                            completionCmd
6                            ) where
7
8import System.Console.Haskeline.Command
9import System.Console.Haskeline.Command.Undo
10import System.Console.Haskeline.Key
11import System.Console.Haskeline.Term (Layout(..), CommandMonad(..))
12import System.Console.Haskeline.LineState
13import System.Console.Haskeline.Prefs
14import System.Console.Haskeline.Completion
15import System.Console.Haskeline.Monads
16
17import Data.List(transpose, unfoldr)
18
19useCompletion :: InsertMode -> Completion -> InsertMode
20useCompletion im c = insertString r im
21    where r | isFinished c = replacement c ++ " "
22            | otherwise = replacement c
23
24askIMCompletions :: CommandMonad m =>
25            Command m InsertMode (InsertMode, [Completion])
26askIMCompletions (IMode xs ys) = do
27    (rest, completions) <- lift $ runCompletion (withRev graphemesToString xs,
28                                            graphemesToString ys)
29    return (IMode (withRev stringToGraphemes rest) ys, completions)
30  where
31    withRev :: ([a] -> [b]) -> [a] -> [b]
32    withRev f = reverse . f . reverse
33
34-- | Create a 'Command' for word completion.
35completionCmd :: (MonadState Undo m, CommandMonad m)
36                => Key -> KeyCommand m InsertMode InsertMode
37completionCmd k = k +> saveForUndo >|> \oldIM -> do
38    (rest,cs) <- askIMCompletions oldIM
39    case cs of
40        [] -> effect RingBell >> return oldIM
41        [c] -> setState $ useCompletion rest c
42        _ -> presentCompletions k oldIM rest cs
43
44presentCompletions :: (MonadReader Prefs m, MonadReader Layout m)
45        => Key -> InsertMode -> InsertMode
46            -> [Completion] -> CmdM m InsertMode
47presentCompletions k oldIM rest cs = do
48    prefs <- ask
49    case completionType prefs of
50        MenuCompletion -> menuCompletion k (map (useCompletion rest) cs) oldIM
51        ListCompletion -> do
52            withPartial <- setState $ makePartialCompletion rest cs
53            if withPartial /= oldIM
54                then return withPartial
55                else pagingCompletion k prefs cs withPartial
56
57menuCompletion :: Monad m => Key -> [InsertMode] -> Command m InsertMode InsertMode
58menuCompletion k = loop
59    where
60        loop [] = setState
61        loop (c:cs) = change (const c) >|> try (k +> loop cs)
62
63makePartialCompletion :: InsertMode -> [Completion] -> InsertMode
64makePartialCompletion im completions = insertString partial im
65  where
66    partial = foldl1 commonPrefix (map replacement completions)
67    commonPrefix (c:cs) (d:ds) | c == d = c : commonPrefix cs ds
68    commonPrefix _ _ = ""
69
70pagingCompletion :: MonadReader Layout m => Key -> Prefs
71                -> [Completion] -> Command m InsertMode InsertMode
72pagingCompletion k prefs completions = \im -> do
73        ls <- asks $ makeLines (map display completions)
74        let pageAction = do
75                askFirst prefs (length completions) $
76                            if completionPaging prefs
77                                then printPage ls
78                                else effect (PrintLines ls)
79                setState im
80        if listCompletionsImmediately prefs
81            then pageAction
82            else effect RingBell >> try (k +> const pageAction) im
83
84askFirst :: Monad m => Prefs -> Int -> CmdM m ()
85            -> CmdM m ()
86askFirst prefs n cmd
87    | maybe False (< n) (completionPromptLimit prefs) = do
88        _ <- setState (Message $ "Display all " ++ show n
89                                 ++ " possibilities? (y or n)")
90        keyChoiceCmdM [
91            simpleChar 'y' +> cmd
92            , simpleChar 'n' +> return ()
93            ]
94    | otherwise = cmd
95
96pageCompletions :: MonadReader Layout m => [String] -> CmdM m ()
97pageCompletions [] = return ()
98pageCompletions wws@(w:ws) = do
99    _ <- setState $ Message "----More----"
100    keyChoiceCmdM [
101        simpleChar '\n' +> oneLine
102        , simpleKey DownKey +> oneLine
103        , simpleChar 'q' +> return ()
104        , simpleChar ' ' +> (clearMessage >> printPage wws)
105        ]
106  where
107    oneLine = clearMessage >> effect (PrintLines [w]) >> pageCompletions ws
108    clearMessage = effect $ LineChange $ const ([],[])
109
110printPage :: MonadReader Layout m => [String] -> CmdM m ()
111printPage ls = do
112    layout <- ask
113    let (ps,rest) = splitAt (height layout - 1) ls
114    effect $ PrintLines ps
115    pageCompletions rest
116
117-----------------------------------------------
118-- Splitting the list of completions into lines for paging.
119makeLines :: [String] -> Layout -> [String]
120makeLines ws layout = let
121    minColPad = 2
122    printWidth = width layout
123    maxLength = min printWidth (maximum (map length ws) + minColPad)
124    numCols = printWidth `div` maxLength
125    ls = if maxLength >= printWidth
126                    then map (: []) ws
127                    else splitIntoGroups numCols ws
128    in map (padWords maxLength) ls
129
130-- Add spaces to the end of each word so that it takes up the given length.
131-- Don't padd the word in the last column, since printing a space in the last column
132-- causes a line wrap on some terminals.
133padWords :: Int -> [String] -> String
134padWords _ [x] = x
135padWords _ [] = ""
136padWords len (x:xs) = x ++ replicate (len - glength x) ' '
137                        ++ padWords len xs
138    where
139        -- kludge: compute the length in graphemes, not chars.
140        -- but don't use graphemes for the max length, since I'm not convinced
141        -- that would work correctly. (This way, the worst that can happen is
142        -- that columns are longer than necessary.)
143        glength = length . stringToGraphemes
144
145-- Split xs into rows of length n,
146-- such that the list increases incrementally along the columns.
147-- e.g.: splitIntoGroups 4 [1..11] ==
148-- [[1,4,7,10]
149-- ,[2,5,8,11]
150-- ,[3,6,9]]
151splitIntoGroups :: Int -> [a] -> [[a]]
152splitIntoGroups n xs = transpose $ unfoldr f xs
153    where
154        f [] = Nothing
155        f ys = Just (splitAt k ys)
156        k = ceilDiv (length xs) n
157
158-- ceilDiv m n is the smallest k such that k * n >= m.
159ceilDiv :: Integral a => a -> a -> a
160ceilDiv m n | m `rem` n == 0    =  m `div` n
161            | otherwise         =  m `div` n + 1
162