Merge pull request #83 from edechter/path_completion

Added path completion on :load directive.

IHaskell.cabal

@@ -73,6 +73,8 @@ library
                        directory,
                        here,
                        system-filepath,
+                       filemanip,
+                       filepath,
                        cereal ==0.3.*,
                        text >=0.11,
                        mtl >= 2.1
@@ -143,11 +145,14 @@ executable IHaskell
                        directory,
                        here,
                        system-filepath,
+                       filemanip,
+                       filepath,
                        cereal ==0.3.*,
                        text >=0.11,
                        mtl >= 2.1
 
 Test-Suite hspec
+  hs-source-dirs:      src
   Type:     exitcode-stdio-1.0
   Ghc-Options: -threaded
   Main-Is: Hspec.hs
@@ -177,9 +182,13 @@ Test-Suite hspec
                        directory,
                        here,
                        system-filepath,
+                       filepath,
                        cereal ==0.3.*,
                        text >=0.11,
                        mtl >= 2.1
+  extensions: DoAndIfThenElse
+              OverloadedStrings
+              ExtendedDefaultRules
 
 source-repository head
   type:     git

src/Hspec.hs

@@ -5,8 +5,11 @@ import GHC
 import GHC.Paths
 import Data.IORef
 import Control.Monad
+import Control.Monad.Trans ( MonadIO, liftIO )
 import Data.List
 import System.Directory
+import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir)
+import Filesystem.Path.CurrentOS (encodeString)
 import Data.String.Here
 import Data.String.Utils (strip, replace)
 import Data.Monoid
@@ -14,9 +17,13 @@ import Data.Monoid
 import IHaskell.Eval.Parser
 import IHaskell.Types
 import IHaskell.IPython
-import IHaskell.Eval.Evaluate as Eval
+import IHaskell.Eval.Evaluate as Eval hiding (liftIO)
+import qualified IHaskell.Eval.Evaluate as Eval (liftIO)
+
 import IHaskell.Eval.Completion
 
+import Debug.Trace
+
 import Test.Hspec
 import Test.Hspec.HUnit
 
@@ -49,7 +56,7 @@ becomes string expected = do
         minIndent = minimum (map indent stringLines)
         newString = unlines $ map (drop minIndent) stringLines
     eval newString >>= comparison
-  where 
+  where
     comparison results = do
       when (length results /= length expected) $
         expectationFailure $ "Expected result to have " ++ show (length expected)
@@ -68,28 +75,39 @@ completes string expected = completionTarget newString cursorloc `shouldBe` expe
           Nothing -> error "Expected cursor written as '!'."
           Just idx -> (replace "!" "" string, idx)
 
-completionHas string expected = do
+completionHas_ action string expected = do
     (matched, completions) <- doGhc $ do
-      initCompleter
+      initCompleter action
       complete newString cursorloc
-    let existsInCompletion =  (`elem` completions)
+    let existsInCompletion = (`elem` completions)
         unmatched = filter (not . existsInCompletion) expected
     unmatched `shouldBe` []
   where (newString, cursorloc) = case elemIndex '!' string of
           Nothing -> error "Expected cursor written as '!'."
           Just idx -> (replace "!" "" string, idx)
 
-initCompleter :: GhcMonad m => m ()
-initCompleter = do
+completionHas = completionHas_ (return ())
+
+initCompleter :: GhcMonad m => m a -> m a
+initCompleter action = do
   flags <- getSessionDynFlags
   setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }
 
   -- Import modules.
   imports <- mapM parseImportDecl ["import Prelude",
-                                  "import qualified Control.Monad",
-                                  "import qualified Data.List as List",
-                                  "import Data.Maybe as Maybe"]
+                                   "import qualified Control.Monad",
+                                   "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 ->
+      do cd dirPath
+         cmd "mkdir"  $ "" </> "dir"
+         cmd "mkdir"  $ "dir" </> "dir1"
+         cmd "touch" "file1.hs"  "dir/file2.hs" "file1.lhs" "dir/file2.lhs"
+         f $ encodeString dirPath
 
 main :: IO ()
 main = hspec $ do
@@ -123,6 +141,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"
 
     it "properly completes identifiers" $ do
        "pri!"           `completionHas` ["print"]
@@ -143,6 +162,21 @@ completionTests = do
       "import Data.M!" `completionHas` ["Data.Maybe"]
       "import Prel!"   `completionHas` ["Prelude"]
 
