Add description support for completions

Author: cycoe

System/Console/Haskeline/Command/Completion.hs

@@ -16,6 +16,7 @@ import System.Console.Haskeline.Completion
 import System.Console.Haskeline.Monads
 
 import Data.List(transpose, unfoldr)
+import Data.Maybe(fromMaybe, catMaybes)
 
 useCompletion :: InsertMode -> Completion -> InsertMode
 useCompletion im c = insertString r im
@@ -71,7 +72,7 @@ makePartialCompletion im completions = insertString partial im
 pagingCompletion :: MonadReader Layout m => Key -> Prefs
                 -> [Completion] -> Command m InsertMode InsertMode
 pagingCompletion k prefs completions = \im -> do
-        ls <- asks $ makeLines (map display completions)
+        ls <- asks $ makeLines completions
         let pageAction = do
                 askFirst prefs (length completions) $
                             if completionPaging prefs
@@ -117,17 +118,26 @@ printPage ls = do
 
 -----------------------------------------------
 -- Splitting the list of completions into lines for paging.
-makeLines :: [String] -> Layout -> [String]
-makeLines ws layout = let
-    minColPad = 2
+makeLines :: [Completion] -> Layout -> [String]
+makeLines cs layout = let
+    descM = description <$> cs
+    descs = fromMaybe [] <$> descM
+    disps = display <$> cs
+    singleColumnMode = not . null . catMaybes $ descM
+    minColPad = if singleColumnMode then 8 else 2
     printWidth = width layout
-    maxWidth = min printWidth (maximum (map (gsWidth . stringToGraphemes) ws) + minColPad)
-    numCols = printWidth `div` maxWidth
+    maxWidth = min printWidth (maximum (map (gsWidth . stringToGraphemes) disps) + minColPad)
+    numCols = if singleColumnMode then 1 else printWidth `div` maxWidth
+    ws = if singleColumnMode then padLines maxWidth disps descs else disps
     ls = if maxWidth >= printWidth
                     then map (: []) ws
                     else splitIntoGroups numCols ws
     in map (padWords maxWidth) ls
 
+padLines :: Int -> [String] -> [String] -> [String]
+padLines wid = zipWith (\x y -> x ++ replicate (wid - widthOf x) ' ' ++ y)
+  where widthOf = gsWidth . stringToGraphemes
+
 -- Add spaces to the end of each word so that it takes up the given visual width.
 -- Don't pad the word in the last column, since printing a space in the last column
 -- causes a line wrap on some terminals.

System/Console/Haskeline/Completion.hs

@@ -38,6 +38,9 @@ data Completion = Completion {replacement  :: String, -- ^ Text to insert in lin
                         display  :: String,
                                 -- ^ Text to display when listing
                                 -- alternatives.
+                        description :: Maybe String,
+                                -- ^ Description to display when listing
+                                -- alternatives.
                         isFinished :: Bool
                             -- ^ Whether this word should be followed by a
                             -- space, end quote, etc.
@@ -121,7 +124,7 @@ completeFilename  = completeQuotedWord (Just '\\') "\"'" listFiles
                                 listFiles
 
 completion :: String -> Completion
-completion str = Completion str str True
+completion str = Completion str str Nothing True
 
 setReplacement :: (String -> String) -> Completion -> Completion
 setReplacement f c = c {replacement = f $ replacement c}
@@ -197,8 +200,9 @@ listFiles path = liftIO $ do
     (dir, file) = splitFileName path
     filterPrefix = filter (\f -> notElem f [".",".."]
                                         && file `isPrefixOf` f)
-    alterIfDir False c = c
+    alterIfDir False c = c {description = Just "some description"}
     alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c),
+                           description = Just "some description",
                             isFinished = False}
     fullName = replaceFileName path
 

examples/Test.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import Data.List
 import System.Console.Haskeline
 import System.Environment
 
@@ -12,11 +13,28 @@ Usage:
 ./Test password (no masking characters)
 ./Test password \*
 ./Test initial  (use initial text in the prompt)
+./Test description (completion with descriptions)
 --}
 
 mySettings :: Settings IO
 mySettings = defaultSettings {historyFile = Just "myhist"}
 
+completeWithDesc :: CompletionFunc IO
+completeWithDesc (l, r) = return ([], completions)
+  where
+    items = [ "first"
+            , "second"
+            , "third"
+            , "forth"
+            , "fifth"
+            ]
+    filterFunc d = (reverse l) `isPrefixOf` d && r `isSuffixOf` d
+    filtered = filter filterFunc items
+    replacements = (\x -> fst $ splitAt (length x - length r) x) <$> filtered
+    descriptions = map (\x -> Just $ "this is the " <> x <> " item") filtered
+    finished = replicate (length filtered) (null r)
+    completions = zipWith4 Completion replacements filtered descriptions finished
+
 main :: IO ()
 main = do
         args <- getArgs
@@ -26,7 +44,10 @@ main = do
                 ["password", [c]] -> getPassword (Just c)
                 ["initial"] -> flip getInputLineWithInitial ("left ", "right")
                 _ -> getInputLine
-        runInputT mySettings $ withInterrupt $ loop inputFunc 0
+            settings = case args of
+                ["description"] -> setComplete completeWithDesc mySettings
+                _ -> mySettings
+        runInputT settings $ withInterrupt $ loop inputFunc 0
     where
         loop :: (String -> InputT IO (Maybe String)) -> Int -> InputT IO ()
         loop inputFunc n = do