diff --git a/ihaskell.cabal b/ihaskell.cabal index 605ecc78..b5ea06bc 100644 --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -164,6 +164,11 @@ Test-Suite hspec Ghc-Options: -threaded Main-Is: Hspec.hs hs-source-dirs: src/tests + other-modules: + IHaskell.Test.Eval + IHaskell.Test.Completion + IHaskell.Test.Util + IHaskell.Test.Parser default-language: Haskell2010 build-depends: base, diff --git a/src/tests/Hspec.hs b/src/tests/Hspec.hs index f775bfdf..38b58169 100644 --- a/src/tests/Hspec.hs +++ b/src/tests/Hspec.hs @@ -1,610 +1,16 @@ -{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules, CPP #-} - --- Keep all the language pragmas here so it can be compiled separately. module Main where import Prelude -import qualified Data.Text as T -import GHC hiding (Qualified) -import GHC.Paths -import Data.IORef -import Control.Monad -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.List -import System.Directory -import Shelly (Sh, shelly, cmd, (), toTextIgnore, cd, withTmpDir, mkdir_p, touchfile, - fromText) -import qualified Data.Text as T -import qualified Shelly -import Control.Applicative ((<$>)) -import System.SetEnv (setEnv) -import Data.String.Here -import Data.Monoid - -import IHaskell.Eval.Parser -import IHaskell.Types -import IHaskell.IPython -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, assertFailure) -lstrip :: String -> String -lstrip = dropWhile (`elem` (" \t\r\n" :: String)) - -rstrip :: String -> String -rstrip = reverse . lstrip . reverse - -strip :: String -> String -strip = rstrip . lstrip - -replace :: String -> String -> String -> String -replace needle replacement haystack = - T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack) - -traceShowId x = traceShow x x - -doGhc = runGhc (Just libdir) - -parses str = do - res <- doGhc $ parseString str - return $ map unloc res - -like parser desired = parser >>= (`shouldBe` desired) - -is string blockType = do - result <- doGhc $ parseString string - map unloc result `shouldBe` [blockType $ strip string] - -eval string = do - outputAccum <- newIORef [] - pagerAccum <- newIORef [] - let publish evalResult = - case evalResult of - IntermediateResult{} -> return () - FinalResult outs page [] -> do - modifyIORef outputAccum (outs :) - modifyIORef pagerAccum (page :) - noWidgetHandling s _ = return s - - getTemporaryDirectory >>= setCurrentDirectory - let state = defaultKernelState { getLintStatus = LintOff } - interpret libdir False $ const $ Eval.evaluate state string publish noWidgetHandling - out <- readIORef outputAccum - pagerOut <- readIORef pagerAccum - return (reverse out, unlines . map extractPlain . reverse $ pagerOut) - -evaluationComparing comparison string = do - let indent (' ':x) = 1 + indent x - indent _ = 0 - empty = null . strip - stringLines = filter (not . empty) $ lines string - minIndent = minimum (map indent stringLines) - newString = unlines $ map (drop minIndent) stringLines - eval newString >>= comparison - -becomes string expected = evaluationComparing comparison string - where - comparison :: ([Display], String) -> IO () - comparison (results, pageOut) = do - when (length results /= length expected) $ - expectationFailure $ "Expected result to have " ++ show (length expected) - ++ " results. Got " ++ show results - - forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of - "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected - str -> str `shouldBe` expected - -pages string expected = evaluationComparing comparison string - where - comparison (results, pageOut) = - strip (stripHtml pageOut) `shouldBe` strip (unlines expected) - - -- A very, very hacky method for removing HTML - stripHtml str = go str - where - go ('<':str) = - case stripPrefix "script" str of - Nothing -> go' str - Just str -> dropScriptTag str - go (x:xs) = x : go xs - go [] = [] - - go' ('>':str) = go str - go' (x:xs) = go' xs - go' [] = error $ "Unending bracket html tag in string " ++ str - - dropScriptTag str = - case stripPrefix "" str of - Just str -> go str - Nothing -> dropScriptTag $ tail str - -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) - -completes string expected = completionTarget newString cursorloc `shouldBe` expected - where - (newString, cursorloc) = readCompletePrompt string - -completionEvent :: String -> Interpreter (String, [String]) -completionEvent string = complete newString cursorloc - where - (newString, cursorloc) = - case elemIndex '*' string of - Nothing -> error "Expected cursor written as '*'." - Just idx -> (replace "*" "" string, idx) - -completionEventInDirectory :: String -> IO (String, [String]) -completionEventInDirectory string = withHsDirectory $ const $ completionEvent string - -shouldHaveCompletionsInDirectory :: String -> [String] -> IO () -shouldHaveCompletionsInDirectory 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 - let existsInCompletion = (`elem` completions) - unmatched = filter (not . existsInCompletion) expected - expected `shouldBeAmong` completions - -initCompleter :: Interpreter () -initCompleter = 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 IHaskell.Display" - , "import Data.Maybe as Maybe" - ] - setContext $ map IIDecl imports - -inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory - -> [Shelly.FilePath] -- ^ files relative to temporary directory - -> (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. -inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do - cd dirPath - mapM_ mkdir_p dirs - mapM_ touchfile files - liftIO $ doGhc $ wrap (T.unpack $ toTextIgnore dirPath) (action dirPath) - where - cdEvent path = liftIO $ setCurrentDirectory path - wrap :: FilePath -> Interpreter a -> Interpreter a - wrap path action = - do - initCompleter - pwd <- Eval.liftIO getCurrentDirectory - cdEvent path -- change to the temporary directory - out <- action -- run action - cdEvent pwd -- change back to the original directory - return out - -withHsDirectory :: (Shelly.FilePath -> Interpreter a) -> IO a -withHsDirectory = inDirectory [p "" p "dir", p "dir" p "dir1"] - [ p "" p "file1.hs" - , p "dir" p "file2.hs" - , p "" p "file1.lhs" - , p "dir" p "file2.lhs" - ] - where - p :: FilePath -> FilePath - p = id +import IHaskell.Test.Completion (testCompletions) +import IHaskell.Test.Parser (testParser) +import IHaskell.Test.Eval (testEval) main :: IO () -main = hspec $ do - parserTests - evalTests - completionTests - -completionTests = do - parseShellTests - describe "Completion" $ do - it "correctly gets the completion identifier without dots" $ do - "hello*" `completes` ["hello"] - "hello aa*bb goodbye" `completes` ["aa"] - "hello aabb* goodbye" `completes` ["aabb"] - "aacc* goodbye" `completes` ["aacc"] - "hello *aabb goodbye" `completes` [] - "*aabb goodbye" `completes` [] - - it "correctly gets the completion identifier with dots" $ do - "hello test.aa*bb goodbye" `completes` ["test", "aa"] - "Test.*" `completes` ["Test", ""] - "Test.Thing*" `completes` ["Test", "Thing"] - "Test.Thing.*" `completes` ["Test", "Thing", ""] - "Test.Thing.*nope" `completes` ["Test", "Thing", ""] - - it "correctly gets the completion type" $ do - completionType "import Data." 12 ["Data", ""] `shouldBe` ModuleName "Data" "" - completionType "import Prel" 11 ["Prel"] `shouldBe` ModuleName "" "Prel" - completionType "import D.B.M" 12 ["D", "B", "M"] `shouldBe` ModuleName "D.B" "M" - completionType " import A." 10 ["A", ""] `shouldBe` ModuleName "A" "" - completionType "import a.x" 10 ["a", "x"] `shouldBe` Identifier "x" - completionType "A.x" 3 ["A", "x"] `shouldBe` Qualified "A" "x" - 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" "A" - completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " "" - - - - it "properly completes identifiers" $ do - "pri*" `completionHas` ["print"] - "ma*" `completionHas` ["map"] - "hello ma*" `completionHas` ["map"] - "print $ catMa*" `completionHas` ["catMaybes"] - - it "properly completes qualified identifiers" $ do - "Control.Monad.liftM*" `completionHas` [ "Control.Monad.liftM" - , "Control.Monad.liftM2" - , "Control.Monad.liftM5" - ] - "print $ List.intercal*" `completionHas` ["List.intercalate"] - "print $ Data.Maybe.cat*" `completionHas` [] - "print $ Maybe.catM*" `completionHas` ["Maybe.catMaybes"] - - it "properly completes imports" $ do - "import Data.*" `completionHas` ["Data.Maybe", "Data.List"] - "import Data.M*" `completionHas` ["Data.Maybe"] - "import Prel*" `completionHas` ["Prelude"] - - it "properly completes haskell file paths on :load directive" $ - let loading xs = ":load " ++ T.unpack (toTextIgnore xs) - paths = map (T.unpack . toTextIgnore) - in do - loading ("dir" "file*") `shouldHaveCompletionsInDirectory` paths - [ "dir" "file2.hs" - , "dir" "file2.lhs" - ] - loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths - [ "" "file1.hs" - , "" "file1.lhs" - ] - loading ("" "file1*") `shouldHaveCompletionsInDirectory` paths - [ "" "file1.hs" - , "" "file1.lhs" - ] - loading ("" "./*") `shouldHaveCompletionsInDirectory` paths - [ "./" "dir/" - , "./" "file1.hs" - , "./" "file1.lhs" - ] - loading ("" "./*") `shouldHaveCompletionsInDirectory` paths - [ "./" "dir/" - , "./" "file1.hs" - , "./" "file1.lhs" - ] - - it "provides path completions on empty shell cmds " $ - ":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore) - [ "" "dir/" - , "" "file1.hs" - , "" "file1.lhs" - ] - - let withHsHome action = withHsDirectory $ \dirPath -> do - home <- shelly $ Shelly.get_env_text "HOME" - setHomeEvent dirPath - result <- action - setHomeEvent $ Shelly.fromText home - return result - setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) - - it "correctly interprets ~ as the environment HOME variable" $ - let shouldHaveCompletions :: String -> [String] -> IO () - shouldHaveCompletions string expected = do - (matched, completions) <- withHsHome $ completionEvent - string - let existsInCompletion = (`elem` completions) - unmatched = filter - (not . existsInCompletion) - expected - expected `shouldBeAmong` completions - in do - ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"] - ":! ~/*" `shouldHaveCompletions` ["~/dir/"] - ":load ~/*" `shouldHaveCompletions` ["~/dir/"] - ":l ~/*" `shouldHaveCompletions` ["~/dir/"] - - let shouldHaveMatchingText :: String -> String -> IO () - shouldHaveMatchingText string expected = do - matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string) - matchText `shouldBe` expected - - setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore 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 - "3" `becomes` ["3"] - "3+5" `becomes` ["8"] - "print 3" `becomes` ["3"] - [hereLit| - let x = 11 - z = 10 in - x+z - |] `becomes` ["21"] - - it "evaluates flags" $ do - ":set -package hello" `becomes` ["Warning: -package not supported yet"] - ":set -XNoImplicitPrelude" `becomes` [] - - it "evaluates multiline expressions" $ do - [hereLit| - import Control.Monad - forM_ [1, 2, 3] $ \x -> - print x - |] `becomes` ["1\n2\n3"] - - it "evaluates function declarations silently" $ do - [hereLit| - fun :: [Int] -> Int - fun [] = 3 - fun (x:xs) = 10 - fun [1, 2] - |] `becomes` ["10"] - - it "evaluates data declarations" $ do - [hereLit| - data X = Y Int - | Z String - deriving (Show, Eq) - print [Y 3, Z "No"] - print (Y 3 == Z "No") - |] `becomes` ["[Y 3,Z \"No\"]", "False"] - - it "evaluates do blocks in expressions" $ do - [hereLit| - show (show (do - Just 10 - Nothing - Just 100)) - |] `becomes` ["\"\\\"Nothing\\\"\""] - - it "is silent for imports" $ do - "import Control.Monad" `becomes` [] - "import qualified Control.Monad" `becomes` [] - "import qualified Control.Monad as CM" `becomes` [] - "import Control.Monad (when)" `becomes` [] - - it "evaluates directives" $ do - ":typ 3" `becomes` ["3 :: forall a. Num a => a"] - ":k Maybe" `becomes` ["Maybe :: * -> *"] -#if MIN_VERSION_ghc(7, 8, 0) - ":in String" `pages` ["type String = [Char] \t-- Defined in \8216GHC.Base\8217"] -#else - ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"] -#endif -parserTests = do - layoutChunkerTests - moduleNameTests - parseStringTests - -layoutChunkerTests = describe "Layout Chunk" $ do - it "chunks 'a string'" $ - map unloc (layoutChunks "a string") `shouldBe` ["a string"] - - it "chunks 'a\\n string'" $ - map unloc (layoutChunks "a\n string") `shouldBe` ["a\n string"] - - it "chunks 'a\\n string\\nextra'" $ - map unloc (layoutChunks "a\n string\nextra") `shouldBe` ["a\n string", "extra"] - - it "chunks strings with too many lines" $ - map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a", "string"] - - it "parses multiple exprs" $ do - let text = [hereLit| - first - - second - third - - fourth - |] - layoutChunks text `shouldBe` [ Located 2 "first" - , Located 4 "second" - , Located 5 "third" - , Located 7 "fourth" - ] - -moduleNameTests = describe "Get Module Name" $ do - it "parses simple module names" $ - "module A where\nx = 3" `named` ["A"] - it "parses module names with dots" $ - "module A.B where\nx = 3" `named` ["A", "B"] - it "parses module names with exports" $ - "module A.B.C ( x ) where x = 3" `named` ["A", "B", "C"] - it "errors when given unnamed modules" $ do - doGhc (getModuleName "x = 3") `shouldThrow` anyException - where - named str result = do - res <- doGhc $ getModuleName str - res `shouldBe` result - -parseStringTests = describe "Parser" $ do - it "parses empty strings" $ - parses "" `like` [] - - it "parses simple imports" $ - "import Data.Monoid" `is` Import - - it "parses simple arithmetic" $ - "3 + 5" `is` Expression - - it "parses :type" $ - parses ":type x\n:ty x" `like` [Directive GetType "x", Directive GetType "x"] - - it "parses :info" $ - parses ":info x\n:in x" `like` [Directive GetInfo "x", Directive GetInfo "x"] - - it "parses :help and :?" $ - parses ":? x\n:help x" `like` [Directive GetHelp "x", Directive GetHelp "x"] - - it "parses :set x" $ - parses ":set x" `like` [Directive SetDynFlag "x"] - - it "parses :extension x" $ - parses ":ex x\n:extension x" `like` [Directive SetExtension "x", Directive SetExtension "x"] - - it "fails to parse :nope" $ - parses ":nope goodbye" `like` [ParseError (Loc 1 1) "Unknown directive: 'nope'."] - - it "parses number followed by let stmt" $ - parses "3\nlet x = expr" `like` [Expression "3", Statement "let x = expr"] - - it "parses let x in y" $ - "let x = 3 in x + 3" `is` Expression - - it "parses a data declaration" $ - "data X = Y Int" `is` Declaration - - it "parses number followed by type directive" $ - parses "3\n:t expr" `like` [Expression "3", Directive GetType "expr"] - - it "parses a <- statement" $ - "y <- print 'no'" `is` Statement - - it "parses a <- stmt followed by let stmt" $ - parses "y <- do print 'no'\nlet x = expr" `like` [ Statement "y <- do print 'no'" - , Statement "let x = expr" - ] - - it "parses <- followed by let followed by expr" $ - parses "y <- do print 'no'\nlet x = expr\nexpression" `like` [ Statement "y <- do print 'no'" - , Statement "let x = expr" - , Expression "expression" - ] - - it "parses two print statements" $ - parses "print yes\nprint no" `like` [Expression "print yes", Expression "print no"] - - it "parses a pattern-maching function declaration" $ - "fun [] = 10" `is` Declaration - - it "parses a function decl followed by an expression" $ - parses "fun [] = 10\nprint 'h'" `like` [Declaration "fun [] = 10", Expression "print 'h'"] - - it "parses list pattern matching fun decl" $ - "fun (x : xs) = 100" `is` Declaration - - it "parses two pattern matches as the same declaration" $ - "fun [] = 10\nfun (x : xs) = 100" `is` Declaration - - it "parses a type signature followed by a declaration" $ - "fun :: [a] -> Int\nfun [] = 10\nfun (x : xs) = 100" `is` Declaration - - it "parases a simple module" $ - "module A where x = 3" `is` Module - - it "parses a module with an export" $ - "module B (x) where x = 3" `is` Module - - it "breaks when a let is incomplete" $ - parses "let x = 3 in" `like` [ ParseError (Loc 1 13) - "parse error (possibly incorrect indentation or mismatched brackets)" - ] - - it "breaks without data kinds" $ - parses "data X = 3" `like` [dataKindsError] - - it "parses statements after imports" $ do - parses "import X\nprint 3" `like` [Import "import X", Expression "print 3"] - parses "import X\n\nprint 3" `like` [Import "import X", Expression "print 3"] - it "ignores blank lines properly" $ - [hereLit| - test arg = hello - where - x = y - - z = w - |] `is` Declaration - it "doesn't break on long strings" $ do - let longString = concat $ replicate 20 "hello " - ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression - - it "parses do blocks in expression" $ do - [hereLit| - show (show (do - Just 10 - Nothing - Just 100)) - |] `is` Expression - it "correctly locates parsed items" $ do - let go = doGhc . parseString - go - [hereLit| - first - - second - |] >>= (`shouldBe` [Located 2 (Expression "first"), Located 4 (Expression "second")]) - where - dataKindsError = ParseError (Loc 1 10) msg -#if MIN_VERSION_ghc(7, 10, 0) - msg = "Cannot parse data constructor in a data/newtype declaration: 3" -#elif MIN_VERSION_ghc(7, 8, 0) - msg = "Illegal literal in type (use DataKinds to enable): 3" -#else - msg = "Illegal literal in type (use -XDataKinds to enable): 3" -#endif -parseShellTests = - describe "Parsing Shell Commands" $ do - test "A" ["A"] - test ":load A" [":load", "A"] - test ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt" - [":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"] - test ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc" - [":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc"] - where - test string expected = - it ("parses " ++ string ++ " correctly") $ - string `shouldParseTo` expected - - 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 - --- Useful HSpec expectations ---- ------------------------------- -shouldBeAmong :: (Show a, Eq a) => [a] -> [a] -> Expectation --- | --- @sublist \`shouldbeAmong\` list@ sets the expectation that @sublist@ elements are --- among those in @list@. -sublist `shouldBeAmong` list = assertBool errorMsg $ and [x `elem` list | x <- sublist] - where - errorMsg = show list ++ " doesn't contain " ++ show sublist +main = + hspec $ do + testParser + testEval + testCompletions diff --git a/src/tests/IHaskell/Test/Completion.hs b/src/tests/IHaskell/Test/Completion.hs new file mode 100644 index 00000000..07cfd56d --- /dev/null +++ b/src/tests/IHaskell/Test/Completion.hs @@ -0,0 +1,220 @@ +module IHaskell.Test.Completion (testCompletions) where + +import Prelude + +import Data.List (elemIndex) +import qualified Data.Text as T +import Control.Monad.IO.Class (liftIO) +import System.Environment (setEnv) +import System.Directory (setCurrentDirectory, getCurrentDirectory) + +import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, + parseImportDecl, HscTarget(..), InteractiveImport(..)) + +import Test.Hspec + +import Shelly (toTextIgnore, (), shelly, fromText, get_env_text, FilePath, cd, mkdir_p, + touchfile, withTmpDir) + +import IHaskell.Eval.Evaluate (Interpreter, liftIO) +import IHaskell.Eval.Completion (complete, CompletionType(..), completionType, + completionTarget) +import IHaskell.Test.Util (replace, shouldBeAmong, ghc) + +-- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of +-- @'*'@ in the input string. +readCompletePrompt :: String -> (String, Int) +readCompletePrompt string = + case elemIndex '*' string of + Nothing -> error "Expected cursor written as '*'." + Just idx -> (replace "*" "" string, idx) + +completionEvent :: String -> Interpreter (String, [String]) +completionEvent string = complete newString cursorloc + where + (newString, cursorloc) = + case elemIndex '*' string of + Nothing -> error "Expected cursor written as '*'." + Just idx -> (replace "*" "" string, idx) + +completionEventInDirectory :: String -> IO (String, [String]) +completionEventInDirectory string = withHsDirectory $ const $ completionEvent string + +shouldHaveCompletionsInDirectory :: String -> [String] -> IO () +shouldHaveCompletionsInDirectory 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) <- ghc $ do + initCompleter + completionEvent string + let existsInCompletion = (`elem` completions) + unmatched = filter (not . existsInCompletion) expected + expected `shouldBeAmong` completions + +initCompleter :: Interpreter () +initCompleter = 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 IHaskell.Display" + , "import Data.Maybe as Maybe" + ] + setContext $ map IIDecl imports + +completes :: String -> [String] -> IO () +completes string expected = completionTarget newString cursorloc `shouldBe` expected + where + (newString, cursorloc) = readCompletePrompt string + +testCompletions :: Spec +testCompletions = do + testIdentifierCompletion + testCommandCompletion + +testIdentifierCompletion :: Spec +testIdentifierCompletion = describe "Completion" $ do + it "correctly gets the completion identifier without dots" $ do + "hello*" `completes` ["hello"] + "hello aa*bb goodbye" `completes` ["aa"] + "hello aabb* goodbye" `completes` ["aabb"] + "aacc* goodbye" `completes` ["aacc"] + "hello *aabb goodbye" `completes` [] + "*aabb goodbye" `completes` [] + + it "correctly gets the completion identifier with dots" $ do + "hello test.aa*bb goodbye" `completes` ["test", "aa"] + "Test.*" `completes` ["Test", ""] + "Test.Thing*" `completes` ["Test", "Thing"] + "Test.Thing.*" `completes` ["Test", "Thing", ""] + "Test.Thing.*nope" `completes` ["Test", "Thing", ""] + + it "correctly gets the completion type" $ do + completionType "import Data." 12 ["Data", ""] `shouldBe` ModuleName "Data" "" + completionType "import Prel" 11 ["Prel"] `shouldBe` ModuleName "" "Prel" + completionType "import D.B.M" 12 ["D", "B", "M"] `shouldBe` ModuleName "D.B" "M" + completionType " import A." 10 ["A", ""] `shouldBe` ModuleName "A" "" + completionType "import a.x" 10 ["a", "x"] `shouldBe` Identifier "x" + completionType "A.x" 3 ["A", "x"] `shouldBe` Qualified "A" "x" + 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" "A" + completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " "" + + + + it "properly completes identifiers" $ do + "pri*" `completionHas` ["print"] + "ma*" `completionHas` ["map"] + "hello ma*" `completionHas` ["map"] + "print $ catMa*" `completionHas` ["catMaybes"] + + it "properly completes qualified identifiers" $ do + "Control.Monad.liftM*" `completionHas` [ "Control.Monad.liftM" + , "Control.Monad.liftM2" + , "Control.Monad.liftM5" + ] + "print $ List.intercal*" `completionHas` ["List.intercalate"] + "print $ Data.Maybe.cat*" `completionHas` [] + "print $ Maybe.catM*" `completionHas` ["Maybe.catMaybes"] + + it "properly completes imports" $ do + "import Data.*" `completionHas` ["Data.Maybe", "Data.List"] + "import Data.M*" `completionHas` ["Data.Maybe"] + "import Prel*" `completionHas` ["Prelude"] + + +testCommandCompletion :: Spec +testCommandCompletion = describe "Completes commands" $ do + it "properly completes haskell file paths on :load directive" $ do + let loading xs = ":load " ++ T.unpack (toTextIgnore xs) + paths = map (T.unpack . toTextIgnore) + testInDirectory start comps = loading start `shouldHaveCompletionsInDirectory` paths comps + testInDirectory ("dir" "file*") ["dir" "file2.hs", "dir" "file2.lhs"] + testInDirectory ("" "file1*") ["" "file1.hs", "" "file1.lhs"] + testInDirectory ("" "file1*") ["" "file1.hs", "" "file1.lhs"] + testInDirectory ("" "./*") ["./" "dir/", "./" "file1.hs", "./" "file1.lhs"] + testInDirectory ("" "./*") ["./" "dir/", "./" "file1.hs", "./" "file1.lhs"] + + it "provides path completions on empty shell cmds " $ + ":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore) + [ "" "dir/" + , "" "file1.hs" + , "" "file1.lhs" + ] + + let withHsHome action = withHsDirectory $ \dirPath -> do + home <- shelly $ Shelly.get_env_text "HOME" + setHomeEvent dirPath + result <- action + setHomeEvent $ Shelly.fromText home + return result + setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) + + it "correctly interprets ~ as the environment HOME variable" $ do + let shouldHaveCompletions :: String -> [String] -> IO () + shouldHaveCompletions string expected = do + (matched, completions) <- withHsHome $ completionEvent string + let existsInCompletion = (`elem` completions) + unmatched = filter (not . existsInCompletion) expected + expected `shouldBeAmong` completions + ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"] + ":! ~/*" `shouldHaveCompletions` ["~/dir/"] + ":load ~/*" `shouldHaveCompletions` ["~/dir/"] + ":l ~/*" `shouldHaveCompletions` ["~/dir/"] + + let shouldHaveMatchingText :: String -> String -> IO () + shouldHaveMatchingText string expected = do + matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string) + matchText `shouldBe` expected + + setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) + + it "generates the correct matchingText on `:! cd ~/*` " $ + ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String) + + it "generates the correct matchingText on `:load ~/*` " $ + ":load ~/*" `shouldHaveMatchingText` ("~/" :: String) + + it "generates the correct matchingText on `:l ~/*` " $ + ":l ~/*" `shouldHaveMatchingText` ("~/" :: String) + +inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary directory + -> [Shelly.FilePath] -- ^ files relative to temporary directory + -> (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. +inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do + cd dirPath + mapM_ mkdir_p dirs + mapM_ touchfile files + liftIO $ ghc $ wrap (T.unpack $ toTextIgnore dirPath) (action dirPath) + where + cdEvent path = liftIO $ setCurrentDirectory path + wrap :: String -> Interpreter a -> Interpreter a + wrap path action = do + initCompleter + pwd <- IHaskell.Eval.Evaluate.liftIO getCurrentDirectory + cdEvent path -- change to the temporary directory + out <- action -- run action + cdEvent pwd -- change back to the original directory + return out + +withHsDirectory :: (Shelly.FilePath -> Interpreter a) -> IO a +withHsDirectory = inDirectory [p "" p "dir", p "dir" p "dir1"] + [ p "" p "file1.hs" + , p "dir" p "file2.hs" + , p "" p "file1.lhs" + , p "dir" p "file2.lhs" + ] + where + p = id diff --git a/src/tests/IHaskell/Test/Eval.hs b/src/tests/IHaskell/Test/Eval.hs new file mode 100644 index 00000000..380fa3bf --- /dev/null +++ b/src/tests/IHaskell/Test/Eval.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +module IHaskell.Test.Eval (testEval) where + +import Prelude + +import Data.List (stripPrefix) +import Control.Monad (when, forM_) +import Data.IORef (newIORef, modifyIORef, readIORef) +import System.Directory (getTemporaryDirectory, setCurrentDirectory) + +import Data.String.Here (hereLit) + +import qualified GHC.Paths + +import Test.Hspec + +import IHaskell.Test.Util (strip) +import IHaskell.Eval.Evaluate (interpret, evaluate) +import IHaskell.Types (EvaluationResult(..), defaultKernelState, KernelState(..), + LintStatus(..), Display(..), extractPlain) + +eval :: String -> IO ([Display], String) +eval string = do + outputAccum <- newIORef [] + pagerAccum <- newIORef [] + let publish evalResult = + case evalResult of + IntermediateResult{} -> return () + FinalResult outs page [] -> do + modifyIORef outputAccum (outs :) + modifyIORef pagerAccum (page :) + noWidgetHandling s _ = return s + + getTemporaryDirectory >>= setCurrentDirectory + let state = defaultKernelState { getLintStatus = LintOff } + interpret GHC.Paths.libdir False $ const $ + IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling + out <- readIORef outputAccum + pagerOut <- readIORef pagerAccum + return (reverse out, unlines . map extractPlain . reverse $ pagerOut) + +becomes :: String -> [String] -> IO () +becomes string expected = evaluationComparing comparison string + where + comparison :: ([Display], String) -> IO () + comparison (results, pageOut) = do + when (length results /= length expected) $ + expectationFailure $ "Expected result to have " ++ show (length expected) + ++ " results. Got " ++ show results + + forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of + "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected + str -> str `shouldBe` expected + +evaluationComparing :: (([Display], String) -> IO b) -> String -> IO b +evaluationComparing comparison string = do + let indent (' ':x) = 1 + indent x + indent _ = 0 + empty = null . strip + stringLines = filter (not . empty) $ lines string + minIndent = minimum (map indent stringLines) + newString = unlines $ map (drop minIndent) stringLines + eval newString >>= comparison + +pages :: String -> [String] -> IO () +pages string expected = evaluationComparing comparison string + where + comparison (results, pageOut) = + strip (stripHtml pageOut) `shouldBe` strip (unlines expected) + + -- A very, very hacky method for removing HTML + stripHtml str = go str + where + go ('<':str) = + case stripPrefix "script" str of + Nothing -> go' str + Just str -> dropScriptTag str + go (x:xs) = x : go xs + go [] = [] + + go' ('>':str) = go str + go' (x:xs) = go' xs + go' [] = error $ "Unending bracket html tag in string " ++ str + + dropScriptTag str = + case stripPrefix "" str of + Just str -> go str + Nothing -> dropScriptTag $ tail str + +testEval :: Spec +testEval = + describe "Code Evaluation" $ do + it "evaluates expressions" $ do + "3" `becomes` ["3"] + "3+5" `becomes` ["8"] + "print 3" `becomes` ["3"] + [hereLit| + let x = 11 + z = 10 in + x+z + |] `becomes` ["21"] + + it "evaluates flags" $ do + ":set -package hello" `becomes` ["Warning: -package not supported yet"] + ":set -XNoImplicitPrelude" `becomes` [] + + it "evaluates multiline expressions" $ do + [hereLit| + import Control.Monad + forM_ [1, 2, 3] $ \x -> + print x + |] `becomes` ["1\n2\n3"] + + it "evaluates function declarations silently" $ do + [hereLit| + fun :: [Int] -> Int + fun [] = 3 + fun (x:xs) = 10 + fun [1, 2] + |] `becomes` ["10"] + + it "evaluates data declarations" $ do + [hereLit| + data X = Y Int + | Z String + deriving (Show, Eq) + print [Y 3, Z "No"] + print (Y 3 == Z "No") + |] `becomes` ["[Y 3,Z \"No\"]", "False"] + + it "evaluates do blocks in expressions" $ do + [hereLit| + show (show (do + Just 10 + Nothing + Just 100)) + |] `becomes` ["\"\\\"Nothing\\\"\""] + + it "is silent for imports" $ do + "import Control.Monad" `becomes` [] + "import qualified Control.Monad" `becomes` [] + "import qualified Control.Monad as CM" `becomes` [] + "import Control.Monad (when)" `becomes` [] + + it "evaluates directives" $ do + ":typ 3" `becomes` ["3 :: forall a. Num a => a"] + ":k Maybe" `becomes` ["Maybe :: * -> *"] +#if MIN_VERSION_ghc(7, 8, 0) + ":in String" `pages` ["type String = [Char] \t-- Defined in \8216GHC.Base\8217"] +#else + ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"] +#endif diff --git a/src/tests/IHaskell/Test/Parser.hs b/src/tests/IHaskell/Test/Parser.hs new file mode 100644 index 00000000..f51ee40c --- /dev/null +++ b/src/tests/IHaskell/Test/Parser.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +module IHaskell.Test.Parser (testParser) where + +import Prelude + +import Data.String.Here (hereLit) + +import Test.Hspec +import Test.Hspec.HUnit +import Test.HUnit (assertBool, assertFailure) + +import IHaskell.Test.Util (ghc, strip) +import IHaskell.Eval.Parser (parseString, getModuleName, unloc, layoutChunks, Located(..), + CodeBlock(..), DirectiveType(..), StringLoc(..)) +import IHaskell.Eval.ParseShell (parseShell) + + +parses :: String -> IO [CodeBlock] +parses str = map unloc <$> ghc (parseString str) + +like :: (Show a, Eq a) => IO a -> a -> IO () +like parser desired = parser >>= (`shouldBe` desired) + +is :: String -> (String -> CodeBlock) -> IO () +is string blockType = do + result <- ghc $ parseString string + map unloc result `shouldBe` [blockType $ strip string] + +testParser :: Spec +testParser = do + testLayoutChunks + testModuleNames + testParseString + testParseShell + +testLayoutChunks :: Spec +testLayoutChunks = describe "Layout Chunk" $ do + it "chunks 'a string'" $ + map unloc (layoutChunks "a string") `shouldBe` ["a string"] + + it "chunks 'a\\n string'" $ + map unloc (layoutChunks "a\n string") `shouldBe` ["a\n string"] + + it "chunks 'a\\n string\\nextra'" $ + map unloc (layoutChunks "a\n string\nextra") `shouldBe` ["a\n string", "extra"] + + it "chunks strings with too many lines" $ + map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a", "string"] + + it "parses multiple exprs" $ do + let text = [hereLit| + first + + second + third + + fourth + |] + layoutChunks text `shouldBe` [ Located 2 "first" + , Located 4 "second" + , Located 5 "third" + , Located 7 "fourth" + ] + +testModuleNames :: Spec +testModuleNames = describe "Get Module Name" $ do + it "parses simple module names" $ + "module A where\nx = 3" `named` ["A"] + it "parses module names with dots" $ + "module A.B where\nx = 3" `named` ["A", "B"] + it "parses module names with exports" $ + "module A.B.C ( x ) where x = 3" `named` ["A", "B", "C"] + it "errors when given unnamed modules" $ do + ghc (getModuleName "x = 3") `shouldThrow` anyException + where + named str result = do + res <- ghc $ getModuleName str + res `shouldBe` result + + +testParseShell :: Spec +testParseShell = + describe "Parsing Shell Commands" $ do + test "A" ["A"] + test ":load A" [":load", "A"] + test ":!l ~/Downloads/MyFile\\ Has\\ Spaces.txt" + [":!l", "~/Downloads/MyFile\\ Has\\ Spaces.txt"] + test ":!l \"~/Downloads/MyFile Has Spaces.txt\" /Another/File\\ WithSpaces.doc" + [":!l", "~/Downloads/MyFile Has Spaces.txt", "/Another/File\\ WithSpaces.doc"] + where + test string expected = + it ("parses " ++ string ++ " correctly") $ + string `shouldParseTo` expected + + shouldParseTo xs ys = + case parseShell xs of + Right xs' -> xs' `shouldBe` ys + Left e -> assertFailure $ "parseShell returned error: \n" ++ show e + +testParseString :: Spec +testParseString = describe "Parser" $ do + it "parses empty strings" $ + parses "" `like` [] + + it "parses simple imports" $ + "import Data.Monoid" `is` Import + + it "parses simple arithmetic" $ + "3 + 5" `is` Expression + + it "parses :type" $ + parses ":type x\n:ty x" `like` [Directive GetType "x", Directive GetType "x"] + + it "parses :info" $ + parses ":info x\n:in x" `like` [Directive GetInfo "x", Directive GetInfo "x"] + + it "parses :help and :?" $ + parses ":? x\n:help x" `like` [Directive GetHelp "x", Directive GetHelp "x"] + + it "parses :set x" $ + parses ":set x" `like` [Directive SetDynFlag "x"] + + it "parses :extension x" $ + parses ":ex x\n:extension x" `like` [Directive SetExtension "x", Directive SetExtension "x"] + + it "fails to parse :nope" $ + parses ":nope goodbye" `like` [ParseError (Loc 1 1) "Unknown directive: 'nope'."] + + it "parses number followed by let stmt" $ + parses "3\nlet x = expr" `like` [Expression "3", Statement "let x = expr"] + + it "parses let x in y" $ + "let x = 3 in x + 3" `is` Expression + + it "parses a data declaration" $ + "data X = Y Int" `is` Declaration + + it "parses number followed by type directive" $ + parses "3\n:t expr" `like` [Expression "3", Directive GetType "expr"] + + it "parses a <- statement" $ + "y <- print 'no'" `is` Statement + + it "parses a <- stmt followed by let stmt" $ + parses "y <- do print 'no'\nlet x = expr" `like` [ Statement "y <- do print 'no'" + , Statement "let x = expr" + ] + + it "parses <- followed by let followed by expr" $ + parses "y <- do print 'no'\nlet x = expr\nexpression" `like` [ Statement "y <- do print 'no'" + , Statement "let x = expr" + , Expression "expression" + ] + + it "parses two print statements" $ + parses "print yes\nprint no" `like` [Expression "print yes", Expression "print no"] + + it "parses a pattern-maching function declaration" $ + "fun [] = 10" `is` Declaration + + it "parses a function decl followed by an expression" $ + parses "fun [] = 10\nprint 'h'" `like` [Declaration "fun [] = 10", Expression "print 'h'"] + + it "parses list pattern matching fun decl" $ + "fun (x : xs) = 100" `is` Declaration + + it "parses two pattern matches as the same declaration" $ + "fun [] = 10\nfun (x : xs) = 100" `is` Declaration + + it "parses a type signature followed by a declaration" $ + "fun :: [a] -> Int\nfun [] = 10\nfun (x : xs) = 100" `is` Declaration + + it "parases a simple module" $ + "module A where x = 3" `is` Module + + it "parses a module with an export" $ + "module B (x) where x = 3" `is` Module + + it "breaks when a let is incomplete" $ + parses "let x = 3 in" `like` [ ParseError (Loc 1 13) + "parse error (possibly incorrect indentation or mismatched brackets)" + ] + + it "breaks without data kinds" $ + parses "data X = 3" `like` [dataKindsError] + + it "parses statements after imports" $ do + parses "import X\nprint 3" `like` [Import "import X", Expression "print 3"] + parses "import X\n\nprint 3" `like` [Import "import X", Expression "print 3"] + it "ignores blank lines properly" $ + [hereLit| + test arg = hello + where + x = y + + z = w + |] `is` Declaration + it "doesn't break on long strings" $ do + let longString = concat $ replicate 20 "hello " + ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression + + it "parses do blocks in expression" $ do + [hereLit| + show (show (do + Just 10 + Nothing + Just 100)) + |] `is` Expression + it "correctly locates parsed items" $ do + ghc (parseString + [hereLit| + first + + second + |]) >>= (`shouldBe` [Located 2 (Expression "first"), Located 4 (Expression "second")]) + where + dataKindsError = ParseError (Loc 1 10) msg +#if MIN_VERSION_ghc(7, 10, 0) + msg = "Cannot parse data constructor in a data/newtype declaration: 3" +#elif MIN_VERSION_ghc(7, 8, 0) + msg = "Illegal literal in type (use DataKinds to enable): 3" +#else + msg = "Illegal literal in type (use -XDataKinds to enable): 3" +#endif diff --git a/src/tests/IHaskell/Test/Util.hs b/src/tests/IHaskell/Test/Util.hs new file mode 100644 index 00000000..5ffd5709 --- /dev/null +++ b/src/tests/IHaskell/Test/Util.hs @@ -0,0 +1,36 @@ +module IHaskell.Test.Util (lstrip, rstrip, strip, replace, ghc, shouldBeAmong) where + +import Prelude +import qualified Data.Text as T + +import Test.HUnit (assertBool) + +import GHC +import qualified GHC.Paths + +-- | Drop whitespace from the left of a string. +lstrip :: String -> String +lstrip = dropWhile (`elem` (" \t\r\n" :: String)) + +-- | Drop whitespace from the right of a string. +rstrip :: String -> String +rstrip = reverse . lstrip . reverse + +-- | Drop whitespace from both sides of a string. +strip :: String -> String +strip = rstrip . lstrip + +-- | Replace all occurrences of a string with another string. +replace :: String -> String -> String -> String +replace needle replacement haystack = + T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack) + +ghc :: Ghc a -> IO a +ghc = runGhc (Just GHC.Paths.libdir) +-- +-- | @sublist \`shouldbeAmong\` list@ sets the expectation that @sublist@ elements are +-- among those in @list@. +shouldBeAmong :: (Show a, Eq a) => [a] -> [a] -> IO () +sublist `shouldBeAmong` list = assertBool errorMsg $ and [x `elem` list | x <- sublist] + where + errorMsg = show list ++ " doesn't contain " ++ show sublist