Merge pull request #103 from edechter/path_completion

Path completion

IHaskell.cabal

@@ -73,11 +73,12 @@ library
                        directory,
                        here,
                        system-filepath,
-                       filemanip,
                        filepath,
                        cereal ==0.3.*,
                        text >=0.11,
                        mtl >= 2.1
+                       transformers,
+                       haskeline
   exposed-modules: IHaskell.Display
                    IHaskell.Eval.Completion
                    IHaskell.Eval.Evaluate
@@ -145,11 +146,12 @@ executable IHaskell
                        directory,
                        here,
                        system-filepath,
-                       filemanip,
                        filepath,
                        cereal ==0.3.*,
                        text >=0.11,
-                       mtl >= 2.1
+                       mtl >= 2.1,
+                       transformers,
+                       haskeline
 
 Test-Suite hspec
   hs-source-dirs:      src
@@ -185,7 +187,9 @@ Test-Suite hspec
                        filepath,
                        cereal ==0.3.*,
                        text >=0.11,
-                       mtl >= 2.1
+                       mtl >= 2.1,
+                       transformers,
+                       haskeline
   extensions: DoAndIfThenElse
               OverloadedStrings
               ExtendedDefaultRules

src/Hspec.hs

@@ -75,9 +75,9 @@ completes string expected = completionTarget newString cursorloc `shouldBe` expe
           Nothing -> error "Expected cursor written as '!'."
           Just idx -> (replace "!" "" string, idx)
 
-completionHas_ action string expected = do
+completionHas_ wrap string expected = do
     (matched, completions) <- doGhc $ do
-      initCompleter action
+      wrap $ do initCompleter
                 complete newString cursorloc
     let existsInCompletion = (`elem` completions)
         unmatched = filter (not . existsInCompletion) expected
@@ -86,10 +86,12 @@ completionHas_ action string expected = do
           Nothing -> error "Expected cursor written as '!'."
           Just idx -> (replace "!" "" string, idx)
 
-completionHas = completionHas_ (return ())
+completionHas = completionHas_ id
 
-initCompleter :: GhcMonad m => m a -> m a
-initCompleter action = do
+initCompleter :: GhcMonad m => m ()
+initCompleter  = do
+  pwd <- Eval.liftIO $ getCurrentDirectory
+  --Eval.liftIO $ traceIO $ pwd
   flags <- getSessionDynFlags
   setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
 
@@ -99,7 +101,6 @@ initCompleter action = do
                                    "import qualified Data.List as List",
                                    "import Data.Maybe as Maybe"]
   setContext $ map IIDecl imports
-  action
 
 withHsDirectory :: (FilePath -> Sh ()) -> IO ()
 withHsDirectory f = shelly $ withTmpDir $ \dirPath ->
@@ -141,7 +142,7 @@ completionTests = do
       completionType "A.x" ["A", "x"]                 `shouldBe` Qualified "A" "x"
       completionType "a.x" ["a", "x"]                 `shouldBe` Identifier "x"
       completionType "pri" ["pri"]                    `shouldBe` Identifier "pri"
-      completionType ":load A" [""]                   `shouldBe` HsFilePath "A"
+      completionType ":load A" ["A"]                   `shouldBe` HsFilePath "A"
 
     it "properly completes identifiers" $ do
        "pri!"           `completionHas` ["print"]
@@ -166,16 +167,23 @@ completionTests = do
        withHsDirectory $ \dirPath ->
          let loading xs = ":load " ++ encodeString xs
              paths xs = map encodeString xs
-             completionHas' = completionHas_ $ 
-                                      do Eval.evaluate defaultKernelState
+             completionHas' = completionHas_ fun
+             fun action = do pwd <- Eval.liftIO getCurrentDirectory
+                             Eval.evaluate defaultKernelState
                                              (":! cd " ++ dirPath)
                                              (\b d -> return ())
+                             out <- action
+                             Eval.evaluate defaultKernelState
+                                             (":! cd " ++ pwd)
+                                             (\b d -> return ())
+                             return out
          in liftIO $ do
             loading ("dir" </> "file!") `completionHas'` paths ["dir" </> "file2.hs",
                                                             "dir" </> "file2.lhs"]
             loading ("" </> "file1!") `completionHas'` paths ["" </> "file1.hs",
                                                               "" </> "file1.lhs"]
-
+            loading ("" </> "file1!") `completionHas'` paths ["" </> "file1.hs",
+                                                  "" </> "file1.lhs"]
 
 evalTests = do
   describe "Code Evaluation" $ do

src/IHaskell/Eval/Completion.hs

@@ -27,15 +27,17 @@ import GhcMonad
 import PackageConfig
 import Outputable (showPpr)
 
-import qualified System.FilePath.Find as Find (find)
-import System.FilePath.Find hiding (find)
+
 import System.Directory
-import System.FilePath.GlobPattern
 import System.FilePath
 import MonadUtils (MonadIO)
 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.Eval.Evaluate (Interpreter)
 
 
 data CompletionType
