mirror of
https://github.com/IHaskell/IHaskell.git
synced 2025-04-18 12:26:08 +00:00
Clean up test suite by splitting it into pieces
This commit is contained in:
Andrew Gibiansky
parent
4dc416c2af
commit
db3515986c
@ -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,
|
||||
|
||||
@ -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 "</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
|
||||
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
|
||||
|
||||
220
src/tests/IHaskell/Test/Completion.hs
Normal file
220
src/tests/IHaskell/Test/Completion.hs
Normal file
@ -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
|
||||
153
src/tests/IHaskell/Test/Eval.hs
Normal file
153
src/tests/IHaskell/Test/Eval.hs
Normal file
@ -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 "</script>" 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
|
||||
225
src/tests/IHaskell/Test/Parser.hs
Normal file
225
src/tests/IHaskell/Test/Parser.hs
Normal file
@ -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
|
||||
36
src/tests/IHaskell/Test/Util.hs
Normal file
36
src/tests/IHaskell/Test/Util.hs
Normal file
@ -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
|
||||
Loading…
x
Reference in New Issue
Block a user