Merge branch 'fix_111_tilde_completion' of https://github.com/edechter/IHaskell

Conflicts:
	IHaskell.cabal

IHaskell.cabal

@@ -80,7 +80,9 @@ library
                        text >=0.11,
                        mtl >= 2.1,
                        transformers,
-                       haskeline
+                       haskeline,
+                       HUnit,
+                       parsec
 
   exposed-modules: IHaskell.Display
                    IHaskell.Eval.Completion
@@ -90,6 +92,7 @@ library
                    IHaskell.Eval.Parser
                    IHaskell.Eval.Stdin
                    IHaskell.Eval.Hoogle
+                   IHaskell.Eval.ParseShell
                    IHaskell.IPython
                    IHaskell.Message.Parser
                    IHaskell.Message.UUID
@@ -114,6 +117,7 @@ executable IHaskell
              IHaskell.Eval.Parser
              IHaskell.Eval.Stdin
              IHaskell.Eval.Hoogle
+             IHaskell.Eval.ParseShell
              IHaskell.IPython
              IHaskell.Message.Parser
              IHaskell.Message.UUID
@@ -158,7 +162,9 @@ executable IHaskell
                        text >=0.11,
                        mtl >= 2.1,
                        transformers,
-                       haskeline
+                       haskeline,
+                       HUnit,
+                       parsec
 
 Test-Suite hspec
   hs-source-dirs:      src
@@ -199,7 +205,9 @@ Test-Suite hspec
                        mtl >= 2.1,
                        transformers,
                        haskeline,
-                       HUnit
+                       HUnit,
+                       setenv,
+                       parsec
 
   extensions: DoAndIfThenElse
               OverloadedStrings

src/Hspec.hs

@@ -13,6 +13,7 @@ import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir, mkdir_p,
   touchfile)
 import qualified Shelly
 import Filesystem.Path.CurrentOS (encodeString)
+import System.SetEnv (setEnv)
 import Data.String.Here
 import Data.String.Utils (strip, replace)
 import Data.Monoid
@@ -24,12 +25,13 @@ import IHaskell.Eval.Evaluate as Eval hiding (liftIO)
 import qualified IHaskell.Eval.Evaluate as Eval (liftIO)
 
 import IHaskell.Eval.Completion
+import IHaskell.Eval.ParseShell
 
 import Debug.Trace
 
 import Test.Hspec
 import Test.Hspec.HUnit
-import Test.HUnit (assertBool)
+import Test.HUnit (assertBool, assertFailure)
 
 doGhc = runGhc (Just libdir)
 
@@ -88,33 +90,38 @@ pages string expected = evaluationComparing comparison string
     comparison (results, pageOut) =
       strip pageOut `shouldBe` strip (unlines expected)
 
-completes string expected = completionTarget newString cursorloc `shouldBe` expected
-  where (newString, cursorloc) = case elemIndex '*' string of
+readCompletePrompt :: String -> (String, Int)
+-- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of
+-- @'*'@ in the input string. 
+readCompletePrompt string = case elemIndex '*' string of
           Nothing -> error "Expected cursor written as '*'."
           Just idx -> (replace "*" "" string, idx)
 
-completionEvent :: String -> [String] -> Interpreter (String, [String])
-completionEvent string expected =
+completes string expected = completionTarget newString cursorloc `shouldBe` expected
+  where (newString, cursorloc) = readCompletePrompt string
+
+completionEvent :: String -> Interpreter (String, [String])
+completionEvent string  =  do
       complete newString cursorloc
   where (newString, cursorloc) = case elemIndex '*' string of
           Nothing -> error "Expected cursor written as '*'."
           Just idx -> (replace "*" "" string, idx)      
 
-completionEventInDirectory :: String -> [String] -> IO (String, [String])
-completionEventInDirectory string expected 
-  = withHsDirectory $ completionEvent string expected
+completionEventInDirectory :: String -> IO (String, [String])
+completionEventInDirectory string  
+  = withHsDirectory $ const $ completionEvent string 
                           
 
 shouldHaveCompletionsInDirectory :: String -> [String] -> IO ()
 shouldHaveCompletionsInDirectory string expected 
-  = do (matched, completions) <- completionEventInDirectory string expected 
+  = do (matched, completions) <- completionEventInDirectory string  
        let existsInCompletion = (`elem` completions)
            unmatched = filter (not . existsInCompletion) expected
        expected `shouldBeAmong` completions
 
 completionHas string expected 
   = do (matched, completions) <- doGhc $ do initCompleter 
-                                            completionEvent string expected 
+                                            completionEvent string  
        let existsInCompletion = (`elem` completions)
            unmatched = filter (not . existsInCompletion) expected
        expected `shouldBeAmong` completions
@@ -133,7 +140,7 @@ initCompleter  = do
 
 inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory
               -> [Shelly.FilePath] -- ^ files relative to temporary directory
-              -> Interpreter a
+              -> (Shelly.FilePath -> Interpreter a)
               -> IO a
 -- | Run an Interpreter action, but first make a temporary directory 
 --   with some files and folder and cd to it.