+    it "properly completes haskell file paths on :load directive" $
+       withHsDirectory $ \dirPath ->
+         let loading xs = ":load " ++ encodeString xs
+             paths xs = map encodeString xs
+             completionHas' = completionHas_ $ 
+                                      do Eval.evaluate defaultKernelState
+                                     (":! cd " ++ dirPath)
+                                     (\b d -> return ())
+         in liftIO $ do
+            loading ("dir" </> "file!") `completionHas'` paths ["dir" </> "file2.hs",
+                                                            "dir" </> "file2.lhs"]
+            loading ("" </> "file1!") `completionHas'` paths ["" </> "file1.hs",
+                                                      "" </> "file1.lhs"]
+
+
 evalTests = do
   describe "Code Evaluation" $ do
     it "evaluates expressions" $  do
@@ -283,7 +317,7 @@ parseStringTests = describe "Parser" $ do
       Directive SetExtension "x"
     ]
 
-  it "fails to parse :nope" $ 
+  it "fails to parse :nope" $
     parses ":nope goodbye" `like` [
       ParseError (Loc 1 1) "Unknown directive: 'nope'."
     ]
@@ -365,13 +399,13 @@ parseStringTests = describe "Parser" $ do
   it "parses statements after imports" $ do
     parses "import X\nprint 3" `like` [
         Import "import X",
-        Expression "print 3" 
+        Expression "print 3"
       ]
     parses "import X\n\nprint 3" `like` [
         Import "import X",
-        Expression "print 3" 
+        Expression "print 3"
       ]
-  it "ignores blank lines properly" $ 
+  it "ignores blank lines properly" $
     [hereLit|
       test arg = hello
         where
@@ -398,4 +432,3 @@ parseStringTests = describe "Parser" $ do
         second
        |] >>= (`shouldBe` [Located 2 (Expression "first"),
                           Located 4 (Expression "second")])
-    

src/IHaskell/Eval/Completion.hs

@@ -18,7 +18,7 @@ import Data.List (find, isPrefixOf, nub, findIndex, intercalate, elemIndex)
 import Data.List.Split
 import Data.List.Split.Internals
 import Data.Maybe
-import Data.String.Utils (strip, startswith, replace)
+import Data.String.Utils (strip, startswith, endswith, replace)
 import Prelude
 
 import GHC
@@ -27,6 +27,14 @@ 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 IHaskell.Types
 
 
@@ -36,6 +44,7 @@ data CompletionType
      | Extension String
      | Qualified String String
      | ModuleName String String
+     | HsFilePath String 
      deriving (Show, Eq)
 
 complete :: GHC.GhcMonad m => String -> Int -> m (String, [String])
@@ -80,6 +89,9 @@ 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 
+
   return (matchedText, options)
 
 getTrueModuleName :: GhcMonad m => String -> m String
@@ -103,6 +115,8 @@ getTrueModuleName name = do
 completionType :: String -> [String] -> CompletionType
 completionType line [] = Empty
 completionType line target
+  | startswith ":l" stripped 
+    = HsFilePath  $ last $ splitOn " " stripped
   | startswith "import" stripped && isModName
     = ModuleName dotted candidate
   | isModName && (not . null . init) target
@@ -119,6 +133,7 @@ completionType line target
         isCapitalized = isUpper . head
 
 
+
 -- | Get the word under a given cursor location.
 completionTarget :: String -> Int -> [String]
 completionTarget code cursor = expandCompletionPiece pieceToComplete
@@ -148,3 +163,33 @@ 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
\ No newline at end of file

src/IHaskell/Eval/Evaluate.hs

@@ -20,6 +20,7 @@ import Data.Dynamic
 import Data.Typeable
 import qualified Data.Serialize as Serialize
 import System.Directory
+import Filesystem.Path.CurrentOS (encodeString)
 import System.Posix.IO
 import System.IO (hGetChar, hFlush)
 import System.Random (getStdGen, randomRs)
@@ -81,7 +82,7 @@ write x = when debug $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
 type Interpreter = Ghc
 
 globalImports :: [String]
-globalImports = 
+globalImports =
   [ "import IHaskell.Display"
   , "import qualified IHaskell.Eval.Stdin"
   , "import Control.Applicative ((<$>))"
@@ -91,6 +92,8 @@ globalImports =
   , "import System.IO"
   ]
 
