Added a parser for shell command line parsing that takes care of escaped...

Added a parser for shell command line parsing that takes care of escaped whitespace and quotations. Addressed notes #116.

IHaskell.cabal

@@ -79,7 +79,9 @@ library
                        text >=0.11,
                        mtl >= 2.1,
                        transformers,
-                       haskeline
+                       haskeline,
+                       HUnit,
+                       parsec
 
   exposed-modules: IHaskell.Display
                    IHaskell.Eval.Completion
@@ -88,6 +90,7 @@ library
                    IHaskell.Eval.Lint
                    IHaskell.Eval.Parser
                    IHaskell.Eval.Stdin
+                   IHaskell.Eval.ParseShell
                    IHaskell.IPython
                    IHaskell.Message.Parser
                    IHaskell.Message.UUID
@@ -111,6 +114,7 @@ executable IHaskell
              IHaskell.Eval.Evaluate
              IHaskell.Eval.Parser
              IHaskell.Eval.Stdin
+             IHaskell.Eval.ParseShell
              IHaskell.IPython
              IHaskell.Message.Parser
              IHaskell.Message.UUID
@@ -154,7 +158,9 @@ executable IHaskell
                        text >=0.11,
                        mtl >= 2.1,
                        transformers,
-                       haskeline
+                       haskeline,
+                       HUnit,
+                       parsec
 
 Test-Suite hspec
   hs-source-dirs:      src
@@ -195,7 +201,8 @@ Test-Suite hspec
                        transformers,
                        haskeline,
                        HUnit,
-                       setenv
+                       setenv,
+                       parsec
 
   extensions: DoAndIfThenElse
               OverloadedStrings

src/Hspec.hs

@@ -24,12 +24,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)
 
@@ -74,33 +75,38 @@ becomes string expected = do
           Just (Display PlainText str) -> str `shouldBe` expected
           Nothing -> expectationFailure $ "No plain-text output in " ++ show result
 
-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 =  do
+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 $ const $ 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
@@ -151,6 +157,7 @@ main = hspec $ do
   completionTests
 
 completionTests = do
+  parseShellTests
   describe "Completion" $ do
     it "correctly gets the completion identifier without dots" $ do
        "hello*"              `completes` ["hello"]
@@ -177,7 +184,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
@@ -228,7 +237,7 @@ completionTests = do
               (matched, completions) 
                     <- withHsDirectory $ \dirPath -> 
                            do setHomeEvent dirPath
-                              completionEvent string expected
+                              completionEvent string 
               let existsInCompletion = (`elem` completions)
                   unmatched = filter (not . existsInCompletion) expected     
               expected `shouldBeAmong` completions
@@ -236,6 +245,29 @@ completionTests = do
             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
@@ -494,6 +526,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])
@@ -68,8 +69,8 @@ complete line pos = do
   let target = completionTarget line pos
 
   let matchedText = case completionType line pos target of 
-        HsFilePath lineUpToCursor -> last . words $ lineUpToCursor 
-        FilePath   lineUpToCursor -> last . words $ lineUpToCursor 
+        HsFilePath _ match ->  match
+        FilePath   _ match ->  match
         otherwise       -> intercalate "." target
 
   options <-
@@ -98,9 +99,9 @@ complete line pos = do
                 nonames = map ("No" ++) names
             return $ filter (ext `isPrefixOf`) $ names ++ nonames
 
-          HsFilePath lineUpToCursor -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
+          HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor
 
-          FilePath lineUpToCursor   -> completePath lineUpToCursor
+          FilePath   lineUpToCursor match  -> completePath lineUpToCursor
 
   return (matchedText, options)
 
@@ -130,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
@@ -153,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
@@ -169,10 +175,8 @@ completionTarget code cursor = expandCompletionPiece pieceToComplete
     }
 
     isDelim :: Char -> Int -> Bool
-    isDelim char idx = char `elem` neverIdent || isSymbol' char
-      where isSymbol' char = isSymbol char && not (char =='~')  -- we don't want to
-                                                                -- delimit on on ~
-                                                                 -- because of paths
+    isDelim char idx = char `elem` neverIdent 
+
     splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]
     splitAlongCursor [] = []
     splitAlongCursor (x:xs) =

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")
+
+