diff --git a/Hspec.hs b/Hspec.hs deleted file mode 100644 --- a/Hspec.hs +++ /dev/null @@ -1,619 +0,0 @@ -{-# 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 --Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish - 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 - -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` ["Data.Maybe.catMaybes"] - "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` [ -#if 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 - ] - - 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")]) - - -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 diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.8.4.0 +version: 0.9.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. @@ -54,8 +54,8 @@ hs-source-dirs: src default-language: Haskell2010 build-depends: - aeson >=0.7 && < 0.12, - base >=4.6 && < 4.9, + aeson >=1.0, + base >=4.6, base64-bytestring >=1.0, bytestring >=0.10, cereal >=0.3, @@ -63,14 +63,14 @@ containers >=0.5, directory -any, filepath -any, - ghc >=7.6 || < 7.11, + ghc >=7.6, ghc-parser >=0.1.7, - ghc-paths ==0.1.*, + ghc-paths >=0.1, haskeline -any, - hlint >=1.9 && <2.0, - haskell-src-exts >=1.16 && < 1.18, - http-client == 0.4.*, - http-client-tls == 0.2.*, + hlint >=1.9, + haskell-src-exts >=1.16, + http-client >= 0.4, + http-client-tls >= 0.2, mtl >=2.1, parsec -any, process >=1.1, @@ -87,10 +87,13 @@ utf8-string -any, uuid >=1.3, vector -any, - ipython-kernel >=0.7 + ipython-kernel >=0.8.4 if flag(binPkgDb) build-depends: bin-package-db + if impl(ghc >= 8.0) + build-depends: ghc-boot >=8.0 && <8.1 + exposed-modules: IHaskell.Display IHaskell.Convert IHaskell.Convert.Args @@ -118,30 +121,25 @@ IHaskellPrelude StringUtils - default-extensions: - NoImplicitPrelude - DoAndIfThenElse - OverloadedStrings - ExtendedDefaultRules - executable ihaskell -- .hs or .lhs file containing the Main module. main-is: Main.hs hs-source-dirs: main other-modules: IHaskellPrelude + Paths_ihaskell ghc-options: -threaded -- Other library packages from which modules are imported. default-language: Haskell2010 build-depends: ihaskell -any, - base >=4.6 && < 4.9, + base >=4.6 && < 4.10, text >=0.11, transformers -any, ghc >=7.6 || < 7.11, process >=1.1, - aeson >=0.7 && < 0.12, + aeson >=0.7, bytestring >=0.10, containers >=0.5, strict >=0.3, @@ -152,65 +150,34 @@ if flag(binPkgDb) build-depends: bin-package-db - default-extensions: - NoImplicitPrelude - DoAndIfThenElse - OverloadedStrings - ExtendedDefaultRules - Test-Suite hspec Type: exitcode-stdio-1.0 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, ihaskell, - aeson >=0.6 && < 0.12, - base >=4.6 && < 4.9, - base64-bytestring >=1.0, - bytestring >=0.10, - cereal >=0.3, - cmdargs >=0.10, - containers >=0.5, - directory -any, - filepath -any, - ghc >=7.6 && < 7.11, - ghc-parser >=0.1.7, - ghc-paths ==0.1.*, - haskeline -any, - hlint >=1.9 && <2.0, - haskell-src-exts >=1.16 && < 1.18, - hspec -any, - HUnit -any, - mtl >=2.1, - parsec -any, - process >=1.1, - random >=1.0, - shelly >=1.5, - split >= 0.2, - stm -any, - strict >=0.3, - system-argv0 -any, - text >=0.11, - http-client == 0.4.*, - http-client-tls == 0.2.*, - transformers -any, - unix >= 2.6, - unordered-containers -any, - utf8-string -any, - uuid >=1.3, - vector -any, - setenv ==0.1.*, - ipython-kernel >= 0.7 + here, + hspec, + hspec-contrib, + HUnit, + ghc, + ghc-paths, + transformers, + directory, + text, + shelly, + setenv if flag(binPkgDb) build-depends: bin-package-db - - default-extensions: - DoAndIfThenElse - OverloadedStrings - ExtendedDefaultRules - source-repository head type: git diff --git a/main/IHaskellPrelude.hs b/main/IHaskellPrelude.hs --- a/main/IHaskellPrelude.hs +++ b/main/IHaskellPrelude.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}{-# LANGUAGE CPP #-} module IHaskellPrelude ( module IHaskellPrelude, module X, @@ -78,7 +78,9 @@ import GHC.Num as X import GHC.Real as X import GHC.Err as X hiding (absentErr) -#if MIN_VERSION_ghc(7,10,0) +#if MIN_VERSION_ghc(8,0,0) +import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..)) +#elif MIN_VERSION_ghc(7,10,0) import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>)) #else import GHC.Base as X hiding (Any) diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Description : Argument parsing and basic messaging loop, using Haskell @@ -128,7 +129,8 @@ useStack = kernelSpecUseStack kernelOpts -- Parse the profile file. - Just profile <- liftM decode $ LBS.readFile profileSrc + let profileErr = error $ "ihaskell: "++profileSrc++": Failed to parse profile file" + profile <- liftM (fromMaybe profileErr . decode) $ LBS.readFile profileSrc -- Necessary for `getLine` and their ilk to work. dir <- getIHaskellDir @@ -263,6 +265,14 @@ } }) +replyTo _ CommInfoRequest{} replyHeader state = + let comms = Map.mapKeys (UUID.uuidToString) (openComms state) in + return + (state, CommInfoReply + { header = replyHeader + , commInfo = Map.map (\(Widget w) -> targetName w) comms + }) + -- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to -- let the frontend know shutdown is happening. replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do @@ -295,7 +305,7 @@ let execCount = getExecutionCounter state -- Let all frontends know the execution count and code that's about to run - inputHeader <- liftIO $ dupHeader replyHeader InputMessage + inputHeader <- liftIO $ dupHeader replyHeader ExecuteInputMessage send $ PublishInput inputHeader (T.unpack code) execCount -- Run code and publish to the frontend as we go. diff --git a/src/IHaskell/CSS.hs b/src/IHaskell/CSS.hs --- a/src/IHaskell/CSS.hs +++ b/src/IHaskell/CSS.hs @@ -4,93 +4,94 @@ ihaskellCSS :: String ihaskellCSS = - unlines [ - -- Custom IHaskell CSS - "/* Styles used for the Hoogle display in the pager */" - , ".hoogle-doc {" - , "display: block;" - , "padding-bottom: 1.3em;" - , "padding-left: 0.4em;" - , "}" - , ".hoogle-code {" - , "display: block;" - , "font-family: monospace;" - , "white-space: pre;" - , "}" - , ".hoogle-text {" - , "display: block;" - , "}" - , ".hoogle-name {" - , "color: green;" - , "font-weight: bold;" - , "}" - , ".hoogle-head {" - , "font-weight: bold;" - , "}" - , ".hoogle-sub {" - , "display: block;" - , "margin-left: 0.4em;" - , "}" - , ".hoogle-package {" - , "font-weight: bold;" - , "font-style: italic;" - , "}" - , ".hoogle-module {" - , "font-weight: bold;" - , "}" - , ".hoogle-class {" - , "font-weight: bold;" - , "}" - , - -- Styles used for basic displays - ".get-type {" - , "color: green;" - , "font-weight: bold;" - , "font-family: monospace;" - , "display: block;" - , "white-space: pre-wrap;" - , "}" - , ".show-type {" - , "color: green;" - , "font-weight: bold;" - , "font-family: monospace;" - , "margin-left: 1em;" - , "}" - , ".mono {" - , "font-family: monospace;" - , "display: block;" - , "}" - , ".err-msg {" - , "color: red;" - , "font-style: italic;" - , "font-family: monospace;" - , "white-space: pre;" - , "display: block;" - , "}" - , "#unshowable {" - , "color: red;" - , "font-weight: bold;" - , "}" - , ".err-msg.in.collapse {" - , "padding-top: 0.7em;" - , "}" - , - -- Code that will get highlighted before it is highlighted - ".highlight-code {" - , "white-space: pre;" - , "font-family: monospace;" - , "}" - , - -- Hlint styles - ".suggestion-warning { " - , "font-weight: bold;" - , "color: rgb(200, 130, 0);" - , "}" - , ".suggestion-error { " - , "font-weight: bold;" - , "color: red;" - , "}" - , ".suggestion-name {" - , "font-weight: bold;" - , "}" - ] + unlines + [ + -- Custom IHaskell CSS + "/* Styles used for the Hoogle display in the pager */" + , ".hoogle-doc {" + , "display: block;" + , "padding-bottom: 1.3em;" + , "padding-left: 0.4em;" + , "}" + , ".hoogle-code {" + , "display: block;" + , "font-family: monospace;" + , "white-space: pre;" + , "}" + , ".hoogle-text {" + , "display: block;" + , "}" + , ".hoogle-name {" + , "color: green;" + , "font-weight: bold;" + , "}" + , ".hoogle-head {" + , "font-weight: bold;" + , "}" + , ".hoogle-sub {" + , "display: block;" + , "margin-left: 0.4em;" + , "}" + , ".hoogle-package {" + , "font-weight: bold;" + , "font-style: italic;" + , "}" + , ".hoogle-module {" + , "font-weight: bold;" + , "}" + , ".hoogle-class {" + , "font-weight: bold;" + , "}" + , + -- Styles used for basic displays + ".get-type {" + , "color: green;" + , "font-weight: bold;" + , "font-family: monospace;" + , "display: block;" + , "white-space: pre-wrap;" + , "}" + , ".show-type {" + , "color: green;" + , "font-weight: bold;" + , "font-family: monospace;" + , "margin-left: 1em;" + , "}" + , ".mono {" + , "font-family: monospace;" + , "display: block;" + , "}" + , ".err-msg {" + , "color: red;" + , "font-style: italic;" + , "font-family: monospace;" + , "white-space: pre;" + , "display: block;" + , "}" + , "#unshowable {" + , "color: red;" + , "font-weight: bold;" + , "}" + , ".err-msg.in.collapse {" + , "padding-top: 0.7em;" + , "}" + , + -- Code that will get highlighted before it is highlighted + ".highlight-code {" + , "white-space: pre;" + , "font-family: monospace;" + , "}" + , + -- Hlint styles + ".suggestion-warning { " + , "font-weight: bold;" + , "color: rgb(200, 130, 0);" + , "}" + , ".suggestion-error { " + , "font-weight: bold;" + , "color: red;" + , "}" + , ".suggestion-name {" + , "font-weight: bold;" + , "}" + ] diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -43,7 +43,7 @@ switchToTmpDir, -- * Internal only use - displayFromChan, + displayFromChanEncoded, serializeDisplay, Widget(..), ) where @@ -151,9 +151,9 @@ -- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out -- of it. -displayFromChan :: IO (Maybe Display) -displayFromChan = - Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) +displayFromChanEncoded :: IO ByteString +displayFromChanEncoded = + Serialize.encode <$> Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) -- | Write to the display channel. The contents will be displayed in the notebook once the current -- execution call ends. diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -22,7 +22,7 @@ import Control.Applicative ((<$>)) import Data.ByteString.UTF8 hiding (drop, take, lines, length) import Data.Char -import Data.List (nub, init, last, head, elemIndex) +import Data.List (nub, init, last, head, elemIndex, concatMap) import qualified Data.List.Split as Split import qualified Data.List.Split.Internals as Split import Data.Maybe (fromJust) @@ -88,7 +88,11 @@ let Just db = pkgDatabase flags getNames = map (moduleNameString . exposedName) . exposedModules +#if MIN_VERSION_ghc(8,0,0) + moduleNames = nub $ concatMap getNames $ concatMap snd db +#else moduleNames = nub $ concatMap getNames db +#endif let target = completionTarget line pos completion = completionType line pos target @@ -107,10 +111,9 @@ Qualified moduleName candidate -> do trueName <- getTrueModuleName moduleName - let prefix = intercalate "." [trueName, candidate] + let prefix = intercalate "." [moduleName, candidate] completions = filter (prefix `isPrefixOf`) qualNames - falsifyName = replace trueName moduleName - return $ map falsifyName completions + return completions ModuleName previous candidate -> do let prefix = if null previous @@ -125,7 +128,11 @@ otherNames = ["-package", "-Wall", "-w"] fNames = map extName fFlags ++ +#if MIN_VERSION_ghc(8,0,0) + map extName wWarningFlags ++ +#else map extName fWarningFlags ++ +#endif map extName fLangFlags fNoNames = map ("no" ++) fNames fAllNames = map ("-f" ++) (fNames ++ fNoNames) diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -7,6 +7,8 @@ -} module IHaskell.Eval.Evaluate ( interpret, + testInterpret, + testEvaluate, evaluate, flushWidgetMessages, Interpreter, @@ -24,6 +26,7 @@ import qualified Data.ByteString.Char8 as CBS import Control.Concurrent (forkIO, threadDelay) +import Data.Foldable (foldMap) import Prelude (putChar, head, tail, last, init, (!!)) import Data.List (findIndex, and, foldl1, nubBy) import Text.Printf @@ -36,7 +39,7 @@ import System.Posix.IO (createPipe) #endif import System.Posix.IO (fdToHandle) -import System.IO (hGetChar, hFlush) +import System.IO (hGetChar, hSetEncoding, utf8, hFlush) import System.Random (getStdGen, randomRs) import Unsafe.Coerce import Control.Monad (guard) @@ -48,6 +51,7 @@ import System.Environment (getEnv) import qualified Data.Map as Map +import qualified GHC.Paths import NameSet import Name import PprTyThing @@ -74,7 +78,7 @@ import qualified Pretty import FastString import Bag -import ErrUtils (errMsgShortDoc, errMsgExtraInfo) +import qualified ErrUtils import IHaskell.Types import IHaskell.IPython @@ -145,6 +149,15 @@ , "import qualified IHaskell.Eval.Widgets" ] +-- | Interpreting function for testing. +testInterpret :: Interpreter a -> IO a +testInterpret val = interpret GHC.Paths.libdir False (const val) + +-- | Evaluation function for testing. +testEvaluate :: String -> IO () +testEvaluate str = void $ testInterpret $ + evaluate defaultKernelState str (const $ return ()) (\state _ -> return state) + -- | Run an interpreting action. This is effectively runGhc with initialization and importing. First -- argument indicates whether `stdin` is handled specially, which cannot be done in a testing -- environment. The argument passed to the action indicates whether Haskell support libraries are @@ -166,19 +179,35 @@ dir <- liftIO getIHaskellDir let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir when (allowedStdin && hasSupportLibraries) $ void $ - runStmt cmd RunToCompletion + execStmt cmd execOptions initializeItVariable -- Run the rest of the interpreter action hasSupportLibraries -#if MIN_VERSION_ghc(7,10,2) -packageIdString' dflags pkg_key = fromMaybe "(unknown)" (packageKeyPackageIdString dflags pkg_key) + +packageIdString' :: DynFlags -> PackageConfig -> String +packageIdString' dflags pkg_cfg = +#if MIN_VERSION_ghc(8,0,0) + fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg) +#elif MIN_VERSION_ghc(7,10,2) + fromMaybe "(unknown)" (packageKeyPackageIdString dflags $ packageConfigId pkg_cfg) #elif MIN_VERSION_ghc(7,10,0) -packageIdString' dflags = packageKeyPackageIdString dflags + packageKeyPackageIdString dflags . packageConfigId #else -packageIdString' dflags = packageIdString + packageIdString . packageConfigId #endif + +getPackageConfigs :: DynFlags -> [PackageConfig] +getPackageConfigs dflags = +#if MIN_VERSION_ghc(8,0,0) + foldMap snd pkgDb +#else + pkgDb +#endif + where + Just pkgDb = pkgDatabase dflags + -- | Initialize our GHC session with imports and a value for 'it'. Return whether the IHaskell -- support libraries are available. initializeImports :: Interpreter Bool @@ -188,25 +217,30 @@ dflags <- getSessionDynFlags broken <- liftIO getBrokenPackages (dflags, _) <- liftIO $ initPackages dflags - let Just db = pkgDatabase dflags - packageNames = map (packageIdString' dflags . packageConfigId) db + let db = getPackageConfigs dflags + packageNames = map (packageIdString' dflags) db initStr = "ihaskell-" -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4" iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) +#if !MIN_VERSION_ghc(8,0,0) + unitId = packageId +#endif + dependsOnRight pkg = not $ null $ do pkg <- db depId <- depends pkg - dep <- filter ((== depId) . installedPackageId) db - let idString = packageIdString' dflags (packageConfigId dep) + dep <- filter ((== depId) . unitId) db + let idString = packageIdString' dflags dep guard (iHaskellPkgName `isPrefixOf` idString) - displayPkgs = [pkgName | pkgName <- packageNames - , Just (x:_) <- [stripPrefix initStr pkgName] - , pkgName `notElem` broken - , isAlpha x] + displayPkgs = [ pkgName + | pkgName <- packageNames + , Just (x:_) <- [stripPrefix initStr pkgName] + , pkgName `notElem` broken + , isAlpha x ] hasIHaskellPackage = not $ null $ filter (== iHaskellPkgName) packageNames @@ -245,7 +279,7 @@ initializeItVariable = -- This is required due to the way we handle `it` in the wrapper statements - if it doesn't exist, -- the first statement will fail. - void $ runStmt "let it = ()" RunToCompletion + void $ execStmt "let it = ()" execOptions -- | Publisher for IHaskell outputs. The first argument indicates whether this output is final -- (true) or intermediate (false). @@ -257,7 +291,7 @@ { evalStatus :: ErrorOccurred , evalResult :: Display , evalState :: KernelState - , evalPager :: String + , evalPager :: [DisplayData] , evalMsgs :: [WidgetMsg] } @@ -269,7 +303,7 @@ str = strip x l = lines str allBrackets = all (fAny [isPrefixOf ">", null]) l - fAny fs x = any ($x) fs + fAny fs x = any ($ x) fs clean = unlines $ map removeBracket l removeBracket ('>':xs) = xs removeBracket [] = [] @@ -320,18 +354,25 @@ -- Get displayed channel outputs. Merge them with normal display outputs. dispsMay <- if supportLibrariesAvailable state - then extractValue "IHaskell.Display.displayFromChan" >>= liftIO + then do + getEncodedDisplays <- extractValue "IHaskell.Display.displayFromChanEncoded" + case getEncodedDisplays of + Left err -> error $ "Deserialization error (Evaluate.hs): " ++ err + Right displaysIO -> do + result <- liftIO displaysIO + case Serialize.decode result of + Left err -> error $ "Deserialization error (Evaluate.hs): " ++ err + Right res -> return res else return Nothing let result = case dispsMay of Nothing -> evalResult evalOut Just disps -> evalResult evalOut <> disps - helpStr = evalPager evalOut -- Output things only if they are non-empty. - let empty = noResults result && null helpStr + let empty = noResults result && null (evalPager evalOut) unless empty $ - liftIO $ output $ FinalResult result [plain helpStr] [] + liftIO $ output $ FinalResult result (evalPager evalOut) [] let tempMsgs = evalMsgs evalOut tempState = evalState evalOut { evalMsgs = [] } @@ -349,26 +390,56 @@ -- | Compile a string and extract a value from it. Effectively extract the result of an expression -- from inside the notebook environment. -extractValue :: Typeable a => String -> Interpreter a +extractValue :: Typeable a => String -> Interpreter (Either String a) extractValue expr = do compiled <- dynCompileExpr expr case fromDynamic compiled of - Nothing -> error "Error casting types in Evaluate.hs" - Just result -> return result + Nothing -> return (Left multipleIHaskells) + Just result -> return (Right result) + where + multipleIHaskells = + concat + [ "The installed IHaskell support libraries do not match" + , " the instance of IHaskell you are running.\n" + , "This *may* cause problems with functioning of widgets or rich media displays.\n" + , "This is most often caused by multiple copies of IHaskell" + , " being installed simultaneously in your environment.\n" + , "To resolve this issue, clear out your environment and reinstall IHaskell.\n" + , "If you are installing support libraries, make sure you only do so once:\n" + , " # Run this without first running `stack install ihaskell`\n" + , " stack install ihaskell-diagrams\n" + , "If you continue to have problems, please file an issue on Github." + ] + flushWidgetMessages :: KernelState -> [WidgetMsg] -> (KernelState -> [WidgetMsg] -> IO KernelState) -> Interpreter KernelState flushWidgetMessages state evalMsgs widgetHandler = do -- Capture all widget messages queued during code execution - messagesIO <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages" - messages <- liftIO messagesIO + extracted <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages" + liftIO $ + case extracted of + Left err -> do + hPutStrLn stderr "Disabling IHaskell widget support due to an encountered error:" + hPutStrLn stderr err + return state + Right messagesIO -> do + messages <- messagesIO - -- Handle all the widget messages - let commMessages = evalMsgs ++ messages - liftIO $ widgetHandler state commMessages + -- Handle all the widget messages + let commMessages = evalMsgs ++ messages + widgetHandler state commMessages + +getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc +#if MIN_VERSION_ghc(8,0,0) +getErrMsgDoc = ErrUtils.pprLocErrMsg +#else +getErrMsgDoc msg = ErrUtils.errMsgShortString msg $$ ErrUtils.errMsgContext msg +#endif + safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler where @@ -379,17 +450,14 @@ { evalStatus = Failure , evalResult = displayError $ show exception , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } sourceErrorHandler :: SourceError -> Interpreter EvalOut sourceErrorHandler srcerr = do let msgs = bagToList $ srcErrorMessages srcerr - errStrs <- forM msgs $ \msg -> do - shortStr <- doc $ errMsgShortDoc msg - contextStr <- doc $ errMsgExtraInfo msg - return $ unlines [shortStr, contextStr] + errStrs <- forM msgs $ doc . getErrMsgDoc let fullErr = unlines errStrs @@ -398,7 +466,7 @@ { evalStatus = Failure , evalResult = displayError fullErr , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -412,7 +480,7 @@ { evalStatus = Success , evalResult = res , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -421,12 +489,7 @@ evalCommand _ (Import importStr) state = wrapExecution state $ do write state $ "Import: " ++ importStr evalImport importStr - - -- Warn about `it` variable. - return $ if "Test.Hspec" `isInfixOf` importStr - then displayError $ "Warning: Hspec is unusable in IHaskell until the resolution of GHC bug #8639." ++ - "\nThe variable `it` is shadowed and cannot be accessed, even in qualified form." - else mempty + return mempty evalCommand _ (Module contents) state = wrapExecution state $ do write state $ "Module:\n" ++ contents @@ -447,7 +510,7 @@ -- Remember which modules we've loaded before. importedModules <- getContext - let + let -- Get the dot-delimited pieces of the module name. moduleNameOf :: InteractiveImport -> [String] moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl @@ -502,7 +565,7 @@ ] ] , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } else do @@ -528,7 +591,7 @@ { evalStatus = Success , evalResult = display , evalState = state' - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -562,7 +625,7 @@ { evalStatus = Failure , evalResult = displayError err , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } else let options = mapMaybe findOption $ words opts @@ -572,7 +635,7 @@ { evalStatus = Success , evalResult = mempty , evalState = updater state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -626,7 +689,7 @@ let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ replace " " "\\ " $ replace "\"" "\\\"" directory - runStmt cmd RunToCompletion + execStmt cmd execOptions return mempty else return $ displayError $ printf "No such directory: '%s'" directory cmd -> liftIO $ do @@ -643,7 +706,7 @@ outputAccum <- liftIO $ newMVar "" -- Start a loop to publish intermediate results. - let + let -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an -- argument of microseconds. ms = 1000 @@ -688,7 +751,7 @@ ] loop - where + where #if MIN_VERSION_base(4,8,0) createPipe' = createPipe #else @@ -706,7 +769,7 @@ { evalStatus = Success , evalResult = Display [out] , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -738,24 +801,25 @@ evalCommand _ (Directive GetInfo str) state = safely state $ do write state $ "Info: " ++ str -- Get all the info for all the names we're given. - strings <- getDescription str + strings <- unlines <$> getDescription str - -- TODO: Make pager work without html by porting to newer architecture - let output = unlines (map htmlify strings) - htmlify str = - printf - "
" - str - ++ script - script = - "" + -- Make pager work without html by porting to newer architecture + let htmlify str = + html $ + concat + [ "
" + , "" + ] return EvalOut { evalStatus = Success , evalResult = mempty , evalState = state - , evalPager = output + , evalPager = [plain strings, htmlify strings] , evalMsgs = [] } @@ -783,7 +847,7 @@ let widgetExpr = printf "(IHaskell.Display.Widget (%s))" expr :: String isWidget <- attempt $ exprType widgetExpr - -- Check if this is a template haskell declaration + -- Check if this is a template haskell declaration let declExpr = printf "((id :: IHaskellTH.DecsQ -> IHaskellTH.DecsQ) (%s))" expr :: String let anyExpr = printf "((id :: IHaskellPrelude.Int -> IHaskellPrelude.Int) (%s))" expr :: String isTHDeclaration <- liftM2 (&&) (attempt $ exprType declExpr) (not <$> attempt (exprType anyExpr)) @@ -793,7 +857,7 @@ write state $ "Is Declaration: " ++ show isTHDeclaration if isTHDeclaration - then + then -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the -- declaration made. do @@ -804,11 +868,11 @@ { evalStatus = Success , evalResult = mempty , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } else if canRunDisplay - then + then -- Use the display. As a result, `it` is set to the output. useDisplay displayExpr else do @@ -949,7 +1013,7 @@ { evalStatus = Failure , evalResult = displayError $ formatParseError loc err , evalState = state - , evalPager = "" + , evalPager = [] , evalMsgs = [] } @@ -966,13 +1030,11 @@ { evalStatus = Success , evalResult = mempty , evalState = state - , evalPager = output + , evalPager = [ plain $ unlines $ map (Hoogle.render Hoogle.Plain) results + , html $ unlines $ map (Hoogle.render Hoogle.HTML) results + ] , evalMsgs = [] } - where - -- TODO: Make pager work with plaintext - fmt = Hoogle.HTML - output = unlines $ map (Hoogle.render fmt) results doLoadModule :: String -> String -> Ghc Display doLoadModule name modName = do @@ -986,7 +1048,11 @@ setSessionDynFlags flags { hscTarget = objTarget flags +#if MIN_VERSION_ghc(8,0,0) + , log_action = \dflags sev srcspan ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) +#else , log_action = \dflags sev srcspan ppr msg -> modifyIORef' errRef (showSDoc flags msg :) +#endif } -- Load the new target. @@ -1048,7 +1114,7 @@ gen <- liftIO getStdGen let rand = take 20 $ randomRs ('0', '9') gen var name = name ++ rand - goStmt s = runStmt s RunToCompletion + goStmt s = execStmt s execOptions itVariable = var "it_var_temp_" goStmt $ printf "let %s = it" itVariable @@ -1061,12 +1127,12 @@ capturedEval :: (String -> IO ()) -- ^ Function used to publish intermediate output. -> Captured a -- ^ Statement to evaluate. - -> Interpreter (String, RunResult) -- ^ Return the output and result. + -> Interpreter (String, ExecResult) -- ^ Return the output and result. capturedEval output stmt = do -- Generate random variable names to use so that we cannot accidentally override the variables by -- using the right names in the terminal. gen <- liftIO getStdGen - let + let -- Variable names generation. rand = take 20 $ randomRs ('0', '9') gen var name = name ++ rand @@ -1101,41 +1167,57 @@ , voidpf "IHaskellIO.closeFd %s" writeVariable , printf "let it = %s" itVariable ] - pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable - goStmt :: String -> Ghc RunResult - goStmt s = runStmt s RunToCompletion + goStmt :: String -> Ghc ExecResult + goStmt s = execStmt s execOptions runWithResult (CapturedStmt str) = goStmt str runWithResult (CapturedIO io) = do status <- gcatch (liftIO io >> return NoException) (return . AnyException) return $ case status of - NoException -> RunOk [] - AnyException e -> RunException e + NoException -> ExecComplete (Right []) 0 + AnyException e -> ExecComplete (Left e) 0 -- Initialize evaluation context. - void $ forM initStmts goStmt + results <- forM initStmts goStmt +#if __GLASGOW_HASKELL__ >= 800 + -- This works fine on GHC 8.0 and newer + dyn <- dynCompileExpr readVariable + pipe <- case fromDynamic dyn of + Nothing -> fail "Evaluate: Bad pipe" + Just fd -> liftIO $ do + handle <- fdToHandle fd + hSetEncoding handle utf8 + return handle +#else -- Get the pipe to read printed output from. This is effectively the source code of dynCompileExpr -- from GHC API's InteractiveEval. However, instead of using a `Dynamic` as an intermediary, it just -- directly reads the value. This is incredibly unsafe! However, for some reason the `getContext` -- and `setContext` required by dynCompileExpr (to import and clear Data.Dynamic) cause issues with -- data declarations being updated (e.g. it drops newer versions of data declarations for older ones -- for unknown reasons). First, compile down to an HValue. + let pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr -- Then convert the HValue into an executable bit, and read the value. pipe <- liftIO $ do - fd <- head <$> unsafeCoerce hValues - fdToHandle fd - + fds <- unsafeCoerce hValues + fd <- case fds of + fd : _ -> return fd + [] -> fail "Failed to evaluate pipes" + _ -> fail $ "Expected one fd, saw "++show (length fds) + handle <- fdToHandle fd + hSetEncoding handle utf8 + return handle +#endif -- Keep track of whether execution has completed. completed <- liftIO $ newMVar False finishedReading <- liftIO newEmptyMVar outputAccum <- liftIO $ newMVar "" -- Start a loop to publish intermediate results. - let + let -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an -- argument of microseconds. ms = 1000 @@ -1208,7 +1290,7 @@ (printed, result) <- capturedEval output cmd case result of - RunOk names -> do + ExecComplete (Right names) _ -> do dflags <- getSessionDynFlags let allNames = map (showPpr dflags) names @@ -1216,7 +1298,8 @@ name == "it" || name == "it" ++ show (getExecutionCounter state) nonItNames = filter (not . isItName) allNames - output = [plain printed | not . null $ strip printed] + output = [ plain printed + | not . null $ strip printed ] write state $ "Names: " ++ show allNames @@ -1239,8 +1322,8 @@ -- Return plain and html versions. Previously there was only a plain version. text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text] - RunException exception -> throw exception - RunBreak{} -> error "Should not break." + ExecComplete (Left exception) _ -> throw exception + ExecBreak{} -> error "Should not break." -- Read from a file handle until we hit a delimiter or until we've read as many characters as -- requested @@ -1269,15 +1352,18 @@ formatErrorWithClass cls = printf "%s" cls . replace "\n" "
" . + fixDollarSigns . + replace "<" "<" . + replace ">" ">" . + replace "&" "&" . replace useDashV "" . replace "Ghci" "IHaskell" . replace "‘interactive:" "‘" . - fixDollarSigns . rstrip . typeCleaner where - fixDollarSigns = replace "$" "$" - useDashV = "\nUse -v to see a list of the files searched for." + fixDollarSigns = replace "$" "$" + useDashV = "\n Use -v to see a list of the files searched for." isShowError err = "No instance for (Show" `isPrefixOf` err && isInfixOf " arising from a use of `print'" err diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -37,10 +37,12 @@ | NoResult String deriving Show -instance FromJSON [HoogleResponse] where +data HoogleResponseList = HoogleResponseList [HoogleResponse] + +instance FromJSON HoogleResponseList where parseJSON (Object obj) = do results <- obj .: "results" - mapM parseJSON results + HoogleResponseList <$> mapM parseJSON results parseJSON _ = fail "Expected object with 'results' field." @@ -54,10 +56,10 @@ -- an error message or the successful JSON result. query :: String -> IO (Either String String) query str = do - request <- parseUrl $ queryUrl $ urlEncode str + request <- parseUrlThrow $ queryUrl $ urlEncode str + mgr <- newManager tlsManagerSettings catch - (Right . CBS.unpack . LBS.toStrict . responseBody <$> withManager tlsManagerSettings - (httpLbs request)) + (Right . CBS.unpack . LBS.toStrict . responseBody <$> httpLbs request mgr) (\e -> return $ Left $ show (e :: SomeException)) where @@ -99,7 +101,7 @@ case eitherDecode $ LBS.fromStrict $ CBS.pack json of Left err -> [NoResult err] Right results -> - case map SearchResult results of + case map SearchResult $ (\(HoogleResponseList l) -> l) results of [] -> [NoResult "no matching identifiers found."] res -> res diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -17,15 +17,15 @@ import Data.Maybe (mapMaybe) import System.IO.Unsafe (unsafePerformIO) -import Language.Haskell.Exts.Annotated.Syntax hiding (Module) -import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts -import Language.Haskell.Exts.Annotated (parseFileContentsWithMode) -import Language.Haskell.Exts.Annotated.Build (doE) -import Language.Haskell.Exts.Annotated hiding (Module) +import Language.Haskell.Exts.Syntax hiding (Module) +import qualified Language.Haskell.Exts.Syntax as SrcExts +import Language.Haskell.Exts (parseFileContentsWithMode) +import Language.Haskell.Exts.Build (doE) +import Language.Haskell.Exts hiding (Module) import Language.Haskell.Exts.SrcLoc import Language.Haskell.HLint as HLint -import Language.Haskell.HLint2 +import Language.Haskell.HLint3 import IHaskell.Types import IHaskell.Display @@ -81,14 +81,15 @@ showIdea idea = case ideaTo idea of Nothing -> Nothing - Just whyNot -> Just - Suggest - { line = srcSpanStartLine $ ideaSpan idea - , found = showSuggestion $ ideaFrom idea - , whyNot = showSuggestion whyNot - , severity = ideaSeverity idea - , suggestion = ideaHint idea - } + Just whyNot -> + Just + Suggest + { line = srcSpanStartLine $ ideaSpan idea + , found = showSuggestion $ ideaFrom idea + , whyNot = showSuggestion whyNot + , severity = ideaSeverity idea + , suggestion = ideaHint idea + } createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule createModule mode (Located line block) = @@ -148,7 +149,7 @@ decl = SpliceDecl loc expr expr :: Exp SrcSpanInfo - expr = doE loc [stmt, ret] + expr = Do loc [stmt, ret] stmt :: Stmt SrcSpanInfo ParseOk stmt = parseStmtWithMode mode stmtStr @@ -187,7 +188,7 @@ _ -> "warning" style :: String -> String -> String - style = printf "
%s
" + style = printf "
%s
" named :: String -> String named = printf "
%s
" diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -59,6 +59,12 @@ import StringUtils (replace) +#if MIN_VERSION_ghc(8,0,1) +import GHC.LanguageExtensions + +type ExtensionFlag = Extension +#endif + -- | A extension flag that can be set or unset. data ExtFlag = SetFlag ExtensionFlag | UnsetFlag ExtensionFlag @@ -97,10 +103,16 @@ , O.text "other dynamic, non-language, flag settings:" O.$$ O.nest 2 (O.vcat (map (setting opt) others)) , O.text "warning settings:" O.$$ - O.nest 2 (O.vcat (map (setting wopt) DynFlags.fWarningFlags)) + O.nest 2 (O.vcat (map (setting wopt) warningFlags)) ] where +#if MIN_VERSION_ghc(8,0,0) + warningFlags = DynFlags.wWarningFlags +#else + warningFlags = DynFlags.fWarningFlags +#endif + #if MIN_VERSION_ghc(7,8,0) opt = gopt #else @@ -239,7 +251,11 @@ originalFlags <- getSessionDynFlags let flag = flip xopt_set unflag = flip xopt_unset +#if MIN_VERSION_ghc(8,0,0) + dflags = flag ExtendedDefaultRules . unflag MonomorphismRestriction $ originalFlags +#else dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags +#endif pkgConfs = case sandboxPackages of Nothing -> extraPkgConfs originalFlags @@ -323,16 +339,23 @@ in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } } where instEq :: ClsInst -> ClsInst -> Bool -#if MIN_VERSION_ghc(7,8,0) +#if MIN_VERSION_ghc(8,0,0) -- Only support replacing instances on GHC 7.8 and up instEq c1 c2 | ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1, ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2 + = cls == cls' && isJust (tcMatchTys tpl_tys tpl_tys') +#elif MIN_VERSION_ghc(7,8,0) + instEq c1 c2 + | ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1, + ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2 = let tpl_tv_set = mkVarSet tpl_tvs in cls == cls' && isJust (tcMatchTys tpl_tv_set tpl_tys tpl_tys') #else instEq _ _ = False #endif + + -- | Get the type of an expression and convert it to a string. getType :: GhcMonad m => String -> m String getType expr = do diff --git a/src/IHaskell/Eval/Widgets.hs b/src/IHaskell/Eval/Widgets.hs --- a/src/IHaskell/Eval/Widgets.hs +++ b/src/IHaskell/Eval/Widgets.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} module IHaskell.Eval.Widgets ( widgetSendOpen, widgetSendView, diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-} module IHaskell.Flags ( diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} -- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and @@ -28,7 +29,7 @@ import System.Directory import System.Exit (exitFailure) import Data.Aeson (toJSON) -import Data.Aeson.Encode (encodeToTextBuilder) +import Data.Aeson.Text (encodeToTextBuilder) import Data.Text.Lazy.Builder (toLazyText) import Control.Monad (mplus) @@ -76,9 +77,9 @@ locateIPython :: SH.Sh SH.FilePath locateIPython = do - mbinary <- SH.which "ipython" + mbinary <- SH.which "jupyter" case mbinary of - Nothing -> SH.errorExit "The IPython binary could not be located" + Nothing -> SH.errorExit "The Jupyter binary could not be located" Just ipython -> return ipython -- | Run the IPython command with any arguments. The kernel is set to IHaskell. diff --git a/src/IHaskell/Publish.hs b/src/IHaskell/Publish.hs --- a/src/IHaskell/Publish.hs +++ b/src/IHaskell/Publish.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} module IHaskell.Publish (publishResult) where import IHaskellPrelude diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} @@ -66,9 +67,9 @@ -- | Display as an interactive widget. class IHaskellDisplay a => IHaskellWidget a where -- | Target name for this widget. The actual input parameter should be ignored. By default evaluate - -- to "ipython.widget", which is used by IPython for its backbone widgets. + -- to "jupyter.widget", which is used by IPython for its backbone widgets. targetName :: a -> String - targetName _ = "ipython.widget" + targetName _ = "jupyter.widget" -- | Target module for this widget. Evaluates to an empty string by default. targetModule :: a -> String @@ -152,7 +153,7 @@ defaultKernelState = KernelState { getExecutionCounter = 1 , getLintStatus = LintOn - , useSvg = True + , useSvg = False , useShowErrors = False , useShowTypes = False , usePager = True diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs --- a/src/IHaskellPrelude.hs +++ b/src/IHaskellPrelude.hs @@ -1,3 +1,4 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} module IHaskellPrelude ( module IHaskellPrelude, @@ -78,7 +79,9 @@ import GHC.Num as X import GHC.Real as X import GHC.Err as X hiding (absentErr) -#if MIN_VERSION_ghc(7,10,0) +#if MIN_VERSION_ghc(8,0,0) +import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..)) +#elif MIN_VERSION_ghc(7,10,0) import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>)) #else import GHC.Base as X hiding (Any) diff --git a/src/tests/Hspec.hs b/src/tests/Hspec.hs new file mode 100644 --- /dev/null +++ b/src/tests/Hspec.hs @@ -0,0 +1,16 @@ +module Main where + +import Prelude + +import Test.Hspec + +import IHaskell.Test.Completion (testCompletions) +import IHaskell.Test.Parser (testParser) +import IHaskell.Test.Eval (testEval) + +main :: IO () +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 --- /dev/null +++ b/src/tests/IHaskell/Test/Completion.hs @@ -0,0 +1,226 @@ +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} +{-# LANGUAGE CPP #-} +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) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + +-- | @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 --- /dev/null +++ b/src/tests/IHaskell/Test/Eval.hs @@ -0,0 +1,164 @@ +{-# 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 (fixQuotes $ 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 + + fixQuotes :: String -> String +#if MIN_VERSION_ghc(7, 8, 0) + fixQuotes = id +#else + fixQuotes = map $ \char -> case char of + '\8216' -> '`' + '\8217' -> '\'' + c -> c +#endif + + +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 "prints Unicode characters correctly" $ do + "putStrLn \"Héllö, Üñiço∂e!\"" `becomes` ["Héllö, Üñiço∂e!"] + "putStrLn \"Привет!\"" `becomes` ["Привет!"] + + it "evaluates directives" $ do + ":typ 3" `becomes` ["3 :: forall t. Num t => t"] + ":k Maybe" `becomes` ["Maybe :: * -> *"] + ":in String" `pages` ["type String = [Char] \t-- Defined in \8216GHC.Base\8217"] diff --git a/src/tests/IHaskell/Test/Parser.hs b/src/tests/IHaskell/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/src/tests/IHaskell/Test/Parser.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +module IHaskell.Test.Parser (testParser) where + +import Prelude + +import Data.String.Here (hereLit) + +import Test.Hspec +import Test.Hspec.Contrib.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) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + + +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" + ] + it "deals with quasiquotes" $ do + let parsesAsBlocks strs = map unloc (layoutChunks $ unlines strs) `shouldBe` strs + parsesAsBlocks ["let x = [q|a quasiquote|]"] + parsesAsBlocks ["let x = [q|a quasiquote|]", "3"] + parsesAsBlocks ["let x = [q|a quasiquote\n|]"] + parsesAsBlocks ["let x = [q|\na quasiquote\n|]"] + parsesAsBlocks ["let x = \"[q|doesn't matter\""] + parsesAsBlocks ["[q|q<-[1..10]]"] + parsesAsBlocks ["[q|x|] [q|x|]"] + parsesAsBlocks ["[q|\nx\n|] [q|x|]"] + + +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 --- /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