+
+
 -- | Run an interpreting action. This is effectively runGhc with
 -- initialization and importing.
 interpret :: Interpreter a -> IO a
@@ -152,7 +155,7 @@ initializeImports = do
   let capitalize :: String -> String
       capitalize (first:rest) = Char.toUpper first : rest
 
-      importFmt = "import IHaskell.Display.%s" 
+      importFmt = "import IHaskell.Display.%s"
 
       toImportStmt :: String -> String
       toImportStmt = printf importFmt . capitalize . (!! 1) . split "-"
@@ -207,7 +210,7 @@ evaluate kernelState code output = do
   where
     runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter KernelState
     runUntilFailure state [] = return state
-    runUntilFailure state (cmd:rest) = do 
+    runUntilFailure state (cmd:rest) = do
       evalOut <- evalCommand output cmd state
 
       -- Output things only if they are non-empty.
@@ -231,7 +234,7 @@ wrapExecution state exec = ghandle handler $ exec >>= \res ->
       evalResult = res,
       evalState = state
     }
-  where 
+  where
     handler :: SomeException -> Interpreter EvalOut
     handler exception =
       return EvalOut {
@@ -290,7 +293,7 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
       -- trying to load. If a module B exist, we cannot load A.B. All
       -- modules must have unique last names (where A.B has last name B).
       -- However, we *can* just reload a module.
-      preventsLoading mod = 
+      preventsLoading mod =
         let pieces = moduleNameOf mod in
             last namePieces == last pieces && namePieces /= pieces
 
@@ -324,7 +327,7 @@ evalCommand _ (Directive SetExtension exts) state = wrapExecution state $ do
               Just (_, flag, _) -> Just $ xopt_set flags flag
               -- If it doesn't match an extension name, try matching against
               -- disabling an extension.
-              Nothing -> 
+              Nothing ->
                 case find (flagMatchesNo ext) xFlags of
                   Just (_, flag, _) -> Just $ xopt_unset flags flag
                   Nothing -> Nothing
@@ -378,7 +381,7 @@ evalCommand _ (Directive SetOpt option) state = do
     evalState = fromMaybe state newState
   }
 
-  where 
+  where
     setOpt :: String -> KernelState -> Maybe KernelState
 
     setOpt "lint" state = Just $
@@ -513,7 +516,7 @@ evalCommand _ (Directive GetInfo str) state = wrapExecution state $ do
       filteredOutput = filter (not . hasParent) infos
 
   -- Convert to textual data.
-  let printInfo (thing, fixity, classInstances) = 
+  let printInfo (thing, fixity, classInstances) =
         pprTyThingInContextLoc False thing $$ showFixity fixity $$ vcat (map GHC.pprInstance classInstances)
         where
           showFixity fixity =
@@ -536,7 +539,7 @@ evalCommand output (Statement stmt) state = wrapExecution state $ do
     RunOk names -> do
       dflags <- getSessionDynFlags
 
-      let allNames = map (showPpr dflags) names  
+      let allNames = map (showPpr dflags) names
           isItName name =
             name == "it" ||
             name == "it" ++ show (getExecutionCounter state)
@@ -580,7 +583,7 @@ evalCommand output (Expression expr) state = do
   -- DisplayData. If typechecking fails and there is no appropriate
   -- typeclass instance, this will throw an exception and thus `attempt` will
   -- return False, and we just resort to plaintext.
-  let displayExpr = printf "(IHaskell.Display.display (%s))" expr
+  let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String
   canRunDisplay <- attempt $ exprType displayExpr
   let out = evalResult evalOut
       showErr = isShowError out
@@ -614,7 +617,7 @@ evalCommand output (Expression expr) state = do
     -- Check if the error is due to trying to print something that doesn't
     -- implement the Show typeclass.
     isShowError errs = case find isPlain errs of
-      Just (Display PlainText msg) -> 
+      Just (Display PlainText msg) ->
         -- Note that we rely on this error message being 'type cleaned', so
         -- that `Show` is not displayed as GHC.Show.Show.
         startswith "No instance for (Show" msg &&
