forked from judah/haskeline
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Completion.hs
164 lines (148 loc) · 6.29 KB
/
Completion.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
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.Char(toLower)
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) | toLower c == toLower d = c : commonPrefix cs ds
-- toLower is useful when there are case-insensitive matches and
-- does nothing to case-sensitive ones.
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