@@ -45,9 +47,10 @@ data CompletionType
      | Qualified String String
      | ModuleName String String
      | HsFilePath String
+     | FilePath String
      deriving (Show, Eq)
 
-complete :: GHC.GhcMonad m => String -> Int -> m (String, [String])
+complete :: String -> Int -> Interpreter (String, [String])
 complete line pos = do
   flags <- getSessionDynFlags
   rdrNames <- map (showPpr flags) <$> getRdrNamesInScope
@@ -89,12 +92,13 @@ complete line pos = do
                 nonames = map ("No" ++) names
             return $ filter (ext `isPrefixOf`) $ names ++ nonames
 
-          HsFilePath path -> do pwd <- liftIO getCurrentDirectory 
-                                completePath pwd (Just [".hs", ".lhs"]) path 
+          HsFilePath path -> completePathWithExtensions [".hs", ".lhs"] path
+
+          FilePath path   -> completePath path
 
   return (matchedText, options)
 
-getTrueModuleName :: GhcMonad m => String -> m String
+getTrueModuleName :: String -> Interpreter String
 getTrueModuleName name = do
   -- Only use the things that were actually imported
   let onlyImportDecl (IIDecl decl) = Just decl
@@ -115,8 +119,10 @@ getTrueModuleName name = do
 completionType :: String -> [String] -> CompletionType
 completionType line [] = Empty
 completionType line target
+  | startswith ":! " stripped
+    = FilePath complete_target
   | startswith ":l" stripped
-    = HsFilePath  $ last $ splitOn " " stripped
+    = HsFilePath complete_target
   | startswith "import" stripped && isModName
     = ModuleName dotted candidate
   | isModName && (not . null . init) target
@@ -131,6 +137,7 @@ completionType line target
         dots = intercalate "." . init
         isModName = all isCapitalized (init target)
         isCapitalized = isUpper . head
+        complete_target = intercalate "." target
 
 
 
@@ -164,32 +171,24 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
     expandCompletionPiece Nothing = []
     expandCompletionPiece (Just str) = splitOn "." str
 
-completePath :: MonadIO m => 
-                String -- ^ Current directory
-             -> Maybe [String] -- ^ list of file extensions 
-             -> String   -- ^ prefix to be completed
-             -> m [String] -- ^ completions, that is, if prefix is "Mai" one completion might be "Main.hs"
-completePath currDir exts prefix
-    = let absolutePrefix = combine currDir prefix
-          searchDir = dropFileName absolutePrefix
-          pattern = absolutePrefix ++ "*" 
-          completions = liftIO $ Find.find always (filePath ~~? pattern) searchDir 
-          allFileCompletions = completions >>= liftIO . filterM (liftM not . doesDirectoryExist)
-          fileCompletions = case exts of 
-                              Nothing -> allFileCompletions
-                              Just exts -> do xs <- allFileCompletions 
-                                              return $ filter (\s -> or [endswith ext s | ext <- exts])  xs
-          dirCompletions  = completions 
-                        >>= liftIO . filterM doesDirectoryExist 
-                        >>= \xs -> do return $ [x  ++ [pathSeparator] | x <- xs]
-          relativeCompletions = do validSearchDir <- liftIO $ doesDirectoryExist searchDir 
-                                   if validSearchDir then
-                                    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
+completePathFilter :: (String -> Bool) -- ^ filter files
+                   -> (String -> Bool) -- ^ filter directories
+                   -> String           -- ^ line contents left of cursor
+                   -> String           -- ^ line contents right of cursor
+                   -> Interpreter [String]
+completePathFilter fileFilter dirFilter loc roc =
+    do (_, comps) <- MonadIO.liftIO $ (completeFilename (reverse loc, roc))
+       let completions = map replacement comps
+       dirs <- liftIO $ filterM doesDirectoryExist completions
+       files <- liftIO $ filterM (liftM not . doesDirectoryExist) completions
+       let dirs' = filter dirFilter files
+           files' = filter fileFilter dirs
+       return $ filter (\x -> elem x $ dirs' ++ files') completions
+
+completePath :: String -> Interpreter [String]
+completePath loc = completePathFilter (const True) (const True) loc ""
+
+completePathWithExtensions :: [String] -> String -> Interpreter [String]
+completePathWithExtensions extensions loc =
+  completePathFilter (\s -> any (\x -> endswith x s) extensions) (const True) loc ""
+

src/IHaskell/Eval/Evaluate.hs

-{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings #-}
+{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances  #-}
+
 {- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
                    a statement, declaration, import, or directive.
 
@@ -29,6 +30,8 @@ import Control.Monad (guard)
 import System.Process
 import System.Exit
 import Data.Maybe (fromJust)
+import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)
+import qualified MonadUtils as MonadUtils (MonadIO, liftIO)
 
 import NameSet
 import Name
@@ -81,6 +84,9 @@ write x = when debug $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
 
 type Interpreter = Ghc
 
+instance MonadIO.MonadIO Interpreter where
+    liftIO = MonadUtils.liftIO
+
 globalImports :: [String]
 globalImports =
   [ "import IHaskell.Display"