@@ -141,7 +148,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath ->
       do cd dirPath
          mapM_ mkdir_p   dirs
          mapM_ touchfile files
-         liftIO $ doGhc $ wrap (encodeString dirPath) action 
+         liftIO $ doGhc $ wrap (encodeString dirPath) (action dirPath)
       where noPublish = const $ return ()
             cdEvent path = Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish
             wrap :: FilePath -> Interpreter a -> Interpreter a
@@ -153,7 +160,7 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath ->
                  cdEvent pwd    -- change back to the original directory
                  return out
 
-withHsDirectory :: Interpreter a  -> IO a
+withHsDirectory :: (Shelly.FilePath -> Interpreter a)  -> IO a
 withHsDirectory = inDirectory ["" </> "dir", "dir" </> "dir1"]
                     [""</> "file1.hs", "dir" </> "file2.hs",  
                      "" </> "file1.lhs", "dir" </> "file2.lhs"]
@@ -165,6 +172,7 @@ main = hspec $ do
   completionTests
 
 completionTests = do
+  parseShellTests
   describe "Completion" $ do
     it "correctly gets the completion identifier without dots" $ do
        "hello*"              `completes` ["hello"]
@@ -191,7 +199,9 @@ completionTests = do
       completionType "a.x" 3 ["a", "x"]                 `shouldBe` Identifier "x"
       completionType "pri" 3 ["pri"]                    `shouldBe` Identifier "pri"
       completionType ":load A" 7 ["A"]                   `shouldBe` HsFilePath ":load A"
-      completionType ":! cd " 6 [""]                     `shouldBe` FilePath   ":! cd "
+                                                                               "A"
+      completionType ":! cd " 6 [""]                     `shouldBe` FilePath   ":! cd " ""
+
 
 
     it "properly completes identifiers" $ do
@@ -235,6 +245,45 @@ completionTests = do
                                                                       , "" </> "file1.hs"
                                                                       , "" </> "file1.lhs"])
 
+
+    it "correctly interprets ~ as the environment HOME variable" $ 
+        let shouldHaveCompletions :: String -> [String] -> IO ()
+            shouldHaveCompletions string expected = do 
+              (matched, completions) 
+                    <- withHsDirectory $ \dirPath -> 
+                           do setHomeEvent dirPath
+                              completionEvent string 
+              let existsInCompletion = (`elem` completions)
+                  unmatched = filter (not . existsInCompletion) expected     
+              expected `shouldBeAmong` completions
+
+            setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
+        in do 
+          ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"]
+          ":! ~/*" `shouldHaveCompletions` ["~/dir/"]
+          ":load ~/*" `shouldHaveCompletions` ["~/dir/"]
+          ":l ~/*" `shouldHaveCompletions` ["~/dir/"]
+
+    let shouldHaveMatchingText :: String -> String -> IO ()
+        shouldHaveMatchingText string expected = do 
+          matchText 
+                <- withHsDirectory $ \dirPath -> 
+                       do setHomeEvent dirPath
+                          (matchText, _) <- uncurry complete (readCompletePrompt string)
+                          return matchText
+          matchText `shouldBe` expected
+
+        setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
+
+    it "generates the correct matchingText on `:! cd ~/*` " $ 
+      do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
+
+    it "generates the correct matchingText on `:load ~/*` " $ 
+      do ":load ~/*" `shouldHaveMatchingText` ("~/" :: String)
+
+    it "generates the correct matchingText on `:l ~/*` " $ 
+      do ":l ~/*" `shouldHaveMatchingText` ("~/" :: String)
+
 evalTests = do
   describe "Code Evaluation" $ do
     it "evaluates expressions" $  do
@@ -492,6 +541,27 @@ parseStringTests = describe "Parser" $ do
                           Located 4 (Expression "second")])
 
 
