diff --git a/IHaskell.cabal b/IHaskell.cabal index 030192b5..2fec4006 100644 --- a/IHaskell.cabal +++ b/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 diff --git a/src/Hspec.hs b/src/Hspec.hs index f084e5d5..a551d99f 100644 --- a/src/Hspec.hs +++ b/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 ---- --------------------------------- diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index 87ab294a..89455f0d 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/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) = diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs new file mode 100644 index 00000000..f910d32e --- /dev/null +++ b/src/IHaskell/Eval/ParseShell.hs @@ -0,0 +1,76 @@ + +-- | 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") + +