Commit 1de89fb4 authored by Eyal Dechter's avatar Eyal Dechter

Added general path completion using haskeline.

parent d01ab001
...@@ -33,19 +33,24 @@ import System.FilePath ...@@ -33,19 +33,24 @@ import System.FilePath
import MonadUtils (MonadIO) import MonadUtils (MonadIO)
import Control.Monad (filterM, mapM, liftM) import Control.Monad (filterM, mapM, liftM)
import System.Console.Haskeline.Completion
import qualified Control.Monad.IO.Class as MonadIO (MonadIO(), liftIO)
import IHaskell.Types import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
data CompletionType data CompletionType
= Empty = Empty
| Identifier String | Identifier String
| Extension String | Extension String
| Qualified String String | Qualified String String
| ModuleName String String | ModuleName String String
| HsFilePath String | HsFilePath String
| FilePath String
deriving (Show, Eq) deriving (Show, Eq)
complete :: GHC.GhcMonad m => String -> Int -> m (String, [String]) complete :: String -> Int -> Interpreter (String, [String])
complete line pos = do complete line pos = do
flags <- getSessionDynFlags flags <- getSessionDynFlags
rdrNames <- map (showPpr flags) <$> getRdrNamesInScope rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
...@@ -61,7 +66,7 @@ complete line pos = do ...@@ -61,7 +66,7 @@ complete line pos = do
let target = completionTarget line pos let target = completionTarget line pos
matchedText = intercalate "." target matchedText = intercalate "." target
options <- options <-
case completionType line target of case completionType line target of
Empty -> return [] Empty -> return []
...@@ -87,12 +92,13 @@ complete line pos = do ...@@ -87,12 +92,13 @@ complete line pos = do
nonames = map ("No" ++) names nonames = map ("No" ++) names
return $ filter (ext `isPrefixOf`) $ names ++ nonames return $ filter (ext `isPrefixOf`) $ names ++ nonames
HsFilePath path -> do pwd <- liftIO getCurrentDirectory HsFilePath path -> completePathWithExtensions [".hs", ".lhs"] path
completePath pwd (Just [".hs", ".lhs"]) path
FilePath path -> completePath path
return (matchedText, options) return (matchedText, options)
getTrueModuleName :: GhcMonad m => String -> m String getTrueModuleName :: String -> Interpreter String
getTrueModuleName name = do getTrueModuleName name = do
-- Only use the things that were actually imported -- Only use the things that were actually imported
let onlyImportDecl (IIDecl decl) = Just decl let onlyImportDecl (IIDecl decl) = Just decl
...@@ -107,20 +113,22 @@ getTrueModuleName name = do ...@@ -107,20 +113,22 @@ getTrueModuleName name = do
let qualifiedImports = filter (isJust . ideclAs) imports let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
case find hasName qualifiedImports of case find hasName qualifiedImports of
Nothing -> return name Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
completionType :: String -> [String] -> CompletionType completionType :: String -> [String] -> CompletionType
completionType line [] = Empty completionType line [] = Empty
completionType line target completionType line target
| startswith ":l" stripped | startswith ":! " stripped
= HsFilePath $ last $ splitOn " " stripped = FilePath complete_target
| startswith ":l" stripped
= HsFilePath complete_target
| startswith "import" stripped && isModName | startswith "import" stripped && isModName
= ModuleName dotted candidate = ModuleName dotted candidate
| isModName && (not . null . init) target | isModName && (not . null . init) target
= Qualified dotted candidate = Qualified dotted candidate
| startswith ":e" stripped | startswith ":e" stripped
= Extension candidate = Extension candidate
| otherwise | otherwise
= Identifier candidate = Identifier candidate
where stripped = strip line where stripped = strip line
...@@ -129,13 +137,14 @@ completionType line target ...@@ -129,13 +137,14 @@ completionType line target
dots = intercalate "." . init dots = intercalate "." . init
isModName = all isCapitalized (init target) isModName = all isCapitalized (init target)
isCapitalized = isUpper . head isCapitalized = isUpper . head
complete_target = intercalate "." target
-- | Get the word under a given cursor location. -- | Get the word under a given cursor location.
completionTarget :: String -> Int -> [String] completionTarget :: String -> Int -> [String]
completionTarget code cursor = expandCompletionPiece pieceToComplete completionTarget code cursor = expandCompletionPiece pieceToComplete
where where
pieceToComplete = map fst <$> find (elem cursor . map snd) pieces pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
pieces = splitAlongCursor $ split splitter $ zip code [1 .. ] pieces = splitAlongCursor $ split splitter $ zip code [1 .. ]
splitter = defaultSplitter { splitter = defaultSplitter {
...@@ -151,7 +160,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete ...@@ -151,7 +160,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
splitAlongCursor [] = [] splitAlongCursor [] = []
splitAlongCursor (x:xs) = splitAlongCursor (x:xs) =
case elemIndex cursor $ map snd x of case elemIndex cursor $ map snd x of
Nothing -> x:splitAlongCursor xs Nothing -> x:splitAlongCursor xs
Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs
...@@ -160,34 +169,28 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete ...@@ -160,34 +169,28 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
neverIdent = " \n\t(),{}[]\\'\"`" neverIdent = " \n\t(),{}[]\\'\"`"
expandCompletionPiece Nothing = [] expandCompletionPiece Nothing = []
expandCompletionPiece (Just str) = splitOn "." str expandCompletionPiece (Just str) = splitOn "." str
completePath :: MonadIO m => completePathFilter :: (String -> Bool) -- ^ filter files
String -- ^ Current directory -> (String -> Bool) -- ^ filter directories
-> Maybe [String] -- ^ list of file extensions -> String -- ^ line contents left of cursor
-> String -- ^ prefix to be completed -> String -- ^ line contents right of cursor
-> m [String] -- ^ completions, that is, if prefix is "Mai" one completion might be "Main.hs" -> Interpreter [String]
completePath currDir exts prefix completePathFilter fileFilter dirFilter loc roc =
= let absolutePrefix = combine currDir prefix do (_, comps) <- MonadIO.liftIO $ (completeFilename (reverse loc, roc))
searchDir = dropFileName absolutePrefix let completions = map replacement comps
pattern = absolutePrefix ++ "*" dirs <- liftIO $ filterM doesDirectoryExist completions
completions = liftIO $ Find.find always (filePath ~~? pattern) searchDir files <- liftIO $ filterM (liftM not . doesDirectoryExist) completions
allFileCompletions = completions >>= liftIO . filterM (liftM not . doesDirectoryExist) let dirs' = filter dirFilter files
fileCompletions = case exts of files' = filter fileFilter dirs
Nothing -> allFileCompletions return $ filter (\x -> elem x $ dirs' ++ files') completions
Just exts -> do xs <- allFileCompletions
return $ filter (\s -> or [endswith ext s | ext <- exts]) xs completePath :: String -> Interpreter [String]
dirCompletions = completions completePath loc = completePathFilter (const True) (const True) loc ""
>>= liftIO . filterM doesDirectoryExist
>>= \xs -> do return $ [x ++ [pathSeparator] | x <- xs] completePathWithExtensions :: [String] -> String -> Interpreter [String]
relativeCompletions = do validSearchDir <- liftIO $ doesDirectoryExist searchDir completePathWithExtensions extensions loc =
if validSearchDir then completePathFilter (\s -> any (\x -> endswith x s) extensions) (const True) loc ""
do xs <- fileCompletions
ys <- dirCompletions
return $ map (cut $ currDir ++ [pathSeparator]) $ xs ++ ys
else return []
cut :: String -> String -> String
cut (x:xs) z@(y:ys) | x == y = cut xs ys
| otherwise = z
cut _ z = z
in relativeCompletions
\ No newline at end of file
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment