module System.Console.Haskeline.Completion(
CompletionFunc,
Completion(..),
noCompletion,
simpleCompletion,
completeWord,
completeWordWithPrev,
completeQuotedWord,
completeFilename,
listFiles,
filenameWordBreakChars
) where
import System.FilePath
import Data.List(isPrefixOf)
import Control.Monad(forM)
import System.Console.Haskeline.Directory
import System.Console.Haskeline.Monads
type CompletionFunc m = (String,String) -> m (String, [Completion])
data Completion = Completion {replacement :: String,
display :: String,
isFinished :: Bool
}
deriving (Eq, Ord, Show)
noCompletion :: Monad m => CompletionFunc m
noCompletion (s,_) = return (s,[])
completeWord :: Monad m => Maybe Char
-> [Char]
-> (String -> m [Completion])
-> CompletionFunc m
completeWord esc ws = completeWordWithPrev esc ws . const
completeWordWithPrev :: Monad m => Maybe Char
-> [Char]
-> (String -> String -> m [Completion])
-> CompletionFunc m
completeWordWithPrev esc ws f (line, _) = do
let (word,rest) = case esc of
Nothing -> break (`elem` ws) line
Just e -> escapedBreak e line
completions <- f rest (reverse word)
return (rest,map (escapeReplacement esc ws) completions)
where
escapedBreak e (c:d:cs) | d == e && c `elem` (e:ws)
= let (xs,ys) = escapedBreak e cs in (c:xs,ys)
escapedBreak e (c:cs) | notElem c ws
= let (xs,ys) = escapedBreak e cs in (c:xs,ys)
escapedBreak _ cs = ("",cs)
simpleCompletion :: String -> Completion
simpleCompletion = completion
filenameWordBreakChars :: String
filenameWordBreakChars = " \t\n`@$><=;|&{("
completeFilename :: MonadIO m => CompletionFunc m
completeFilename = completeQuotedWord (Just '\\') "\"'" listFiles
$ completeWord (Just '\\') ("\"\'" ++ filenameWordBreakChars)
listFiles
completion :: String -> Completion
completion str = Completion str str True
setReplacement :: (String -> String) -> Completion -> Completion
setReplacement f c = c {replacement = f $ replacement c}
escapeReplacement :: Maybe Char -> String -> Completion -> Completion
escapeReplacement esc ws f = case esc of
Nothing -> f
Just e -> f {replacement = escape e (replacement f)}
where
escape e (c:cs) | c `elem` (e:ws) = e : c : escape e cs
| otherwise = c : escape e cs
escape _ "" = ""
completeQuotedWord :: Monad m => Maybe Char
-> [Char]
-> (String -> m [Completion])
-> CompletionFunc m
-> CompletionFunc m
completeQuotedWord esc qs completer alterative line@(left,_)
= case splitAtQuote esc qs left of
Just (w,rest) | isUnquoted esc qs rest -> do
cs <- completer (reverse w)
return (rest, map (addQuotes . escapeReplacement esc qs) cs)
_ -> alterative line
addQuotes :: Completion -> Completion
addQuotes c = if isFinished c
then c {replacement = "\"" ++ replacement c ++ "\""}
else c {replacement = "\"" ++ replacement c}
splitAtQuote :: Maybe Char -> String -> String -> Maybe (String,String)
splitAtQuote esc qs line = case line of
c:e:cs | isEscape e && isEscapable c
-> do
(w,rest) <- splitAtQuote esc qs cs
return (c:w,rest)
q:cs | isQuote q -> Just ("",cs)
c:cs -> do
(w,rest) <- splitAtQuote esc qs cs
return (c:w,rest)
"" -> Nothing
where
isQuote = (`elem` qs)
isEscape c = Just c == esc
isEscapable c = isEscape c || isQuote c
isUnquoted :: Maybe Char -> String -> String -> Bool
isUnquoted esc qs s = case splitAtQuote esc qs s of
Just (_,s') -> not (isUnquoted esc qs s')
_ -> True
listFiles :: MonadIO m => FilePath -> m [Completion]
listFiles path = liftIO $ do
fixedDir <- fixPath dir
dirExists <- doesDirectoryExist fixedDir
allFiles <- if not dirExists
then return []
else fmap (map completion . filterPrefix)
$ getDirectoryContents fixedDir
forM allFiles $ \c -> do
isDir <- doesDirectoryExist (fixedDir </> replacement c)
return $ setReplacement fullName $ alterIfDir isDir c
where
(dir, file) = splitFileName path
filterPrefix = filter (\f -> notElem f [".",".."]
&& file `isPrefixOf` f)
alterIfDir False c = c
alterIfDir True c = c {replacement = addTrailingPathSeparator (replacement c),
isFinished = False}
fullName = replaceFileName path
fixPath :: String -> IO String
fixPath "" = return "."
fixPath ('~':c:path) | isPathSeparator c = do
home <- getHomeDirectory
return (home </> path)
fixPath path = return path