+
+testParseShell string expected 
+        = do describe "parseShell" $ do
+              it ("parses " ++ string ++ " correctly: \n\t" ++ show expected)  $ do
+                    string `shouldParseTo` expected
+    where shouldParseTo :: String -> [String] -> Expectation
+          shouldParseTo xs ys = fun ys (parseShell xs)
+                where fun ys (Right xs')  = xs' `shouldBe` ys
+                      fun ys (Left e)     = assertFailure $ "parseShell returned error: \n" ++ show e
+
+parseShellTests = do 
+           testParseShell "A" ["A"]
+           testParseShell ":load A" [":load", "A"]
+           testParseShell ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt" 
+                         [":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"]
+           testParseShell ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc" 
+                         [":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc" ]
+
+
+
+
 -- Useful HSpec expectations ----
 ---------------------------------
 

src/IHaskell/Eval/Completion.hs

@@ -40,6 +40,7 @@ import System.Console.Haskeline.Completion
 
 import IHaskell.Types
 import IHaskell.Eval.Evaluate (Interpreter)
+import IHaskell.Eval.ParseShell (parseShell)
 
 
 data CompletionType
@@ -48,8 +49,8 @@ data CompletionType
      | Extension String
      | Qualified String String
      | ModuleName String String
-     | HsFilePath String
-     | FilePath String
+     | HsFilePath String String
+     | FilePath   String String 
      deriving (Show, Eq)
 
 complete :: String -> Int -> Interpreter (String, [String])
@@ -66,7 +67,11 @@ complete line pos = do
       moduleNames = nub $ concatMap getNames db
 
   let target = completionTarget line pos
-      matchedText = intercalate "." target
+
+  let matchedText = case completionType line pos target of 
+        HsFilePath _ match ->  match
+        FilePath   _ match ->  match
+        otherwise       -> intercalate "." target
 
   options <-
         case completionType line pos target of
@@ -94,9 +99,9 @@ complete line pos = do
                 nonames = map ("No" ++) names
             return $ filter (ext `isPrefixOf`) $ names ++ nonames
 
-          HsFilePath path -> completePathWithExtensions [".hs", ".lhs"] path
+          HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
 
-          FilePath path   -> completePath path
+          FilePath   lineUpToCursor match  -> completePath lineUpToCursor
 
   return (matchedText, options)
 
@@ -126,9 +131,13 @@ completionType :: String            -- ^ The line on which the completion is bei
 completionType line loc target
   -- File and directory completions are special
   | startswith ":!" stripped
-    = FilePath lineUpToCursor
+    = case parseShell lineUpToCursor of 
+          Right xs -> FilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []
+          Left  _  -> Empty
   | startswith ":l" stripped
-    = HsFilePath lineUpToCursor
+    = case parseShell lineUpToCursor of 
+          Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []
+          Left  _  -> Empty
   -- Use target for other completions.
   -- If it's empty, no completion.
   | null target
@@ -149,6 +158,7 @@ completionType line loc target
         isCapitalized = isUpper . head
         lineUpToCursor = take loc line
 
+
 -- | Get the word under a given cursor location.
 completionTarget :: String -> Int -> [String]
 completionTarget code cursor = expandCompletionPiece pieceToComplete
@@ -164,8 +174,8 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
       delimPolicy = Drop
     }
 
-    isDelim :: Char -> Int -> Bool
-    isDelim char idx = char `elem` neverIdent || isSymbol char
+    isDelim :: Char -> Int -> Bool 
+    isDelim char idx = char `elem` neverIdent  || isSymbol char
 
     splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
     splitAlongCursor [] = []

src/IHaskell/Eval/ParseShell.hs

+
+-- | This module splits a shell command line into a list of strings,
+--   one for each command / filename
+module IHaskell.Eval.ParseShell (parseShell) where 
+
+import Prelude hiding (words)
+import Text.ParserCombinators.Parsec hiding (manyTill)
+import Control.Applicative hiding ((<|>), many, optional)
+
+import Debug.Trace
+
+import Test.Hspec
+import Test.Hspec.HUnit
+import Test.HUnit (assertBool, assertFailure)
+
+debug = False
+
+trace' x a = if debug then trace x a else a
+
+eol :: Parser Char
+eol = do x <- oneOf "\n\r"
+         return x
+    <?> "end of line"
+ 
+
+quote :: Parser Char 
+quote    = char '\"'
+
+manyTill :: Parser a -> Parser [a] -> Parser [a]
+-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
+manyTill p end      = do scan
+                    where
+                      scan  = do{ x <- end; return x }
+                            <|>
+                              do{ x <- p; xs <- scan; return $ x:xs }
+
+manyTill1 p end = do x <- p 
+                     xs <- manyTill p end 
+                     return $ x : xs
+
+unescapedChar :: Parser Char -> Parser String 
+unescapedChar p = try $ do x <- noneOf ['\\'] 
+                           lookAhead p
+                           return $ x : []
+
+quotedString = (trace' "in quotedString") 
+               (do quote <?> "expected starting quote"
+                   manyTill anyChar end <* quote)
+            <?> "unexpected in quoted String "
+        where end = unescapedChar quote
+
+unquotedString = (trace' "in unquotedString") 
+                 manyTill1 anyChar end  
+        where end = unescapedChar space 
+                <|> do x <- lookAhead eol 
+                       return []
+
+word = quotedString <|> unquotedString <?> "word"
+
+separator :: Parser String
+separator = many1 space <?> "separator"
+
+words :: Parser [String ]
+-- | Input must terminate in a space character (like a \n)
+words = try (eof *> return []) <|>
+        do x <-  word 
+           rest1 <- trace' ("word: " ++ show x) lookAhead (many anyToken)
+           ss <- trace' ("rest1: " ++ show rest1) separator 
+           rest2 <- trace' ("spaces: " ++ show ss) lookAhead (many anyToken)
+           xs <- trace' ("rest2: " ++ show rest2) words 
+           return $ x : xs 
+
+parseShell :: String -> Either ParseError [String]
+parseShell string = parse words "shell" (string ++ "\n")
+
+