Ticket #109: Completion.hs

File Completion.hs, 7.5 kB (added by boris, 4 years ago)
Line 
1module System.Console.Haskeline.Completion(
2                            CompletionFunc,
3                            Completion(..),
4                            completeWord,
5                            completeWordWithModifier,
6                            completeQuotedWord,
7                            -- * Building 'CompletionFunc's
8                            noCompletion,
9                            simpleCompletion,
10                            -- * Filename completion
11                            completeFilename,
12                            listFiles,
13                            filenameWordBreakChars
14                        ) where
15
16
17import System.FilePath
18import Data.List(isPrefixOf, find)
19import Control.Monad(forM)
20
21import System.Console.Haskeline.Directory
22import System.Console.Haskeline.Monads
23
24-- | Performs completions from the given line state.
25--
26-- The first 'String' argument is the contents of the line to the left of the cursor,
27-- reversed.
28-- The second 'String' argument is the contents of the line to the right of the cursor.
29--
30-- The output 'String' is the unused portion of the left half of the line, reversed.
31type CompletionFunc m = (String,String) -> m (String, [Completion])
32
33
34data Completion = Completion {replacement  :: String, -- ^ Text to insert in line.
35                        display  :: String,
36                                -- ^ Text to display when listing
37                                -- alternatives.
38                        isFinished :: Bool
39                            -- ^ Whether this word should be followed by a
40                            -- space, end quote, etc.
41                            }
42                    deriving Show
43
44-- | Disable completion altogether.
45noCompletion :: Monad m => CompletionFunc m
46noCompletion (s,_) = return (s,[])
47
48--------------
49-- Word break functions
50
51-- | The following function creates a custom 'CompletionFunc' for use in the 'Settings.'
52completeWord :: Monad m => Maybe Char
53        -- ^ An optional escape character
54        -> String -- ^ List of characters which count as whitespace
55        -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions
56        -> CompletionFunc m
57completeWord esc ws f = completeWordWithModifier esc ws "" (const f)
58   
59-- | The following function creates a custom 'CompletionFunc' for use in the 'Settings.'
60completeWordWithModifier :: Monad m => Maybe Char
61        -- ^ An optional escape character
62        -> String -- ^ List of characters which count as whitespace
63        -> String -- ^ List of characters which count as modifiers. May coincede with whitespace
64        -> (Maybe Char -> String -> m [Completion]) -- ^ Function to produce a list of possible completions
65        -> CompletionFunc m
66completeWordWithModifier esc ws ms f (line, _) = do
67    let (word,rest) = case esc of
68                        Nothing -> break (`elem` ws) line
69                        Just e -> escapedBreak e line
70    let modifier = find (`elem` ms) rest
71    completions <- f modifier (reverse word)
72    return (rest,map (escapeReplacement esc ws) completions)
73  where
74    escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws)
75            = let (xs,ys) = escapedBreak e cs in (c:xs,ys)
76    escapedBreak e (c:cs) | notElem c ws
77            = let (xs,ys) = escapedBreak e cs in (c:xs,ys)
78    escapedBreak _ cs = ("",cs)
79
80-- | Create a finished completion out of the given word.
81simpleCompletion :: String -> Completion
82simpleCompletion = completion
83
84-- NOTE: this is the same as for readline, except that I took out the '\\'
85-- so they can be used as a path separator.
86filenameWordBreakChars :: String
87filenameWordBreakChars = " \t\n`@$><=;|&{("
88
89-- A completion command for file and folder names.
90completeFilename :: MonadIO m => CompletionFunc m
91completeFilename  = completeQuotedWord (Just '\\') "\"'" listFiles
92                        $ completeWord (Just '\\') ("\"\'" ++ filenameWordBreakChars)
93                                listFiles
94
95completion :: String -> Completion
96completion str = Completion str str True
97
98setReplacement :: (String -> String) -> Completion -> Completion
99setReplacement f c = c {replacement = f $ replacement c}
100
101escapeReplacement :: Maybe Char -> String -> Completion -> Completion
102escapeReplacement esc ws f = case esc of
103    Nothing -> f
104    Just e -> f {replacement = escape e (replacement f)}
105  where
106    escape e (c:cs) | c `elem` (e:ws)     = e : c : escape e cs
107                    | otherwise = c : escape e cs
108    escape _ "" = ""
109
110
111---------
112-- Quoted completion
113completeQuotedWord :: Monad m => Maybe Char -- ^ An optional escape character
114                            -> String -- List of characters which set off quotes
115                            -> (String -> m [Completion]) -- ^ Function to produce a list of possible completions
116                            -> CompletionFunc m -- ^ Alternate completion to perform if the
117                                            -- cursor is not at a quoted word
118                            -> CompletionFunc m
119completeQuotedWord esc qs completer alterative line@(left,_)
120  = case splitAtQuote esc qs left of
121    Just (w,rest) | isUnquoted esc qs rest -> do
122        cs <- completer (reverse w)
123        return (rest, map (addQuotes . escapeReplacement esc qs) cs)
124    _ -> alterative line
125
126addQuotes :: Completion -> Completion
127addQuotes c = if isFinished c
128    then c {replacement = "\"" ++ replacement c ++ "\""}
129    else c {replacement = "\"" ++ replacement c}
130
131splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String)
132splitAtQuote esc qs line = case line of
133    c:e:cs | isEscape e && isEscapable c 
134                        -> do
135                            (w,rest) <- splitAtQuote esc qs cs
136                            return (c:w,rest)
137    q:cs   | isQuote q  -> Just ("",cs)
138    c:cs                -> do
139                            (w,rest) <- splitAtQuote esc qs cs
140                            return (c:w,rest)
141    ""                  -> Nothing
142  where
143    isQuote = (`elem` qs)
144    isEscape c = Just c == esc
145    isEscapable c = isEscape c || isQuote c
146
147isUnquoted :: Maybe Char -> String -> String -> Bool
148isUnquoted esc qs s = case splitAtQuote esc qs s of
149    Just (_,s') -> not (isUnquoted esc qs s')
150    _ -> True
151
152
153-- | List all of the files or folders beginning with this path.
154listFiles :: MonadIO m => FilePath -> m [Completion]
155listFiles path = liftIO $ do
156    fixedDir <- fixPath dir
157    dirExists <- doesDirectoryExist fixedDir
158    -- get all of the files in that directory, as basenames
159    allFiles <- if not dirExists
160                    then return []
161                    else fmap (map completion . filterPrefix)
162                            $ getDirectoryContents fixedDir
163    -- The replacement text should include the directory part, and also
164    -- have a trailing slash if it's itself a directory.
165    forM allFiles $ \c -> do
166            isDir <- doesDirectoryExist (fixedDir </> replacement c)
167            return $ setReplacement fullName $ alterIfDir isDir c
168  where
169    (dir, file) = splitFileName path
170    filterPrefix = filter (\f -> notElem f [".",".."]
171                                        && file `isPrefixOf` f)
172    alterIfDir False c = c
173    alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c),
174                            isFinished = False}
175    fullName = replaceFileName path
176
177-- turn a user-visible path into an internal version useable by System.FilePath.
178fixPath :: String -> IO String
179-- For versions of filepath < 1.2
180fixPath "" = return "."
181fixPath ('~':c:path) | isPathSeparator c = do
182    home <- getHomeDirectory
183    return (home </> path)
184fixPath path = return path