Skip to content

G
gargantext-ihaskell
Commit 989625b8 authored by Andrew Gibiansky's avatar Andrew Gibiansky
Browse files
Options

Travis fixes 10

parent 654369fd
Show whitespace changes
Inline Side-by-side
Showing with 233 additions and 241 deletions
.travis.yml
View file @ 989625b8
......@@ -26,6 +26,7 @@ addons:
packages:
- libmagic-dev
- libgmp-dev
- python3
before_install:
# Download and unpack the stack executable
......@@ -58,3 +59,4 @@ script:
- export LD_LIBRARY_PATH=$HOME/zeromq/lib
- stack build --resolver=$RESOLVER
- stack test --resolver=$RESOLVER
- ./verify_formatting.py
src/IHaskell/Eval/Evaluate.hs
View file @ 989625b8
......@@ -147,7 +147,6 @@ ihaskellGlobalImports =
, "import qualified IHaskell.Eval.Widgets"
]
-- | Evaluation function for testing.
testInterpret :: Interpreter a -> IO a
testInterpret val = interpret GHC.Paths.libdir False (const val)
......
src/tests/Hspec.hs
View file @ 989625b8
{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules, CPP #-}
-- Keep all the language pragmas here so it can be compiled separately.
module Main where
......@@ -65,8 +66,9 @@ is string blockType = do
eval string = do
outputAccum <- newIORef []
pagerAccum <- newIORef []
let publish evalResult = case evalResult of
IntermediateResult {} -> return ()
let publish evalResult =
case evalResult of
IntermediateResult{} -> return ()
FinalResult outs page [] -> do
modifyIORef outputAccum (outs :)
modifyIORef pagerAccum (page :)
......@@ -96,8 +98,7 @@ becomes string expected = evaluationComparing comparison string
expectationFailure $ "Expected result to have " ++ show (length expected)
++ " results. Got " ++ show results
forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) ->
case extractPlain result of
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
......@@ -109,7 +110,8 @@ pages string expected = evaluationComparing comparison string
-- A very, very hacky method for removing HTML
stripHtml str = go str
where
go ('<':str) = case stripPrefix "script" str of
go ('<':str) =
case stripPrefix "script" str of
Nothing -> go' str
Just str -> dropScriptTag str
go (x:xs) = x : go xs
......@@ -119,30 +121,33 @@ pages string expected = evaluationComparing comparison string
go' (x:xs) = go' xs
go' [] = error $ "Unending bracket html tag in string " ++ str
dropScriptTag str = case stripPrefix "</script>" str of
dropScriptTag str =
case stripPrefix "</script>" 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
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
where
(newString, cursorloc) = readCompletePrompt string
completionEvent :: String -> Interpreter (String, [String])
completionEvent string = complete newString cursorloc
where (newString, cursorloc) = case elemIndex '*' string of
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
completionEventInDirectory string = withHsDirectory $ const $ completionEvent string
shouldHaveCompletionsInDirectory :: String -> [String] -> IO ()
shouldHaveCompletionsInDirectory string expected = do
......@@ -151,8 +156,9 @@ shouldHaveCompletionsInDirectory string expected = do
unmatched = filter (not . existsInCompletion) expected
expected `shouldBeAmong` completions
completionHas string expected
= do (matched, completions) <- doGhc $ do initCompleter
completionHas string expected = do
(matched, completions) <- doGhc $ do
initCompleter
completionEvent string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
......@@ -164,11 +170,13 @@ initCompleter = do
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"]
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
......@@ -177,15 +185,17 @@ inDirectory :: [Shelly.FilePath] -- ^ directories relative to temporary director
-> 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
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 --Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish
where
cdEvent path = liftIO $ setCurrentDirectory path
wrap :: FilePath -> Interpreter a -> Interpreter a
wrap path action =
do initCompleter
do
initCompleter
pwd <- Eval.liftIO getCurrentDirectory
cdEvent path -- change to the temporary directory
out <- action -- run action
......@@ -194,8 +204,11 @@ inDirectory dirs files action = shelly $ withTmpDir $ \dirPath ->
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"]
[ p "" </> p "file1.hs"
, p "dir" </> p "file2.hs"
, p "" </> p "file1.lhs"
, p "dir" </> p "file2.lhs"
]
where
p :: FilePath -> FilePath
p = id
......@@ -233,8 +246,7 @@ completionTests = do
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 ":load A" 7 ["A"] `shouldBe` HsFilePath ":load A" "A"
completionType ":! cd " 6 [""] `shouldBe` FilePath ":! cd " ""
......@@ -248,7 +260,8 @@ completionTests = do
it "properly completes qualified identifiers" $ do
"Control.Monad.liftM*" `completionHas` [ "Control.Monad.liftM"
, "Control.Monad.liftM2"
, "Control.Monad.liftM5"]
, "Control.Monad.liftM5"
]
"print $ List.intercal*" `completionHas` ["List.intercalate"]
"print $ Data.Maybe.cat*" `completionHas` []
"print $ Maybe.catM*" `completionHas` ["Maybe.catMaybes"]
......@@ -262,25 +275,37 @@ completionTests = do
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/"
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.lhs"
]
loading ("" </> "./*") `shouldHaveCompletionsInDirectory` paths
[ "./" </> "dir/"
, "./" </> "file1.hs"
, "./" </> "file1.lhs"]
, "./" </> "file1.lhs"
]
it "provides path completions on empty shell cmds " $
":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore) ["" </> "dir/"
":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore)
[ "" </> "dir/"
, "" </> "file1.hs"
, "" </> "file1.lhs"]
, "" </> "file1.lhs"
]
let withHsHome action = withHsDirectory $ \dirPath-> do
let withHsHome action = withHsDirectory $ \dirPath -> do
home <- shelly $ Shelly.get_env_text "HOME"
setHomeEvent dirPath
result <- action
......@@ -291,11 +316,13 @@ completionTests = do
it "correctly interprets ~ as the environment HOME variable" $
let shouldHaveCompletions :: String -> [String] -> IO ()
shouldHaveCompletions string expected = do
(matched, completions) <- withHsHome $ completionEvent string
(matched, completions) <- withHsHome $ completionEvent
string
let existsInCompletion = (`elem` completions)
unmatched = filter (not . existsInCompletion) expected
unmatched = filter
(not . existsInCompletion)
expected
expected `shouldBeAmong` completions
in do
":! cd ~/*" `shouldHaveCompletions` ["~/dir/"]
":! ~/*" `shouldHaveCompletions` ["~/dir/"]
......@@ -310,13 +337,16 @@ completionTests = do
setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path)
it "generates the correct matchingText on `:! cd ~/*` " $
do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
do
":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
it "generates the correct matchingText on `:load ~/*` " $
do ":load ~/*" `shouldHaveMatchingText` ("~/" :: String)
do
":load ~/*" `shouldHaveMatchingText` ("~/" :: String)
it "generates the correct matchingText on `:l ~/*` " $
do ":l ~/*" `shouldHaveMatchingText` ("~/" :: String)
do
":l ~/*" `shouldHaveMatchingText` ("~/" :: String)
evalTests = do
describe "Code Evaluation" $ do
......@@ -380,7 +410,6 @@ evalTests = do
#else
":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"]
#endif
parserTests = do
layoutChunkerTests
moduleNameTests
......@@ -394,10 +423,10 @@ layoutChunkerTests = describe "Layout Chunk" $ do
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"]
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"]
map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a", "string"]
it "parses multiple exprs" $ do
let text = [hereLit|
......@@ -408,11 +437,11 @@ layoutChunkerTests = describe "Layout Chunk" $ do
fourth
|]
layoutChunks text `shouldBe`
[Located 2 "first",
Located 4 "second",
Located 5 "third",
Located 7 "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" $
......@@ -439,44 +468,25 @@ parseStringTests = describe "Parser" $ do
"3 + 5" `is` Expression
it "parses :type" $
parses ":type x\n:ty x" `like` [
Directive GetType "x",
Directive GetType "x"
]
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"
]
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"
]
parses ":? x\n:help x" `like` [Directive GetHelp "x", Directive GetHelp "x"]
it "parses :set x" $
parses ":set x" `like` [
Directive SetDynFlag "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"
]
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'."
]
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"
]
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
......@@ -485,41 +495,30 @@ parseStringTests = describe "Parser" $ do
"data X = Y Int" `is` Declaration
it "parses number followed by type directive" $
parses "3\n:t expr" `like` [
Expression "3",
Directive GetType "expr"
]
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"
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"
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"
]
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'"
]
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
......@@ -537,30 +536,16 @@ parseStringTests = describe "Parser" $ do
"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)"
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` [
#if MIN_VERSION_ghc(7, 10, 0)
ParseError (Loc 1 10) "Cannot parse data constructor in a data/newtype declaration: 3"
#elif MIN_VERSION_ghc(7, 8, 0)
ParseError (Loc 1 10) "Illegal literal in type (use DataKinds to enable): 3"
#else
ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3"
#endif
]
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"
]
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
......@@ -582,14 +567,21 @@ parseStringTests = describe "Parser" $ do
|] `is` Expression
it "correctly locates parsed items" $ do
let go = doGhc . parseString
go [hereLit|
go
[hereLit|
first
second
|] >>= (`shouldBe` [Located 2 (Expression "first"),
Located 4 (Expression "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"]
......@@ -597,25 +589,22 @@ parseShellTests =
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" ]
[":!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
where
fun ys (Right xs') = xs' `shouldBe` ys
fun ys (Left e) = assertFailure $ "parseShell returned error: \n" ++ show e
-- Useful HSpec expectations ----
---------------------------------
-- 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]
sublist `shouldBeAmong` list = assertBool errorMsg $ and [x `elem` list | x <- sublist]
where
errorMsg = show list ++ " doesn't contain " ++ show sublist
stack.yaml
View file @ 989625b8
......@@ -4,3 +4,5 @@ packages:
- './ipython-kernel'
- './ghc-parser'
resolver: lts-6.2
extra-deps:
- system-argv0-0.1.1 # Necessary for LTS 2.22 (GHC 7.8)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment