module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import ClassyPrelude hiding (init, last, head, liftIO)
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take)
import Data.Char
import Data.List (nub, init, last, head, elemIndex)
import Data.List.Split
import Data.List.Split.Internals
import Data.Maybe (fromJust)
import Data.String.Utils (strip, startswith, endswith, replace)
import qualified Data.String.Utils as StringUtils
import System.Environment (getEnv)
import GHC
import DynFlags
import GhcMonad
import PackageConfig
import Outputable (showPpr)
import System.Directory
import System.FilePath
import MonadUtils (MonadIO)
import System.Console.Haskeline.Completion
import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
data CompletionType
= Empty
| Identifier String
| DynFlag String
| Qualified String String
| ModuleName String String
| HsFilePath String String
| FilePath String String
| KernelOption String
| Extension String
deriving (Show, Eq)
complete :: String -> Int -> Interpreter (String, [String])
complete line pos = do
flags <- getSessionDynFlags
rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope
let isQualified = ('.' `elem`)
unqualNames = nub $ filter (not . isQualified) rdrNames
qualNames = nub $ scopeNames ++ filter isQualified rdrNames
let Just db = pkgDatabase flags
getNames = map moduleNameString . exposedModules
moduleNames = nub $ concatMap getNames db
let target = completionTarget line pos
completion = completionType line pos target
let matchedText = case completion of
HsFilePath _ match -> match
FilePath _ match -> match
otherwise -> intercalate "." target
options <-
case completion of
Empty -> return []
Identifier candidate ->
return $ filter (candidate `isPrefixOf`) unqualNames
Qualified moduleName candidate -> do
trueName <- getTrueModuleName moduleName
let prefix = intercalate "." [trueName, candidate]
completions = filter (prefix `isPrefixOf`) qualNames
falsifyName = replace trueName moduleName
return $ map falsifyName completions
ModuleName previous candidate -> do
let prefix = if null previous
then candidate
else intercalate "." [previous, candidate]
return $ filter (prefix `isPrefixOf`) moduleNames
DynFlag ext -> do
let extName (name, _, _) = name
kernelOptNames = concatMap getSetName kernelOpts
otherNames = ["-package","-Wall","-w"]
fNames = map extName fFlags ++
map extName fWarningFlags ++
map extName fLangFlags
fNoNames = map ("no"++) fNames
fAllNames = map ("-f"++) (fNames ++ fNoNames)
xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
xAllNames = map ("-X"++) (xNames ++ xNoNames)
allNames = xAllNames ++ otherNames ++ fAllNames
return $ filter (ext `isPrefixOf`) allNames
Extension ext -> do
let extName (name, _, _) = name
xNames = map extName xFlags
xNoNames = map ("No" ++) xNames
return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames
HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
FilePath lineUpToCursor match -> completePath lineUpToCursor
KernelOption str -> return $
filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)
return (matchedText, options)
getTrueModuleName :: String -> Interpreter String
getTrueModuleName name = do
let onlyImportDecl (IIDecl decl) = Just decl
onlyImportDecl _ = Nothing
imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext
flags <- getSessionDynFlags
let qualifiedImports = filter (isJust . ideclAs) imports
hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
case find hasName qualifiedImports of
Nothing -> return name
Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
completionType :: String
-> Int
-> [String]
-> CompletionType
completionType line loc target
| startswith ":!" stripped
= fileComplete FilePath
| startswith ":l" stripped
= fileComplete HsFilePath
| startswith ":s" stripped
= DynFlag candidate
| startswith ":o" stripped
= KernelOption candidate
| startswith ":e" stripped
= Extension candidate
| null target
= Empty
| cursorInString line loc
= FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
| startswith "import" stripped && isModName
= ModuleName dotted candidate
| isModName && (not . null . init) target
= Qualified dotted candidate
| otherwise
= Identifier candidate
where stripped = strip line
dotted = dots target
candidate | null target = ""
| otherwise = last target
dots = intercalate "." . init
isModName = all isCapitalized (init target)
isCapitalized = isUpper . head
lineUpToCursor = take loc line
fileComplete filePath = case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $
if endswith (last xs) lineUpToCursor
then last xs
else []
Left _ -> Empty
cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0
nquotes ('\\':'"':xs) = nquotes xs
nquotes ('"':xs) = 1 + nquotes xs
nquotes (_:xs) = nquotes xs
nquotes [] = 0
getStringTarget :: String -> String
getStringTarget = go "" . reverse
where
go acc rest = case rest of
'"':'\\':rem -> go ('"':acc) rem
'"':rem -> acc
' ':'\\':rem -> go (' ':acc) rem
' ':rem -> acc
x:rem -> go (x:acc) rem
[] -> acc
completionTarget :: String -> Int -> [String]
completionTarget code cursor = expandCompletionPiece pieceToComplete
where
pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
pieces = splitAlongCursor $ split splitter $ zip code [1 .. ]
splitter = defaultSplitter {
delimiter = Delimiter [uncurry isDelim],
condensePolicy = Condense,
delimPolicy = Drop
}
isDelim :: Char -> Int -> Bool
isDelim char idx = char `elem` neverIdent || isSymbol char
splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
splitAlongCursor [] = []
splitAlongCursor (x:xs) =
case elemIndex cursor $ map snd x of
Nothing -> x:splitAlongCursor xs
Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs
neverIdent :: String
neverIdent = " \n\t(),{}[]\\'\"`"
expandCompletionPiece Nothing = []
expandCompletionPiece (Just str) = splitOn "." str
getHome :: IO String
getHome = do
homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)
return $ case homeEither of
Left _ -> "~"
Right home -> home
dirExpand :: String -> IO String
dirExpand str = do
home <- getHome
return $ replace "~" home str
unDirExpand :: String -> IO String
unDirExpand str = do
home <- getHome
return $ replace home "~" str
completePath :: String -> Interpreter [String]
completePath line = completePathFilter acceptAll acceptAll line ""
where acceptAll = const True
completePathWithExtensions :: [String] -> String -> Interpreter [String]
completePathWithExtensions extensions line =
completePathFilter (extensionIsOneOf extensions) acceptAll line ""
where
acceptAll = const True
extensionIsOneOf exts str = any correctEnding exts
where correctEnding ext = endswith ext str
completePathFilter :: (String -> Bool)
-> (String -> Bool)
-> String
-> String
-> Interpreter [String]
completePathFilter includeFile includeDirectory left right = liftIO $ do
expanded <- dirExpand left
completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
areDirs <- mapM doesDirectoryExist completions
let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs
files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs
suggestions <- mapM unDirExpand $ dirs ++ files
let isHidden str = startswith "." . last . StringUtils.split "/" $
if endswith "/" str
then init str
else str
visible = filter (not . isHidden) suggestions
hidden = filter isHidden suggestions
return $ visible ++ hidden