ihaskell 0.8.4.0 → 0.9.0.0
raw patch · 22 files changed
+1082/−912 lines, 22 filesdep +ghc-bootdep +heredep +hspec-contribdep ~aesondep ~basedep ~ghc
Dependencies added: ghc-boot, here, hspec-contrib
Dependency ranges changed: aeson, base, ghc, ghc-paths, haskell-src-exts, hlint, http-client, http-client-tls, ipython-kernel, setenv, shelly, text
Files
- Hspec.hs +0/−619
- ihaskell.cabal +34/−67
- main/IHaskellPrelude.hs +4/−2
- main/Main.hs +12/−2
- src/IHaskell/CSS.hs +91/−90
- src/IHaskell/Display.hs +4/−4
- src/IHaskell/Eval/Completion.hs +11/−4
- src/IHaskell/Eval/Evaluate.hs +179/−93
- src/IHaskell/Eval/Hoogle.hs +8/−6
- src/IHaskell/Eval/Lint.hs +17/−16
- src/IHaskell/Eval/Util.hs +25/−2
- src/IHaskell/Eval/Widgets.hs +1/−0
- src/IHaskell/Flags.hs +1/−0
- src/IHaskell/IPython.hs +4/−3
- src/IHaskell/Publish.hs +1/−0
- src/IHaskell/Types.hs +4/−3
- src/IHaskellPrelude.hs +4/−1
- src/tests/Hspec.hs +16/−0
- src/tests/IHaskell/Test/Completion.hs +226/−0
- src/tests/IHaskell/Test/Eval.hs +164/−0
- src/tests/IHaskell/Test/Parser.hs +240/−0
- src/tests/IHaskell/Test/Util.hs +36/−0
− Hspec.hs
@@ -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 "</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 --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
ihaskell.cabal view
@@ -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
main/IHaskellPrelude.hs view
@@ -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)
main/Main.hs view
@@ -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.
src/IHaskell/CSS.hs view
@@ -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;"+ , "}"+ ]
src/IHaskell/Display.hs view
@@ -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.
src/IHaskell/Eval/Completion.hs view
@@ -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)
src/IHaskell/Eval/Evaluate.hs view
@@ -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- "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>"- str- ++ script- script =- "<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>"+ -- Make pager work without html by porting to newer architecture+ let htmlify str =+ html $+ concat+ [ "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>"+ , str+ , "</textarea></form></div>"+ , "<script>CodeMirror.fromTextArea(document.getElementById('code'),"+ , " {mode: 'haskell', readOnly: 'nocursor'});</script>"+ ] 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 "<span class='%s'>%s</span>" cls . replace "\n" "<br/>" .+ fixDollarSigns .+ replace "<" "<" .+ replace ">" ">" .+ replace "&" "&" . replace useDashV "" . replace "Ghci" "IHaskell" . replace "‘interactive:" "‘" .- fixDollarSigns . rstrip . typeCleaner where- fixDollarSigns = replace "$" "<span>$</span>"- useDashV = "\nUse -v to see a list of the files searched for."+ fixDollarSigns = replace "$" "<span>$</span>"+ 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
src/IHaskell/Eval/Hoogle.hs view
@@ -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
src/IHaskell/Eval/Lint.hs view
@@ -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 "<div class=\"suggestion-%s\">%s</div>"+ style = printf "<div class=\"suggestion-%s\">%s</div>" named :: String -> String named = printf "<div class=\"suggestion-name\" style=\"clear:both;\">%s</div>"
src/IHaskell/Eval/Util.hs view
@@ -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
src/IHaskell/Eval/Widgets.hs view
@@ -1,3 +1,4 @@+{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} module IHaskell.Eval.Widgets ( widgetSendOpen, widgetSendView,
src/IHaskell/Flags.hs view
@@ -1,3 +1,4 @@+{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-} module IHaskell.Flags (
src/IHaskell/IPython.hs view
@@ -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.
src/IHaskell/Publish.hs view
@@ -1,3 +1,4 @@+{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} module IHaskell.Publish (publishResult) where import IHaskellPrelude
src/IHaskell/Types.hs view
@@ -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
src/IHaskellPrelude.hs view
@@ -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)
+ src/tests/Hspec.hs view
@@ -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
+ src/tests/IHaskell/Test/Completion.hs view
@@ -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
+ src/tests/IHaskell/Test/Eval.hs view
@@ -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 "</script>" 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"]
+ src/tests/IHaskell/Test/Parser.hs view
@@ -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
+ src/tests/IHaskell/Test/Util.hs view
@@ -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