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,10 +75,10 @@ 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
-      complete newString cursorloc
+      wrap $ do initCompleter
+                complete newString cursorloc
     let existsInCompletion = (`elem` completions)
         unmatched = filter (not . existsInCompletion) expected
     unmatched `shouldBe` []
@@ -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
-                                     (":! cd " ++ dirPath)
-                                     (\b d -> return ())
+             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"]
-
+                                                              "" </> "file1.lhs"]
+            loading ("" </> "file1!") `completionHas'` paths ["" </> "file1.hs",
+                                                  "" </> "file1.lhs"]
 
 evalTests = do
   describe "Code Evaluation" $ do

src/IHaskell/Eval/Completion.hs

@@ -27,27 +27,30 @@ 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 
-     = Empty 
+data CompletionType
+     = Empty
      | Identifier String
      | Extension String
      | Qualified String String
      | ModuleName String String
-     | HsFilePath 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
@@ -63,7 +66,7 @@ complete line pos = do
   let target = completionTarget line pos
       matchedText = intercalate "." target
 
-  options <- 
+  options <-
         case completionType line target of
           Empty -> return []
 
@@ -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
@@ -109,20 +113,22 @@ getTrueModuleName name = do
   let qualifiedImports = filter (isJust . ideclAs) imports
       hasName imp = name == (showPpr flags . fromJust . ideclAs) imp
   case find hasName qualifiedImports of
-    Nothing -> return name  
+    Nothing -> return name
     Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp
 
 completionType :: String -> [String] -> CompletionType
 completionType line [] = Empty
 completionType line target
-  | startswith ":l" stripped 
-    = HsFilePath  $ last $ splitOn " " stripped
+  | startswith ":! " stripped
+    = FilePath complete_target
+  | startswith ":l" stripped
+    = HsFilePath complete_target
   | startswith "import" stripped && isModName
     = ModuleName dotted candidate
   | isModName && (not . null . init) target
     = Qualified dotted candidate
   | startswith ":e" stripped
-    = Extension candidate 
+    = Extension candidate
   | otherwise
     = Identifier candidate
   where stripped = strip line
@@ -131,13 +137,14 @@ completionType line target
         dots = intercalate "." . init
         isModName = all isCapitalized (init target)
         isCapitalized = isUpper . head
+        complete_target = intercalate "." target
 
 
 
 -- | Get the word under a given cursor location.
 completionTarget :: String -> Int -> [String]
 completionTarget code cursor = expandCompletionPiece pieceToComplete
-  where 
+  where
     pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
     pieces = splitAlongCursor $ split splitter $ zip code [1 .. ]
     splitter = defaultSplitter {
@@ -153,7 +160,7 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
 
     splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
     splitAlongCursor [] = []
-    splitAlongCursor (x:xs) = 
+    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
@@ -162,34 +169,26 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
     neverIdent = " \n\t(),{}[]\\'\"`"
 
     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
+    expandCompletionPiece (Just str) = splitOn "." str
+
+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"
@@ -406,8 +412,8 @@ evalCommand _ (Directive SetOpt option) state = do
 
     setOpt _ _ = Nothing
 
-evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $ 
-  case words cmd of 
+evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $
+  case words cmd of
     "cd":dirs ->
       let directory = unwords dirs in do
         setCurrentDirectory directory
@@ -423,13 +429,13 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
             std_err = UseHandle handle
           }
       (_, _, _, process) <- createProcess procSpec
-          
+
       -- Accumulate output from the process.
       outputAccum <- liftIO $ newMVar ""
 
       -- Start a loop to publish intermediate results.
-      let 
-        -- Compute how long to wait between reading pieces of the output. 
+      let
+        -- Compute how long to wait between reading pieces of the output.
         -- `threadDelay` takes an argument of microseconds.
         ms = 1000
         delay = 100 * ms
@@ -458,7 +464,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
           if not computationDone
           then do
             -- Write to frontend and repeat.
-            readMVar outputAccum >>= output 
+            readMVar outputAccum >>= output
             loop
           else do
             out <- readMVar outputAccum
@@ -471,7 +477,7 @@ evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $
                         html $ printf "<span class='mono'>%s</span>" out ++ htmlErr]
 
       loop
-      
+
 
 -- This is taken largely from GHCi's info section in InteractiveUI.
 evalCommand _ (Directive GetHelp _) state = do
@@ -688,7 +694,7 @@ evalCommand _ (Declaration decl) state = wrapExecution state $ do
   names <- runDecls decl
 
   dflags <- getSessionDynFlags
-  let boundNames = map (replace ":Interactive." "" . showPpr dflags) names  
+  let boundNames = map (replace ":Interactive." "" . showPpr dflags) names
       nonDataNames = filter (not . isUpper . head) boundNames
 
   -- Display the types of all bound names if the option is on.
@@ -982,7 +988,7 @@ formatType :: String -> [DisplayData]
 formatType typeStr =  [plain typeStr, html $ formatGetType typeStr]
 
 displayError :: ErrMsg -> [DisplayData]
-displayError msg = [plain . fixStdinError . typeCleaner $ msg, html $ formatError msg] 
+displayError msg = [plain . fixStdinError . typeCleaner $ msg, html $ formatError msg]
 
 fixStdinError :: ErrMsg -> ErrMsg
 fixStdinError err =