From d45a937b30899ea967d41a551e753ad46f43bd73 Mon Sep 17 00:00:00 2001 From: wisut hantanong Date: Sat, 1 Sep 2018 14:04:05 +0700 Subject: [PATCH] Case insensitive completion I am not author of the patch, this commit use patch from https://paste.debian.net/plainh/ec5ae9040 see #84 https://github.com/judah/haskeline/issues/84#issuecomment-417755709 --- .../Console/Haskeline/Command/Completion.hs | 5 +- System/Console/Haskeline/Completion.hs | 37 ++++++++++++++ examples/Case.hs | 50 +++++++++++++++++++ haskeline.cabal | 2 +- 4 files changed, 92 insertions(+), 2 deletions(-) create mode 100644 examples/Case.hs diff --git a/System/Console/Haskeline/Command/Completion.hs b/System/Console/Haskeline/Command/Completion.hs index 71a0f124..8edada0b 100644 --- a/System/Console/Haskeline/Command/Completion.hs +++ b/System/Console/Haskeline/Command/Completion.hs @@ -14,6 +14,7 @@ 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 @@ -64,7 +65,9 @@ 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 (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 diff --git a/System/Console/Haskeline/Completion.hs b/System/Console/Haskeline/Completion.hs index b17bb0c7..2e71b4df 100644 --- a/System/Console/Haskeline/Completion.hs +++ b/System/Console/Haskeline/Completion.hs @@ -1,10 +1,12 @@ module System.Console.Haskeline.Completion( CompletionFunc, Completion(..), + CaseSensitivity(..), noCompletion, simpleCompletion, -- * Word completion completeWord, + completeList, completeWordWithPrev, completeQuotedWord, -- * Filename completion @@ -17,6 +19,7 @@ module System.Console.Haskeline.Completion( import System.FilePath import Data.List(isPrefixOf) import Control.Monad(forM) +import Data.Char(toLower) import System.Console.Haskeline.Directory import System.Console.Haskeline.Monads @@ -41,6 +44,9 @@ data Completion = Completion {replacement :: String, -- ^ Text to insert in lin } deriving (Eq, Ord, Show) +-- | Case sensitivity for autocomplete-from-wordlist functions. +data CaseSensitivity = MatchCase | IgnoreCase + -- | Disable completion altogether. noCompletion :: Monad m => CompletionFunc m noCompletion (s,_) = return (s,[]) @@ -58,6 +64,37 @@ completeWord :: Monad m => Maybe Char -> CompletionFunc m completeWord esc ws = completeWordWithPrev esc ws . const +-- | Autocomplete from list of words, following the same behaviour as +-- 'completeWord' (completes to the immediate left of the cursor, word begins +-- at newline or unescaped whitespace). +-- +-- This function allows selecting case-sensitivity of the autocomplete. +-- e.g. with 'IgnoreCase', @readf\@ will be expanded to +-- @readFile@. +completeList :: Monad m => Maybe Char -- ^ An optional escape character + -> [Char] -- ^ Characters which count as whitespace + -> [String] -- ^ List of autocompletable words + -> CaseSensitivity -- ^ Case sensitivity + -> CompletionFunc m +completeList esc ws ml cs = do + completeWordWithPrev esc ws (complFun ml) + where + complFun :: Monad m => [String] -> String -> String -> m [Completion] + complFun dic _ part = return . map simpleCompletion . + selectMatches cs part $ dic + + -- selectMatches performs an `isPrefixOf` filter on a dictionary; + -- for IgnoreCase, perfect matches will be listed higher. + selectMatches :: CaseSensitivity -> String -> [String] -> [String] + selectMatches MatchCase part dic = filter (isPrefixOf part) dic + selectMatches IgnoreCase part dic = + filter (isPrefixOf part) dic ++ + filter (\d -> isPrefixOf (low part) (low d) && + (not $ isPrefixOf part d)) dic + + low :: String -> String + low t = map toLower t + -- | A custom 'CompletionFunc' which completes the word immediately to the left of the cursor, -- and takes into account the line contents to the left of the word. -- diff --git a/examples/Case.hs b/examples/Case.hs new file mode 100644 index 00000000..6b031508 --- /dev/null +++ b/examples/Case.hs @@ -0,0 +1,50 @@ +module Main where + +import System.Console.Haskeline +import System.Console.Haskeline.Completion +import System.Environment +import Control.Exception (AsyncException(..)) + +{- +Testing case-insensitive autocompletion. + +Usage: +(from the project folder) + cabal new-repl +(an then from inside ghci) + :load examples/Case.hs + main +-} + +{- Expected behaviour: + r does not change cap of the letter + R does not change cap of the letter + Ca suggestions are "Cane callo" + ca suggestions are "callo Cane" + ma gets completed to "maybe" + Ma gets completed to "Maybe" + cane gets completed to "Cane" +-} + +mySettings :: Settings IO +mySettings = setComplete cfCI defaultSettings + where + cfCI :: CompletionFunc IO + cfCI = completeList Nothing " " + ["Rana", "rosa", "Cane", "callo", "maybe", "Maybe"] + IgnoreCase + +main :: IO () +main = runInputT mySettings $ withInterrupt $ loop getInputLine 0 + where + loop inputFunc n = do + minput <- handle (\Interrupt -> return (Just "Caught interrupted")) + $ inputFunc (show n ++ ":") + case minput of + Nothing -> return () + Just "quit" -> return () + Just "q" -> return () + Just s -> do + outputStrLn ("line " ++ show n ++ ":" ++ s) + loop inputFunc (n+1) + diff --git a/haskeline.cabal b/haskeline.cabal index 903a01db..dd7a7b3f 100644 --- a/haskeline.cabal +++ b/haskeline.cabal @@ -20,7 +20,7 @@ Homepage: https://github.com/judah/haskeline Bug-Reports: https://github.com/judah/haskeline/issues Stability: Stable Build-Type: Simple -extra-source-files: examples/Test.hs Changelog includes/*.h +extra-source-files: examples/Test.hs examples/Case.hs Changelog includes/*.h source-repository head type: git