@@ -655,7 +658,7 @@ evalCommand output (Expression expr) state = do
         Just (Display PlainText text) = find isPlain disps
 
         postprocess (Display MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script
-          where 
+          where
             fmt = "<div class='collapse-group'><span class='btn' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"
             script = unlines [
                 "$('#unshowable').on('click', function(e) {",
@@ -740,7 +743,7 @@ readChars handle delims nchars = do
 
 doLoadModule :: String -> String -> Ghc [DisplayData]
 doLoadModule name modName = flip gcatch unload $ do
-  -- Compile loaded modules. 
+  -- Compile loaded modules.
   flags <- getSessionDynFlags
   let objTarget = defaultObjectTarget
   setSessionDynFlags flags{ hscTarget = objTarget }
@@ -789,7 +792,7 @@ capturedStatement output stmt = do
     -- Variable names generation.
     rand = take 20 $ randomRs ('0', '9') gen
     var name = name ++ rand
-    
+
     -- Variables for the pipe input and outputs.
     readVariable = var "file_read_var_"
     writeVariable = var "file_write_var_"
@@ -801,9 +804,9 @@ capturedStatement output stmt = do
     itVariable = var "it_var_"
 
     voidpf str = printf $ str ++ " >> return ()"
-    
+
     -- Statements run before the thing we're evaluating.
-    initStmts = 
+    initStmts =
       [ printf "let %s = it" itVariable
       , printf "(%s, %s) <- createPipe" readVariable writeVariable
       , printf "%s <- dup stdOutput" oldVariable
@@ -811,9 +814,9 @@ capturedStatement output stmt = do
       , voidpf "hSetBuffering stdout NoBuffering"
       , printf "let it = %s" itVariable
       ]
-    
+
     -- Statements run after evaluation.
-    postStmts = 
+    postStmts =
       [ printf "let %s = it" itVariable
       , voidpf "hFlush stdout"
       , voidpf "dupTo %s stdOutput" oldVariable
@@ -842,14 +845,38 @@ capturedStatement output stmt = do
     fd <- head <$> unsafeCoerce hValues
     fdToHandle fd
 
+  -- Read from a file handle until we hit a delimiter or until we've read
+  -- as many characters as requested
+  let
+    readChars :: Handle -> String -> Int -> IO String
+
+    -- If we're done reading, return nothing.
+    readChars handle delims 0 = return []
+
+    readChars handle delims nchars = do
+      -- Try reading a single character. It will throw an exception if the
+      -- handle is already closed.
+      tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)
+      case tryRead of
+        Right char ->
+          -- If this is a delimiter, stop reading.
+          if char `elem` delims
+          then return [char]
+          else do
+            next <- readChars handle delims (nchars - 1)
+            return $ char:next
+        -- An error occurs at the end of the stream, so just stop reading.
+        Left _ -> return []
+
+
   -- Keep track of whether execution has completed.
   completed <- liftIO $ newMVar False
   finishedReading <- liftIO newEmptyMVar
   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
@@ -895,7 +922,7 @@ capturedStatement output stmt = do
     -- Wait for reading to finish to that the output accumulator is
     -- completely filled.
     liftIO $ takeMVar finishedReading
-    
+
   printedOutput <- liftIO $ readMVar outputAccum
   return (printedOutput, result)
 
@@ -905,13 +932,13 @@ formatError = formatErrorWithClass "err-msg"
 formatErrorWithClass :: String -> ErrMsg -> String
 formatErrorWithClass cls =
     printf "<span class='%s'>%s</span>" cls .
-    replace "\n" "<br/>" . 
+    replace "\n" "<br/>" .
     fixLineWrapping .
     fixStdinError .
     replace useDashV "" .
-    rstrip . 
+    rstrip .
     typeCleaner
-  where 
+  where
     useDashV = "\nUse -v to see a list of the files searched for."
     fixLineWrapping err
       | isThreePartTypeError err =
@@ -925,7 +952,7 @@ formatErrorWithClass cls =
           let (one, arising:possibleFix:two) = break ("arising" `isInfixOf`)  $ lines err in
             unlines $ map unstripped [one, [arising], [possibleFix], two]
       | otherwise = err
-      where 
+      where
         unstripped (line:lines) = unwords $ line:map lstrip lines
 
     isThreePartTypeError err = all (`isInfixOf` err) [
@@ -939,13 +966,13 @@ formatErrorWithClass cls =
       "with actual type"
       ]
 
-    isShowError err = 
+    isShowError err =
       startswith "No instance for (Show" err &&
       isInfixOf " arising from a use of `print'" err
 
 
 formatParseError :: StringLoc -> String -> ErrMsg
-formatParseError (Loc line col) = 
+formatParseError (Loc line col) =
   printf "Parse error (line %d, column %d): %s" line col
 
 formatGetType :: String -> String