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