ihaskell 0.5.0.0 → 0.6.0.0
raw patch · 29 files changed
+3654/−3635 lines, 29 filesdep +bin-package-dbdep −template-haskelldep ~basedep ~ghcdep ~ghc-parsersetup-changednew-component:exe:ihaskellbinary-added
Dependencies added: bin-package-db
Dependencies removed: template-haskell
Dependency ranges changed: base, ghc, ghc-parser, ipython-kernel, mono-traversable, shelly
Files
- Hspec.hs +601/−0
- Setup.hs +1/−24
- html/custom.css +96/−0
- html/kernel.js +87/−0
- html/logo-64x64.png binary
- ihaskell.cabal +81/−73
- installation/ipython.sh +0/−32
- installation/run.sh +0/−20
- installation/virtualenv.sh +0/−18
- profile/profile.tar binary
- src/Hspec.hs +0/−576
- src/IHaskell/BrokenPackages.hs +18/−20
- src/IHaskell/Convert.hs +21/−19
- src/IHaskell/Convert/Args.hs +67/−73
- src/IHaskell/Convert/IpynbToLhs.hs +32/−32
- src/IHaskell/Convert/LhsToIpynb.hs +75/−57
- src/IHaskell/Display.hs +69/−65
- src/IHaskell/Eval/Completion.hs +190/−170
- src/IHaskell/Eval/Evaluate.hs +1254/−1213
- src/IHaskell/Eval/Hoogle.hs +119/−107
- src/IHaskell/Eval/Info.hs +10/−12
- src/IHaskell/Eval/Lint.hs +102/−112
- src/IHaskell/Eval/ParseShell.hs +23/−22
- src/IHaskell/Eval/Parser.hs +124/−134
- src/IHaskell/Eval/Util.hs +192/−102
- src/IHaskell/Flags.hs +77/−116
- src/IHaskell/IPython.hs +165/−313
- src/IHaskell/Types.hs +102/−145
- src/Main.hs +148/−180
+ Hspec.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules, CPP #-}+-- Keep all the language pragmas here so it can be compiled separately.+module Main where+import Prelude+import GHC+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)+import qualified Shelly+import Control.Applicative ((<$>))+import Filesystem.Path.CurrentOS (encodeString)+import System.SetEnv (setEnv)+import Data.String.Here+import Data.String.Utils (strip, replace)+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)++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 :)++ getTemporaryDirectory >>= setCurrentDirectory+ let state = defaultKernelState { getLintStatus = LintOff }+ interpret libdir False $ Eval.evaluate state string publish+ out <- readIORef outputAccum+ pagerOut <- readIORef pagerAccum+ return (reverse out, unlines $ 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 (encodeString 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 ["" </> "dir", "dir" </> "dir1"]+ [""</> "file1.hs", "dir" </> "file2.hs", + "" </> "file1.lhs", "dir" </> "file2.lhs"]++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 " ++ encodeString xs+ paths = map encodeString+ 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 encodeString ["" </> "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" (encodeString 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" (encodeString 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
Setup.hs view
@@ -1,25 +1,2 @@ import Distribution.Simple--import Control.Applicative ((<$>))-import Data.List (isInfixOf)-import Codec.Archive.Tar (create)-import System.Directory (getDirectoryContents)---- This is currently *not used*. build-type is Simple.--- This is because it breaks installing from Hackage.-main = defaultMainWithHooks simpleUserHooks {- preBuild = makeProfileTar- }--makeProfileTar args flags = do- putStrLn "Building profile.tar."-- let profileDir = "profile"- tarFile = profileDir ++ "/profile.tar"- files <- filter realFile <$> filter notProfileTar <$> getDirectoryContents profileDir- print files- create tarFile profileDir files- preBuild simpleUserHooks args flags- where- notProfileTar str = not $ "profile.tar" `isInfixOf` str- realFile str = str /= "." && str /= ".."+main = defaultMain
+ html/custom.css view
@@ -0,0 +1,96 @@+/*+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;+}
+ html/kernel.js view
@@ -0,0 +1,87 @@++define(['require',+ 'codemirror/lib/codemirror',+ 'codemirror/addon/mode/loadmode',+ 'base/js/namespace',+ 'base/js/events',+ 'base/js/utils'],+ function(require, CodeMirror, CodemirrorLoadmode, IPython, events, utils){++ var onload = function(){+ console.log('Kernel haskell kernel.js is loading.');++ // add here logic that shoudl be run once per **page load**+ // like adding specific UI, or changing the default value+ // of codecell highlight.++ // Set tooltips to be triggered after 800ms+ IPython.tooltip.time_before_tooltip = 800;++ // IPython keycodes.+ var space = 32;+ var downArrow = 40;+ IPython.keyboard.keycodes.down = downArrow; // space++ IPython.CodeCell.options_default['cm_config']['mode'] = 'haskell';++ utils.requireCodeMirrorMode('haskell', function(){+ // Create a multiplexing mode that uses Haskell highlighting by default but+ // doesn't highlight command-line directives.+ CodeMirror.defineMode("ihaskell", function(config) {+ return CodeMirror.multiplexingMode(+ CodeMirror.getMode(config, "haskell"),+ {+ open: /:(?=!)/, // Matches : followed by !, but doesn't consume !+ close: /^(?!!)/, // Matches start of line not followed by !, doesn't consume character+ mode: CodeMirror.getMode(config, "text/plain"),+ delimStyle: "delimit"+ }+ );+ });++ cells = IPython.notebook.get_cells();+ for(var i in cells){+ c = cells[i];+ if (c.cell_type === 'code') {+ // Force the mode to be Haskell+ // This is necessary, otherwise sometimes highlighting just doesn't happen.+ // This may be an IPython bug.+ c.code_mirror.setOption('mode', 'ihaskell');+ c.auto_highlight();+ }+ }+ });++ // Prevent the pager from surrounding everything with a <pre>+ IPython.Pager.prototype.append_text = function (text) {+ this.pager_element.find(".container").append($('<div/>').html(IPython.utils.autoLinkUrls(text)));+ };++ events.on('shell_reply.Kernel', function() {+ // Add logic here that should be run once per reply.++ // Highlight things with a .highlight-code class+ // The id is the mode with with to highlight+ $('.highlight-code').each(function() {+ var $this = $(this),+ $code = $this.html(),+ $unescaped = $('<div/>').html($code).text();++ $this.empty();++ // Never highlight this block again.+ this.className = "";++ CodeMirror(this, {+ value: $unescaped,+ mode: this.id,+ lineNumbers: false,+ readOnly: true+ });+ });+ });+ console.log('IHaskell kernel.js should have been loaded.')+ } // end def of onload+ return {onload:onload};+ }+);
+ html/logo-64x64.png view
binary file changed (absent → 2924 bytes)
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.5.0.0+version: 0.6.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project.@@ -43,28 +43,32 @@ cabal-version: >=1.16 data-files: - installation/ipython.sh- installation/virtualenv.sh- installation/run.sh- profile/profile.tar+ html/kernel.js+ html/custom.css+ html/logo-64x64.png +flag binPkgDb+ default: True+ description: bin-package-db package needed (needed for GHC >= 7.10)+ library hs-source-dirs: src default-language: Haskell2010 build-depends: aeson >=0.6 && < 0.9,- base >=4.6 && < 4.8,+ base >=4.6 && < 4.9, base64-bytestring >=1.0, bytestring >=0.10, cereal >=0.3, classy-prelude >=0.9.5 && <0.11,- mono-traversable >=0.6 && < 0.7,+ mono-traversable >=0.6, cmdargs >=0.10, containers >=0.5, directory -any, filepath -any,- ghc ==7.6.* || == 7.8.*,- ghc-parser >=0.1.4,+ ghc >=7.6 || < 7.11,+ ghc-parser >=0.1.6,+ ghc-paths ==0.1.*, haskeline -any, here ==1.2.*, hlint >=1.9 && <2.0,@@ -78,14 +82,13 @@ parsec -any, process >=1.1, random >=1.0,- shelly ==1.5.*,+ shelly >=1.5, split >= 0.2, stm -any, strict >=0.3, system-argv0 -any, system-filepath -any, tar -any,- template-haskell -any, text >=0.11, transformers -any, unix >= 2.6,@@ -93,7 +96,9 @@ utf8-string -any, uuid >=1.3, vector -any,- ipython-kernel >=0.3+ ipython-kernel >=0.6+ if flag(binPkgDb)+ build-depends: bin-package-db exposed-modules: IHaskell.Display IHaskell.Convert@@ -116,88 +121,91 @@ -- other-modules: -- Paths_ihaskell -executable IHaskell+executable ihaskell -- .hs or .lhs file containing the Main module. main-is: src/Main.hs ghc-options: -threaded-- default-extensions: DoAndIfThenElse -- Other library packages from which modules are imported. default-language: Haskell2010 build-depends: - base >=4.6 && < 4.8,- ghc-paths ==0.1.*,+ base >=4.6 && < 4.9, aeson >=0.6 && < 0.9, bytestring >=0.10, cereal >=0.3, classy-prelude >=0.9.2 && <0.11,- mono-traversable >=0.6 && < 0.7,+ mono-traversable >=0.6, containers >=0.5, directory -any,- ghc ==7.6.* || == 7.8.*,+ ghc >=7.6 && < 7.11, ihaskell -any, MissingH >=1.2,+ here ==1.2.*, text -any,- ipython-kernel >= 0.2,+ ipython-kernel >= 0.6, unix >= 2.6+ if flag(binPkgDb)+ build-depends: bin-package-db Test-Suite hspec- hs-source-dirs: src- Type: exitcode-stdio-1.0- Ghc-Options: -threaded- Main-Is: Hspec.hs- default-language: Haskell2010- build-depends: - aeson >=0.6 && < 0.9,- base >=4.6 && < 4.8,- base64-bytestring >=1.0,- bytestring >=0.10,- cereal >=0.3,- classy-prelude >=0.9.2 && <0.11,- mono-traversable >=0.6 && < 0.7,- cmdargs >=0.10,- containers >=0.5,- directory -any,- filepath -any,- ghc ==7.6.* || == 7.8.*,- ghc-parser >=0.1.1,- ghc-paths ==0.1.*,- haskeline -any,- here ==1.2.*,- hlint >=1.9 && <2.0,- haskell-src-exts ==1.16.*,- hspec -any,- HUnit -any,- MissingH >=1.2,- 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,- system-filepath -any,- tar -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.2+ Type: exitcode-stdio-1.0+ Ghc-Options: -threaded+ Main-Is: Hspec.hs+ default-language: Haskell2010+ build-depends:+ ihaskell,+ aeson >=0.6 && < 0.9,+ base >=4.6 && < 4.9,+ base64-bytestring >=1.0,+ bytestring >=0.10,+ cereal >=0.3,+ classy-prelude >=0.9.2 && <0.11,+ mono-traversable >=0.6,+ cmdargs >=0.10,+ containers >=0.5,+ directory -any,+ filepath -any,+ ghc >=7.6 && < 7.11,+ ghc-parser >=0.1.6,+ ghc-paths ==0.1.*,+ haskeline -any,+ here ==1.2.*,+ hlint >=1.9 && <2.0,+ haskell-src-exts ==1.16.*,+ hspec -any,+ HUnit -any,+ MissingH >=1.2,+ 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,+ system-filepath -any,+ tar -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.6 + if flag(binPkgDb)+ build-depends: bin-package-db - default-extensions:- DoAndIfThenElse- OverloadedStrings- ExtendedDefaultRules+ default-extensions:+ DoAndIfThenElse+ OverloadedStrings+ ExtendedDefaultRules+ source-repository head type: git
− installation/ipython.sh
@@ -1,32 +0,0 @@-#!/bin/bash-set -e--# Which virtualenv to use.-VIRTUALENV=$1--# Activate the virtualenv.-source $VIRTUALENV/bin/activate--# Upgrade pip.-echo "Upgrading pip."-pip install --upgrade "pip>=1.4.1"--# Install all necessary dependencies with Pip.-echo "Installing dependency (pyzmq)."-pip install pyzmq==14.0.1--echo "Installing dependency (markupsafe)."-pip install markupsafe==0.18--echo "Installing dependency (jinja2)."-pip install jinja2==2.7.1--echo "Installing dependency (tornado)."-pip install tornado==3.1.1--echo "Installing dependency (pygments)."-pip install pygments==1.6--# Install IPython itself.-echo "Installing IPython (this may take a while)."-pip install ipython
− installation/run.sh
@@ -1,20 +0,0 @@-#!/bin/bash-set -e--# Which virtualenv to use.-VIRTUALENV=$1-shift--# Activate the virtualenv, if it exists.-if [[ -f $VIRTUALENV/bin/activate ]]; then- source $VIRTUALENV/bin/activate;-fi--# Run IPython.-# Quotes around $@ are necessary to deal properly with spaces.-# Only add IHASKELL_IPYTHON_ARGS to notebook.-if [[ $1 == "notebook" ]]; then- ipython "$@" $IHASKELL_IPYTHON_ARGS-else- ipython "$@"-fi
− installation/virtualenv.sh
@@ -1,18 +0,0 @@-#!/bin/bash-set -e--# Which version of virtualenv to use.-VIRTUALENV=virtualenv-1.9.1--# Where to install the virtualenv.-DESTINATION=$1--# Download virtualenv.-echo "Downloading virtualenv."-curl -O https://pypi.python.org/packages/source/v/virtualenv/$VIRTUALENV.tar.gz-tar xvfz $VIRTUALENV.tar.gz-cd $VIRTUALENV--# Create a virtualenv.-echo "Creating a virtualenv."-python virtualenv.py $DESTINATION
− profile/profile.tar
binary file changed (73728 → absent bytes)
− src/Hspec.hs
@@ -1,576 +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 GHC-import GHC.Paths-import Data.IORef-import Control.Monad-import Control.Monad.Trans ( MonadIO, liftIO )-import Data.List-import System.Directory-import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir, mkdir_p,- touchfile)-import qualified Shelly-import Control.Applicative ((<$>))-import Filesystem.Path.CurrentOS (encodeString)-import System.SetEnv (setEnv)-import Data.String.Here-import Data.String.Utils (strip, replace)-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)--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 :)-- getTemporaryDirectory >>= setCurrentDirectory- let state = defaultKernelState { getLintStatus = LintOff }- interpret libdir False $ Eval.evaluate state string publish- out <- readIORef outputAccum- pagerOut <- readIORef pagerAccum- return (reverse out, unlines $ 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 pageOut `shouldBe` strip (unlines expected)--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 (encodeString 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 ["" </> "dir", "dir" </> "dir1"]- [""</> "file1.hs", "dir" </> "file2.hs", - "" </> "file1.lhs", "dir" </> "file2.lhs"]--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 " ++ encodeString xs- paths = map encodeString- 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 encodeString ["" </> "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" (encodeString 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" (encodeString 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 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 :: * -> *"]- ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"]--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
src/IHaskell/BrokenPackages.hs view
@@ -1,40 +1,38 @@-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}+ module IHaskell.BrokenPackages (getBrokenPackages) where -import ClassyPrelude hiding ((<|>))+import ClassyPrelude hiding ((<|>)) -import Text.Parsec-import Text.Parsec.String-import Control.Applicative hiding ((<|>), many)+import Text.Parsec+import Text.Parsec.String+import Control.Applicative hiding ((<|>), many) -import Data.String.Utils (startswith)+import Data.String.Utils (startswith) -import Shelly+import Shelly -data BrokenPackage = BrokenPackage {- packageID :: String,- brokenDeps :: [String]- }+data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] } instance Show BrokenPackage where show = packageID --- | Get a list of broken packages.--- This function internally shells out to `ghc-pkg`, and parses the output--- in order to determine what packages are broken.+-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the+-- output in order to determine what packages are broken. getBrokenPackages :: IO [String] getBrokenPackages = shelly $ do silently $ errExit False $ run "ghc-pkg" ["check"] checkOut <- lastStderr- + -- Get rid of extraneous things- let rightStart str = startswith "There are problems" str || - startswith " dependency" str + let rightStart str = startswith "There are problems" str ||+ startswith " dependency" str ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut - return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of- Left err -> []- Right pkgs -> map show pkgs+ return $+ case parse (many check) "ghc-pkg output" ghcPkgOutput of+ Left err -> []+ Right pkgs -> map show pkgs check :: Parser BrokenPackage check = string "There are problems in package "
src/IHaskell/Convert.hs view
@@ -1,27 +1,31 @@ -- | Description : mostly reversible conversion between ipynb and lhs module IHaskell.Convert (convert) where-import Control.Monad.Identity (Identity(Identity), unless, when)-import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)-import IHaskell.Convert.IpynbToLhs (ipynbToLhs)-import IHaskell.Convert.LhsToIpynb (lhsToIpynb)-import IHaskell.Flags (Argument)-import System.Directory (doesFileExist)-import Text.Printf (printf) +import Control.Monad.Identity (Identity(Identity), unless, when)+import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)+import IHaskell.Convert.IpynbToLhs (ipynbToLhs)+import IHaskell.Convert.LhsToIpynb (lhsToIpynb)+import IHaskell.Flags (Argument)+import System.Directory (doesFileExist)+import Text.Printf (printf)+ -- | used by @IHaskell convert@ convert :: [Argument] -> IO ()-convert args = case fromJustConvertSpec (toConvertSpec args) of- ConvertSpec { convertToIpynb = Identity toIpynb,- convertInput = Identity inputFile,- convertOutput = Identity outputFile,- convertLhsStyle = Identity lhsStyle,- convertOverwriteFiles = force }+convert args =+ case fromJustConvertSpec (toConvertSpec args) of+ ConvertSpec+ { convertToIpynb = Identity toIpynb+ , convertInput = Identity inputFile+ , convertOutput = Identity outputFile+ , convertLhsStyle = Identity lhsStyle+ , convertOverwriteFiles = force+ } | toIpynb -> do- unless force (failIfExists outputFile)- lhsToIpynb lhsStyle inputFile outputFile+ unless force (failIfExists outputFile)+ lhsToIpynb lhsStyle inputFile outputFile | otherwise -> do- unless force (failIfExists outputFile)- ipynbToLhs lhsStyle inputFile outputFile+ unless force (failIfExists outputFile)+ ipynbToLhs lhsStyle inputFile outputFile -- | Call fail when the named file already exists. failIfExists :: FilePath -> IO ()@@ -29,5 +33,3 @@ exists <- doesFileExist file when exists $ fail $ printf "File %s already exists. To force supply --force." file--
src/IHaskell/Convert/Args.hs view
@@ -1,107 +1,101 @@ -- | Description: interpret flags parsed by "IHaskell.Flags"-module IHaskell.Convert.Args- (ConvertSpec(..),- fromJustConvertSpec,- toConvertSpec,- ) where+module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where -import Control.Applicative ((<$>))-import Control.Monad.Identity (Identity(Identity))-import Data.Char (toLower)-import Data.List (partition)-import Data.Maybe (fromMaybe)+import Control.Applicative ((<$>))+import Control.Monad.Identity (Identity(Identity))+import Data.Char (toLower)+import Data.List (partition)+import Data.Maybe (fromMaybe) import qualified Data.Text.Lazy as T (pack, Text)-import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))-import System.FilePath ((<.>), dropExtension, takeExtension)-import Text.Printf (printf)-+import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))+import System.FilePath ((<.>), dropExtension, takeExtension)+import Text.Printf (printf) -- | ConvertSpec is the accumulator for command line arguments-data ConvertSpec f = ConvertSpec- { convertToIpynb :: f Bool,- convertInput :: f FilePath,- convertOutput :: f FilePath,- convertLhsStyle :: f (LhsStyle T.Text),- convertOverwriteFiles :: Bool- }+data ConvertSpec f =+ ConvertSpec+ { convertToIpynb :: f Bool+ , convertInput :: f FilePath+ , convertOutput :: f FilePath+ , convertLhsStyle :: f (LhsStyle T.Text)+ , convertOverwriteFiles :: Bool+ } --- | Convert a possibly-incomplete specification for what to convert--- into one which can be executed. Calls error when data is missing.-fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity-fromJustConvertSpec convertSpec = convertSpec {- convertToIpynb = Identity toIpynb,- convertInput = Identity inputFile,- convertOutput = Identity outputFile,- convertLhsStyle = Identity $ fromMaybe- (T.pack <$> lhsStyleBird)- (convertLhsStyle convertSpec)- }+-- | Convert a possibly-incomplete specification for what to convert into one which can be executed.+-- Calls error when data is missing.+fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity+fromJustConvertSpec convertSpec = convertSpec+ { convertToIpynb = Identity toIpynb+ , convertInput = Identity inputFile+ , convertOutput = Identity outputFile+ , convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)+ } where toIpynb = fromMaybe (error "Error: direction for conversion unknown")- (convertToIpynb convertSpec)- (inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of+ (convertToIpynb convertSpec)+ (inputFile, outputFile) =+ case (convertInput convertSpec, convertOutput convertSpec) of (Nothing, Nothing) -> error "Error: no files specified for conversion"- (Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb")- | otherwise -> (i, dropExtension i <.> "lhs")- (Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o)- | otherwise -> (dropExtension o <.> "ipynb", o)+ (Just i, Nothing)+ | toIpynb -> (i, dropExtension i <.> "ipynb")+ | otherwise -> (i, dropExtension i <.> "lhs")+ (Nothing, Just o)+ | toIpynb -> (dropExtension o <.> "lhs", o)+ | otherwise -> (dropExtension o <.> "ipynb", o) (Just i, Just o) -> (i, o) -- | Does this @Argument@ explicitly request a file format?-isFormatSpec :: Argument -> Bool+isFormatSpec :: Argument -> Bool isFormatSpec (ConvertToFormat _) = True isFormatSpec (ConvertFromFormat _) = True isFormatSpec _ = False - toConvertSpec :: [Argument] -> ConvertSpec Maybe-toConvertSpec args = mergeArgs otherArgs- (mergeArgs formatSpecArgs initialConvertSpec)+toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec) where (formatSpecArgs, otherArgs) = partition isFormatSpec args initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False -mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe+mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe mergeArgs args initialConvertSpec = foldr mergeArg initialConvertSpec args -mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe+mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True } mergeArg (ConvertLhsStyle lhsStyle) convertSpec | Just previousLhsStyle <- convertLhsStyle convertSpec,- previousLhsStyle /= fmap T.pack lhsStyle = error $ printf- "Conflicting lhs styles requested: <%s> and <%s>"- (show lhsStyle) (show previousLhsStyle)+ previousLhsStyle /= fmap T.pack lhsStyle+ = error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)+ (show previousLhsStyle) | otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) } mergeArg (ConvertFrom inputFile) convertSpec | Just previousInputFile <- convertInput convertSpec,- previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>"- inputFile previousInputFile- | otherwise = convertSpec {- convertInput = Just inputFile,- convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of- (prev, Nothing) -> prev- (prev @ (Just _), _) -> prev- (Nothing, format) -> fmap (== LhsMarkdown) format- }-+ previousInputFile /= inputFile+ = error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile+ | otherwise = convertSpec+ { convertInput = Just inputFile+ , convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of+ (prev, Nothing) -> prev+ (prev@(Just _), _) -> prev+ (Nothing, format) -> fmap (== LhsMarkdown) format+ } mergeArg (ConvertTo outputFile) convertSpec | Just previousOutputFile <- convertOutput convertSpec,- previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>"- outputFile previousOutputFile- | otherwise = convertSpec {- convertOutput = Just outputFile,- convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of- (prev, Nothing) -> prev- (prev @ (Just _), _) -> prev- (Nothing, format) -> fmap (== IpynbFile) format- }-+ previousOutputFile /= outputFile+ = error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile+ | otherwise = convertSpec+ { convertOutput = Just outputFile+ , convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of+ (prev, Nothing) -> prev+ (prev@(Just _), _) -> prev+ (Nothing, format) -> fmap (== IpynbFile) format+ } mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "- ++ show unexpectedArg+ ++ show unexpectedArg -- | Guess the format based on the file extension.-fromExt :: FilePath -> Maybe NotebookFormat-fromExt s = case map toLower (takeExtension s) of- ".lhs" -> Just LhsMarkdown- ".ipynb" -> Just IpynbFile- _ -> Nothing+fromExt :: FilePath -> Maybe NotebookFormat+fromExt s =+ case map toLower (takeExtension s) of+ ".lhs" -> Just LhsMarkdown+ ".ipynb" -> Just IpynbFile+ _ -> Nothing
src/IHaskell/Convert/IpynbToLhs.hs view
@@ -1,66 +1,66 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+ module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where -import Control.Applicative ((<$>))-import Data.Aeson (decode, Object, Value(Array, Object, String))+import Control.Applicative ((<$>))+import Data.Aeson (decode, Object, Value(Array, Object, String)) import qualified Data.ByteString.Lazy as L (readFile) import qualified Data.HashMap.Strict as M (lookup)-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), Monoid(mempty))+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>), Monoid(mempty)) import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines) import qualified Data.Text.Lazy.IO as T (writeFile)-import Data.Vector (Vector)+import Data.Vector (Vector) import qualified Data.Vector as V (map, mapM, toList)-import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix))+import IHaskell.Flags (LhsStyle(..)) ipynbToLhs :: LhsStyle T.Text- -> FilePath -- ^ the filename of an ipython notebook- -> FilePath -- ^ the filename of the literate haskell to write- -> IO ()+ -> FilePath -- ^ the filename of an ipython notebook+ -> FilePath -- ^ the filename of the literate haskell to write+ -> IO () ipynbToLhs sty from to = do Just (js :: Object) <- decode <$> L.readFile from- case M.lookup "worksheets" js of- Just (Array worksheets)- | [ Object worksheet ] <- V.toList worksheets,- Just (Array cells) <- M.lookup "cells" worksheet ->- T.writeFile to $ T.unlines $ V.toList- $ V.map (\(Object y) -> convCell sty y) cells- _ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema" + case M.lookup "cells" js of+ Just (Array cells) ->+ T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells+ _ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema" concatWithPrefix :: T.Text -- ^ the prefix to add to every line- -> Vector Value -- ^ a json array of text lines- -> Maybe T.Text+ -> Vector Value -- ^ a json array of text lines+ -> Maybe T.Text concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr toStr :: Value -> Maybe T.Text toStr (String x) = Just (T.fromStrict x) toStr _ = Nothing --- | @convCell sty cell@ converts a single cell in JSON into text suitable--- for the type of lhs file described by the @sty@+-- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file+-- described by the @sty@ convCell :: LhsStyle T.Text -> Object -> T.Text convCell _sty object | Just (String "markdown") <- M.lookup "cell_type" object,- Just (Array xs) <- M.lookup "source" object,- ~ (Just s) <- concatWithPrefix "" xs = s+ Just (Array xs) <- M.lookup "source" object,+ ~(Just s) <- concatWithPrefix "" xs+ = s convCell sty object- | Just (String "code") <- M.lookup "cell_type" object,- Just (Array i) <- M.lookup "input" object,- Just (Array o) <- M.lookup "outputs" object,- ~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i,- o <- fromMaybe mempty (convOutputs sty o) = "\n" <>- lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"+ | Just (String "code") <- M.lookup "cell_type" object,+ Just (Array i) <- M.lookup "source" object,+ Just (Array o) <- M.lookup "outputs" object,+ ~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,+ o <- fromMaybe mempty (convOutputs sty o)+ = "\n" <>+ lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n" convCell _ _ = "IHaskell.Convert.convCell: unknown cell" -convOutputs :: LhsStyle T.Text- -> Vector Value -- ^ JSON array of output lines containing text or markup- -> Maybe T.Text+convOutputs :: LhsStyle T.Text+ -> Vector Value -- ^ JSON array of output lines containing text or markup+ -> Maybe T.Text convOutputs sty array = do outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty -getTexts :: T.Text -> Value -> Maybe T.Text+getTexts :: T.Text -> Value -> Maybe T.Text getTexts p (Object object) | Just (Array text) <- M.lookup "text" object = concatWithPrefix p text getTexts _ _ = Nothing
src/IHaskell/Convert/LhsToIpynb.hs view
@@ -1,103 +1,121 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+ module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where -import Control.Applicative ((<$>))-import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String))+import Control.Applicative ((<$>))+import Control.Monad (mplus)+import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null)) import qualified Data.ByteString.Lazy as L (writeFile)-import Data.Char (isSpace)-import Data.Monoid (Monoid(mempty))+import Data.Char (isSpace)+import Data.Monoid (Monoid(mempty)) import qualified Data.Text as TS (Text)-import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict)+import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip) import qualified Data.Text.Lazy.IO as T (readFile) import qualified Data.Vector as V (fromList, singleton)-import IHaskell.Flags (LhsStyle(LhsStyle))+import IHaskell.Flags (LhsStyle(LhsStyle)) lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO () lhsToIpynb sty from to = do- classed <- classifyLines sty . T.lines <$> T.readFile from+ classed <- classifyLines sty . T.lines <$> T.readFile from L.writeFile to . encode . encodeCells $ groupClassified classed -data CellLine a = CodeLine a | OutputLine a | MarkdownLine a- deriving Show+data CellLine a = CodeLine a+ | OutputLine a+ | MarkdownLine a+ deriving Show -isCode :: CellLine t -> Bool+isCode :: CellLine t -> Bool isCode (CodeLine _) = True isCode _ = False -isOutput :: CellLine t -> Bool+isOutput :: CellLine t -> Bool isOutput (OutputLine _) = True isOutput _ = False -isMD :: CellLine t -> Bool+isMD :: CellLine t -> Bool isMD (MarkdownLine _) = True isMD _ = False -isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool+isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool isEmptyMD (MarkdownLine a) = a == mempty isEmptyMD _ = False --untag :: CellLine t -> t+untag :: CellLine t -> t untag (CodeLine a) = a untag (OutputLine a) = a untag (MarkdownLine a) = a -data Cell a = Code a a | Markdown a- deriving (Show)+data Cell a = Code a a+ | Markdown a+ deriving Show encodeCells :: [Cell [T.Text]] -> Value encodeCells xs = object $- [ "worksheets" .= Array (V.singleton (object- [ "cells" .= Array (V.fromList (map cellToVal xs)) ] ))- ] ++ boilerplate+ ["cells" .= Array (V.fromList (map cellToVal xs))]+ ++ boilerplate cellToVal :: Cell [T.Text] -> Value cellToVal (Code i o) = object $- [ "cell_type" .= String "code",- "collapsed" .= Bool False,- "language" .= String "python", -- is what it IPython gives us- "metadata" .= object [],- "input" .= arrayFromTxt i,- "outputs" .= Array - (V.fromList (- [ object ["text" .= arrayFromTxt o,- "metadata" .= object [],- "output_type" .= String "display_data" ]- | _ <- take 1 o])) ]-+ [ "cell_type" .= String "code"+ , "execution_count" .= Null+ , "metadata" .= object ["collapsed" .= Bool False]+ , "source" .= arrayFromTxt i+ , "outputs" .= Array+ (V.fromList+ ([object+ [ "text" .= arrayFromTxt o+ , "metadata" .= object []+ , "output_type" .= String "display_data"+ ] | _ <- take 1 o]))+ ] cellToVal (Markdown txt) = object $- [ "cell_type" .= String "markdown",- "metadata" .= object [],- "source" .= arrayFromTxt txt ]+ [ "cell_type" .= String "markdown"+ , "metadata" .= object ["hidden" .= Bool False]+ , "source" .= arrayFromTxt txt+ ] -- | arrayFromTxt makes a JSON array of string s-arrayFromTxt :: [T.Text] -> Value-arrayFromTxt i = Array (V.fromList (map (String . T.toStrict) i))+arrayFromTxt :: [T.Text] -> Value+arrayFromTxt i = Array (V.fromList $ map stringify i)+ where+ stringify = String . T.toStrict . flip T.snoc '\n' --- | ihaskell needs this boilerplate at the upper level to interpret the--- json describing cells and output correctly.+-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and+-- output correctly. boilerplate :: [(TS.Text, Value)] boilerplate =- [ "metadata" .= object [ "language" .= String "haskell", "name" .= String ""],- "nbformat" .= Number 3,- "nbformat_minor" .= Number 0 ]+ ["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]+ where+ kernelspec = "kernelspec" .= object+ [ "display_name" .= String "Haskell"+ , "language" .= String "haskell"+ , "name" .= String "haskell"+ ]+ lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc] groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]-groupClassified (CodeLine a : x)- | (c,x) <- span isCode x,- (_,x) <- span isEmptyMD x,- (o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x-groupClassified (MarkdownLine a : x)- | (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x-groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x+groupClassified (CodeLine a:x)+ | (c, x) <- span isCode x,+ (_, x) <- span isEmptyMD x,+ (o, x) <- span isOutput x+ = Code (a : map untag c) (map untag o) : groupClassified x+groupClassified (MarkdownLine a:x)+ | (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x+groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x groupClassified [] = [] classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]-classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) = case (sp c, sp o) of- (Just a, Nothing) -> CodeLine a : classifyLines sty ls- (Nothing, Just a) -> OutputLine a : classifyLines sty ls- (Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls- _ -> error "IHaskell.Convert.classifyLines"- where sp c = T.stripPrefix (T.dropWhile isSpace c) (T.dropWhile isSpace l)-classifyLines _ [] = [] -+classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =+ case (sp c, sp o) of+ (Just a, Nothing) -> CodeLine a : classifyLines sty ls+ (Nothing, Just a) -> OutputLine a : classifyLines sty ls+ (Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls+ _ -> error "IHaskell.Convert.classifyLines"+ where+ sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x+ blankCodeLine x = if T.strip x == T.strip l+ then Just ""+ else Nothing+ dropSpace = T.dropWhile isSpace+classifyLines _ [] = []
src/IHaskell/Display.hs view
@@ -1,56 +1,66 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-} --- | If you are interested in the IHaskell library for the purpose of--- augmenting the IHaskell notebook or writing your own display mechanisms--- and widgets, this module contains all functions you need. +-- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell+-- notebook or writing your own display mechanisms and widgets, this module contains all functions+-- you need. ----- In order to create a display mechanism for a particular data type, write--- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.--- (Note the capitalization - it's important!) Then, in that module, add an--- instance of @IHaskellDisplay@ for your data type. Similarly, to create--- a widget, add an instance of @IHaskellWidget@. +-- In order to create a display mechanism for a particular data type, write a module named (for+-- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the+-- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for+-- your data type. Similarly, to create a widget, add an instance of @IHaskellWidget@. ----- An example of creating a display is provided in the <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.+-- An example of creating a display is provided in the+-- <http://gibiansky.github.io/IHaskell/demo.html demo notebook>. -- module IHaskell.Display (- -- * Rich display and interactive display typeclasses and types- IHaskellDisplay(..),- Display(..),- DisplayData(..),- IHaskellWidget(..),+ -- * Rich display and interactive display typeclasses and types+ IHaskellDisplay(..),+ Display(..),+ DisplayData(..),+ IHaskellWidget(..), - -- ** Interactive use functions- printDisplay,+ -- ** Interactive use functions+ printDisplay, - -- * Constructors for displays- plain, html, png, jpg, svg, latex, javascript, many,+ -- * Constructors for displays+ plain,+ html,+ png,+ jpg,+ svg,+ latex,+ javascript,+ many, - -- ** Image and data encoding functions- Width, Height, Base64(..),- encode64, base64,+ -- ** Image and data encoding functions+ Width,+ Height,+ Base64(..),+ encode64,+ base64, - -- ** Utilities- switchToTmpDir,+ -- ** Utilities+ switchToTmpDir, - -- * Internal only use- displayFromChan,- serializeDisplay,- Widget(..),- ) where+ -- * Internal only use+ displayFromChan,+ serializeDisplay,+ Widget(..),+ ) where -import ClassyPrelude-import Data.Serialize as Serialize-import Data.ByteString hiding (map, pack)-import Data.String.Utils (rstrip) +import ClassyPrelude+import Data.Serialize as Serialize+import Data.ByteString hiding (map, pack)+import Data.String.Utils (rstrip) import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as Char-import Data.Aeson (Value)-import System.Directory(getTemporaryDirectory, setCurrentDirectory)+import Data.Aeson (Value)+import System.Directory (getTemporaryDirectory, setCurrentDirectory) -import Control.Concurrent.STM.TChan-import System.IO.Unsafe (unsafePerformIO)+import Control.Concurrent.STM.TChan+import System.IO.Unsafe (unsafePerformIO) -import IHaskell.Types+import IHaskell.Types type Base64 = Text @@ -61,8 +71,7 @@ -- > IO [Display] -- > IO (IO Display) ----- be run the IO and get rendered (if the frontend allows it) in the pretty--- form.+-- be run the IO and get rendered (if the frontend allows it) in the pretty form. instance IHaskellDisplay a => IHaskellDisplay (IO a) where display = (display =<<) @@ -101,15 +110,15 @@ javascript :: String -> DisplayData javascript = DisplayData MimeJavascript . pack --- | Generate a PNG display of the given width and height. Data must be--- provided in a Base64 encoded manner, suitable for embedding into HTML.--- The @base64@ function may be used to encode data into this format.+-- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded+-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into+-- this format. png :: Width -> Height -> Base64 -> DisplayData png width height = DisplayData (MimePng width height) --- | Generate a JPG display of the given width and height. Data must be--- provided in a Base64 encoded manner, suitable for embedding into HTML.--- The @base64@ function may be used to encode data into this format.+-- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded+-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into+-- this format. jpg :: Width -> Height -> Base64 -> DisplayData jpg width height = DisplayData (MimeJpg width height) @@ -121,42 +130,37 @@ base64 :: ByteString -> Base64 base64 = decodeUtf8 . Base64.encode --- | For internal use within IHaskell.--- Serialize displays to a ByteString.+-- | For internal use within IHaskell. Serialize displays to a ByteString. serializeDisplay :: Display -> ByteString serializeDisplay = Serialize.encode --- | Items written to this chan will be included in the output sent--- to the frontend (ultimately the browser), the next time IHaskell--- has an item to display.+-- | Items written to this chan will be included in the output sent to the frontend (ultimately the+-- browser), the next time IHaskell has an item to display. {-# NOINLINE displayChan #-} displayChan :: TChan Display displayChan = unsafePerformIO newTChanIO --- | Take everything that was put into the 'displayChan' at that point--- out, and make a 'Display' out of it.+-- | 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) --- | This is unfoldM from monad-loops. It repeatedly runs an IO action--- until it return Nothing, and puts all the Justs in a list.--- If you find yourself using more functionality from monad-loops, just add--- the package dependency instead of copying more code from it.+-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and+-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,+-- just add the package dependency instead of copying more code from it. unfoldM :: IO (Maybe a) -> IO [a]-unfoldM f = maybe (return []) (\r -> (r:) <$> unfoldM f) =<< f+unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f --- | Write to the display channel. The contents will be displayed in the--- notebook once the current execution call ends.+-- | Write to the display channel. The contents will be displayed in the notebook once the current+-- execution call ends. printDisplay :: IHaskellDisplay a => a -> IO () printDisplay disp = display disp >>= atomically . writeTChan displayChan --- | Convenience function for client libraries. Switch to a temporary--- directory so that any files we create aren't visible. On Unix, this is--- usually /tmp.+-- | Convenience function for client libraries. Switch to a temporary directory so that any files we+-- create aren't visible. On Unix, this is usually /tmp. switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))- where + where switchDir =- getTemporaryDirectory >>=+ getTemporaryDirectory >>= setCurrentDirectory-
src/IHaskell/Eval/Completion.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}+{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+ {- | Description: Generates tab completion options. @@ -11,52 +13,67 @@ -} module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where -import ClassyPrelude hiding (init, last, head, liftIO)---import Prelude+import ClassyPrelude hiding (init, last, head, liftIO) -import Control.Applicative ((<$>))-import Data.ByteString.UTF8 hiding (drop, take)-import Data.Char-import Data.List (nub, init, last, head, elemIndex)-import Data.List.Split-import Data.List.Split.Internals-import Data.Maybe (fromJust)-import Data.String.Utils (strip, startswith, endswith, replace)+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.Split+import Data.List.Split.Internals+import Data.Maybe (fromJust)+import Data.String.Utils (strip, startswith, endswith, replace) import qualified Data.String.Utils as StringUtils-import System.Environment (getEnv)+import System.Environment (getEnv) -import GHC-import DynFlags-import GhcMonad-import PackageConfig-import Outputable (showPpr)+import GHC hiding (Qualified)+#if MIN_VERSION_ghc(7,10,0)+import GHC.PackageDb (ExposedModule(exposedName))+#endif+import DynFlags+import GhcMonad+import PackageConfig+import Outputable (showPpr) -import System.Directory-import System.FilePath-import MonadUtils (MonadIO)--import System.Console.Haskeline.Completion+import System.Directory+import System.FilePath+import MonadUtils (MonadIO) -import IHaskell.Types-import IHaskell.Eval.Evaluate (Interpreter)-import IHaskell.Eval.ParseShell (parseShell)+import System.Console.Haskeline.Completion +import IHaskell.Types+import IHaskell.Eval.Evaluate (Interpreter)+import IHaskell.Eval.ParseShell (parseShell) -data CompletionType- = Empty- | Identifier String- | DynFlag String- | Qualified String String- | ModuleName String String- | HsFilePath String String- | FilePath String String- | KernelOption String- | Extension String- deriving (Show, Eq)+data CompletionType = Empty+ | Identifier String+ | DynFlag String+ | Qualified String String+ | ModuleName String String+ | HsFilePath String String+ | FilePath String String+ | KernelOption String+ | Extension String+ deriving (Show, Eq)+#if MIN_VERSION_ghc(7,10,0)+extName (FlagSpec { flagSpecName = name }) = name+#else+extName (name, _, _) = name +exposedName = id+#endif complete :: String -> Int -> Interpreter (String, [String])-complete line pos = do+complete code posOffset = do+ -- Get the line of code which is being completed and offset within that line+ let findLine offset (first:rest) =+ if offset <= length first+ then (offset, first)+ else findLine (offset - length first - 1) rest+ findLine _ [] = error $ "Could not find line: " ++ show (map length $ lines code, posOffset)+ (pos, line) = findLine posOffset (lines code)++ flags <- getSessionDynFlags rdrNames <- map (showPpr flags) <$> getRdrNamesInScope scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope@@ -65,72 +82,69 @@ qualNames = nub $ scopeNames ++ filter isQualified rdrNames let Just db = pkgDatabase flags- getNames = map moduleNameString . exposedModules+ getNames = map (moduleNameString . exposedName) . exposedModules moduleNames = nub $ concatMap getNames db let target = completionTarget line pos completion = completionType line pos target - let matchedText = case completion of- HsFilePath _ match -> match- FilePath _ match -> match- otherwise -> intercalate "." target-- options <-+ let matchedText = case completion of- Empty -> return []+ HsFilePath _ match -> match+ FilePath _ match -> match+ otherwise -> intercalate "." target - Identifier candidate ->- return $ filter (candidate `isPrefixOf`) unqualNames+ options <- case completion of+ Empty -> return [] - Qualified moduleName candidate -> do- trueName <- getTrueModuleName moduleName- let prefix = intercalate "." [trueName, candidate]- completions = filter (prefix `isPrefixOf`) qualNames- falsifyName = replace trueName moduleName- return $ map falsifyName completions+ Identifier candidate ->+ return $ filter (candidate `isPrefixOf`) unqualNames - ModuleName previous candidate -> do- let prefix = if null previous- then candidate- else intercalate "." [previous, candidate]- return $ filter (prefix `isPrefixOf`) moduleNames+ Qualified moduleName candidate -> do+ trueName <- getTrueModuleName moduleName+ let prefix = intercalate "." [trueName, candidate]+ completions = filter (prefix `isPrefixOf`) qualNames+ falsifyName = replace trueName moduleName+ return $ map falsifyName completions - DynFlag ext -> do- -- Possibly leave out the fLangFlags? The- -- -XUndecidableInstances vs. obsolete- -- -fallow-undecidable-instances.- let extName (name, _, _) = name+ ModuleName previous candidate -> do+ let prefix = if null previous+ then candidate+ else intercalate "." [previous, candidate]+ return $ filter (prefix `isPrefixOf`) moduleNames - kernelOptNames = concatMap getSetName kernelOpts- otherNames = ["-package","-Wall","-w"]+ DynFlag ext -> do+ -- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete+ -- -fallow-undecidable-instances.+ let kernelOptNames = concatMap getSetName kernelOpts+ otherNames = ["-package", "-Wall", "-w"] - fNames = map extName fFlags ++- map extName fWarningFlags ++- map extName fLangFlags- fNoNames = map ("no"++) fNames- fAllNames = map ("-f"++) (fNames ++ fNoNames)+ fNames = map extName fFlags +++ map extName fWarningFlags +++ map extName fLangFlags+ fNoNames = map ("no" ++) fNames+ fAllNames = map ("-f" ++) (fNames ++ fNoNames) - xNames = map extName xFlags- xNoNames = map ("No" ++) xNames- xAllNames = map ("-X"++) (xNames ++ xNoNames)+ xNames = map extName xFlags+ xNoNames = map ("No" ++) xNames+ xAllNames = map ("-X" ++) (xNames ++ xNoNames) - allNames = xAllNames ++ otherNames ++ fAllNames+ allNames = xAllNames ++ otherNames ++ fAllNames - return $ filter (ext `isPrefixOf`) allNames+ return $ filter (ext `isPrefixOf`) allNames - Extension ext -> do- let extName (name, _, _) = name- xNames = map extName xFlags- xNoNames = map ("No" ++) xNames- return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames+ Extension ext -> do+ let xNames = map extName xFlags+ xNoNames = map ("No" ++) xNames+ return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames - HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor+ HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"]+ lineUpToCursor - FilePath lineUpToCursor match -> completePath lineUpToCursor+ FilePath lineUpToCursor match -> completePath lineUpToCursor - KernelOption str -> return $- filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)+ KernelOption str -> return $+ filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts) return (matchedText, options) @@ -143,113 +157,118 @@ -- Get all imports that we use. imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext - -- Find the ones that have a qualified name attached.- -- If this name isn't one of them, it already is the true name.+ -- Find the ones that have a qualified name attached. If this name isn't one of them, it already is+ -- the true name. flags <- getSessionDynFlags let qualifiedImports = filter (isJust . ideclAs) imports hasName imp = name == (showPpr flags . fromJust . ideclAs) imp case find hasName qualifiedImports of- Nothing -> return name+ Nothing -> return name Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp -- | Get which type of completion this is from the surrounding context. completionType :: String -- ^ The line on which the completion is being done.- -> Int -- ^ Location of the cursor in the line.+ -> Int -- ^ Location of the cursor in the line. -> [String] -- ^ The identifier being completed (pieces separated by dots). -> CompletionType completionType line loc target -- File and directory completions are special- | startswith ":!" stripped- = fileComplete FilePath- | startswith ":l" stripped- = fileComplete HsFilePath+ | startswith ":!" stripped =+ fileComplete FilePath+ | startswith ":l" stripped =+ fileComplete HsFilePath -- Complete :set, :opt, and :ext- | startswith ":s" stripped- = DynFlag candidate- | startswith ":o" stripped- = KernelOption candidate- | startswith ":e" stripped- = Extension candidate+ | startswith ":s" stripped =+ DynFlag candidate+ | startswith ":o" stripped =+ KernelOption candidate+ | startswith ":e" stripped =+ Extension candidate - -- Use target for other completions.- -- If it's empty, no completion.- | null target- = Empty+ -- Use target for other completions. If it's empty, no completion.+ | null target =+ Empty -- When in a string, complete filenames.- | cursorInString line loc- = FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)+ | cursorInString line loc =+ FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor) -- Complete module names in imports and elsewhere.- | startswith "import" stripped && isModName- = ModuleName dotted candidate- | isModName && (not . null . init) target- = Qualified dotted candidate+ | startswith "import" stripped && isModName =+ ModuleName dotted candidate+ | isModName && (not . null . init) target =+ Qualified dotted candidate -- Default to completing identifiers.- | otherwise- = Identifier candidate- where stripped = strip line- dotted = dots target- candidate | null target = ""- | otherwise = last target- dots = intercalate "." . init- isModName = all isCapitalized (init target)- isCapitalized = isUpper . head- lineUpToCursor = take loc line- fileComplete filePath = case parseShell lineUpToCursor of- Right xs -> filePath lineUpToCursor $- if endswith (last xs) lineUpToCursor- then last xs- else []- Left _ -> Empty+ | otherwise =+ Identifier candidate+ where+ stripped = strip line+ dotted = dots target+ candidate+ | null target = ""+ | otherwise = last target+ dots = intercalate "." . init+ isModName = all isCapitalized (init target) - cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0+ isCapitalized [] = False+ isCapitalized (x:_) = isUpper x - nquotes ('\\':'"':xs) = nquotes xs- nquotes ('"':xs) = 1 + nquotes xs- nquotes (_:xs) = nquotes xs- nquotes [] = 0+ lineUpToCursor = take loc line+ fileComplete filePath =+ case parseShell lineUpToCursor of+ Right xs -> filePath lineUpToCursor $+ if endswith (last xs) lineUpToCursor+ then last xs+ else []+ Left _ -> Empty - -- Get the bit of a string that might be a filename completion.- -- Logic is a bit convoluted, but basically go backwards from the- -- end, stopping at any quote or space, unless they are escaped.- getStringTarget :: String -> String- getStringTarget = go "" . reverse- where- go acc rest = case rest of- '"':'\\':rem -> go ('"':acc) rem- '"':rem -> acc- ' ':'\\':rem -> go (' ':acc) rem- ' ':rem -> acc- x:rem -> go (x:acc) rem- [] -> acc+ cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0 + nquotes ('\\':'"':xs) = nquotes xs+ nquotes ('"':xs) = 1 + nquotes xs+ nquotes (_:xs) = nquotes xs+ nquotes [] = 0++ -- Get the bit of a string that might be a filename completion. Logic is a bit convoluted, but+ -- basically go backwards from the end, stopping at any quote or space, unless they are escaped.+ getStringTarget :: String -> String+ getStringTarget = go "" . reverse+ where+ go acc rest =+ case rest of+ '"':'\\':rem -> go ('"' : acc) rem+ '"':rem -> acc+ ' ':'\\':rem -> go (' ' : acc) rem+ ' ':rem -> acc+ x:rem -> go (x : acc) rem+ [] -> acc+ -- | Get the word under a given cursor location. completionTarget :: String -> Int -> [String] completionTarget code cursor = expandCompletionPiece pieceToComplete where pieceToComplete = map fst <$> find (elem cursor . map snd) pieces- pieces = splitAlongCursor $ split splitter $ zip code [1 .. ]- splitter = defaultSplitter {- -- Split using only the characters, which are the first elements of- -- the (char, index) tuple- delimiter = Delimiter [uncurry isDelim],+ pieces = splitAlongCursor $ split splitter $ zip code [1 ..]+ splitter = defaultSplitter+ { + -- Split using only the characters, which are the first elements of the (char, index) tuple+ delimiter = Delimiter [uncurry isDelim] -- Condense multiple delimiters into one and then drop them.- condensePolicy = Condense,- delimPolicy = Drop- }+ , condensePolicy = Condense+ , delimPolicy = Drop+ } isDelim :: Char -> Int -> Bool- isDelim char idx = char `elem` neverIdent || isSymbol char+ isDelim char idx = char `elem` neverIdent || isSymbol char splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor [] = [] splitAlongCursor (x:xs) =- case elemIndex cursor $ map snd x of- Nothing -> x:splitAlongCursor xs- Just idx -> take (idx + 1) x:drop (idx + 1) x:splitAlongCursor xs+ case elemIndex cursor $ map snd x of+ Nothing -> x : splitAlongCursor xs+ Just idx -> take (idx + 1) x : drop (idx + 1) x : splitAlongCursor xs -- These are never part of an identifier. neverIdent :: String@@ -260,10 +279,11 @@ getHome :: IO String getHome = do- homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)- return $ case homeEither of- Left _ -> "~"- Right home -> home+ homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)+ return $+ case homeEither of+ Left _ -> "~"+ Right home -> home dirExpand :: String -> IO String dirExpand str = do@@ -277,7 +297,8 @@ completePath :: String -> Interpreter [String] completePath line = completePathFilter acceptAll acceptAll line ""- where acceptAll = const True+ where+ acceptAll = const True completePathWithExtensions :: [String] -> String -> Interpreter [String] completePathWithExtensions extensions line =@@ -285,7 +306,8 @@ where acceptAll = const True extensionIsOneOf exts str = any correctEnding exts- where correctEnding ext = endswith ext str+ where+ correctEnding ext = endswith ext str completePathFilter :: (String -> Bool) -- ^ File filter: test whether to include this file. -> (String -> Bool) -- ^ Directory filter: test whether to include this directory.@@ -297,21 +319,19 @@ expanded <- dirExpand left completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right) - -- Split up into files and directories.- -- Filter out ones we don't want.+ -- Split up into files and directories. Filter out ones we don't want. areDirs <- mapM doesDirectoryExist completions- let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs- files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs+ let dirs = filter includeDirectory $ map fst $ filter snd $ zip completions areDirs+ files = filter includeFile $ map fst $ filter (not . snd) $ zip completions areDirs - -- Return directories before files. However, stick everything that starts- -- with a dot after everything else. If we wanted to keep original- -- order, we could instead use+ -- Return directories before files. However, stick everything that starts with a dot after+ -- everything else. If we wanted to keep original order, we could instead use -- filter (`elem` (dirs ++ files)) completions suggestions <- mapM unDirExpand $ dirs ++ files let isHidden str = startswith "." . last . StringUtils.split "/" $ if endswith "/" str- then init str- else str+ then init str+ else str visible = filter (not . isHidden) suggestions- hidden = filter isHidden suggestions+ hidden = filter isHidden suggestions return $ visible ++ hidden
src/IHaskell/Eval/Evaluate.hs view
@@ -1,1216 +1,1257 @@-{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, CPP #-}--{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs- a statement, declaration, import, or directive.--This module exports all functions used for evaluation of IHaskell input.--}-module IHaskell.Eval.Evaluate (- interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports- ) where--import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try)-import Control.Concurrent (forkIO, threadDelay)-import Prelude (putChar, head, tail, last, init, (!!))-import Data.List.Utils-import Data.List (findIndex, and)-import Data.String.Utils-import Text.Printf-import Data.Char as Char-import Data.Dynamic-import Data.Typeable-import qualified Data.Serialize as Serialize-import qualified Language.Haskell.TH as TH -import System.Directory-import Filesystem.Path.CurrentOS (encodeString)-import System.Posix.IO-import System.IO (hGetChar, hFlush)-import System.Random (getStdGen, randomRs)-import Unsafe.Coerce-import Control.Monad (guard)-import System.Process-import System.Exit-import Data.Maybe (fromJust)-import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)-import qualified MonadUtils (MonadIO, liftIO)-import System.Environment (getEnv)-import qualified Data.Map as Map--import NameSet-import Name-import PprTyThing-import InteractiveEval-import DynFlags-import Type-import Exception (gtry)-import HscTypes-import HscMain-import qualified Linker-import TcType-import Unify-import InstEnv-import GhcMonad (liftIO, withSession)-import GHC hiding (Stmt, TypeSig)-import Exception hiding (evaluate)-import Outputable hiding ((<>))-import Packages-import Module-import qualified Pretty-import FastString-import Bag-import ErrUtils (errMsgShortDoc, errMsgExtraInfo)--import qualified System.IO.Strict as StrictIO--import IHaskell.Types-import IHaskell.IPython-import IHaskell.Eval.Parser-import IHaskell.Eval.Lint-import IHaskell.Display-import qualified IHaskell.Eval.Hoogle as Hoogle-import IHaskell.Eval.Util-import IHaskell.BrokenPackages-import qualified IHaskell.IPython.Message.UUID as UUID--import Paths_ihaskell (version)-import Data.Version (versionBranch)--data ErrorOccurred = Success | Failure deriving (Show, Eq)---- | Enable debugging output-debug :: Bool-debug = False ---- | Set GHC's verbosity for debugging-ghcVerbosity :: Maybe Int-ghcVerbosity = Nothing -- Just 5--ignoreTypePrefixes :: [String]-ignoreTypePrefixes = ["GHC.Types", "GHC.Base", "GHC.Show", "System.IO",- "GHC.Float", ":Interactive", "GHC.Num", "GHC.IO",- "GHC.Integer.Type"]--typeCleaner :: String -> String-typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)- where- fullPrefixes = map (++ ".") ignoreTypePrefixes- useStringType = replace "[Char]" "String"--write :: GhcMonad m => String -> m ()-write x = when debug $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x--type Interpreter = Ghc--#if MIN_VERSION_ghc(7, 8, 0)- -- GHC 7.8 exports a MonadIO instance for Ghc-#else-instance MonadIO.MonadIO Interpreter where- liftIO = MonadUtils.liftIO-#endif--globalImports :: [String]-globalImports =- [ "import IHaskell.Display()"- , "import qualified Prelude as IHaskellPrelude"- , "import qualified System.Directory as IHaskellDirectory"- , "import qualified IHaskell.Display"- , "import qualified IHaskell.IPython.Stdin"- , "import qualified System.Posix.IO as IHaskellIO"- , "import qualified System.IO as IHaskellSysIO"- , "import qualified Language.Haskell.TH as IHaskellTH"- ]---- | 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.-interpret :: String -> Bool -> Interpreter a -> IO a-interpret libdir allowedStdin action = runGhc (Just libdir) $ do- -- If we're in a sandbox, add the relevant package database- sandboxPackages <- liftIO getSandboxPackageConf- initGhci sandboxPackages- case ghcVerbosity of- Just verb -> do dflags <- getSessionDynFlags- void $ setSessionDynFlags $ dflags { verbosity = verb }- Nothing -> return ()-- initializeImports-- -- Close stdin so it can't be used.- -- Otherwise it'll block the kernel forever.- dir <- liftIO getIHaskellDir- let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir- when allowedStdin $ void $- runStmt cmd RunToCompletion-- initializeItVariable-- -- Run the rest of the interpreter- action---- | Initialize our GHC session with imports and a value for 'it'.-initializeImports :: Interpreter ()-initializeImports = do- -- Load packages that start with ihaskell-*, aren't just IHaskell,- -- and depend directly on the right version of the ihaskell library.- -- Also verify that the packages we load are not broken.- dflags <- getSessionDynFlags- broken <- liftIO getBrokenPackages- displayPackages <- liftIO $ do- (dflags, _) <- initPackages dflags- let Just db = pkgDatabase dflags- packageNames = map (packageIdString . packageConfigId) db-- initStr = "ihaskell-"-- -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"- iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version))-- dependsOnRight pkg = not $ null $ do- pkg <- db- depId <- depends pkg- dep <- filter ((== depId) . installedPackageId) db- guard (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))-- -- ideally the Paths_ihaskell module could provide a way to get the- -- hash too (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9),- -- for now. Things will end badly if you also happen to have an- -- ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.- iHaskellPkg = case filter (== iHaskellPkgName) packageNames of- [x] -> x- [] -> error ("cannot find required haskell library: " ++ iHaskellPkgName)- _ -> error ("multiple haskell packages " ++ iHaskellPkgName ++ " found")-- displayPkgs = [ pkgName- | pkgName <- packageNames,- Just (x:_) <- [stripPrefix initStr pkgName],- pkgName `notElem` broken,- isAlpha x]-- return displayPkgs-- -- Generate import statements all Display modules.- let capitalize :: String -> String- capitalize (first:rest) = Char.toUpper first : rest-- importFmt = "import IHaskell.Display.%s"-- toImportStmt :: String -> String- toImportStmt = printf importFmt . capitalize . (!! 1) . split "-"-- displayImports = map toImportStmt displayPackages-- -- Import implicit prelude.- importDecl <- parseImportDecl "import Prelude"- let implicitPrelude = importDecl { ideclImplicit = True }-- -- Import modules.- mapM_ (write . ("Importing " ++ )) displayImports- imports <- mapM parseImportDecl $ globalImports ++ displayImports- setContext $ map IIDecl $ implicitPrelude : imports---- | Give a value for the `it` variable.-initializeItVariable :: Interpreter ()-initializeItVariable = do- -- This is required due to the way we handle `it` in the wrapper- -- statements - if it doesn't exist, the first statement will fail.- write "Setting `it` to unit."- void $ runStmt "let it = ()" RunToCompletion---- | Publisher for IHaskell outputs. The first argument indicates whether--- this output is final (true) or intermediate (false).-type Publisher = (EvaluationResult -> IO ())---- | Output of a command evaluation.-data EvalOut = EvalOut {- evalStatus :: ErrorOccurred,- evalResult :: Display,- evalState :: KernelState,- evalPager :: String,- evalComms :: [CommInfo]- }---- | Evaluate some IPython input code.-evaluate :: KernelState -- ^ The kernel state.- -> String -- ^ Haskell code or other interpreter commands.- -> (EvaluationResult -> IO ()) -- ^ Function used to publish data outputs.- -> Interpreter KernelState-evaluate kernelState code output = do- cmds <- parseString (strip code)- let execCount = getExecutionCounter kernelState-- when (getLintStatus kernelState /= LintOff) $ liftIO $ do- lintSuggestions <- lint cmds- unless (noResults lintSuggestions) $- output $ FinalResult lintSuggestions "" []-- updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])- return updated {- getExecutionCounter = execCount + 1- }- where- noResults (Display res) = null res- noResults (ManyDisplay res) = all noResults res-- runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter KernelState- runUntilFailure state [] = return state- runUntilFailure state (cmd:rest) = do- evalOut <- evalCommand output cmd state-- -- Get displayed channel outputs.- -- Merge them with normal display outputs.- dispsIO <- extractValue "IHaskell.Display.displayFromChan"- dispsMay <- liftIO dispsIO- 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 && null (evalComms evalOut)- unless empty $- liftIO $ output $ FinalResult result helpStr (evalComms evalOut)-- -- Make sure to clear all comms we've started.- let newState = evalState evalOut { evalComms = [] }-- case evalStatus evalOut of- Success -> runUntilFailure newState rest- Failure -> return newState-- storeItCommand execCount = Statement $ printf "let it%d = it" execCount-- extractValue :: Typeable a => String -> Interpreter a- extractValue expr = do- compiled <- dynCompileExpr expr- case fromDynamic compiled of- Nothing -> error "Expecting value!"- Just result -> return result--safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut-safely state = ghandle handler . ghandle sourceErrorHandler- where- handler :: SomeException -> Interpreter EvalOut- handler exception =- return EvalOut {- evalStatus = Failure,- evalResult = displayError $ show exception,- evalState = state,- evalPager = "",- evalComms = []- }-- 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]-- let fullErr = unlines errStrs-- return EvalOut {- evalStatus = Failure,- evalResult = displayError fullErr,- evalState = state,- evalPager = "",- evalComms = []- }--wrapExecution :: KernelState- -> Interpreter Display- -> Interpreter EvalOut-wrapExecution state exec = safely state $ exec >>= \res ->- return EvalOut {- evalStatus = Success,- evalResult = res,- evalState = state,- evalPager = "",- evalComms = []- }---- | Return the display data for this command, as well as whether it--- resulted in an error.-evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut-evalCommand _ (Import importStr) state = wrapExecution state $ do- write $ "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--evalCommand _ (Module contents) state = wrapExecution state $ do- write $ "Module:\n" ++ contents-- -- Write the module contents to a temporary file in our work directory- namePieces <- getModuleName contents- liftIO (print namePieces)- let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"- filename = last namePieces ++ ".hs"- liftIO $ do- createDirectoryIfMissing True directory- writeFile (fpFromString $ directory ++ filename) contents-- -- Clear old modules of this name- let modName = intercalate "." namePieces- removeTarget $ TargetModule $ mkModuleName modName- removeTarget $ TargetFile filename Nothing-- -- Remember which modules we've loaded before.- importedModules <- getContext-- let -- Get the dot-delimited pieces of the module name.- moduleNameOf :: InteractiveImport -> [String]- moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl- moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp-- -- Return whether this module prevents the loading of the one we're- -- trying to load. If a module B exist, we cannot load A.B. All- -- modules must have unique last names (where A.B has last name B).- -- However, we *can* just reload a module.- preventsLoading mod =- let pieces = moduleNameOf mod in- last namePieces == last pieces && namePieces /= pieces-- -- If we've loaded anything with the same last name, we can't use this.- -- Otherwise, GHC tries to load the original *.hs fails and then fails.- case find preventsLoading importedModules of- -- If something prevents loading this module, return an error.- Just previous -> do- let prevLoaded = intercalate "." (moduleNameOf previous)- return $ displayError $- printf "Can't load module %s because already loaded %s" modName prevLoaded-- -- Since nothing prevents loading the module, compile and load it.- Nothing -> doLoadModule modName modName---- | Directives set via `:set`.-evalCommand output (Directive SetDynFlag flags) state =- case words flags of- -- For a single flag.- [flag] -> do- write $ "DynFlags: " ++ flags-- -- Check if this is setting kernel options.- case find (elem flag . getSetName) kernelOpts of- -- If this is a kernel option, just set it.- Just (KernelOpt _ _ updater) ->- return EvalOut {- evalStatus = Success,- evalResult = mempty,- evalState = updater state,- evalPager = "",- evalComms = []- }-- -- If not a kernel option, must be a dyn flag.- Nothing -> do- errs <- setFlags [flag]- let display = case errs of- [] -> mempty- _ -> displayError $ intercalate "\n" errs-- -- For -XNoImplicitPrelude, remove the Prelude import.- -- For -XImplicitPrelude, add it back in.- case flag of- "-XNoImplicitPrelude" ->- evalImport "import qualified Prelude as Prelude"- "-XImplicitPrelude" -> do- importDecl <- parseImportDecl "import Prelude"- let implicitPrelude = importDecl { ideclImplicit = True }- imports <- getContext- setContext $ IIDecl implicitPrelude : imports- _ -> return ()-- return EvalOut {- evalStatus = Success,- evalResult = display,- evalState = state,- evalPager = "",- evalComms = []- }-- -- Apply many flags.- flag:manyFlags -> do- firstEval <- evalCommand output (Directive SetDynFlag flag) state- case evalStatus firstEval of- Failure -> return firstEval- Success -> do- let newState = evalState firstEval- results = evalResult firstEval- restEval <- evalCommand output (Directive SetDynFlag $ unwords manyFlags) newState- return restEval {- evalResult = results ++ evalResult restEval- }--evalCommand output (Directive SetExtension opts) state = do- write $ "Extension: " ++ opts- let set = concatMap (" -X" ++) $ words opts- evalCommand output (Directive SetDynFlag set) state--evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do- write $ "Load Module: " ++ mods- let stripped@(firstChar:remainder) = mods- (modules, removeModule) =- case firstChar of- '+' -> (words remainder, False)- '-' -> (words remainder, True)- _ -> (words stripped, False)-- forM_ modules $ \modl ->- if removeModule- then removeImport modl- else evalImport $ "import " ++ modl-- return mempty--evalCommand a (Directive SetOption opts) state = do- write $ "Option: " ++ opts- let (existing, nonExisting) = partition optionExists $ words opts- if not $ null nonExisting- then- let err = "No such options: " ++ intercalate ", " nonExisting in- return EvalOut {- evalStatus = Failure,- evalResult = displayError err,- evalState = state,- evalPager = "",- evalComms = []- }- else- let options = mapMaybe findOption $ words opts- updater = foldl' (.) id $ map getUpdateKernelState options in- return EvalOut {- evalStatus = Success,- evalResult = mempty,- evalState = updater state,- evalPager = "",- evalComms = []- }- where- optionExists = isJust . findOption- findOption opt =- find (elem opt . getOptionName) kernelOpts--evalCommand _ (Directive GetType expr) state = wrapExecution state $ do- write $ "Type: " ++ expr- formatType <$> ((expr ++ " :: ") ++ ) <$> getType expr--evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do- write $ "Kind: " ++ expr- (_, kind) <- GHC.typeKind False expr- flags <- getSessionDynFlags- let typeStr = showSDocUnqual flags $ ppr kind- return $ formatType $ expr ++ " :: " ++ typeStr--evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do- write $ "Load: " ++ name-- let filename = if endswith ".hs" name- then name- else name ++ ".hs"- contents <- readFile $ fpFromString filename- modName <- intercalate "." <$> getModuleName contents- doLoadModule filename modName--evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $- case words cmd of- "cd":dirs -> do- -- Get home so we can replace '~` with it.- homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))- let home = case homeEither of- Left _ -> "~"- Right val -> val-- let directory = replace "~" home $ unwords dirs- exists <- liftIO $ doesDirectoryExist directory- if exists- then do- -- Set the directory in IHaskell native code, for future shell- -- commands. This doesn't set it for user code, though.- liftIO $ setCurrentDirectory directory-- -- Set the directory for user code.- let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $- replace " " "\\ " $- replace "\"" "\\\"" directory- runStmt cmd RunToCompletion- return mempty- else- return $ displayError $ printf "No such directory: '%s'" directory- cmd -> liftIO $ do- (readEnd, writeEnd) <- createPipe- handle <- fdToHandle writeEnd- pipe <- fdToHandle readEnd- let initProcSpec = shell $ unwords cmd- procSpec = initProcSpec {- std_in = Inherit,- std_out = UseHandle handle,- std_err = UseHandle handle- }- (_, _, _, process) <- createProcess procSpec-- -- Accumulate output from the process.- outputAccum <- liftIO $ newMVar ""-- -- Start a loop to publish intermediate results.- let- -- Compute how long to wait between reading pieces of the output.- -- `threadDelay` takes an argument of microseconds.- ms = 1000- delay = 100 * ms-- -- Maximum size of the output (after which we truncate).- maxSize = 100 * 1000- incSize = 200- output str = publish $ IntermediateResult $ Display [plain str]-- loop = do- -- Wait and then check if the computation is done.- threadDelay delay-- -- Read next chunk and append to accumulator.- nextChunk <- readChars pipe "\n" incSize- modifyMVar_ outputAccum (return . (++ nextChunk))-- -- Check if we're done.- exitCode <- getProcessExitCode process- let computationDone = isJust exitCode-- when computationDone $ do- nextChunk <- readChars pipe "" maxSize- modifyMVar_ outputAccum (return . (++ nextChunk))-- if not computationDone- then do- -- Write to frontend and repeat.- readMVar outputAccum >>= output- loop- else do- out <- readMVar outputAccum- case fromJust exitCode of- ExitSuccess -> return $ Display [plain out]- ExitFailure code -> do- let errMsg = "Process exited with error code " ++ show code- htmlErr = printf "<span class='err-msg'>%s</span>" errMsg- return $ Display [plain $ out ++ "\n" ++ errMsg,- html $ printf "<span class='mono'>%s</span>" out ++ htmlErr]-- loop----- This is taken largely from GHCi's info section in InteractiveUI.-evalCommand _ (Directive GetHelp _) state = do- write "Help via :help or :?."- return EvalOut {- evalStatus = Success,- evalResult = Display [out],- evalState = state,- evalPager = "",- evalComms = []- }- where out = plain $ intercalate "\n"- ["The following commands are available:"- ," :extension <Extension> - Enable a GHC extension."- ," :extension No<Extension> - Disable a GHC extension."- ," :type <expression> - Print expression type."- ," :info <name> - Print all info for a name."- ," :hoogle <query> - Search for a query on Hoogle."- ," :doc <ident> - Get documentation for an identifier via Hogole."- ," :set -XFlag -Wall - Set an option (like ghci)."- ," :option <opt> - Set an option."- ," :option no-<opt> - Unset an option."- ," :?, :help - Show this help text."- ,""- ,"Any prefix of the commands will also suffice, e.g. use :ty for :type."- ,""- ,"Options:"- ," lint - enable or disable linting."- ," svg - use svg output (cannot be resized)."- ," show-types - show types of all bound names"- ," show-errors - display Show instance missing errors normally."- ]---- This is taken largely from GHCi's info section in InteractiveUI.-evalCommand _ (Directive GetInfo str) state = safely state $ do- write $ "Info: " ++ str- -- Get all the info for all the names we're given.- strings <- getDescription str-- let output = case getFrontend state of- IPythonConsole -> unlines strings- IPythonNotebook -> 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>"-- return EvalOut {- evalStatus = Success,- evalResult = mempty,- evalState = state,- evalPager = output,- evalComms = []- }--evalCommand _ (Directive SearchHoogle query) state = safely state $ do- results <- liftIO $ Hoogle.search query- return $ hoogleResults state results--evalCommand _ (Directive GetDoc query) state = safely state $ do- results <- liftIO $ Hoogle.document query- return $ hoogleResults state results--evalCommand output (Statement stmt) state = wrapExecution state $ do- write $ "Statement:\n" ++ stmt- let outputter str = output $ IntermediateResult $ Display [plain str]- (printed, result) <- capturedStatement outputter stmt- case result of- RunOk names -> do- dflags <- getSessionDynFlags-- let allNames = map (showPpr dflags) names- isItName name =- name == "it" ||- name == "it" ++ show (getExecutionCounter state)- nonItNames = filter (not . isItName) allNames- output = [plain printed | not . null $ strip printed]-- write $ "Names: " ++ show allNames-- -- Display the types of all bound names if the option is on.- -- This is similar to GHCi :set +t.- if not $ useShowTypes state- then return $ Display output- else do- -- Get all the type strings.- types <- forM nonItNames $ \name -> do- theType <- showSDocUnqual dflags . ppr <$> exprType name- return $ name ++ " :: " ++ theType-- let joined = unlines types- htmled = unlines $ map formatGetType types-- return $ case extractPlain output of- "" -> Display [html htmled]-- -- 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."--evalCommand output (Expression expr) state = do- write $ "Expression:\n" ++ expr-- -- Try to use `display` to convert our type into the output- -- Dislay If typechecking fails and there is no appropriate- -- typeclass instance, this will throw an exception and thus `attempt` will- -- return False, and we just resort to plaintext.- let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String- canRunDisplay <- attempt $ exprType displayExpr-- -- Check if this is a widget.- let widgetExpr = printf "(IHaskell.Display.Widget (%s))" expr :: String- isWidget <- attempt $ exprType widgetExpr-- -- 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))-- write $ "Can Display: " ++ show canRunDisplay- write $ "Is Widget: " ++ show isWidget - write $ "Is Declaration: " ++ show isTHDeclaration -- if isTHDeclaration - -- If it typechecks as a DecsQ, we do not want to display the DecsQ, - -- we just want the declaration made. - then do - write $ "Suppressing display for template haskell declaration" - GHC.runDecls expr - return EvalOut {- evalStatus = Success,- evalResult = mempty, - evalState = state,- evalPager = "",- evalComms = []- }- else do - if canRunDisplay- then do- -- Use the display. As a result, `it` is set to the output.- out <- useDisplay displayExpr-- -- Register the `it` object as a widget.- if isWidget- then registerWidget out- else return out- else do- -- Evaluate this expression as though it's just a statement.- -- The output is bound to 'it', so we can then use it.- evalOut <- evalCommand output (Statement expr) state-- let out = evalResult evalOut- showErr = isShowError out-- -- If evaluation failed, return the failure. If it was successful, we- -- may be able to use the IHaskellDisplay typeclass.- return $ if not showErr || useShowErrors state- then evalOut- else postprocessShowError evalOut-- where- -- Try to evaluate an action. Return True if it succeeds and False if- -- it throws an exception. The result of the action is discarded.- attempt :: Interpreter a -> Interpreter Bool- attempt action = gcatch (action >> return True) failure- where failure :: SomeException -> Interpreter Bool- failure _ = return False-- -- Check if the error is due to trying to print something that doesn't- -- implement the Show typeclass.- isShowError (ManyDisplay _) = False- isShowError (Display errs) =- -- Note that we rely on this error message being 'type cleaned', so- -- that `Show` is not displayed as GHC.Show.Show.- startswith "No instance for (Show" msg &&- isInfixOf " arising from a use of `print'" msg- where msg = extractPlain errs-- isSvg (DisplayData mime _) = mime == MimeSvg-- removeSvg :: Display -> Display- removeSvg (Display disps) = Display $ filter (not . isSvg) disps- removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps-- useDisplay displayExpr = do- -- If there are instance matches, convert the object into- -- a Display. We also serialize it into a bytestring. We get- -- the bytestring IO action as a dynamic and then convert back to- -- a bytestring, which we promptly unserialize. Note that- -- attempting to do this without the serialization to binary and- -- back gives very strange errors - all the types match but it- -- refuses to decode back into a Display.- -- Suppress output, so as not to mess up console.-- -- First, evaluate the expression in such a way that we have access to `it`.- io <- isIO expr- let stmtTemplate = if io- then "it <- (%s)"- else "let { it = %s }"- evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state- case evalStatus evalOut of- Failure -> return evalOut- Success -> wrapExecution state $ do- -- Compile the display data into a bytestring.- let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"- displayedBytestring <- dynCompileExpr compileExpr-- -- Convert from the bytestring into a display.- case fromDynamic displayedBytestring of- Nothing -> error "Expecting lazy Bytestring"- Just bytestringIO -> do- bytestring <- liftIO bytestringIO- case Serialize.decode bytestring of- Left err -> error err- Right display ->- return $- if useSvg state- then display :: Display- else removeSvg display-- registerWidget :: EvalOut -> Ghc EvalOut- registerWidget evalOut =- case evalStatus evalOut of- Failure -> return evalOut- Success -> do- element <- dynCompileExpr "IHaskell.Display.Widget it"- case fromDynamic element of- Nothing -> error "Expecting widget"- Just widget -> do- -- Stick the widget in the kernel state.- uuid <- liftIO UUID.random- let state = evalState evalOut- newComms = Map.insert uuid widget $ openComms state- state' = state { openComms = newComms }-- -- Store the fact that we should start this comm.- return evalOut {- evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut,- evalState = state'- }-- isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr-- postprocessShowError :: EvalOut -> EvalOut- postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps }- where- Display disps = evalResult evalOut- text = extractPlain disps-- postprocess (DisplayData MimeHtml _) = html $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" text) script- where- fmt = "<div class='collapse-group'><span class='btn' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"- script = unlines [- "$('#unshowable').on('click', function(e) {",- " e.preventDefault();",- " var $this = $(this);",- " var $collapse = $this.closest('.collapse-group').find('.err-msg');",- " $collapse.collapse('toggle');",- "});"- ]-- postprocess other = other-- unshowableType = fromMaybe "" $ do- let pieces = words text- before = takeWhile (/= "arising") pieces- after = init $ unwords $ tail $ dropWhile (/= "(Show") before-- firstChar <- headMay after- return $ if firstChar == '('- then init $ tail after- else after----evalCommand _ (Declaration decl) state = wrapExecution state $ do- write $ "Declaration:\n" ++ decl- boundNames <- evalDeclarations decl- let nonDataNames = filter (not . isUpper . head) boundNames-- -- Display the types of all bound names if the option is on.- -- This is similar to GHCi :set +t.- if not $ useShowTypes state- then return mempty- else do- -- Get all the type strings.- dflags <- getSessionDynFlags- types <- forM nonDataNames $ \name -> do- theType <- showSDocUnqual dflags . ppr <$> exprType name- return $ name ++ " :: " ++ theType-- return $ Display [html $ unlines $ map formatGetType types]--evalCommand _ (TypeSignature sig) state = wrapExecution state $- -- We purposefully treat this as a "success" because that way execution- -- continues. Empty type signatures are likely due to a parse error later- -- on, and we want that to be displayed.- return $ displayError $ "The type signature " ++ sig ++- "\nlacks an accompanying binding."--evalCommand _ (ParseError loc err) state = do- write "Parse Error."- return EvalOut {- evalStatus = Failure,- evalResult = displayError $ formatParseError loc err,- evalState = state,- evalPager = "",- evalComms = []- }--evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $- return $ displayError $ "Pragmas of type " ++ pragmaType ++- "\nare not supported."--evalCommand output (Pragma PragmaLanguage pragmas) state = do- write $ "Got LANGUAGE pragma " ++ show pragmas- evalCommand output (Directive SetExtension $ unwords pragmas) state--hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut-hoogleResults state results = EvalOut {- evalStatus = Success,- evalResult = mempty,- evalState = state,- evalPager = output,- evalComms = []- }- where- fmt =- case getFrontend state of- IPythonNotebook -> Hoogle.HTML- IPythonConsole -> Hoogle.Plain- output = unlines $ map (Hoogle.render fmt) results---- Read from a file handle until we hit a delimiter or until we've read--- as many characters as requested-readChars :: Handle -> String -> Int -> IO String---- If we're done reading, return nothing.-readChars handle delims 0 = return []--readChars handle delims nchars = do- -- Try reading a single character. It will throw an exception if the- -- handle is already closed.- tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)- case tryRead of- Right char ->- -- If this is a delimiter, stop reading.- if char `elem` delims- then return [char]- else do- next <- readChars handle delims (nchars - 1)- return $ char:next- -- An error occurs at the end of the stream, so just stop reading.- Left _ -> return []---doLoadModule :: String -> String -> Ghc Display-doLoadModule name modName = do- -- Remember which modules we've loaded before.- importedModules <- getContext-- flip gcatch (unload importedModules) $ do- -- Compile loaded modules.- flags <- getSessionDynFlags-#if MIN_VERSION_ghc(7,8,0)- let objTarget = defaultObjectTarget platform- platform = targetPlatform flags-#else- let objTarget = defaultObjectTarget-#endif- setSessionDynFlags flags{ hscTarget = objTarget }-- -- Clear old targets to be sure.- setTargets []- load LoadAllTargets-- -- Load the new target.- target <- guessTarget name Nothing- addTarget target- result <- load LoadAllTargets-- -- Reset the context, since loading things screws it up.- initializeItVariable-- -- Add imports- importDecl <- parseImportDecl $ "import " ++ modName- let implicitImport = importDecl { ideclImplicit = True }- setContext $ IIDecl implicitImport : importedModules-- -- Switch back to interpreted mode.- flags <- getSessionDynFlags- setSessionDynFlags flags{ hscTarget = HscInterpreted }-- case result of- Succeeded -> return mempty- Failed -> return $ displayError $ "Failed to load module " ++ modName- where- unload :: [InteractiveImport] -> SomeException -> Ghc Display- unload imported exception = do- print $ show exception- -- Explicitly clear targets- setTargets []- load LoadAllTargets-- -- Switch to interpreted mode!- flags <- getSessionDynFlags- setSessionDynFlags flags{ hscTarget = HscInterpreted }-- -- Return to old context, make sure we have `it`.- setContext imported- initializeItVariable-- return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception--keepingItVariable :: Interpreter a -> Interpreter a-keepingItVariable act = do- -- Generate the it variable temp name- gen <- liftIO getStdGen- let rand = take 20 $ randomRs ('0', '9') gen- var name = name ++ rand- goStmt s = runStmt s RunToCompletion- itVariable = var "it_var_temp_"-- goStmt $ printf "let %s = it" itVariable- val <- act- goStmt $ printf "let it = %s" itVariable- act--capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output.- -> String -- ^ Statement to evaluate.- -> Interpreter (String, RunResult) -- ^ Return the output and result.-capturedStatement 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- -- Variable names generation.- rand = take 20 $ randomRs ('0', '9') gen- var name = name ++ rand-- -- Variables for the pipe input and outputs.- readVariable = var "file_read_var_"- writeVariable = var "file_write_var_"-- -- Variable where to store old stdout.- oldVariable = var "old_var_"-- -- Variable used to store true `it` value.- itVariable = var "it_var_"-- voidpf str = printf $ str ++ " IHaskellPrelude.>> IHaskellPrelude.return ()"-- -- Statements run before the thing we're evaluating.- initStmts =- [ printf "let %s = it" itVariable- , printf "(%s, %s) <- IHaskellIO.createPipe" readVariable writeVariable- , printf "%s <- IHaskellIO.dup IHaskellIO.stdOutput" oldVariable- , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" writeVariable- , voidpf "IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"- , printf "let it = %s" itVariable- ]-- -- Statements run after evaluation.- postStmts =- [ printf "let %s = it" itVariable- , voidpf "IHaskellSysIO.hFlush IHaskellSysIO.stdout"- , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" oldVariable- , 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-- -- Initialize evaluation context.- void $ forM initStmts goStmt-- -- 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.- 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-- -- Read from a file handle until we hit a delimiter or until we've read- -- as many characters as requested- let- readChars :: Handle -> String -> Int -> IO String-- -- If we're done reading, return nothing.- readChars handle delims 0 = return []-- readChars handle delims nchars = do- -- Try reading a single character. It will throw an exception if the- -- handle is already closed.- tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)- case tryRead of- Right char ->- -- If this is a delimiter, stop reading.- if char `elem` delims- then return [char]- else do- next <- readChars handle delims (nchars - 1)- return $ char:next- -- An error occurs at the end of the stream, so just stop reading.- Left _ -> return []--- -- 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- -- Compute how long to wait between reading pieces of the output.- -- `threadDelay` takes an argument of microseconds.- ms = 1000- delay = 100 * ms-- -- How much to read each time.- chunkSize = 100-- -- Maximum size of the output (after which we truncate).- maxSize = 100 * 1000-- loop = do- -- Wait and then check if the computation is done.- threadDelay delay- computationDone <- readMVar completed-- if not computationDone- then do- -- Read next chunk and append to accumulator.- nextChunk <- readChars pipe "\n" 100- modifyMVar_ outputAccum (return . (++ nextChunk))-- -- Write to frontend and repeat.- readMVar outputAccum >>= output- loop- else do- -- Read remainder of output and accumulate it.- nextChunk <- readChars pipe "" maxSize- modifyMVar_ outputAccum (return . (++ nextChunk))-- -- We're done reading.- putMVar finishedReading True-- liftIO $ forkIO loop-- result <- gfinally (goStmt stmt) $ do- -- Execution is done.- liftIO $ modifyMVar_ completed (const $ return True)-- -- Finalize evaluation context.- void $ forM postStmts goStmt-- -- Once context is finalized, reading can finish.- -- Wait for reading to finish to that the output accumulator is- -- completely filled.- liftIO $ takeMVar finishedReading-- printedOutput <- liftIO $ readMVar outputAccum- return (printedOutput, result)--formatError :: ErrMsg -> String-formatError = formatErrorWithClass "err-msg"--formatErrorWithClass :: String -> ErrMsg -> String-formatErrorWithClass cls =- printf "<span class='%s'>%s</span>" cls .- replace "\n" "<br/>" .- replace useDashV "" .- replace "Ghci" "IHaskell" .- fixDollarSigns .- rstrip .- typeCleaner- where- fixDollarSigns = replace "$" "<span>$</span>"- useDashV = "\nUse -v to see a list of the files searched for."- isShowError err =- startswith "No instance for (Show" err &&- isInfixOf " arising from a use of `print'" err---formatParseError :: StringLoc -> String -> ErrMsg-formatParseError (Loc line col) =- printf "Parse error (line %d, column %d): %s" line col--formatGetType :: String -> String-formatGetType = printf "<span class='get-type'>%s</span>"--formatType :: String -> Display-formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr]+{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}++{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs+ a statement, declaration, import, or directive.++This module exports all functions used for evaluation of IHaskell input.+-}+module IHaskell.Eval.Evaluate (+ interpret,+ evaluate,+ Interpreter,+ liftIO,+ typeCleaner,+ globalImports,+ ) where++import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try)+import Control.Concurrent (forkIO, threadDelay)+import Prelude (putChar, head, tail, last, init, (!!))+import Data.List.Utils+import Data.List (findIndex, and, foldl1, nubBy)+import Data.String.Utils+import Text.Printf+import Data.Char as Char+import Data.Dynamic+import Data.Typeable+import qualified Data.Serialize as Serialize+import System.Directory+import Filesystem.Path.CurrentOS (encodeString)+#if !MIN_VERSION_base(4,8,0)+import System.Posix.IO (createPipe)+#endif+import System.Posix.IO (fdToHandle)+import System.IO (hGetChar, hFlush)+import System.Random (getStdGen, randomRs)+import Unsafe.Coerce+import Control.Monad (guard)+import System.Process+import System.Exit+import Data.Maybe (fromJust)+import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO)+import qualified MonadUtils (MonadIO, liftIO)+import System.Environment (getEnv)+import qualified Data.Map as Map++import NameSet+import Name+import PprTyThing+import InteractiveEval+import DynFlags+import Type+import Exception (gtry)+import HscTypes+import HscMain+import qualified Linker+import TcType+import Unify+import InstEnv+import GhcMonad (liftIO, withSession)+import GHC hiding (Stmt, TypeSig)+import Exception hiding (evaluate)+import Outputable hiding ((<>))+import Packages+import Module hiding (Module)+import qualified Pretty+import FastString+import Bag+import ErrUtils (errMsgShortDoc, errMsgExtraInfo)++import qualified System.IO.Strict as StrictIO++import IHaskell.Types+import IHaskell.IPython+import IHaskell.Eval.Parser+import IHaskell.Eval.Lint+import IHaskell.Display+import qualified IHaskell.Eval.Hoogle as Hoogle+import IHaskell.Eval.Util+import IHaskell.BrokenPackages+import qualified IHaskell.IPython.Message.UUID as UUID++import Paths_ihaskell (version)+import Data.Version (versionBranch)++data ErrorOccurred = Success+ | Failure+ deriving (Show, Eq)++-- | Set GHC's verbosity for debugging+ghcVerbosity :: Maybe Int+ghcVerbosity = Nothing -- Just 5++ignoreTypePrefixes :: [String]+ignoreTypePrefixes = [ "GHC.Types"+ , "GHC.Base"+ , "GHC.Show"+ , "System.IO"+ , "GHC.Float"+ , ":Interactive"+ , "GHC.Num"+ , "GHC.IO"+ , "GHC.Integer.Type"+ ]++typeCleaner :: String -> String+typeCleaner = useStringType . foldl' (.) id (map (`replace` "") fullPrefixes)+ where+ fullPrefixes = map (++ ".") ignoreTypePrefixes+ useStringType = replace "[Char]" "String"++write :: GhcMonad m => KernelState -> String -> m ()+write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x++type Interpreter = Ghc+#if MIN_VERSION_ghc(7, 8, 0)+ -- GHC 7.8 exports a MonadIO instance for Ghc+#else+instance MonadIO.MonadIO Interpreter where+ liftIO = MonadUtils.liftIO+#endif+globalImports :: [String]+globalImports =+ [ "import IHaskell.Display()"+ , "import qualified Prelude as IHaskellPrelude"+ , "import qualified System.Directory as IHaskellDirectory"+ , "import qualified IHaskell.Display"+ , "import qualified IHaskell.IPython.Stdin"+ , "import qualified System.Posix.IO as IHaskellIO"+ , "import qualified System.IO as IHaskellSysIO"+ , "import qualified Language.Haskell.TH as IHaskellTH"+ ]++-- | 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.+interpret :: String -> Bool -> Interpreter a -> IO a+interpret libdir allowedStdin action = runGhc (Just libdir) $ do+ -- If we're in a sandbox, add the relevant package database+ sandboxPackages <- liftIO getSandboxPackageConf+ initGhci sandboxPackages+ case ghcVerbosity of+ Just verb -> do+ dflags <- getSessionDynFlags+ void $ setSessionDynFlags $ dflags { verbosity = verb }+ Nothing -> return ()++ initializeImports++ -- Close stdin so it can't be used. Otherwise it'll block the kernel forever.+ dir <- liftIO getIHaskellDir+ let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir+ when allowedStdin $ void $+ runStmt cmd RunToCompletion++ initializeItVariable++ -- Run the rest of the interpreter+ action+#if MIN_VERSION_ghc(7,10,0)+packageIdString' dflags = packageKeyPackageIdString dflags+#else+packageIdString' dflags = packageIdString+#endif+-- | Initialize our GHC session with imports and a value for 'it'.+initializeImports :: Interpreter ()+initializeImports = do+ -- Load packages that start with ihaskell-*, aren't just IHaskell, and depend directly on the right+ -- version of the ihaskell library. Also verify that the packages we load are not broken.+ dflags <- getSessionDynFlags+ broken <- liftIO getBrokenPackages+ displayPackages <- liftIO $ do+ (dflags, _) <- initPackages dflags+ let Just db = pkgDatabase dflags+ packageNames = map (packageIdString' dflags . packageConfigId) db++ initStr = "ihaskell-"++ -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4"+ iHaskellPkgName = initStr ++ intercalate "."+ (map show (versionBranch version))++ dependsOnRight pkg = not $ null $ do+ pkg <- db+ depId <- depends pkg+ dep <- filter ((== depId) . installedPackageId) db+ guard+ (iHaskellPkgName `isPrefixOf` packageIdString (packageConfigId dep))++ -- ideally the Paths_ihaskell module could provide a way to get the hash too+ -- (ihaskell-0.2.0.5-f2bce922fa881611f72dfc4a854353b9), for now. Things will end badly if you also+ -- happen to have an ihaskell-0.2.0.5-ce34eadc18cf2b28c8d338d0f3755502 installed.+ iHaskellPkg =+ case filter (== iHaskellPkgName) packageNames of+ [x] -> x+ [] -> error+ ("cannot find required haskell library: " ++ iHaskellPkgName)+ _ -> error+ ("multiple haskell packages " ++ iHaskellPkgName ++ " found")++ displayPkgs = [pkgName | pkgName <- packageNames+ , Just (x:_) <- [stripPrefix initStr pkgName]+ , pkgName `notElem` broken+ , isAlpha x]++ return displayPkgs++ -- Generate import statements all Display modules.+ let capitalize :: String -> String+ capitalize (first:rest) = Char.toUpper first : rest++ importFmt = "import IHaskell.Display.%s"++ dropFirstAndLast :: [a] -> [a]+ dropFirstAndLast = reverse . drop 1 . reverse . drop 1++ toImportStmt :: String -> String+ toImportStmt = printf importFmt . concat . map capitalize . dropFirstAndLast . split "-"++ displayImports = map toImportStmt displayPackages++ -- Import implicit prelude.+ importDecl <- parseImportDecl "import Prelude"+ let implicitPrelude = importDecl { ideclImplicit = True }++ -- Import modules.+ imports <- mapM parseImportDecl $ globalImports ++ displayImports+ setContext $ map IIDecl $ implicitPrelude : imports++-- | Give a value for the `it` variable.+initializeItVariable :: Interpreter ()+initializeItVariable = do+ -- 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++-- | Publisher for IHaskell outputs. The first argument indicates whether this output is final+-- (true) or intermediate (false).+type Publisher = (EvaluationResult -> IO ())++-- | Output of a command evaluation.+data EvalOut =+ EvalOut+ { evalStatus :: ErrorOccurred+ , evalResult :: Display+ , evalState :: KernelState+ , evalPager :: String+ , evalComms :: [CommInfo]+ }++cleanString :: String -> String+cleanString x = if allBrackets+ then clean+ else str+ where+ str = strip x+ l = lines str+ allBrackets = all (fAny [isPrefixOf ">", null]) l+ fAny fs x = any ($x) fs+ clean = unlines $ map removeBracket l+ removeBracket ('>':xs) = xs+ removeBracket [] = []+ -- should never happen:+ removeBracket other = error $ "Expected bracket as first char, but got string: " ++ other++-- | Evaluate some IPython input code.+evaluate :: KernelState -- ^ The kernel state.+ -> String -- ^ Haskell code or other interpreter commands.+ -> (EvaluationResult -> IO ()) -- ^ Function used to publish data outputs.+ -> Interpreter KernelState+evaluate kernelState code output = do+ cmds <- parseString (cleanString code)+ let execCount = getExecutionCounter kernelState++ -- Extract all parse errors.+ let justError x@ParseError{} = Just x+ justError _ = Nothing+ errs = mapMaybe (justError . unloc) cmds++ updated <- case errs of+ -- Only run things if there are no parse errors.+ [] -> do+ when (getLintStatus kernelState /= LintOff) $ liftIO $ do+ lintSuggestions <- lint cmds+ unless (noResults lintSuggestions) $+ output $ FinalResult lintSuggestions "" []++ runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount])+ -- Print all parse errors.+ errs -> do+ forM_ errs $ \err -> do+ out <- evalCommand output err kernelState+ liftIO $ output $ FinalResult (evalResult out) "" []+ return kernelState++ return updated { getExecutionCounter = execCount + 1 }++ where+ noResults (Display res) = null res+ noResults (ManyDisplay res) = all noResults res++ runUntilFailure :: KernelState -> [CodeBlock] -> Interpreter KernelState+ runUntilFailure state [] = return state+ runUntilFailure state (cmd:rest) = do+ evalOut <- evalCommand output cmd state++ -- Get displayed channel outputs. Merge them with normal display outputs.+ dispsIO <- extractValue "IHaskell.Display.displayFromChan"+ dispsMay <- liftIO dispsIO+ 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 && null (evalComms evalOut)+ unless empty $+ liftIO $ output $ FinalResult result helpStr (evalComms evalOut)++ -- Make sure to clear all comms we've started.+ let newState = evalState evalOut { evalComms = [] }++ case evalStatus evalOut of+ Success -> runUntilFailure newState rest+ Failure -> return newState++ storeItCommand execCount = Statement $ printf "let it%d = it" execCount++ extractValue :: Typeable a => String -> Interpreter a+ extractValue expr = do+ compiled <- dynCompileExpr expr+ case fromDynamic compiled of+ Nothing -> error "Expecting value!"+ Just result -> return result++safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut+safely state = ghandle handler . ghandle sourceErrorHandler+ where+ handler :: SomeException -> Interpreter EvalOut+ handler exception =+ return+ EvalOut+ { evalStatus = Failure+ , evalResult = displayError $ show exception+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }++ 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]++ let fullErr = unlines errStrs++ return+ EvalOut+ { evalStatus = Failure+ , evalResult = displayError fullErr+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }++wrapExecution :: KernelState+ -> Interpreter Display+ -> Interpreter EvalOut+wrapExecution state exec = safely state $+ exec >>= \res ->+ return+ EvalOut+ { evalStatus = Success+ , evalResult = res+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }++-- | Return the display data for this command, as well as whether it resulted in an error.+evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut+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++evalCommand _ (Module contents) state = wrapExecution state $ do+ write state $ "Module:\n" ++ contents++ -- Write the module contents to a temporary file in our work directory+ namePieces <- getModuleName contents+ let directory = "./" ++ intercalate "/" (init namePieces) ++ "/"+ filename = last namePieces ++ ".hs"+ liftIO $ do+ createDirectoryIfMissing True directory+ writeFile (fpFromString $ directory ++ filename) contents++ -- Clear old modules of this name+ let modName = intercalate "." namePieces+ removeTarget $ TargetModule $ mkModuleName modName+ removeTarget $ TargetFile filename Nothing++ -- Remember which modules we've loaded before.+ importedModules <- getContext++ let + -- Get the dot-delimited pieces of the module name.+ moduleNameOf :: InteractiveImport -> [String]+ moduleNameOf (IIDecl decl) = split "." . moduleNameString . unLoc . ideclName $ decl+ moduleNameOf (IIModule imp) = split "." . moduleNameString $ imp++ -- Return whether this module prevents the loading of the one we're trying to load. If a module B+ -- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B).+ -- However, we *can* just reload a module.+ preventsLoading mod =+ let pieces = moduleNameOf mod+ in last namePieces == last pieces && namePieces /= pieces++ -- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load+ -- the original *.hs fails and then fails.+ case find preventsLoading importedModules of+ -- If something prevents loading this module, return an error.+ Just previous -> do+ let prevLoaded = intercalate "." (moduleNameOf previous)+ return $ displayError $+ printf "Can't load module %s because already loaded %s" modName prevLoaded++ -- Since nothing prevents loading the module, compile and load it.+ Nothing -> doLoadModule modName modName++-- | Directives set via `:set`.+evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do+ write state $ "All Flags: " ++ flagsStr++ -- Find which flags are IHaskell flags, and which are GHC flags+ let flags = words flagsStr++ -- Get the kernel state updater for any IHaskell flag; Nothing for things that aren't IHaskell+ -- flags.+ ihaskellFlagUpdater :: String -> Maybe (KernelState -> KernelState)+ ihaskellFlagUpdater flag = getUpdateKernelState <$> find (elem flag . getSetName) kernelOpts++ (ihaskellFlags, ghcFlags) = partition (isJust . ihaskellFlagUpdater) flags++ write state $ "IHaskell Flags: " ++ unwords ihaskellFlags+ write state $ "GHC Flags: " ++ unwords ghcFlags++ if null flags+ then do+ flags <- getSessionDynFlags+ return+ EvalOut+ { evalStatus = Success+ , evalResult = Display+ [ plain $ showSDoc flags $ vcat+ [ pprDynFlags False flags+ , pprLanguages False flags+ ]+ ]+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }+ else do+ -- Apply all IHaskell flag updaters to the state to get the new state+ let state' = (foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags)) state+ errs <- setFlags ghcFlags+ let display =+ case errs of+ [] -> mempty+ _ -> displayError $ intercalate "\n" errs++ -- For -XNoImplicitPrelude, remove the Prelude import. For -XImplicitPrelude, add it back in.+ if "-XNoImplicitPrelude" `elem` flags+ then evalImport "import qualified Prelude as Prelude"+ else when ("-XImplicitPrelude" `elem` flags) $ do+ importDecl <- parseImportDecl "import Prelude"+ let implicitPrelude = importDecl { ideclImplicit = True }+ imports <- getContext+ setContext $ IIDecl implicitPrelude : imports++ return+ EvalOut+ { evalStatus = Success+ , evalResult = display+ , evalState = state'+ , evalPager = ""+ , evalComms = []+ }++evalCommand output (Directive SetExtension opts) state = do+ write state $ "Extension: " ++ opts+ let set = concatMap (" -X" ++) $ words opts+ evalCommand output (Directive SetDynFlag set) state++evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do+ write state $ "Load Module: " ++ mods+ let stripped@(firstChar:remainder) = mods+ (modules, removeModule) =+ case firstChar of+ '+' -> (words remainder, False)+ '-' -> (words remainder, True)+ _ -> (words stripped, False)++ forM_ modules $ \modl -> if removeModule+ then removeImport modl+ else evalImport $ "import " ++ modl++ return mempty++evalCommand a (Directive SetOption opts) state = do+ write state $ "Option: " ++ opts+ let (existing, nonExisting) = partition optionExists $ words opts+ if not $ null nonExisting+ then let err = "No such options: " ++ intercalate ", " nonExisting+ in return+ EvalOut+ { evalStatus = Failure+ , evalResult = displayError err+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }+ else let options = mapMaybe findOption $ words opts+ updater = foldl' (.) id $ map getUpdateKernelState options+ in return+ EvalOut+ { evalStatus = Success+ , evalResult = mempty+ , evalState = updater state+ , evalPager = ""+ , evalComms = []+ }++ where+ optionExists = isJust . findOption+ findOption opt =+ find (elem opt . getOptionName) kernelOpts++evalCommand _ (Directive GetType expr) state = wrapExecution state $ do+ write state $ "Type: " ++ expr+ formatType <$> ((expr ++ " :: ") ++) <$> getType expr++evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do+ write state $ "Kind: " ++ expr+ (_, kind) <- GHC.typeKind False expr+ flags <- getSessionDynFlags+ let typeStr = showSDocUnqual flags $ ppr kind+ return $ formatType $ expr ++ " :: " ++ typeStr++evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do+ write state $ "Load: " ++ names++ displays <- forM (words names) $ \name -> do+ let filename = if endswith ".hs" name+ then name+ else name ++ ".hs"+ contents <- readFile $ fpFromString filename+ modName <- intercalate "." <$> getModuleName contents+ doLoadModule filename modName+ return (ManyDisplay displays)++evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $+ case words cmd of+ "cd":dirs -> do+ -- Get home so we can replace '~` with it.+ homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String))+ let home =+ case homeEither of+ Left _ -> "~"+ Right val -> val++ let directory = replace "~" home $ unwords dirs+ exists <- liftIO $ doesDirectoryExist directory+ if exists+ then do+ -- Set the directory in IHaskell native code, for future shell commands. This doesn't set it for+ -- user code, though.+ liftIO $ setCurrentDirectory directory++ -- Set the directory for user code.+ let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $+ replace " " "\\ " $+ replace "\"" "\\\"" directory+ runStmt cmd RunToCompletion+ return mempty+ else return $ displayError $ printf "No such directory: '%s'" directory+ cmd -> liftIO $ do+ (pipe, handle) <- createPipe'+ let initProcSpec = shell $ unwords cmd+ procSpec = initProcSpec+ { std_in = Inherit+ , std_out = UseHandle handle+ , std_err = UseHandle handle+ }+ (_, _, _, process) <- createProcess procSpec++ -- Accumulate output from the process.+ outputAccum <- liftIO $ newMVar ""++ -- Start a loop to publish intermediate results.+ let + -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an+ -- argument of microseconds.+ ms = 1000+ delay = 100 * ms++ -- Maximum size of the output (after which we truncate).+ maxSize = 100 * 1000+ incSize = 200+ output str = publish $ IntermediateResult $ Display [plain str]++ loop = do+ -- Wait and then check if the computation is done.+ threadDelay delay++ -- Read next chunk and append to accumulator.+ nextChunk <- readChars pipe "\n" incSize+ modifyMVar_ outputAccum (return . (++ nextChunk))++ -- Check if we're done.+ exitCode <- getProcessExitCode process+ let computationDone = isJust exitCode++ when computationDone $ do+ nextChunk <- readChars pipe "" maxSize+ modifyMVar_ outputAccum (return . (++ nextChunk))++ if not computationDone+ then do+ -- Write to frontend and repeat.+ readMVar outputAccum >>= output+ loop+ else do+ out <- readMVar outputAccum+ case fromJust exitCode of+ ExitSuccess -> return $ Display [plain out]+ ExitFailure code -> do+ let errMsg = "Process exited with error code " ++ show code+ htmlErr = printf "<span class='err-msg'>%s</span>" errMsg+ return $ Display+ [ plain $ out ++ "\n" ++ errMsg+ , html $ printf "<span class='mono'>%s</span>" out ++ htmlErr+ ]++ loop+ where +#if MIN_VERSION_base(4,8,0)+ createPipe' = createPipe+#else+ createPipe' = do+ (readEnd, writeEnd) <- createPipe+ handle <- fdToHandle writeEnd+ pipe <- fdToHandle readEnd+ return (pipe, handle)+#endif+-- This is taken largely from GHCi's info section in InteractiveUI.+evalCommand _ (Directive GetHelp _) state = do+ write state "Help via :help or :?."+ return+ EvalOut+ { evalStatus = Success+ , evalResult = Display [out]+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }++ where+ out = plain $ intercalate "\n"+ [ "The following commands are available:"+ , " :extension <Extension> - Enable a GHC extension."+ , " :extension No<Extension> - Disable a GHC extension."+ , " :type <expression> - Print expression type."+ , " :info <name> - Print all info for a name."+ , " :hoogle <query> - Search for a query on Hoogle."+ , " :doc <ident> - Get documentation for an identifier via Hogole."+ , " :set -XFlag -Wall - Set an option (like ghci)."+ , " :option <opt> - Set an option."+ , " :option no-<opt> - Unset an option."+ , " :?, :help - Show this help text."+ , ""+ , "Any prefix of the commands will also suffice, e.g. use :ty for :type."+ , ""+ , "Options:"+ , " lint – enable or disable linting."+ , " svg – use svg output (cannot be resized)."+ , " show-types – show types of all bound names"+ , " show-errors – display Show instance missing errors normally."+ , " pager – use the pager to display results of :info, :doc, :hoogle, etc."+ ]++-- This is taken largely from GHCi's info section in InteractiveUI.+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++ -- 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>"++ return+ EvalOut+ { evalStatus = Success+ , evalResult = mempty+ , evalState = state+ , evalPager = output+ , evalComms = []+ }++evalCommand _ (Directive SearchHoogle query) state = safely state $ do+ results <- liftIO $ Hoogle.search query+ return $ hoogleResults state results++evalCommand _ (Directive GetDoc query) state = safely state $ do+ results <- liftIO $ Hoogle.document query+ return $ hoogleResults state results++evalCommand output (Statement stmt) state = wrapExecution state $ do+ write state $ "Statement:\n" ++ stmt+ let outputter str = output $ IntermediateResult $ Display [plain str]+ (printed, result) <- capturedStatement outputter stmt+ case result of+ RunOk names -> do+ dflags <- getSessionDynFlags++ let allNames = map (showPpr dflags) names+ isItName name =+ name == "it" ||+ name == "it" ++ show (getExecutionCounter state)+ nonItNames = filter (not . isItName) allNames+ output = [plain printed | not . null $ strip printed]++ write state $ "Names: " ++ show allNames++ -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.+ if not $ useShowTypes state+ then return $ Display output+ else do+ -- Get all the type strings.+ types <- forM nonItNames $ \name -> do+ theType <- showSDocUnqual dflags . ppr <$> exprType name+ return $ name ++ " :: " ++ theType++ let joined = unlines types+ htmled = unlines $ map formatGetType types++ return $+ case extractPlain output of+ "" -> Display [html htmled]++ -- 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."++evalCommand output (Expression expr) state = do+ write state $ "Expression:\n" ++ expr++ -- Try to use `display` to convert our type into the output Dislay If typechecking fails and there+ -- is no appropriate typeclass instance, this will throw an exception and thus `attempt` will return+ -- False, and we just resort to plaintext.+ let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String+ canRunDisplay <- attempt $ exprType displayExpr++ -- Check if this is a widget.+ let widgetExpr = printf "(IHaskell.Display.Widget (%s))" expr :: String+ isWidget <- attempt $ exprType widgetExpr++ -- 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))++ write state $ "Can Display: " ++ show canRunDisplay+ write state $ "Is Widget: " ++ show isWidget+ write state $ "Is Declaration: " ++ show isTHDeclaration++ if isTHDeclaration+ then + -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the+ -- declaration made.+ do+ write state $ "Suppressing display for template haskell declaration"+ GHC.runDecls expr+ return+ EvalOut+ { evalStatus = Success+ , evalResult = mempty+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }+ else do+ if canRunDisplay+ then do+ -- Use the display. As a result, `it` is set to the output.+ out <- useDisplay displayExpr++ -- Register the `it` object as a widget.+ if isWidget+ then registerWidget out+ else return out+ else do+ -- Evaluate this expression as though it's just a statement. The output is bound to 'it', so we can+ -- then use it.+ evalOut <- evalCommand output (Statement expr) state++ let out = evalResult evalOut+ showErr = isShowError out++ -- If evaluation failed, return the failure. If it was successful, we may be able to use the+ -- IHaskellDisplay typeclass.+ return $ if not showErr || useShowErrors state+ then evalOut+ else postprocessShowError evalOut++ where+ -- Try to evaluate an action. Return True if it succeeds and False if it throws an exception. The+ -- result of the action is discarded.+ attempt :: Interpreter a -> Interpreter Bool+ attempt action = gcatch (action >> return True) failure+ where+ failure :: SomeException -> Interpreter Bool+ failure _ = return False++ -- Check if the error is due to trying to print something that doesn't implement the Show typeclass.+ isShowError (ManyDisplay _) = False+ isShowError (Display errs) =+ -- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as+ -- GHC.Show.Show. This is also very fragile!+ startswith "No instance for (Show" msg &&+ isInfixOf "print it" msg+ where+ msg = extractPlain errs++ isSvg (DisplayData mime _) = mime == MimeSvg++ removeSvg :: Display -> Display+ removeSvg (Display disps) = Display $ filter (not . isSvg) disps+ removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps++ useDisplay displayExpr = do+ -- If there are instance matches, convert the object into a Display. We also serialize it into a+ -- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring,+ -- which we promptly unserialize. Note that attempting to do this without the serialization to+ -- binary and back gives very strange errors - all the types match but it refuses to decode back+ -- into a Display. Suppress output, so as not to mess up console. First, evaluate the expression in+ -- such a way that we have access to `it`.+ io <- isIO expr+ let stmtTemplate = if io+ then "it <- (%s)"+ else "let { it = %s }"+ evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state+ case evalStatus evalOut of+ Failure -> return evalOut+ Success -> wrapExecution state $ do+ -- Compile the display data into a bytestring.+ let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"+ displayedBytestring <- dynCompileExpr compileExpr++ -- Convert from the bytestring into a display.+ case fromDynamic displayedBytestring of+ Nothing -> error "Expecting lazy Bytestring"+ Just bytestringIO -> do+ bytestring <- liftIO bytestringIO+ case Serialize.decode bytestring of+ Left err -> error err+ Right display ->+ return $+ if useSvg state+ then display :: Display+ else removeSvg display++ registerWidget :: EvalOut -> Ghc EvalOut+ registerWidget evalOut =+ case evalStatus evalOut of+ Failure -> return evalOut+ Success -> do+ element <- dynCompileExpr "IHaskell.Display.Widget it"+ case fromDynamic element of+ Nothing -> error "Expecting widget"+ Just widget -> do+ -- Stick the widget in the kernel state.+ uuid <- liftIO UUID.random+ let state = evalState evalOut+ newComms = Map.insert uuid widget $ openComms state+ state' = state { openComms = newComms }++ -- Store the fact that we should start this comm.+ return+ evalOut+ { evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut+ , evalState = state'+ }++ isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr++ postprocessShowError :: EvalOut -> EvalOut+ postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps }+ where+ Display disps = evalResult evalOut+ text = extractPlain disps++ postprocess (DisplayData MimeHtml _) = html $ printf+ fmt+ unshowableType+ (formatErrorWithClass "err-msg collapse"+ text)+ script+ where+ fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>"+ script = unlines+ [ "$('#unshowable').on('click', function(e) {"+ , " e.preventDefault();"+ , " var $this = $(this);"+ , " var $collapse = $this.closest('.collapse-group').find('.err-msg');"+ , " $collapse.collapse('toggle');"+ , "});"+ ]++ postprocess other = other++ unshowableType = fromMaybe "" $ do+ let pieces = words text+ before = takeWhile (/= "arising") pieces+ after = init $ unwords $ tail $ dropWhile (/= "(Show") before++ firstChar <- headMay after+ return $ if firstChar == '('+ then init $ tail after+ else after+++evalCommand _ (Declaration decl) state = wrapExecution state $ do+ write state $ "Declaration:\n" ++ decl+ boundNames <- evalDeclarations decl+ let nonDataNames = filter (not . isUpper . head) boundNames++ -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t.+ if not $ useShowTypes state+ then return mempty+ else do+ -- Get all the type strings.+ dflags <- getSessionDynFlags+ types <- forM nonDataNames $ \name -> do+ theType <- showSDocUnqual dflags . ppr <$> exprType name+ return $ name ++ " :: " ++ theType++ return $ Display [html $ unlines $ map formatGetType types]++evalCommand _ (TypeSignature sig) state = wrapExecution state $+ -- We purposefully treat this as a "success" because that way execution continues. Empty type+ -- signatures are likely due to a parse error later on, and we want that to be displayed.+ return $ displayError $ "The type signature " ++ sig ++ "\nlacks an accompanying binding."++evalCommand _ (ParseError loc err) state = do+ write state "Parse Error."+ return+ EvalOut+ { evalStatus = Failure+ , evalResult = displayError $ formatParseError loc err+ , evalState = state+ , evalPager = ""+ , evalComms = []+ }++evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $+ return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported."++evalCommand output (Pragma PragmaLanguage pragmas) state = do+ write state $ "Got LANGUAGE pragma " ++ show pragmas+ evalCommand output (Directive SetExtension $ unwords pragmas) state++hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut+hoogleResults state results =+ EvalOut+ { evalStatus = Success+ , evalResult = mempty+ , evalState = state+ , evalPager = output+ , evalComms = []+ }+ 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+ -- Remember which modules we've loaded before.+ importedModules <- getContext++ flip gcatch (unload importedModules) $ do+ -- Compile loaded modules.+ flags <- getSessionDynFlags+ errRef <- liftIO $ newIORef []+ setSessionDynFlags+ flags+ { hscTarget = objTarget flags+ , log_action = \dflags sev srcspan ppr msg -> modifyIORef errRef (showSDoc flags msg :)+ }++ -- Load the new target.+ target <- guessTarget name Nothing+ oldTargets <- getTargets+ -- Add a target, but make sure targets are unique!+ addTarget target+ getTargets >>= return . (nubBy ((==) `on` targetId)) >>= setTargets+ result <- load LoadAllTargets++ -- Reset the context, since loading things screws it up.+ initializeItVariable++ -- Reset targets if we failed.+ case result of+ Failed -> setTargets oldTargets+ Succeeded{} -> return ()++ -- Add imports+ setContext $+ case result of+ Failed -> importedModules+ Succeeded -> IIDecl (simpleImportDecl $ mkModuleName modName) : importedModules++ -- Switch back to interpreted mode.+ setSessionDynFlags flags++ case result of+ Succeeded -> return mempty+ Failed -> do+ errorStrs <- unlines <$> reverse <$> liftIO (readIORef errRef)+ return $ displayError $ "Failed to load module " ++ modName ++ "\n" ++ errorStrs++ where+ unload :: [InteractiveImport] -> SomeException -> Ghc Display+ unload imported exception = do+ print $ show exception+ -- Explicitly clear targets+ setTargets []+ load LoadAllTargets++ -- Switch to interpreted mode!+ flags <- getSessionDynFlags+ setSessionDynFlags flags { hscTarget = HscInterpreted }++ -- Return to old context, make sure we have `it`.+ setContext imported+ initializeItVariable++ return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception+#if MIN_VERSION_ghc(7,8,0)+objTarget flags = defaultObjectTarget $ targetPlatform flags+#else+objTarget flags = defaultObjectTarget+#endif+keepingItVariable :: Interpreter a -> Interpreter a+keepingItVariable act = do+ -- Generate the it variable temp name+ gen <- liftIO getStdGen+ let rand = take 20 $ randomRs ('0', '9') gen+ var name = name ++ rand+ goStmt s = runStmt s RunToCompletion+ itVariable = var "it_var_temp_"++ goStmt $ printf "let %s = it" itVariable+ val <- act+ goStmt $ printf "let it = %s" itVariable+ act++capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output.+ -> String -- ^ Statement to evaluate.+ -> Interpreter (String, RunResult) -- ^ Return the output and result.+capturedStatement 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 + -- Variable names generation.+ rand = take 20 $ randomRs ('0', '9') gen+ var name = name ++ rand++ -- Variables for the pipe input and outputs.+ readVariable = var "file_read_var_"+ writeVariable = var "file_write_var_"++ -- Variable where to store old stdout.+ oldVariable = var "old_var_"++ -- Variable used to store true `it` value.+ itVariable = var "it_var_"++ voidpf str = printf $ str ++ " IHaskellPrelude.>> IHaskellPrelude.return ()"++ -- Statements run before the thing we're evaluating.+ initStmts =+ [ printf "let %s = it" itVariable+ , printf "(%s, %s) <- IHaskellIO.createPipe" readVariable writeVariable+ , printf "%s <- IHaskellIO.dup IHaskellIO.stdOutput" oldVariable+ , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" writeVariable+ , voidpf "IHaskellSysIO.hSetBuffering IHaskellSysIO.stdout IHaskellSysIO.NoBuffering"+ , printf "let it = %s" itVariable+ ]++ -- Statements run after evaluation.+ postStmts =+ [ printf "let %s = it" itVariable+ , voidpf "IHaskellSysIO.hFlush IHaskellSysIO.stdout"+ , voidpf "IHaskellIO.dupTo %s IHaskellIO.stdOutput" oldVariable+ , 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++ -- Initialize evaluation context.+ void $ forM initStmts goStmt++ -- 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.+ 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+++ -- 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 + -- Compute how long to wait between reading pieces of the output. `threadDelay` takes an+ -- argument of microseconds.+ ms = 1000+ delay = 100 * ms++ -- How much to read each time.+ chunkSize = 100++ -- Maximum size of the output (after which we truncate).+ maxSize = 100 * 1000++ loop = do+ -- Wait and then check if the computation is done.+ threadDelay delay+ computationDone <- readMVar completed++ if not computationDone+ then do+ -- Read next chunk and append to accumulator.+ nextChunk <- readChars pipe "\n" 100+ modifyMVar_ outputAccum (return . (++ nextChunk))++ -- Write to frontend and repeat.+ readMVar outputAccum >>= output+ loop+ else do+ -- Read remainder of output and accumulate it.+ nextChunk <- readChars pipe "" maxSize+ modifyMVar_ outputAccum (return . (++ nextChunk))++ -- We're done reading.+ putMVar finishedReading True++ liftIO $ forkIO loop++ result <- gfinally (goStmt stmt) $ do+ -- Execution is done.+ liftIO $ modifyMVar_ completed (const $ return True)++ -- Finalize evaluation context.+ void $ forM postStmts goStmt++ -- Once context is finalized, reading can finish. Wait for reading to finish to that the output+ -- accumulator is completely filled.+ liftIO $ takeMVar finishedReading++ printedOutput <- liftIO $ readMVar outputAccum+ return (printedOutput, result)++-- Read from a file handle until we hit a delimiter or until we've read as many characters as+-- requested+readChars :: Handle -> String -> Int -> IO String+readChars handle delims 0 =+ -- If we're done reading, return nothing.+ return []+readChars handle delims nchars = do+ -- Try reading a single character. It will throw an exception if the handle is already closed.+ tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char)+ case tryRead of+ Right char ->+ -- If this is a delimiter, stop reading.+ if char `elem` delims+ then return [char]+ else do+ next <- readChars handle delims (nchars - 1)+ return $ char : next+ -- An error occurs at the end of the stream, so just stop reading.+ Left _ -> return []++formatError :: ErrMsg -> String+formatError = formatErrorWithClass "err-msg"++formatErrorWithClass :: String -> ErrMsg -> String+formatErrorWithClass cls =+ printf "<span class='%s'>%s</span>" cls .+ replace "\n" "<br/>" .+ 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."+ isShowError err =+ startswith "No instance for (Show" err &&+ isInfixOf " arising from a use of `print'" err++formatParseError :: StringLoc -> String -> ErrMsg+formatParseError (Loc line col) =+ printf "Parse error (line %d, column %d): %s" line col++formatGetType :: String -> String+formatGetType = printf "<span class='get-type'>%s</span>"++formatType :: String -> Display+formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr] displayError :: ErrMsg -> Display displayError msg = Display [plain . typeCleaner $ msg, html $ formatError msg]
src/IHaskell/Eval/Hoogle.hs view
@@ -1,41 +1,38 @@ {-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}+ module IHaskell.Eval.Hoogle (- search,- document,- render,- OutputFormat(..),- HoogleResult- ) where+ search,+ document,+ render,+ OutputFormat(..),+ HoogleResult,+ ) where -import ClassyPrelude hiding (last, span, div)-import Text.Printf-import Network.HTTP.Client-import Network.HTTP.Client.TLS-import Data.Aeson-import Data.String.Utils-import Data.List (elemIndex, (!!), last)+import ClassyPrelude hiding (last, span, div)+import Text.Printf+import Network.HTTP.Client+import Network.HTTP.Client.TLS+import Data.Aeson+import Data.String.Utils+import Data.List (elemIndex, (!!), last)+import Data.Char (isAscii, isAlphaNum) import qualified Data.ByteString.Lazy.Char8 as Char+import qualified Prelude as P -import IHaskell.IPython+import IHaskell.IPython -- | Types of formats to render output to.-data OutputFormat- = Plain -- ^ Render to plain text.- | HTML -- ^ Render to HTML.+data OutputFormat = Plain -- ^ Render to plain text.+ | HTML -- ^ Render to HTML. -data HoogleResponse = HoogleResponse {- location :: String,- self :: String,- docs :: String- }+data HoogleResponse = HoogleResponse { location :: String, self :: String, docs :: String } deriving (Eq, Show) -data HoogleResult- = SearchResult HoogleResponse- | DocResult HoogleResponse- | NoResult String- deriving Show+data HoogleResult = SearchResult HoogleResponse+ | DocResult HoogleResponse+ | NoResult String+ deriving Show instance FromJSON [HoogleResponse] where parseJSON (Object obj) = do@@ -46,57 +43,80 @@ instance FromJSON HoogleResponse where parseJSON (Object obj) =- HoogleResponse <$>- obj .: "location" <*>- obj .: "self" <*>- obj .: "docs"+ HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs" parseJSON _ = fail "Expected object with fields: location, self, docs" --- | Query Hoogle for the given string.--- This searches Hoogle using the internet. It returns either an error--- message or the successful JSON result.+-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either+-- an error message or the successful JSON result. query :: String -> IO (Either String String) query str = do- request <- parseUrl $ queryUrl str+ request <- parseUrl $ queryUrl $ urlEncode str response <- try $ withManager tlsManagerSettings $ httpLbs request- return $ case response of- Left err -> Left $ show (err :: SomeException)- Right resp -> Right $ Char.unpack $ responseBody resp+ return $+ case response of+ Left err -> Left $ show (err :: SomeException)+ Right resp -> Right $ Char.unpack $ responseBody resp+ where queryUrl :: String -> String queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json" --- | Search for a query on Hoogle.--- Return all search results.+-- | Copied from the HTTP package.+urlEncode :: String -> String+urlEncode [] = []+urlEncode (ch:t)+ | (isAscii ch && isAlphaNum ch) || ch `P.elem` "-_.~" = ch : urlEncode t+ | not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch))+ | otherwise = escape (P.fromEnum ch) (urlEncode t)+ where+ escape :: Int -> String -> String+ escape b rs = '%' : showH (b `P.div` 16) (showH (b `mod` 16) rs)++ showH :: Int -> String -> String+ showH x xs+ | x <= 9 = toEnum (o_0 + x) : xs+ | otherwise = toEnum (o_A + (x - 10)) : xs+ where+ o_0 = P.fromEnum '0'+ o_A = P.fromEnum 'A'++ eightBs :: [Int] -> Int -> [Int]+ eightBs acc x+ | x <= 255 = x : acc+ | otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)++-- | Search for a query on Hoogle. Return all search results. search :: String -> IO [HoogleResult] search string = do response <- query string- return $ case response of- Left err -> [NoResult err]- Right json ->- case eitherDecode $ Char.pack json of- Left err -> [NoResult err]- Right results ->- case map SearchResult results of- [] -> [NoResult "no matching identifiers found."]- res -> res+ return $+ case response of+ Left err -> [NoResult err]+ Right json ->+ case eitherDecode $ Char.pack json of+ Left err -> [NoResult err]+ Right results ->+ case map SearchResult results of+ [] -> [NoResult "no matching identifiers found."]+ res -> res --- | Look up an identifier on Hoogle.--- Return documentation for that identifier. If there are many+-- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many -- identifiers, include documentation for all of them. document :: String -> IO [HoogleResult] document string = do matchingResults <- filter matches <$> search string let results = map toDocResult matchingResults- return $ case results of- [] -> [NoResult "no matching identifiers found."]- res -> res+ return $+ case results of+ [] -> [NoResult "no matching identifiers found."]+ res -> res+ where matches (SearchResult resp) = case split " " $ self resp of name:_ -> strip string == strip name- _ -> False+ _ -> False matches _ = False toDocResult (SearchResult resp) = DocResult resp@@ -104,25 +124,18 @@ -- | Render a Hoogle search result into an output format. render :: OutputFormat -> HoogleResult -> String render Plain = renderPlain-render HTML = renderHtml+render HTML = renderHtml -- | Render a Hoogle result to plain text. renderPlain :: HoogleResult -> String- renderPlain (NoResult res) = "No response available: " ++ res renderPlain (SearchResult resp) =- printf "%s\nURL: %s\n%s"- (self resp)- (location resp)- (docs resp)+ printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp) renderPlain (DocResult resp) =- printf "%s\nURL: %s\n%s"- (self resp)- (location resp)- (docs resp)+ printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp) -- | Render a Hoogle result to HTML. renderHtml :: HoogleResult -> String@@ -141,37 +154,37 @@ renderSelf :: String -> String -> String renderSelf string loc- | startswith "package" string- = pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)+ | startswith "package" string =+ pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string) - | startswith "module" string- = let package = extractPackageName loc in- mod ++ " " ++- span "hoogle-module" (link loc $ extractModule string) ++- packageSub package+ | startswith "module" string =+ let package = extractPackageName loc+ in mod ++ " " +++ span "hoogle-module" (link loc $ extractModule string) +++ packageSub package - | startswith "class" string- = let package = extractPackageName loc in- cls ++ " " ++- span "hoogle-class" (link loc $ extractClass string) ++- packageSub package+ | startswith "class" string =+ let package = extractPackageName loc+ in cls ++ " " +++ span "hoogle-class" (link loc $ extractClass string) +++ packageSub package - | startswith "data" string- = let package = extractPackageName loc in- dat ++ " " ++- span "hoogle-class" (link loc $ extractData string) ++- packageSub package+ | startswith "data" string =+ let package = extractPackageName loc+ in dat ++ " " +++ span "hoogle-class" (link loc $ extractData string) +++ packageSub package - | otherwise- = let [name, args] = split "::" string+ | otherwise =+ let [name, args] = split "::" string package = extractPackageName loc- modname = extractModuleName loc in- span "hoogle-name" (unicodeReplace $- link loc (strip name) ++- " :: " ++- strip args)- ++ packageAndModuleSub package modname-+ modname = extractModuleName loc+ in span "hoogle-name"+ (unicodeReplace $+ link loc (strip name) +++ " :: " +++ strip args)+ ++ packageAndModuleSub package modname where extractPackage = strip . replace "package" "" extractModule = strip . replace "module" ""@@ -184,10 +197,10 @@ unicodeReplace :: String -> String unicodeReplace =- replace "forall" "∀" .- replace "=>" "⇒" .- replace "->" "→" .- replace "::" "∷"+ replace "forall" "∀" .+ replace "=>" "⇒" .+ replace "->" "→" .+ replace "::" "∷" packageSub Nothing = "" packageSub (Just package) =@@ -197,26 +210,25 @@ packageAndModuleSub Nothing _ = "" packageAndModuleSub (Just package) Nothing = packageSub (Just package) packageAndModuleSub (Just package) (Just modname) =- span "hoogle-sub" $- "(" ++ pkg ++ " " ++ span "hoogle-package" package ++- ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")"+ span "hoogle-sub" $+ "(" ++ pkg ++ " " ++ span "hoogle-package" package +++ ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")" renderDocs :: String -> String renderDocs doc = let groups = groupBy bothAreCode $ lines doc nonull = filter (not . null . strip) bothAreCode s1 s2 =- startswith ">" (strip s1) &&- startswith ">" (strip s2)+ startswith ">" (strip s1) &&+ startswith ">" (strip s2) isCode (s:_) = startswith ">" $ strip s makeBlock lines =- if isCode lines- then div "hoogle-code" $ unlines $ nonull lines- else div "hoogle-text" $ unlines $ nonull lines- in- div "hoogle-doc" $ unlines $ map makeBlock groups+ if isCode lines+ then div "hoogle-code" $ unlines $ nonull lines+ else div "hoogle-text" $ unlines $ nonull lines+ in div "hoogle-doc" $ unlines $ map makeBlock groups -extractPackageName :: String -> Maybe String+extractPackageName :: String -> Maybe String extractPackageName link = do let pieces = split "/" link archiveLoc <- elemIndex "archive" pieces@@ -224,7 +236,7 @@ guard $ latestLoc - archiveLoc == 2 return $ pieces !! (latestLoc - 1) -extractModuleName :: String -> Maybe String+extractModuleName :: String -> Maybe String extractModuleName link = do let pieces = split "/" link guard $ not $ null pieces
src/IHaskell/Eval/Info.hs view
@@ -1,23 +1,21 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{- | Description : Inspect type and function information and documentation.--}-module IHaskell.Eval.Info (- info- ) where -import ClassyPrelude hiding (liftIO)+{- | Description : Inspect type and function information and documentation. -}+module IHaskell.Eval.Info (info) where -import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)+import ClassyPrelude hiding (liftIO) -import GHC-import Outputable-import Exception+import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) +import GHC+import Outputable+import Exception+ info :: String -> Interpreter String info name = ghandle handler $ do dflags <- getSessionDynFlags result <- exprType name- return $ typeCleaner $ showPpr dflags result - where + return $ typeCleaner $ showPpr dflags result+ where handler :: SomeException -> Interpreter String handler _ = return ""
src/IHaskell/Eval/Lint.hs view
@@ -1,45 +1,44 @@ {-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}-module IHaskell.Eval.Lint ( - lint- ) where -import Data.String.Utils (replace, startswith, strip, split)-import Prelude (head, tail, last)-import ClassyPrelude hiding (last)-import Control.Monad-import Data.List (findIndex)-import Text.Printf-import Data.String.Here-import Data.Char-import Data.Monoid-import Data.Maybe (mapMaybe)-import System.IO.Unsafe (unsafePerformIO)+module IHaskell.Eval.Lint (lint) where -import Language.Haskell.Exts.Annotated.Syntax hiding (Module)+import Data.String.Utils (replace, startswith, strip, split)+import Prelude (head, tail, last)+import ClassyPrelude hiding (last)+import Control.Monad+import Data.List (findIndex)+import Text.Printf+import Data.String.Here+import Data.Char+import Data.Monoid+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.SrcLoc+import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)+import Language.Haskell.Exts.Annotated.Build (doE)+import Language.Haskell.Exts.Annotated hiding (Module)+import Language.Haskell.Exts.SrcLoc -import Language.Haskell.HLint as HLint-import Language.Haskell.HLint2+import Language.Haskell.HLint as HLint+import Language.Haskell.HLint2 -import IHaskell.Types-import IHaskell.Display-import IHaskell.IPython-import IHaskell.Eval.Parser hiding (line)+import IHaskell.Types+import IHaskell.Display+import IHaskell.IPython+import IHaskell.Eval.Parser hiding (line) type ExtsModule = SrcExts.Module SrcSpanInfo -data LintSuggestion- = Suggest {- line :: LineNumber,- found :: String,- whyNot :: String,- severity :: Severity,- suggestion :: String- }+data LintSuggestion =+ Suggest+ { line :: LineNumber+ , found :: String+ , whyNot :: String+ , severity :: Severity+ , suggestion :: String+ } deriving (Eq, Show) -- Store settings for Hlint once it's initialized.@@ -51,8 +50,8 @@ lintIdent :: String lintIdent = "lintIdentAEjlkQeh" --- | Given parsed code chunks, perform linting and output a displayable--- report on linting warnings and errors.+-- | Given parsed code chunks, perform linting and output a displayable report on linting warnings+-- and errors. lint :: [Located CodeBlock] -> IO Display lint blocks = do -- Initialize hlint settings@@ -66,63 +65,62 @@ -- create 'suggestions' let modules = mapMaybe (createModule mode) blocks- ideas = applyHints classify hint (map (\m->(m,[])) modules)+ ideas = applyHints classify hint (map (\m -> (m, [])) modules) suggestions = mapMaybe showIdea ideas return $ Display $ if null suggestions- then []- else - [plain $ concatMap plainSuggestion suggestions,- html $ htmlSuggestions suggestions]+ then []+ else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions] showIdea :: Idea -> Maybe LintSuggestion-showIdea idea = +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) = +createModule mode (Located line block) = case block of- Expression expr -> unparse $ exprToModule expr- Declaration decl -> unparse $ declToModule decl - Statement stmt -> unparse $ stmtToModule stmt- Import impt -> unparse $ imptToModule impt- Module mod -> unparse $ parseModule mod- _ -> Nothing+ Expression expr -> unparse $ exprToModule expr+ Declaration decl -> unparse $ declToModule decl+ Statement stmt -> unparse $ stmtToModule stmt+ Import impt -> unparse $ imptToModule impt+ Module mod -> unparse $ parseModule mod+ _ -> Nothing where- blockStr = + blockStr = case block of- Expression expr -> expr- Declaration decl -> decl - Statement stmt -> stmt- Import impt -> impt- Module mod -> mod+ Expression expr -> expr+ Declaration decl -> decl+ Statement stmt -> stmt+ Import impt -> impt+ Module mod -> mod unparse :: ParseResult a -> Maybe a unparse (ParseOk a) = Just a unparse _ = Nothing srcSpan :: SrcSpan- srcSpan = SrcSpan {- srcSpanFilename = "<interactive>",- srcSpanStartLine = line,- srcSpanStartColumn = 0,- srcSpanEndLine = line + length (lines blockStr),- srcSpanEndColumn = length $ last $ lines blockStr- }+ srcSpan = SrcSpan+ { srcSpanFilename = "<interactive>"+ , srcSpanStartLine = line+ , srcSpanStartColumn = 0+ , srcSpanEndLine = line + length (lines blockStr)+ , srcSpanEndColumn = length $ last $ lines blockStr+ } loc :: SrcSpanInfo loc = SrcSpanInfo srcSpan [] - moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule + moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl] parseModule :: String -> ParseResult ExtsModule@@ -135,9 +133,10 @@ exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp stmtToModule :: String -> ParseResult ExtsModule- stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of- ParseOk stmt -> ParseOk mod- ParseFailed a b -> ParseFailed a b+ stmtToModule stmtStr =+ case parseStmtWithMode mode stmtStr of+ ParseOk stmt -> ParseOk mod+ ParseFailed a b -> ParseFailed a b where mod = moduleWithDecls decl @@ -157,35 +156,31 @@ imptToModule = parseFileContentsWithMode mode plainSuggestion :: LintSuggestion -> String-plainSuggestion suggest = - printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s"- (line suggest)- (suggestion suggest)- (found suggest)+plainSuggestion suggest =+ printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest) (whyNot suggest) htmlSuggestions :: [LintSuggestion] -> String-htmlSuggestions = concatMap toHtml +htmlSuggestions = concatMap toHtml where toHtml :: LintSuggestion -> String- toHtml suggest = concat - [- named $ suggestion suggest,- floating "left" $ style severityClass "Found:" ++- -- Things that look like this get highlighted.- styleId "highlight-code" "haskell" (found suggest),- floating "left" $ style severityClass "Why Not:" ++- -- Things that look like this get highlighted.- styleId "highlight-code" "haskell" (whyNot suggest)- ]-+ toHtml suggest = concat+ [ named $ suggestion suggest+ , floating "left" $ style severityClass "Found:" +++ -- Things that look like this get highlighted.+ styleId "highlight-code" "haskell" (found suggest)+ , floating "left" $ style severityClass "Why Not:" +++ -- Things that look like this get highlighted.+ styleId "highlight-code" "haskell" (whyNot suggest)+ ] where- severityClass = case severity suggest of- Error -> "error"- Warning -> "warning"+ severityClass =+ case severity suggest of+ Error -> "error"+ Warning -> "warning" - -- Should not occur- _ -> "warning"+ -- Should not occur+ _ -> "warning" style :: String -> String -> String style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]@@ -195,37 +190,32 @@ styleId :: String -> String -> String -> String styleId cls id thing = [i| <div class="${cls}" id="${id}">${thing}</div> |]- + floating :: String -> String -> String floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |] - showSuggestion :: String -> String-showSuggestion = remove lintIdent . dropDo+showSuggestion = remove lintIdent . dropDo where remove str = replace str "" -- Drop leading ' do ', and blank spaces following. dropDo :: String -> String- dropDo string = + dropDo string = -- If this is not a statement, we don't need to drop the do statement. if lintIdent `isInfixOf` string- then unlines . clean . lines $ string- else string+ then unlines . clean . lines $ string+ else string clean :: [String] -> [String]- -- If the first line starts with a `do`...- -- Note that hlint always indents by two spaces in its output.- clean ((stripPrefix " do " -> Just a) : as) =- -- Take all indented lines and unindent them.- let unindented = catMaybes- $ takeWhile isJust- $ map (stripPrefix " ") as- fullDo = a:unindented- afterDo = drop (length unindented) as- in - -- - fullDo ++ clean afterDo+ -- If the first line starts with a `do`... Note that hlint always indents by two spaces in its+ -- output.+ clean ((stripPrefix " do " -> Just a):as) =+ -- Take all indented lines and unindent them.+ let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as+ fullDo = a : unindented+ afterDo = drop (length unindented) as+ in fullDo ++ clean afterDo -- Ignore other list elements - just proceed onwards. clean (x:xs) = x : clean xs
src/IHaskell/Eval/ParseShell.hs view
@@ -1,16 +1,15 @@- -- | This module splits a shell command line into a list of strings, -- one for each command / filename-module IHaskell.Eval.ParseShell (parseShell) where +module IHaskell.Eval.ParseShell (parseShell) where -import Prelude hiding (words)-import Text.ParserCombinators.Parsec hiding (manyTill)-import Control.Applicative hiding ((<|>), many, optional)+import Prelude hiding (words)+import Text.ParserCombinators.Parsec hiding (manyTill)+import Control.Applicative hiding ((<|>), many, optional) eol :: Parser Char eol = oneOf "\n\r" <?> "end of line" -quote :: Parser Char +quote :: Parser Char quote = char '\"' -- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@@@ -18,16 +17,17 @@ manyTill p end = scan where scan = end <|> do- x <- p- xs <- scan- return $ x:xs+ x <- p+ xs <- scan+ return $ x : xs -manyTill1 p end = do x <- p - xs <- manyTill p end - return $ x : xs+manyTill1 p end = do+ x <- p+ xs <- manyTill p end+ return $ x : xs -unescapedChar :: Parser Char -> Parser String -unescapedChar p = try $ do +unescapedChar :: Parser Char -> Parser String+unescapedChar p = try $ do x <- noneOf "\\" lookAhead p return [x]@@ -36,8 +36,9 @@ quote <?> "expected starting quote" (manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String " -unquotedString = manyTill1 anyChar end - where end = unescapedChar space +unquotedString = manyTill1 anyChar end+ where+ end = unescapedChar space <|> (lookAhead eol >> return []) word = quotedString <|> unquotedString <?> "word"@@ -48,12 +49,12 @@ -- | Input must terminate in a space character (like a \n) words :: Parser [String] words = try (eof *> return []) <|> do- x <- word - rest1 <- lookAhead (many anyToken)- ss <- separator - rest2 <- lookAhead (many anyToken)- xs <- words - return $ x : xs + x <- word+ rest1 <- lookAhead (many anyToken)+ ss <- separator+ rest2 <- lookAhead (many anyToken)+ xs <- words+ return $ x : xs parseShell :: String -> Either ParseError [String] parseShell string = parse words "shell" (string ++ "\n")
src/IHaskell/Eval/Parser.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+ module IHaskell.Eval.Parser ( parseString, CodeBlock(..),@@ -14,67 +15,55 @@ PragmaType(..), ) where --- Hide 'unlines' to use our own 'joinLines' instead.-import ClassyPrelude hiding (head, tail, liftIO, unlines, maximumBy)+import ClassyPrelude hiding (head, liftIO, maximumBy) -import Data.List (findIndex, maximumBy, maximum, inits)-import Data.String.Utils (startswith, strip, split)-import Data.List.Utils (subIndex)-import Prelude (init, last, head, tail)-import Control.Monad (msum)+import Data.List (maximumBy, inits)+import Data.String.Utils (startswith, strip, split)+import Prelude (head, tail)+import Control.Monad (msum) -import Bag-import ErrUtils hiding (ErrMsg)-import FastString-import GHC hiding (Located)-import GhcMonad-import Lexer-import OrdList-import Outputable hiding ((<>))-import SrcLoc hiding (Located)-import StringBuffer+import GHC hiding (Located) -import Language.Haskell.GHC.Parser-import IHaskell.Eval.Util+import Language.Haskell.GHC.Parser+import IHaskell.Eval.Util --- | A block of code to be evaluated.--- Each block contains a single element - one declaration, statement,--- expression, etc. If parsing of the block failed, the block is instead--- a ParseError, which has the error location and error message.-data CodeBlock- = Expression String -- ^ A Haskell expression.- | Declaration String -- ^ A data type or function declaration.- | Statement String -- ^ A Haskell statement (as if in a `do` block).- | Import String -- ^ An import statement.- | TypeSignature String -- ^ A lonely type signature (not above a function declaration).- | Directive DirectiveType String -- ^ An IHaskell directive.- | Module String -- ^ A full Haskell module, to be compiled and loaded.- | ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block failed.- | Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-} block)+-- | A block of code to be evaluated. Each block contains a single element - one declaration,+-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,+-- which has the error location and error message.+data CodeBlock = Expression String -- ^ A Haskell expression.+ | Declaration String -- ^ A data type or function declaration.+ | Statement String -- ^ A Haskell statement (as if in a `do` block).+ | Import String -- ^ An import statement.+ | TypeSignature String -- ^ A lonely type signature (not above a function+ -- declaration).+ | Directive DirectiveType String -- ^ An IHaskell directive.+ | Module String -- ^ A full Haskell module, to be compiled and loaded.+ | ParseError StringLoc ErrMsg -- ^ An error indicating that parsing the code block+ -- failed.+ | Pragma PragmaType [String] -- ^ A list of GHC pragmas (from a {-# LANGUAGE ... #-}+ -- block) deriving (Show, Eq) --- | Directive types. Each directive is associated with a string in the--- directive code block.-data DirectiveType- = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)- | GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)- | SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`. Emulates GHCi's `:set`- | LoadFile -- ^ Load a Haskell module.- | SetOption -- ^ Set IHaskell kernel option `:option`.- | SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`- | ShellCmd -- ^ Execute a shell command.- | GetHelp -- ^ General help via ':?' or ':help'.- | SearchHoogle -- ^ Search for something via Hoogle.- | GetDoc -- ^ Get documentation for an identifier via Hoogle.- | GetKind -- ^ Get the kind of a type via ':kind'.- | LoadModule -- ^ Load and unload modules via ':module'.+-- | Directive types. Each directive is associated with a string in the directive code block.+data DirectiveType = GetType -- ^ Get the type of an expression via ':type' (or unique prefixes)+ | GetInfo -- ^ Get info about the identifier via ':info' (or unique prefixes)+ | SetDynFlag -- ^ Enable or disable an extensions, packages etc. via `:set`.+ -- Emulates GHCi's `:set`+ | LoadFile -- ^ Load a Haskell module.+ | SetOption -- ^ Set IHaskell kernel option `:option`.+ | SetExtension -- ^ `:extension Foo` is a shortcut for `:set -XFoo`+ | ShellCmd -- ^ Execute a shell command.+ | GetHelp -- ^ General help via ':?' or ':help'.+ | SearchHoogle -- ^ Search for something via Hoogle.+ | GetDoc -- ^ Get documentation for an identifier via Hoogle.+ | GetKind -- ^ Get the kind of a type via ':kind'.+ | LoadModule -- ^ Load and unload modules via ':module'. deriving (Show, Eq) --- | Pragma types. Only LANGUAGE pragmas are currently supported.--- Other pragma types are kept around as a string for error reporting.-data PragmaType- = PragmaLanguage- | PragmaUnsupported String+-- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around+-- as a string for error reporting.+data PragmaType = PragmaLanguage+ | PragmaUnsupported String deriving (Show, Eq) -- | Parse a string into code blocks.@@ -84,17 +73,18 @@ flags <- getSessionDynFlags let output = runParser flags parserModule codeString case output of- Parsed {} -> return [Located 1 $ Module codeString]- Failure {} -> do+ Parsed mod+ | Just _ <- hsmodName (unLoc mod) -> return [Located 1 $ Module codeString]+ _ -> do -- Split input into chunks based on indentation. let chunks = layoutChunks $ removeComments codeString result <- joinFunctions <$> processChunks [] chunks - -- Return to previous flags. When parsing, flags can be set to make- -- sure parsing works properly. But we don't want those flags to be- -- set during evaluation until the right time.- setSessionDynFlags flags+ -- Return to previous flags. When parsing, flags can be set to make sure parsing works properly. But+ -- we don't want those flags to be set during evaluation until the right time.+ _ <- setSessionDynFlags flags return result+ where parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock) parseChunk chunk line = Located line <$> handleChunk chunk line@@ -111,7 +101,7 @@ [] -> return $ reverse accum -- If we have more remaining, parse the current chunk and recurse.- Located line chunk:remaining -> do+ Located line chunk:remaining -> do block <- parseChunk chunk line activateExtensions $ unloc block processChunks (block : accum) remaining@@ -124,16 +114,12 @@ isPragma :: String -> Bool isPragma = startswith "{-#" . strip - -- Number of lines in this string.- nlines :: String -> Int- nlines = length . lines- activateExtensions :: GhcMonad m => CodeBlock -> m () activateExtensions (Directive SetExtension ext) = void $ setExtension ext activateExtensions (Directive SetDynFlag flags) = case stripPrefix "-X" flags of Just ext -> void $ setExtension ext- Nothing -> return ()+ Nothing -> return () activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions where setAll :: GhcMonad m => [String] -> m (Maybe String)@@ -145,20 +131,21 @@ -- | Parse a single chunk of code, as indicated by the layout of the code. parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock parseCodeChunk code startLine = do- flags <- getSessionDynFlags- let- -- Try each parser in turn.- rawResults = map (tryParser code) (parsers flags)+ flags <- getSessionDynFlags+ let + -- Try each parser in turn.+ rawResults = map (tryParser code) (parsers flags) - -- Convert statements into expressions where we can- results = map (statementToExpression flags) rawResults in- case successes results of- -- If none of them succeeded, choose the best error message to- -- display. Only one of the error messages is actually relevant.- [] -> return $ bestError $ failures results+ -- Convert statements into expressions where we can+ results = map (statementToExpression flags) rawResults+ case successes results of+ -- If none of them succeeded, choose the best error message to display. Only one of the error+ -- messages is actually relevant.+ [] -> return $ bestError $ failures results - -- If one of the parsers succeeded- result:_ -> return result+ -- If one of the parsers succeeded+ result:_ -> return result+ where successes :: [ParseOutput a] -> [a] successes [] = []@@ -178,46 +165,50 @@ statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock statementToExpression flags (Parsed (Statement stmt)) = Parsed result- where result = if isExpr flags stmt- then Expression stmt- else Statement stmt+ where+ result = if isExpr flags stmt+ then Expression stmt+ else Statement stmt statementToExpression _ other = other -- Check whether a string is a valid expression. isExpr :: DynFlags -> String -> Bool- isExpr flags str = case runParser flags parserExpression str of- Parsed {} -> True- _ -> False+ isExpr flags str =+ case runParser flags parserExpression str of+ Parsed{} -> True+ _ -> False tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock- tryParser string (blockType, parser) = case parser string of- Parsed res -> Parsed (blockType res)- Failure err loc -> Failure err loc+ tryParser string (blockType, parser) =+ case parser string of+ Parsed res -> Parsed (blockType res)+ Failure err loc -> Failure err loc+ otherwise -> error "tryParser failed, output was neither Parsed nor Failure" parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)] parsers flags =- [ (Import, unparser parserImport)+ [ (Import, unparser parserImport) , (TypeSignature, unparser parserTypeSignature)- , (Statement, unparser parserStatement)- , (Declaration, unparser parserDeclaration)+ , (Statement, unparser parserStatement)+ , (Declaration, unparser parserDeclaration) ] where unparser :: Parser a -> String -> ParseOutput String unparser parser code = case runParser flags parser code of- Parsed out -> Parsed code+ Parsed out -> Parsed code Partial out strs -> Partial code strs- Failure err loc -> Failure err loc+ Failure err loc -> Failure err loc --- | Find consecutive declarations of the same function and join them into--- a single declaration. These declarations may also include a type--- signature, which is also joined with the subsequent declarations.+-- | Find consecutive declarations of the same function and join them into a single declaration.+-- These declarations may also include a type signature, which is also joined with the subsequent+-- declarations. joinFunctions :: [Located CodeBlock] -> [Located CodeBlock] joinFunctions [] = [] joinFunctions blocks = if signatureOrDecl $ unloc $ head blocks- then Located lnum (conjoin $ map unloc decls) : joinFunctions rest- else head blocks : joinFunctions (tail blocks)+ then Located lnum (conjoin $ map unloc decls) : joinFunctions rest+ else head blocks : joinFunctions (tail blocks) where decls = takeWhile (signatureOrDecl . unloc) blocks rest = drop (length decls) blocks@@ -234,7 +225,6 @@ conjoin :: [CodeBlock] -> CodeBlock conjoin = Declaration . intercalate "\n" . map str - -- | Parse a pragma of the form {-# LANGUAGE ... #-} parsePragma :: String -- ^ Pragma string. -> Int -- ^ Line number at which the directive appears.@@ -242,10 +232,11 @@ parsePragma ('{':'-':'#':pragma) line = let commaToSpace :: Char -> Char commaToSpace ',' = ' '- commaToSpace x = x- pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma in- case pragmas of- [] -> Pragma (PragmaUnsupported "") [] --empty string pragmas are unsupported+ commaToSpace x = x+ pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma+ in case pragmas of+ --empty string pragmas are unsupported+ [] -> Pragma (PragmaUnsupported "") [] "LANGUAGE":xs -> Pragma PragmaLanguage xs x:xs -> Pragma (PragmaUnsupported x) xs @@ -253,51 +244,50 @@ parseDirective :: String -- ^ Directive string. -> Int -- ^ Line number at which the directive appears. -> CodeBlock -- ^ Directive code block or a parse error.--parseDirective (':':'!':directive) line = Directive ShellCmd $ '!':directive-parseDirective (':':directive) line = case find rightDirective directives of- Just (directiveType, _) -> Directive directiveType arg- where arg = unwords restLine- _:restLine = words directive- Nothing ->- let directiveStart = case words directive of- [] -> ""- first:_ -> first in- ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'."+parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive+parseDirective (':':directive) line =+ case find rightDirective directives of+ Just (directiveType, _) -> Directive directiveType arg+ where arg = unwords restLine+ _:restLine = words directive+ Nothing ->+ let directiveStart =+ case words directive of+ [] -> ""+ first:_ -> first+ in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'." where- rightDirective (_, dirname) = case words directive of- [] -> False- dir:_ -> dir `elem` tail (inits dirname)+ rightDirective (_, dirname) =+ case words directive of+ [] -> False+ dir:_ -> dir `elem` tail (inits dirname) directives =- [ (LoadModule, "module")- , (GetType, "type")- , (GetKind, "kind")- , (GetInfo, "info")+ [ (LoadModule, "module")+ , (GetType, "type")+ , (GetKind, "kind")+ , (GetInfo, "info") , (SearchHoogle, "hoogle")- , (GetDoc, "documentation")- , (SetDynFlag, "set")- , (LoadFile, "load")- , (SetOption, "option")+ , (GetDoc, "documentation")+ , (SetDynFlag, "set")+ , (LoadFile, "load")+ , (SetOption, "option") , (SetExtension, "extension")- , (GetHelp, "?")- , (GetHelp, "help")+ , (GetHelp, "?")+ , (GetHelp, "help") ] parseDirective _ _ = error "Directive must start with colon!" --- | Parse a module and return the name declared in the 'module X where'--- line. That line is required, and if it does not exist, this will error.--- Names with periods in them are returned piece y piece.+-- | Parse a module and return the name declared in the 'module X where' line. That line is+-- required, and if it does not exist, this will error. Names with periods in them are returned+-- piece y piece. getModuleName :: GhcMonad m => String -> m [String] getModuleName moduleSrc = do flags <- getSessionDynFlags let output = runParser flags parserModule moduleSrc case output of- Failure {} -> error "Module parsing failed."+ Failure{} -> error "Module parsing failed." Parsed mod -> case unLoc <$> hsmodName (unLoc mod) of- Nothing -> error "Module must have a name."+ Nothing -> error "Module must have a name." Just name -> return $ split "." $ moduleNameString name---- Not the same as 'unlines', due to trailing \n-joinLines :: [String] -> String-joinLines = intercalate "\n"+ otherwise -> error "getModuleName failed, output was neither Parsed nor Failure"
src/IHaskell/Eval/Util.hs view
@@ -1,26 +1,29 @@ {-# LANGUAGE CPP, NoImplicitPrelude #-}+ module IHaskell.Eval.Util (- -- * Initialization- initGhci,+ -- * Initialization+ initGhci, - -- * Flags and extensions- -- ** Set and unset flags.- extensionFlag, setExtension,- ExtFlag(..),- setFlags,+ -- * Flags and extensions ** Set and unset flags.+ extensionFlag,+ setExtension,+ ExtFlag(..),+ setFlags, - -- * Code Evaluation- evalImport,- removeImport,- evalDeclarations,- getType,- getDescription,+ -- * Code Evaluation+ evalImport,+ removeImport,+ evalDeclarations,+ getType,+ getDescription, - -- * Pretty printing- doc,- ) where+ -- * Pretty printing+ doc,+ pprDynFlags,+ pprLanguages,+ ) where -import ClassyPrelude+import ClassyPrelude hiding ((<>)) -- GHC imports. import DynFlags@@ -48,35 +51,114 @@ import Data.List (nubBy) -- | A extension flag that can be set or unset.-data ExtFlag- = SetFlag ExtensionFlag- | UnsetFlag ExtensionFlag+data ExtFlag = SetFlag ExtensionFlag+ | UnsetFlag ExtensionFlag --- | Find the extension that corresponds to a given flag. Create the--- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.--- If no such extension exist, yield @Nothing@.+-- | Find the extension that corresponds to a given flag. Create the corresponding 'ExtFlag' via+-- @SetFlag@ or @UnsetFlag@. If no such extension exist, yield @Nothing@. extensionFlag :: String -- Extension name, such as @"DataKinds"@ -> Maybe ExtFlag extensionFlag ext = case find (flagMatches ext) xFlags of- Just (_, flag, _) -> Just $ SetFlag flag- -- If it doesn't match an extension name, try matching against- -- disabling an extension.+ Just fs -> Just $ SetFlag $ flagSpecFlag fs+ -- If it doesn't match an extension name, try matching against disabling an extension. Nothing -> case find (flagMatchesNo ext) xFlags of- Just (_, flag, _) -> Just $ UnsetFlag flag+ Just fs -> Just $ UnsetFlag $ flagSpecFlag fs Nothing -> Nothing- where -- Check if a FlagSpec matches an extension name.- flagMatches ext (name, _, _) = ext == name+ flagMatches ext fs = ext == flagSpecName fs - -- Check if a FlagSpec matches "No<ExtensionName>".- -- In that case, we disable the extension.- flagMatchesNo ext (name, _, _) = ext == "No" ++ name+ -- Check if a FlagSpec matches "No<ExtensionName>". In that case, we disable the extension.+ flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs+#if !MIN_VERSION_ghc(7,10,0)+flagSpecName (name, _, _) = name --- | Set an extension and update flags.--- Return @Nothing@ on success. On failure, return an error message.+flagSpecFlag (_, flag, _) = flag+#endif+-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)+pprDynFlags :: Bool -- ^ Whether to include flags which are on by default+ -> DynFlags+ -> SDoc+pprDynFlags show_all dflags =+ vcat+ [ text "GHCi-specific dynamic flag settings:" $$+ nest 2 (vcat (map (setting opt) ghciFlags))+ , text "other dynamic, non-language, flag settings:" $$+ nest 2 (vcat (map (setting opt) others))+ , text "warning settings:" $$+ nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))+ ]+ where++#if MIN_VERSION_ghc(7,8,0)+ opt = gopt+#else+ opt = dopt+#endif+ setting test flag+ | quiet = empty+ | is_on = fstr name+ | otherwise = fnostr name+ where+ name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on+ + default_dflags = defaultDynFlags (settings dflags)+ + fstr str = text "-f" <> text str+ + fnostr str = text "-fno-" <> text str+ + (ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags+ + flgs = concat [flgs1, flgs2, flgs3]+ + flgs1 = [Opt_PrintExplicitForalls]+#if MIN_VERSION_ghc(7,8,0)+ flgs2 = [Opt_PrintExplicitKinds]+#else+ flgs2 = []+#endif+flgs3 = [Opt_PrintBindResult, Opt_BreakOnException, Opt_BreakOnError, Opt_PrintEvldWithShow]++-- | Pretty-print the base language and active options (taken from `InteractiveUI` module of+-- `ghc-bin`)+pprLanguages :: Bool -- ^ Whether to include flags which are on by default+ -> DynFlags+ -> SDoc+pprLanguages show_all dflags =+ vcat+ [text "base language is: " <>+ case language dflags of+ Nothing -> text "Haskell2010"+ Just Haskell98 -> text "Haskell98"+ Just Haskell2010 -> text "Haskell2010", (if show_all+ then text "all active language options:"+ else text "with the following modifiers:") $$+ nest 2 (vcat (map (setting xopt) DynFlags.xFlags))]+ where+ setting test flag+ | quiet = empty+ | is_on = text "-X" <> text name+ | otherwise = text "-XNo" <> text name+ where+ name = flagSpecName flag+ f = flagSpecFlag flag+ is_on = test f dflags+ quiet = not show_all && test f default_dflags == is_on++ default_dflags =+ defaultDynFlags (settings dflags) `lang_set`+ case language dflags of+ Nothing -> Just Haskell2010+ other -> other++-- | Set an extension and update flags. Return @Nothing@ on success. On failure, return an error+-- message. setExtension :: GhcMonad m => String -> m (Maybe String) setExtension ext = do flags <- getSessionDynFlags@@ -85,37 +167,35 @@ Just flag -> do setSessionDynFlags $ case flag of- SetFlag ghcFlag -> xopt_set flags ghcFlag+ SetFlag ghcFlag -> xopt_set flags ghcFlag UnsetFlag ghcFlag -> xopt_unset flags ghcFlag return Nothing --- | Set a list of flags, as per GHCi's `:set`.--- This was adapted from GHC's InteractiveUI.hs (newDynFlags).--- It returns a list of error messages.+-- | Set a list of flags, as per GHCi's `:set`. This was adapted from GHC's InteractiveUI.hs+-- (newDynFlags). It returns a list of error messages. setFlags :: GhcMonad m => [String] -> m [String] setFlags ext = do- -- Try to parse flags.- flags <- getSessionDynFlags- (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)+ -- Try to parse flags.+ flags <- getSessionDynFlags+ (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) - -- First, try to check if this flag matches any extension name.- let restorePkg x = x { packageFlags = packageFlags flags }- let restoredPkgs = flags' { packageFlags = packageFlags flags}- GHC.setProgramDynFlags restoredPkgs- GHC.setInteractiveDynFlags restoredPkgs+ -- First, try to check if this flag matches any extension name.+ let restorePkg x = x { packageFlags = packageFlags flags }+ let restoredPkgs = flags' { packageFlags = packageFlags flags }+ GHC.setProgramDynFlags restoredPkgs+ GHC.setInteractiveDynFlags restoredPkgs - -- Create the parse errors.- let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized- allWarns = map unLoc warnings ++- ["-package not supported yet" | packageFlags flags /= packageFlags flags']- warnErrs = map ("Warning: " ++) allWarns- return $ noParseErrs ++ warnErrs+ -- Create the parse errors.+ let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized+ allWarns = map unLoc warnings +++ ["-package not supported yet" | packageFlags flags /= packageFlags flags']+ warnErrs = map ("Warning: " ++) allWarns+ return $ noParseErrs ++ warnErrs --- | Convert an 'SDoc' into a string. This is similar to the family of--- 'showSDoc' functions, but does not impose an arbitrary width limit on--- the output (in terms of number of columns). Instead, it respsects the--- 'pprCols' field in the structure returned by 'getSessionDynFlags', and--- thus gives a configurable width of output.+-- | Convert an 'SDoc' into a string. This is similar to the family of 'showSDoc' functions, but+-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,+-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus+-- gives a configurable width of output. doc :: GhcMonad m => SDoc -> m String doc sdoc = do flags <- getSessionDynFlags@@ -124,15 +204,16 @@ let cols = pprCols flags d = runSDoc sdoc (initSDocContext flags style) return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d+ where string_txt :: Pretty.TextDetails -> String -> String- string_txt (Pretty.Chr c) s = c:s- string_txt (Pretty.Str s1) s2 = s1 ++ s2+ string_txt (Pretty.Chr c) s = c : s+ string_txt (Pretty.Str s1) s2 = s1 ++ s2 string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 --- | Initialize the GHC API. Run this as the first thing in the `runGhc`.--- This initializes some dyn flags (@ExtendedDefaultRules@,+-- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn+-- flags (@ExtendedDefaultRules@, -- @NoMonomorphismRestriction@), sets the target to interpreted, link in -- memory, sets a reasonable output width, and potentially a few other -- things. It should be invoked before other functions from this module.@@ -142,27 +223,28 @@ -- (and only the first time) it is called. initGhci :: GhcMonad m => Maybe String -> m () initGhci sandboxPackages = do- -- Initialize dyn flags.- -- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.+ -- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction. originalFlags <- getSessionDynFlags let flag = flip xopt_set unflag = flip xopt_unset dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags- pkgConfs = case sandboxPackages of- Nothing -> extraPkgConfs originalFlags- Just path ->- let pkg = PkgConfFile path in- (pkg:) . extraPkgConfs originalFlags+ pkgConfs =+ case sandboxPackages of+ Nothing -> extraPkgConfs originalFlags+ Just path ->+ let pkg = PkgConfFile path+ in (pkg :) . extraPkgConfs originalFlags - void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,- ghcLink = LinkInMemory,- pprCols = 300,- extraPkgConfs = pkgConfs }+ void $ setSessionDynFlags $ dflags+ { hscTarget = HscInterpreted+ , ghcLink = LinkInMemory+ , pprCols = 300+ , extraPkgConfs = pkgConfs+ } --- | Evaluate a single import statement.--- If this import statement is importing a module which was previously--- imported implicitly (such as `Prelude`) or if this module has a `hiding`--- annotation, the previous import is removed.+-- | Evaluate a single import statement. If this import statement is importing a module which was+-- previously imported implicitly (such as `Prelude`) or if this module has a `hiding` annotation,+-- the previous import is removed. evalImport :: GhcMonad m => String -> m () evalImport imports = do importDecl <- parseImportDecl imports@@ -173,8 +255,8 @@ -- If this is a `hiding` import, remove previous non-`hiding` imports. oldImps = if isHiddenImport importDecl- then filter (not . importOf importDecl) context- else noImplicit+ then filter (not . importOf importDecl) context+ else noImplicit -- Replace the context. setContext $ IIDecl importDecl : oldImps@@ -193,9 +275,10 @@ -- Check whether an import is hidden. isHiddenImport :: ImportDecl RdrName -> Bool- isHiddenImport imp = case ideclHiding imp of- Just (True, _) -> True- _ -> False+ isHiddenImport imp =+ case ideclHiding imp of+ Just (True, _) -> True+ _ -> False removeImport :: GhcMonad m => String -> m () removeImport moduleName = do@@ -209,8 +292,7 @@ isImportOf name (IIModule modName) = name == modName isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl) --- | Evaluate a series of declarations.--- Return all names which were bound by these declarations.+-- | Evaluate a series of declarations. Return all names which were bound by these declarations. evalDeclarations :: GhcMonad m => String -> m [String] evalDeclarations decl = do names <- runDecls decl@@ -221,7 +303,7 @@ cleanUpDuplicateInstances :: GhcMonad m => m () cleanUpDuplicateInstances = modifySession $ \hscEnv -> let - -- Get all class instancesj+ -- Get all class instances ic = hsc_IC hscEnv (clsInsts, famInsts) = ic_instances ic -- Remove duplicates@@ -229,11 +311,16 @@ in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } } where instEq :: ClsInst -> ClsInst -> Bool- instEq ClsInst{is_tvs = tpl_tvs,is_tys = tpl_tys} ClsInst{is_tys = tpl_tys'} =- let tpl_tv_set = mkVarSet tpl_tvs- in isJust $ tcMatchTys tpl_tv_set tpl_tys tpl_tys'--+#if MIN_VERSION_ghc(7,8,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+ = 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@@ -245,21 +332,23 @@ -- | A wrapper around @getInfo@. Return info about each name in the string. getDescription :: GhcMonad m => String -> m [String] getDescription str = do- names <- parseName str+ names <- parseName str maybeInfos <- mapM getInfo' names - -- Filter out types that have parents in the same set.- -- GHCi also does this.+ -- Filter out types that have parents in the same set. GHCi also does this. let infos = catMaybes maybeInfos allNames = mkNameSet $ map (getName . getType) infos- hasParent info = case tyThingParent_maybe (getType info) of- Just parent -> getName parent `elemNameSet` allNames- Nothing -> False+ hasParent info =+ case tyThingParent_maybe (getType info) of+ Just parent -> getName parent `elemNameSet` allNames+ Nothing -> False filteredOutput = filter (not . hasParent) infos -- Print nicely mapM (doc . printInfo) filteredOutput+ where+ #if MIN_VERSION_ghc(7,8,0) getInfo' = getInfo False #else@@ -274,15 +363,16 @@ #if MIN_VERSION_ghc(7,8,0) printInfo (thing, fixity, classInstances, famInstances) =- pprTyThingInContextLoc thing $$- showFixity thing fixity $$- vcat (map GHC.pprInstance classInstances) $$- vcat (map GHC.pprFamInst famInstances)+ pprTyThingInContextLoc thing $$+ showFixity thing fixity $$+ vcat (map GHC.pprInstance classInstances) $$+ vcat (map GHC.pprFamInst famInstances) #else printInfo (thing, fixity, classInstances) =- pprTyThingInContextLoc False thing $$ showFixity thing fixity $$ vcat (map GHC.pprInstance classInstances)+ pprTyThingInContextLoc False thing $$ showFixity thing fixity $$+ vcat (map GHC.pprInstance classInstances) #endif showFixity thing fixity = if fixity == GHC.defaultFixity- then empty- else ppr fixity <+> pprInfixName (getName thing)+ then empty+ else ppr fixity <+> pprInfixName (getName thing)
src/IHaskell/Flags.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}+ module IHaskell.Flags ( IHaskellMode(..), Argument(..), Args(..), LhsStyle(..),- lhsStyleBird, NotebookFormat(..),+ lhsStyleBird, parseFlags, help, ) where@@ -16,32 +17,31 @@ import Data.List (findIndex) import IHaskell.Types --- Command line arguments to IHaskell. A set of aruments is annotated with--- the mode being invoked.+-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked. data Args = Args IHaskellMode [Argument] deriving Show -data Argument = ServeFrom String -- ^ Which directory to serve notebooks from.- | Extension String -- ^ An extension to load at startup.- | ConfFile String -- ^ A file with commands to load at startup.- | IPythonFrom String -- ^ Which executable to use for IPython.+data Argument = ConfFile String -- ^ A file with commands to load at startup. | OverwriteFiles -- ^ Present when output should overwrite existing files. + | GhcLibDir String -- ^ Where to find the GHC libraries.+ | KernelDebug -- ^ Spew debugging output from the kernel.+ | Help -- ^ Display help text. | ConvertFrom String | ConvertTo String | ConvertFromFormat NotebookFormat | ConvertToFormat NotebookFormat | ConvertLhsStyle (LhsStyle String)- | GhcLibDir String -- ^ Where to find the GHC libraries.- | Help -- ^ Display help text. deriving (Eq, Show) -data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@- , lhsOutputPrefix :: string -- ^ @<<@- , lhsBeginCode :: string -- ^ @\\begin{code}@- , lhsEndCode :: string -- ^ @\\end{code}@- , lhsBeginOutput :: string -- ^ @\\begin{verbatim}@- , lhsEndOutput :: string -- ^ @\\end{verbatim}@- }+data LhsStyle string =+ LhsStyle+ { lhsCodePrefix :: string -- ^ @>@+ , lhsOutputPrefix :: string -- ^ @<<@+ , lhsBeginCode :: string -- ^ @\\begin{code}@+ , lhsEndCode :: string -- ^ @\\end{code}@+ , lhsBeginOutput :: string -- ^ @\\begin{verbatim}@+ , lhsEndOutput :: string -- ^ @\\end{verbatim}@+ } deriving (Eq, Functor, Show) data NotebookFormat = LhsMarkdown@@ -49,74 +49,69 @@ deriving (Eq, Show) -- Which mode IHaskell is being invoked in.--- `None` means no mode was specified. data IHaskellMode = ShowHelp String- | Notebook- | Console+ | InstallKernelSpec | ConvertLhs | Kernel (Maybe String)- | View (Maybe ViewFormat) (Maybe String) deriving (Eq, Show) --- | Given a list of command-line arguments, return the IHaskell mode and--- arguments to process.+-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process. parseFlags :: [String] -> Either String Args-parseFlags flags = - let modeIndex = findIndex (`elem` modeFlags) flags in- case modeIndex of- Nothing -> Left $ "No mode provided. Modes available are: " ++ show modeFlags ++ "\n" ++- pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)- Just 0 -> process ihaskellArgs flags+parseFlags flags =+ let modeIndex = findIndex (`elem` modeFlags) flags+ in case modeIndex of+ Nothing ->+ -- Treat no mode as 'console'.+ if "--help" `elem` flags+ then Left $ pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)+ else process ihaskellArgs flags+ Just 0 -> process ihaskellArgs flags + Just idx -> -- If mode not first, move it to be first.- Just idx -> - let (start, first:end) = splitAt idx flags in- process ihaskellArgs $ first:start ++ end+ let (start, first:end) = splitAt idx flags+ in process ihaskellArgs $ first : start ++ end where modeFlags = concatMap modeNames allModes allModes :: [Mode Args]-allModes = [console, notebook, view, kernel, convert]+allModes = [installKernelSpec, kernel, convert] -- | Get help text for a given IHaskell ode. help :: IHaskellMode -> String help mode = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode where- chooseMode Console = console- chooseMode Notebook = notebook+ chooseMode InstallKernelSpec = installKernelSpec chooseMode (Kernel _) = kernel chooseMode ConvertLhs = convert -ipythonFlag :: Flag Args-ipythonFlag = flagReq ["ipython", "i"] (store IPythonFrom) "<path>" "Executable for IPython."- ghcLibFlag :: Flag Args ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "<path>" "Library directory for GHC." -universalFlags :: [Flag Args]-universalFlags = [ flagReq ["extension", "e", "X"] (store Extension) "<ghc-extension>"- "Extension to enable at start."- , flagReq ["conf", "c"] (store ConfFile) "<rc.hs>"- "File with commands to execute at start; replaces ~/.ihaskell/rc.hs."- , flagHelpSimple (add Help)- ]+kernelDebugFlag :: Flag Args+kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel." where- add flag (Args mode flags) = Args mode $ flag : flags+ addDebug (Args mode prev) = Args mode (KernelDebug : prev) +confFlag :: Flag Args+confFlag = flagReq ["conf", "c"] (store ConfFile) "<rc.hs>"+ "File with commands to execute at start; replaces ~/.ihaskell/rc.hs."++helpFlag = flagHelpSimple (add Help)++add flag (Args mode flags) = Args mode $ flag : flags+ store :: (String -> Argument) -> String -> Args -> Either String Args store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev -notebook :: Mode Args-notebook = mode "notebook" (Args Notebook []) "Browser-based notebook interface." noArgs $- flagReq ["serve","s"] (store ServeFrom) "<dir>" "Directory to serve notebooks from.":- ipythonFlag:- universalFlags--console :: Mode Args-console = mode "console" (Args Console []) "Console-based interactive repl." noArgs $ ipythonFlag : universalFlags+installKernelSpec :: Mode Args+installKernelSpec =+ mode "install" (Args InstallKernelSpec []) "Install the Jupyter kernelspec." noArgs+ [ghcLibFlag, kernelDebugFlag, confFlag, helpFlag] kernel :: Mode Args-kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [ghcLibFlag]+kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg+ [ghcLibFlag, kernelDebugFlag, confFlag] where kernelArg = flagArg update "<json-kernel-file>" update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags@@ -125,85 +120,51 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlags where description = "Convert between Literate Haskell (*.lhs) and Ipython notebooks (*.ipynb)."- convertFlags = universalFlags ++ [ flagReq ["input", "i"] (store ConvertFrom) "<file>"- "File to read."- , flagReq ["output", "o"] (store ConvertTo) "<file>"- "File to write."- , flagReq ["from", "f"] (storeFormat ConvertFromFormat)- "lhs|ipynb" "Format of the file to read."- , flagReq ["to", "t"] (storeFormat ConvertToFormat) "lhs|ipynb"- "Format of the file to write."- , flagNone ["force"] consForce- "Overwrite existing files with output."- , flagReq ["style", "s"] storeLhs "bird|tex"- "Type of markup used for the literate haskell file"- , flagNone ["bird"] (consStyle lhsStyleBird)- "Literate haskell uses >"- , flagNone ["tex"] (consStyle lhsStyleTex)- "Literate haskell uses \\begin{code}"- ]+ convertFlags = [ flagReq ["input", "i"] (store ConvertFrom) "<file>" "File to read."+ , flagReq ["output", "o"] (store ConvertTo) "<file>" "File to write."+ , flagReq ["from", "f"] (storeFormat ConvertFromFormat) "lhs|ipynb"+ "Format of the file to read."+ , flagReq ["to", "t"] (storeFormat ConvertToFormat) "lhs|ipynb"+ "Format of the file to write."+ , flagNone ["force"] consForce "Overwrite existing files with output."+ , flagReq ["style", "s"] storeLhs "bird|tex"+ "Type of markup used for the literate haskell file"+ , flagNone ["bird"] (consStyle lhsStyleBird) "Literate haskell uses >"+ , flagNone ["tex"] (consStyle lhsStyleTex) "Literate haskell uses \\begin{code}"+ , helpFlag+ ] consForce (Args mode prev) = Args mode (OverwriteFiles : prev) unnamedArg = Arg (store ConvertFrom) "<file>" False consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev) - storeFormat constructor str (Args mode prev) = case toLower str of- "lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev- "ipynb" -> Right $ Args mode $ constructor IpynbFile : prev- _ -> Left $ "Unknown format requested: " ++ str+ storeFormat constructor str (Args mode prev) =+ case toLower str of+ "lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev+ "ipynb" -> Right $ Args mode $ constructor IpynbFile : prev+ _ -> Left $ "Unknown format requested: " ++ str - storeLhs str previousArgs = case toLower str of- "bird" -> success lhsStyleBird- "tex" -> success lhsStyleTex- _ -> Left $ "Unknown lhs style: " ++ str+ storeLhs str previousArgs =+ case toLower str of+ "bird" -> success lhsStyleBird+ "tex" -> success lhsStyleTex+ _ -> Left $ "Unknown lhs style: " ++ str where success lhsStyle = Right $ consStyle lhsStyle previousArgs lhsStyleBird, lhsStyleTex :: LhsStyle String lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" ""-lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}" +lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}" -view :: Mode Args-view =- let empty = mode "view" (Args (View Nothing Nothing) []) "View IHaskell notebook." noArgs flags in- empty {- modeNames = ["view"],- modeCheck =- \a@(Args (View fmt file) _) ->- if not (isJust fmt && isJust file)- then Left "Syntax: IHaskell view <format> <name>[.ipynb]"- else Right a,- modeHelp = concat [- "Convert an IHaskell notebook to another format.\n",- "Notebooks are searched in the IHaskell directory and the current directory.\n",- "Available formats are " ++ intercalate ", " (map show - ["pdf", "html", "ipynb", "markdown", "latex"]),- "."- ],- modeArgs = ([formatArg, filenameArg] ++ fst (modeArgs empty),- snd $ modeArgs empty)- - }- where- flags = [ipythonFlag, flagHelpSimple (add Help)]- formatArg = flagArg updateFmt "<format>"- filenameArg = flagArg updateFile "<name>[.ipynb]"- updateFmt fmtStr (Args (View _ s) flags) = - case readMay fmtStr of- Just fmt -> Right $ Args (View (Just fmt) s) flags- Nothing -> Left $ "Invalid format '" ++ fmtStr ++ "'."- updateFile name (Args (View f _) flags) = Right $ Args (View f (Just name)) flags- add flag (Args mode flags) = Args mode $ flag : flags- ihaskellArgs :: Mode Args ihaskellArgs =- let descr = "Haskell for Interactive Computing." + let descr = "Haskell for Interactive Computing." helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs onlyHelp = [flagHelpSimple (add Help)]- noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in- noMode { modeGroupModes = toGroup allModes }- where + noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp+ in noMode { modeGroupModes = toGroup allModes }+ where add flag (Args mode flags) = Args mode $ flag : flags noArgs = flagArg unexpected ""
src/IHaskell/IPython.hs view
@@ -1,94 +1,90 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DoAndIfThenElse #-}+ -- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and -- @console@ commands. module IHaskell.IPython (- setupIPython,- runConsole,- runNotebook,- readInitInfo,- defaultConfFile,- getIHaskellDir,- getSandboxPackageConf,- nbconvert,- subHome,- ViewFormat(..),- WhichIPython(..),-) where+ replaceIPythonKernelspec,+ defaultConfFile,+ getIHaskellDir,+ getSandboxPackageConf,+ subHome,+ kernelName,+ KernelSpecOptions(..),+ defaultKernelSpecOptions,+ ) where -import ClassyPrelude-import Control.Concurrent (threadDelay)-import Prelude (read, reads, init)-import Shelly hiding (find, trace, path, (</>))-import System.Argv0-import System.Directory-import qualified Filesystem.Path.CurrentOS as FS-import Data.List.Utils (split)-import Data.String.Utils (rstrip, endswith, strip, replace)-import Text.Printf-import Data.Maybe (fromJust)+import ClassyPrelude+import Control.Concurrent (threadDelay)+import Prelude (read, reads, init)+import Shelly hiding (find, trace, path, (</>))+import System.Argv0+import System.Directory+import qualified Filesystem.Path.CurrentOS as FS+import Data.List.Utils (split)+import Data.String.Utils (rstrip, endswith, strip, replace)+import Text.Printf+import qualified Data.Text as T+import Data.Maybe (fromJust)+import System.Exit (exitFailure)+import Data.Aeson (toJSON)+import Data.Aeson.Encode (encodeToTextBuilder)+import Data.Text.Lazy.Builder (toLazyText) import qualified System.IO.Strict as StrictIO import qualified Paths_ihaskell as Paths import qualified Codec.Archive.Tar as Tar -import IHaskell.Types-import System.Posix.Signals+import qualified GHC.Paths+import IHaskell.Types+import System.Posix.Signals --- | Which IPython to use.-data WhichIPython- = DefaultIPython -- ^ Use the one that IHaskell tries to install.- | ExplicitIPython String -- ^ Use the command-line flag provided one.- deriving Eq+data KernelSpecOptions =+ KernelSpecOptions+ { kernelSpecGhcLibdir :: String -- ^ GHC libdir.+ , kernelSpecDebug :: Bool -- ^ Spew debugging output?+ , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.+ } --- | The IPython profile name.-ipythonProfile :: String-ipythonProfile = "haskell"+defaultKernelSpecOptions :: KernelSpecOptions+defaultKernelSpecOptions = KernelSpecOptions+ { kernelSpecGhcLibdir = GHC.Paths.libdir+ , kernelSpecDebug = False+ , kernelSpecConfFile = defaultConfFile+ } --- | The current IPython profile version.--- This must be the same as the file in the profile.tar.--- The filename used is @profileVersionFile@.-profileVersion :: String-profileVersion = "0.4.2.0"+-- | The IPython kernel name.+kernelName :: IsString a => a+kernelName = "haskell" --- | Filename in the profile where the version ins kept.-profileVersionFile :: FilePath-profileVersionFile = ".profile_version"+kernelArgs :: IsString a => [a]+kernelArgs = ["--kernel", kernelName] --- | Run IPython with any arguments.-ipython :: WhichIPython -- ^ Which IPython to use (user-provided or IHaskell-installed).- -> Bool -- ^ Whether to suppress output.+-- | Run the IPython command with any arguments. The kernel is set to IHaskell.+ipython :: Bool -- ^ Whether to suppress output. -> [Text] -- ^ IPython command line arguments. -> Sh String -- ^ IPython output.-ipython which suppress args- | which == DefaultIPython = do- runCmd <- liftIO $ Paths.getDataFileName "installation/run.sh"- venv <- fpToText <$> ipythonDir- let cmdArgs = [pack runCmd, venv] ++ args- -- If we have PYTHONDONTWRITEBYTECODE enabled, everything breaks.- setenv "PYTHONDONTWRITEBYTECODE" ""-- liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing+ipython suppress args = do+ liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing - -- We have this because using `run` does not let us use stdin.- runHandles "bash" cmdArgs handles doNothing- | otherwise = do- let ExplicitIPython exe = which- runHandles (fpFromString exe) args handles doNothing+ -- We have this because using `run` does not let us use stdin.+ runHandles "ipython" args handles doNothing - where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]- outHandle True = OutHandle CreatePipe- outHandle False = OutHandle Inherit- errorHandle True = ErrorHandle CreatePipe- errorHandle False = ErrorHandle Inherit- doNothing _ stdout _ = if suppress - then liftIO $ StrictIO.hGetContents stdout- else return ""+ where+ handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]+ outHandle True = OutHandle CreatePipe+ outHandle False = OutHandle Inherit+ errorHandle True = ErrorHandle CreatePipe+ errorHandle False = ErrorHandle Inherit+ doNothing _ stdout _ = if suppress+ then liftIO $ StrictIO.hGetContents stdout+ else return "" -- | Run while suppressing all output. quietRun path args = runHandles path args handles nothing where- handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]+ handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe] nothing _ _ _ = return () -- | Create the directory and return it.@@ -107,18 +103,9 @@ ipythonDir :: Sh FilePath ipythonDir = ensure $ (</> "ipython") <$> ihaskellDir -ipythonExePath :: WhichIPython -> Sh FilePath-ipythonExePath which = - case which of- DefaultIPython -> (</> ("bin" </> "ipython")) <$> ipythonDir- ExplicitIPython path -> return $ fromString path- notebookDir :: Sh FilePath notebookDir = ensure $ (</> "notebooks") <$> ihaskellDir -ipythonSourceDir :: Sh FilePath-ipythonSourceDir = ensure $ (</> "ipython-src") <$> ihaskellDir- getIHaskellDir :: IO String getIHaskellDir = shelly $ fpToString <$> ihaskellDir @@ -127,85 +114,90 @@ filename <- (</> "rc.hs") <$> ihaskellDir exists <- test_f filename return $ if exists- then Just $ fpToString filename- else Nothing+ then Just $ fpToString filename+ else Nothing --- | Find a notebook and then convert it into the provided format.--- Notebooks are searched in the current directory as well as the IHaskell--- notebook directory (in that order).-nbconvert :: WhichIPython -> ViewFormat -> String -> IO ()-nbconvert which fmt name = void . shelly $ do- curdir <- pwd- nbdir <- notebookDir+replaceIPythonKernelspec :: KernelSpecOptions -> IO ()+replaceIPythonKernelspec kernelSpecOpts = shelly $ do+ verifyIPythonVersion+ installKernelspec True kernelSpecOpts - -- Find which of the options is available. - let notebookOptions = [- curdir </> fpFromString name,- curdir </> fpFromString (name ++ ".ipynb"),- nbdir </> fpFromString name,- nbdir </> fpFromString (name ++ ".ipynb")- ]- maybeNb <- headMay <$> filterM test_f notebookOptions- case maybeNb of- Nothing -> do- putStrLn $ "Cannot find notebook: " ++ pack name- putStrLn "Tried:"- mapM_ (putStrLn . (" " ++) . fpToText) notebookOptions +-- | Verify that a proper version of IPython is installed and accessible.+verifyIPythonVersion :: Sh ()+verifyIPythonVersion = do+ pathMay <- which "ipython"+ case pathMay of+ Nothing -> badIPython "No IPython detected -- install IPython 3.0+ before using IHaskell."+ Just path -> do+ output <- unpack <$> silently (run path ["--version"])+ case parseVersion output of+ Just (3:_) -> return ()+ Just (2:_) -> oldIPython+ Just (1:_) -> oldIPython+ Just (0:_) -> oldIPython+ _ -> badIPython "Detected IPython, but could not parse version number." - Just notebook ->- let viewArgs = case fmt of- Pdf -> ["--to=latex", "--post=pdf"]- Html -> ["--to=html", "--template=ihaskell"]- fmt -> ["--to=" ++ show fmt] in- void $ runIHaskell which ipythonProfile "nbconvert" $ viewArgs ++ [fpToString notebook]+ where+ badIPython :: Text -> Sh ()+ badIPython message = liftIO $ do+ hPutStrLn stderr message+ exitFailure+ oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up." --- | Set up IPython properly.-setupIPython :: WhichIPython -> IO ()+-- | Install an IHaskell kernelspec into the right location. The right location is determined by+-- using `ipython kernelspec install --user`.+installKernelspec :: Bool -> KernelSpecOptions -> Sh ()+installKernelspec replace opts = void $ do+ ihaskellPath <- getIHaskellPath+ confFile <- liftIO $ kernelSpecConfFile opts -setupIPython (ExplicitIPython path) = do- exists <- shelly $- test_f $ fromString path+ let kernelFlags :: [String]+ kernelFlags =+ ["--debug" | kernelSpecDebug opts] +++ (case confFile of+ Nothing -> []+ Just file -> ["--conf", file])+ ++ ["--ghclib", kernelSpecGhcLibdir opts] - unless exists $- fail $ "Cannot find IPython at " ++ path+ let kernelSpec = KernelSpec+ { kernelDisplayName = "Haskell"+ , kernelLanguage = kernelName+ , kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags+ } -setupIPython DefaultIPython = do- installed <- ipythonInstalled- when (not installed) $ do- path <- shelly $ which "ipython"- case path of- Just ipythonPath -> checkIPythonVersion ipythonPath- Nothing -> badIPython "Did not detect IHaskell-installed or system IPython."- where- checkIPythonVersion :: FilePath -> IO ()- checkIPythonVersion path = do- output <- unpack <$> shelly (silently $ run path ["--version"])- case parseVersion output of- Just (3:_) -> putStrLn "Using system-wide dev version of IPython."- Just (2:_) -> putStrLn "Using system-wide IPython."- Just (1:_) -> badIPython "Detected old version of IPython. IHaskell requires 2.0.0 or up."- Just (0:_) -> badIPython "Detected old version of IPython. IHaskell requires 2.0.0 or up."- _ -> badIPython "Detected IPython, but could not parse version number."+ -- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,+ -- shell out to IPython to install this kernelspec directory.+ withTmpDir $ \tmp -> do+ let kernelDir = tmp </> kernelName+ let filename = kernelDir </> "kernel.json" - badIPython :: Text -> IO ()- badIPython reason = void $ do- putStrLn reason- putStrLn "IHaskell will now proceed to install IPython (locally for itself)."- putStrLn "Installing IPython in IHaskell's virtualenv in 10 seconds. Ctrl-C to cancel."- threadDelay $ 1000 * 1000 * 10- installIPython+ mkdir_p kernelDir+ writefile filename $ toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec+ let files = ["kernel.js", "logo-64x64.png"]+ forM_ files $ \file -> do+ src <- liftIO $ Paths.getDataFileName $ "html/" ++ file+ cp (fpFromString src) (tmp </> kernelName </> fpFromString file) + Just ipython <- which "ipython"+ let replaceFlag = ["--replace" | replace]+ cmd = ["kernelspec", "install", "--user", fpToText kernelDir] ++ replaceFlag+ silently $ run ipython cmd --- | Replace "~" with $HOME if $HOME is defined.--- Otherwise, do nothing.+kernelSpecCreated :: Sh Bool+kernelSpecCreated = do+ Just ipython <- which "ipython"+ out <- silently $ run ipython ["kernelspec", "list"]+ let kernelspecs = map T.strip $ lines out+ return $ kernelName `elem` kernelspecs++-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing. subHome :: String -> IO String subHome path = shelly $ do home <- unpack <$> fromMaybe "~" <$> get_env "HOME" return $ replace "~" home path ---- | Get the path to an executable. If it doensn't exist, fail with an--- error message complaining about it.+-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining+-- about it. path :: Text -> Sh FilePath path exe = do path <- which $ fromText exe@@ -217,129 +209,18 @@ -- | Parse an IPython version string into a list of integers. parseVersion :: String -> Maybe [Int]-parseVersion versionStr = +parseVersion versionStr = let versions = map read' $ split "." versionStr- parsed = all isJust versions in- if parsed- then Just $ map fromJust versions- else Nothing- where + parsed = all isJust versions+ in if parsed+ then Just $ map fromJust versions+ else Nothing+ where read' :: String -> Maybe Int- read' x = + read' x = case reads x of [(n, _)] -> Just n- _ -> Nothing---- | Run an IHaskell application using the given profile.-runIHaskell :: WhichIPython- -> String -- ^ IHaskell profile name. - -> String -- ^ IPython app name.- -> [String] -- ^ Arguments to IPython.- -> Sh ()-runIHaskell which profile app args = void $ do- -- Try to locate the profile. Do not die if it doesn't exist.- errExit False $ ipython which True ["locate", "profile", pack profile]-- -- If the profile doesn't exist, create it.- exitCode <- lastExitCode- if exitCode /= 0- then liftIO $ do- putStrLn "Creating IPython profile."- setupIPythonProfile which profile- -- If the profile exists, update it if necessary.- else updateIPythonProfile which profile-- -- Run the IHaskell command.- ipython which False $ map pack $ [app, "--profile", profile] ++ args--runConsole :: WhichIPython -> InitInfo -> IO ()-runConsole which initInfo = void . shelly $ do- writeInitInfo initInfo- runIHaskell which ipythonProfile "console" []--runNotebook :: WhichIPython -> InitInfo -> Maybe String -> IO ()-runNotebook which initInfo maybeServeDir = void . shelly $ do- notebookDirStr <- fpToString <$> notebookDir- let args = case maybeServeDir of - Nothing -> ["--notebook-dir", unpack notebookDirStr]- Just dir -> ["--notebook-dir", dir]-- writeInitInfo initInfo- runIHaskell which ipythonProfile "notebook" args--writeInitInfo :: InitInfo -> Sh ()-writeInitInfo info = do- filename <- (</> ".last-arguments") <$> ihaskellDir- liftIO $ writeFile filename $ show info--readInitInfo :: IO InitInfo-readInitInfo = shelly $ do- filename <- (</> ".last-arguments") <$> ihaskellDir- exists <- test_f filename- if exists- then read <$> liftIO (readFile filename)- else do- dir <- fromMaybe "." <$> fmap unpack <$> get_env "HOME"- return InitInfo { extensions = [], initCells = [], initDir = dir, frontend = IPythonNotebook }---- | Create the IPython profile.-setupIPythonProfile :: WhichIPython- -> String -- ^ IHaskell profile name.- -> IO ()-setupIPythonProfile which profile = shelly $ do- -- Create the IPython profile.- void $ ipython which True ["profile", "create", pack profile]-- -- Find the IPython profile directory. Make sure to get rid of trailing- -- newlines from the output of the `ipython locate` call.- ipythonDir <- pack <$> rstrip <$> ipython which True ["locate"]- let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/"-- liftIO $ copyProfile profileDir- insertIHaskellPath profileDir---- | Update the IPython profile.-updateIPythonProfile :: WhichIPython- -> String -- ^ IHaskell profile name.- -> Sh ()-updateIPythonProfile which profile = do- -- Find out whether the profile exists.- dir <- pack <$> rstrip <$> errExit False (ipython which True ["locate", "profile", pack profile])- exitCode <- lastExitCode- updated <- if exitCode == 0 && dir /= ""- then do- let versionFile = fpFromText dir </> profileVersionFile- fileExists <- test_f versionFile- if not fileExists- then return False- else liftIO $ do- contents <- StrictIO.readFile $ fpToString versionFile- return $ strip contents == profileVersion- else return False-- when (not updated) $ do- putStrLn "Updating IPython profile."- liftIO $ copyProfile dir- insertIHaskellPath $ dir ++ "/"---- | Copy the profile files into the IPython profile. -copyProfile :: Text -> IO ()-copyProfile profileDir = do- profileTar <- Paths.getDataFileName "profile/profile.tar"- putStrLn $ pack $ "Loading profile from " ++ profileTar - Tar.extract (unpack profileDir) profileTar ---- | Insert the IHaskell path into the IPython configuration.-insertIHaskellPath :: Text -> Sh ()-insertIHaskellPath profileDir = do- path <- getIHaskellPath- let filename = profileDir ++ "ipython_config.py"- template = "exe = '%s'.replace(' ', '\\\\ ')"- exeLine = printf template $ unpack path :: String-- liftIO $ do- contents <- StrictIO.readFile $ unpack filename- writeFile (fromText filename) $ exeLine ++ "\n" ++ contents+ _ -> Nothing -- | Get the absolute path to this IHaskell executable. getIHaskellPath :: Sh String@@ -349,62 +230,33 @@ -- If we have an absolute path, that's the IHaskell we're interested in. if FS.absolute f- then return $ FS.encodeString f- else- -- Check whether this is a relative path, or just 'IHaskell' with $PATH- -- resolution done by the shell. If it's just 'IHaskell', use the $PATH- -- variable to find where IHaskell lives.+ then return $ FS.encodeString f+ else + -- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by+ -- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives. if FS.filename f == f- then do- ihaskellPath <- which "IHaskell"- case ihaskellPath of- Nothing -> error "IHaskell not on $PATH and not referenced relative to directory."- Just path -> return $ FS.encodeString path- else do- -- If it's actually a relative path, make it absolute.- cd <- liftIO getCurrentDirectory- return $ FS.encodeString $ FS.decodeString cd FS.</> f+ then do+ ihaskellPath <- which "ihaskell"+ case ihaskellPath of+ Nothing -> error "ihaskell not on $PATH and not referenced relative to directory."+ Just path -> return $ FS.encodeString path+ else do+ -- If it's actually a relative path, make it absolute.+ cd <- liftIO getCurrentDirectory+ return $ FS.encodeString $ FS.decodeString cd FS.</> f getSandboxPackageConf :: IO (Maybe String) getSandboxPackageConf = shelly $ do myPath <- getIHaskellPath let sandboxName = ".cabal-sandbox"- if not $ sandboxName`isInfixOf` myPath- then return Nothing- else do- let pieces = split "/" myPath- sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName]- subdirs <- ls $ fpFromString sandboxDir- let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs- case confdirs of- [] -> return Nothing- dir:_ -> - return $ Just dir---- | Check whether IPython is properly installed.-ipythonInstalled :: IO Bool-ipythonInstalled = shelly $ do- ipythonPath <- ipythonExePath DefaultIPython- test_f ipythonPath---- | Install IPython from source.-installIPython :: IO ()-installIPython = shelly $ do- -- Print a message and wait a little.- liftIO $ do- putStrLn "Installing IPython for IHaskell. This may take a while."- threadDelay $ 500 * 1000-- -- Set up the virtualenv.- virtualenvScript <- liftIO $ Paths.getDataFileName "installation/virtualenv.sh"- venvDir <- fpToText <$> ipythonDir- runTmp virtualenvScript [venvDir]-- -- Set up Python depenencies.- setenv "ARCHFLAGS" "-Wno-error=unused-command-line-argument-hard-error-in-future"- installScript <- liftIO $ Paths.getDataFileName "installation/ipython.sh"- runTmp installScript [venvDir]--runTmp script args = withTmpDir $ \tmp -> do- cd tmp- run_ "bash" $ pack script: args+ if not $ sandboxName `isInfixOf` myPath+ then return Nothing+ else do+ let pieces = split "/" myPath+ sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName]+ subdirs <- ls $ fpFromString sandboxDir+ let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs+ case confdirs of+ [] -> return Nothing+ dir:_ ->+ return $ Just dir
src/IHaskell/Types.hs view
@@ -1,80 +1,48 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}-{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}+ -- | Description : All message type definitions. module IHaskell.Types (- Message (..),- MessageHeader (..),- MessageType(..),- Username,- Metadata(..),- replyType,- ExecutionState (..),- StreamType(..),- MimeType(..),- DisplayData(..),- EvaluationResult(..),- ExecuteReplyStatus(..),- InitInfo(..),- KernelState(..),- LintStatus(..),- Width, Height,- FrontendType(..),- ViewFormat(..),- Display(..),- defaultKernelState,- extractPlain,- kernelOpts,- KernelOpt(..),- IHaskellDisplay(..),- IHaskellWidget(..),- Widget(..),- CommInfo(..),- ) where--import ClassyPrelude-import qualified Data.ByteString.Char8 as Char-import Data.Serialize-import GHC.Generics-import Data.Map (Map, empty)-import Data.Aeson (Value)--import Text.Read as Read hiding (pfail, String)-import Text.ParserCombinators.ReadP--import IHaskell.IPython.Kernel--data ViewFormat- = Pdf- | Html- | Ipynb- | Markdown- | Latex- deriving Eq+ Message(..),+ MessageHeader(..),+ MessageType(..),+ Username,+ Metadata(..),+ replyType,+ ExecutionState(..),+ StreamType(..),+ MimeType(..),+ DisplayData(..),+ EvaluationResult(..),+ ExecuteReplyStatus(..),+ KernelState(..),+ LintStatus(..),+ Width,+ Height,+ Display(..),+ defaultKernelState,+ extractPlain,+ kernelOpts,+ KernelOpt(..),+ IHaskellDisplay(..),+ IHaskellWidget(..),+ Widget(..),+ CommInfo(..),+ KernelSpec(..),+ ) where -instance Show ViewFormat where- show Pdf = "pdf"- show Html = "html"- show Ipynb = "ipynb"- show Markdown = "markdown"- show Latex = "latex"+import ClassyPrelude+import qualified Data.ByteString.Char8 as Char+import Data.Serialize+import GHC.Generics+import Data.Map (Map, empty)+import Data.Aeson (Value) -instance Read ViewFormat where- readPrec = Read.lift $ do- str <- munch (const True)- case str of- "pdf" -> return Pdf- "html" -> return Html- "ipynb" -> return Ipynb- "notebook" -> return Ipynb- "latex" -> return Latex- "markdown" -> return Markdown- "md" -> return Markdown- _ -> pfail+import IHaskell.IPython.Kernel -- | A class for displayable Haskell types. ----- IHaskell's displaying of results behaves as if these two--- overlapping/undecidable instances also existed:+-- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also+-- existed: -- -- > instance (Show a) => IHaskellDisplay a -- > instance Show a where shows _ = id@@ -83,12 +51,10 @@ -- | Display as an interactive widget. class IHaskellDisplay a => IHaskellWidget a where- -- | Output target name for this widget.- -- The actual input parameter should be ignored.+ -- | Output target name for this widget. The actual input parameter should be ignored. targetName :: a -> String - -- | Called when the comm is opened. Allows additional messages to be sent- -- after comm open.+ -- | Called when the comm is opened. Allows additional messages to be sent after comm open. open :: a -- ^ Widget to open a comm port with. -> (Value -> IO ()) -- ^ Way to respond to the message. -> IO ()@@ -108,7 +74,7 @@ close _ _ = return () data Widget = forall a. IHaskellWidget a => Widget a- deriving Typeable+ deriving Typeable instance IHaskellDisplay Widget where display (Widget widget) = display widget@@ -122,101 +88,92 @@ instance Show Widget where show _ = "<Widget>" ---- | Wrapper for ipython-kernel's DisplayData which allows sending multiple--- results from the same expression.+-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same+-- expression. data Display = Display [DisplayData] | ManyDisplay [Display]- deriving (Show, Typeable, Generic)+ deriving (Show, Typeable, Generic)+ instance Serialize Display instance Monoid Display where- mempty = Display []- ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b)- ManyDisplay a `mappend` b = ManyDisplay (a ++ [b])- a `mappend` ManyDisplay b = ManyDisplay (a : b)- a `mappend` b = ManyDisplay [a,b]+ mempty = Display []+ ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b)+ ManyDisplay a `mappend` b = ManyDisplay (a ++ [b])+ a `mappend` ManyDisplay b = ManyDisplay (a : b)+ a `mappend` b = ManyDisplay [a, b] instance Semigroup Display where a <> b = a `mappend` b -- | All state stored in the kernel between executions.-data KernelState = KernelState- { getExecutionCounter :: Int,- getLintStatus :: LintStatus, -- Whether to use hlint, and what arguments to pass it. - getFrontend :: FrontendType,- useSvg :: Bool,- useShowErrors :: Bool,- useShowTypes :: Bool,- usePager :: Bool,- openComms :: Map UUID Widget- }+data KernelState =+ KernelState+ { getExecutionCounter :: Int+ , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. + , useSvg :: Bool+ , useShowErrors :: Bool+ , useShowTypes :: Bool+ , usePager :: Bool+ , openComms :: Map UUID Widget+ , kernelDebug :: Bool+ } deriving Show defaultKernelState :: KernelState defaultKernelState = KernelState- { getExecutionCounter = 1,- getLintStatus = LintOn,- getFrontend = IPythonConsole,- useSvg = True,- useShowErrors = False,- useShowTypes = False,- usePager = True,- openComms = empty+ { getExecutionCounter = 1+ , getLintStatus = LintOn+ , useSvg = True+ , useShowErrors = False+ , useShowTypes = False+ , usePager = False+ , openComms = empty+ , kernelDebug = False } -data FrontendType- = IPythonConsole- | IPythonNotebook- deriving (Show, Eq, Read)- -- | Kernel options to be set via `:set` and `:option`.-data KernelOpt = KernelOpt {- getOptionName :: [String], -- ^ Ways to set this option via `:option`- getSetName :: [String], -- ^ Ways to set this option via `:set`- getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.- }+data KernelOpt =+ KernelOpt+ { getOptionName :: [String] -- ^ Ways to set this option via `:option`+ , getSetName :: [String] -- ^ Ways to set this option via `:set`+ , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel+ -- state.+ } kernelOpts :: [KernelOpt] kernelOpts =- [ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }- , KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }- , KernelOpt ["svg"] [] $ \state -> state { useSvg = True }- , KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }- , KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }- , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }- , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }- , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }- , KernelOpt ["pager"] [] $ \state -> state { usePager = True }- , KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }+ [ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }+ , KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }+ , KernelOpt ["svg"] [] $ \state -> state { useSvg = True }+ , KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }+ , KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }+ , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }+ , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }+ , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }+ , KernelOpt ["pager"] [] $ \state -> state { usePager = True }+ , KernelOpt ["no-pager"] [] $ \state -> state { usePager = False } ] --- | Initialization information for the kernel.-data InitInfo = InitInfo {- extensions :: [String], -- ^ Extensions to enable at start.- initCells :: [String], -- ^ Code blocks to run before start.- initDir :: String, -- ^ Which directory this kernel should pretend to operate in.- frontend :: FrontendType -- ^ What frontend this serves.- }- deriving (Show, Read)- -- | Current HLint status.-data LintStatus- = LintOn- | LintOff- deriving (Eq, Show)+data LintStatus = LintOn+ | LintOff+ deriving (Eq, Show) data CommInfo = CommInfo Widget UUID String+ deriving Show -- | Output of evaluation. data EvaluationResult =- -- | An intermediate result which communicates what has been printed thus- -- far.- IntermediateResult {- outputs :: Display -- ^ Display outputs.- }- | FinalResult {- outputs :: Display, -- ^ Display outputs.- pagerOut :: String, -- ^ Text to display in the IPython pager.- startComms :: [CommInfo] -- ^ Comms to start.- }+ -- | An intermediate result which communicates what has been printed thus+ -- far.+ IntermediateResult+ { outputs :: Display -- ^ Display outputs.+ }+ |+ FinalResult+ { outputs :: Display -- ^ Display outputs.+ , pagerOut :: String -- ^ Text to display in the IPython pager.+ , startComms :: [CommInfo] -- ^ Comms to start.+ }+ deriving Show
src/Main.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}+ -- | Description : Argument parsing and basic messaging loop, using Haskell -- Chans to communicate with the ZeroMQ sockets.-module Main where+module Main (main) where -- Prelude imports. import ClassyPrelude hiding (last, liftIO, readChan, writeChan)@@ -17,6 +18,7 @@ import Text.Printf import System.Posix.Signals import qualified Data.Map as Map+import Data.String.Here (hereFile) -- IHaskell imports. import IHaskell.Convert (convert)@@ -35,7 +37,6 @@ -- GHC API imports. import GHC hiding (extensions, language)-import qualified GHC.Paths -- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h ghcVersionInts :: [Int]@@ -44,7 +45,14 @@ dotToSpace '.' = ' ' dotToSpace x = x +ihaskellCSS :: String+ihaskellCSS = [hereFile|html/custom.css|] +consoleBanner :: Text+consoleBanner =+ "Welcome to IHaskell! Run `IHaskell --help` for more information.\n" +++ "Enter `:help` to learn more about IHaskell built-ins."+ main :: IO () main = do args <- parseFlags <$> map unpack <$> getArgs@@ -52,95 +60,43 @@ Left errorMessage -> hPutStrLn stderr errorMessage Right args -> ihaskell args -chooseIPython [] = return DefaultIPython-chooseIPython (IPythonFrom path:_) = ExplicitIPython <$> subHome path-chooseIPython (_:xs) = chooseIPython xs- ihaskell :: Args -> IO ()--- If no mode is specified, print help text. ihaskell (Args (ShowHelp help) _) = putStrLn $ pack help- ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args--ihaskell (Args Console flags) = showingHelp Console flags $ do- ipython <- chooseIPython flags- setupIPython ipython-- flags <- addDefaultConfFile flags- info <- initInfo IPythonConsole flags- runConsole ipython info--ihaskell (Args mode@(View (Just fmt) (Just name)) args) = showingHelp mode args $ do- ipython <- chooseIPython args- nbconvert ipython fmt name--ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do- ipython <- chooseIPython flags- setupIPython ipython-- let server = case mapMaybe serveDir flags of- [] -> Nothing- xs -> Just $ last xs-- flags <- addDefaultConfFile flags-- undirInfo <- initInfo IPythonNotebook flags- curdir <- getCurrentDirectory- let info = undirInfo { initDir = curdir }-- runNotebook ipython info server- where- serveDir (ServeFrom dir) = Just dir- serveDir _ = Nothing--ihaskell (Args (Kernel (Just filename)) flags) = do- initInfo <- readInitInfo- runKernel libdir filename initInfo-- where- libdir = case flags of- [] -> GHC.Paths.libdir- [GhcLibDir dir] -> dir----- | Add a conf file to the arguments if none exists.-addDefaultConfFile :: [Argument] -> IO [Argument]-addDefaultConfFile flags = do- def <- defaultConfFile- case (find isConfFile flags, def) of- (Nothing, Just file) -> return $ ConfFile file : flags- _ -> return flags- where- isConfFile (ConfFile _) = True- isConfFile _ = False+ihaskell (Args InstallKernelSpec args) = showingHelp InstallKernelSpec args $ do+ let kernelSpecOpts = parseKernelArgs args+ replaceIPythonKernelspec kernelSpecOpts+ihaskell (Args (Kernel (Just filename)) args) = do+ let kernelSpecOpts = parseKernelArgs args+ runKernel kernelSpecOpts filename showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () showingHelp mode flags act =- case find (==Help) flags of+ case find (== Help) flags of Just _ -> putStrLn $ pack $ help mode Nothing -> act -- | Parse initialization information from the flags.-initInfo :: FrontendType -> [Argument] -> IO InitInfo-initInfo front [] = return InitInfo { extensions = [], initCells = [], initDir = ".", frontend = front }-initInfo front (flag:flags) = do- info <- initInfo front flags- case flag of- Extension ext -> return info { extensions = ext:extensions info }- ConfFile filename -> do- cell <- readFile (fpFromText $ pack filename)- return info { initCells = cell:initCells info }- _ -> return info+parseKernelArgs :: [Argument] -> KernelSpecOptions+parseKernelArgs = foldl' addFlag defaultKernelSpecOptions+ where+ addFlag kernelSpecOpts (ConfFile filename) =+ kernelSpecOpts { kernelSpecConfFile = return (Just filename) }+ addFlag kernelSpecOpts KernelDebug =+ kernelSpecOpts { kernelSpecDebug = True }+ addFlag kernelSpecOpts (GhcLibDir libdir) =+ kernelSpecOpts { kernelSpecGhcLibdir = libdir }+ addFlag kernelSpecOpts flag = error $ "Unknown flag" ++ show flag -- | Run the IHaskell language kernel.-runKernel :: String -- ^ GHC libdir.- -> String -- ^ Filename of profile JSON file.- -> InitInfo -- ^ Initialization information from the invocation.+runKernel :: KernelSpecOptions -- ^ Various options from when the kernel was installed.+ -> String -- ^ File with kernel profile JSON (ports, etc). -> IO ()-runKernel libdir profileSrc initInfo = do- setCurrentDirectory $ initDir initInfo+runKernel kernelOpts profileSrc = do+ let debug = kernelSpecDebug kernelOpts+ libdir = kernelSpecGhcLibdir kernelOpts -- Parse the profile file. Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc@@ -150,33 +106,31 @@ Stdin.recordKernelProfile dir profile -- Serve on all sockets and ports defined in the profile.- interface <- serveProfile profile+ interface <- serveProfile profile debug -- Create initial state in the directory the kernel *should* be in. state <- initialKernelState modifyMVar_ state $ \kernelState -> return $- kernelState { getFrontend = frontend initInfo }+ kernelState { kernelDebug = debug } -- Receive and reply to all messages on the shell socket. interpret libdir True $ do- -- Ignore Ctrl-C the first time. This has to go inside the- -- `interpret`, because GHC API resets the signal handlers for some- -- reason (completely unknown to me).+ -- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the+ -- signal handlers for some reason (completely unknown to me). liftIO ignoreCtrlC - -- Initialize the context by evaluating everything we got from the- -- command line flags. This includes enabling some extensions and also- -- running some code.- let extLines = map (":extension " ++) $ extensions initInfo- noPublish _ = return ()+ -- Initialize the context by evaluating everything we got from the command line flags.+ let noPublish _ = return () evaluator line = void $ do -- Create a new state each time. stateVar <- liftIO initialKernelState state <- liftIO $ takeMVar stateVar evaluate state line noPublish - mapM_ evaluator extLines- mapM_ evaluator $ initCells initInfo+ confFile <- liftIO $ kernelSpecConfFile kernelOpts+ case confFile of+ Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator+ Nothing -> return () forever $ do -- Read the request from the request channel.@@ -185,34 +139,34 @@ -- Create a header for the reply. replyHeader <- createReplyHeader (header request) - -- We handle comm messages and normal ones separately.- -- The normal ones are a standard request/response style, while comms- -- can be anything, and don't necessarily require a response.+ -- We handle comm messages and normal ones separately. The normal ones are a standard+ -- request/response style, while comms can be anything, and don't necessarily require a response. if isCommMessage request- then liftIO $ do- oldState <- takeMVar state- let replier = writeChan (iopubChannel interface)- newState <- handleComm replier oldState request replyHeader- putMVar state newState- writeChan (shellReplyChannel interface) SendNothing- else do- -- Create the reply, possibly modifying kernel state.- oldState <- liftIO $ takeMVar state- (newState, reply) <- replyTo interface request replyHeader oldState- liftIO $ putMVar state newState+ then liftIO $ do+ oldState <- takeMVar state+ let replier = writeChan (iopubChannel interface)+ newState <- handleComm replier oldState request replyHeader+ putMVar state newState+ writeChan (shellReplyChannel interface) SendNothing+ else do+ -- Create the reply, possibly modifying kernel state.+ oldState <- liftIO $ takeMVar state+ (newState, reply) <- replyTo interface request replyHeader oldState+ liftIO $ putMVar state newState - -- Write the reply to the reply channel.- liftIO $ writeChan (shellReplyChannel interface) reply+ -- Write the reply to the reply channel.+ liftIO $ writeChan (shellReplyChannel interface) reply+ where ignoreCtrlC =- installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing+ installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.")+ Nothing isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage] -- Initial kernel state. initialKernelState :: IO (MVar KernelState)-initialKernelState =- newMVar defaultKernelState+initialKernelState = newMVar defaultKernelState -- | Duplicate a message header, giving it a new UUID and message type. dupHeader :: MessageHeader -> MessageType -> IO MessageHeader@@ -229,62 +183,59 @@ let repType = fromMaybe err (replyType $ msgType parent) err = error $ "No reply for message " ++ show (msgType parent) - return MessageHeader {- identifiers = identifiers parent,- parentHeader = Just parent,- metadata = Map.fromList [],- messageId = newMessageId,- sessionId = sessionId parent,- username = username parent,- msgType = repType- }+ return+ MessageHeader+ { identifiers = identifiers parent+ , parentHeader = Just parent+ , metadata = Map.fromList []+ , messageId = newMessageId+ , sessionId = sessionId parent+ , username = username parent+ , msgType = repType+ } -- | Compute a reply to a message. replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)---- Reply to kernel info requests with a kernel info reply. No computation--- needs to be done, as a kernel info reply is a static object (all info is--- hard coded into the representation of that message type).+-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a+-- kernel info reply is a static object (all info is hard coded into the representation of that+-- message type). replyTo _ KernelInfoRequest{} replyHeader state =- return (state, KernelInfoReply {- header = replyHeader,- language = "haskell",- versionList = ghcVersionInts- })+ return+ (state, KernelInfoReply+ { header = replyHeader+ , language = "haskell"+ , versionList = ghcVersionInts+ }) --- 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- writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending- exitSuccess+-- 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+ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending+ exitSuccess --- Reply to an execution request. The reply itself does not require--- computation, but this causes messages to be sent to the IOPub socket--- with the output of the code in the execution request.-replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do- -- Convenience function to send a message to the IOPub socket.+-- Reply to an execution request. The reply itself does not require computation, but this causes+-- messages to be sent to the IOPub socket with the output of the code in the execution request.+replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do+ -- Convenience function to send a message to the IOPub socket. let send msg = liftIO $ writeChan (iopubChannel interface) msg -- Log things so that we can use stdin. dir <- liftIO getIHaskellDir liftIO $ Stdin.recordParentHeader dir $ header req - -- Notify the frontend that the kernel is busy computing.- -- All the headers are copies of the reply header with a different- -- message type, because this preserves the session ID, parent header,- -- and other important information.+ -- Notify the frontend that the kernel is busy computing. All the headers are copies of the reply+ -- header with a different message type, because this preserves the session ID, parent header, and+ -- other important information. busyHeader <- liftIO $ dupHeader replyHeader StatusMessage send $ PublishStatus busyHeader Busy - -- Construct a function for publishing output as this is going.- -- This function accepts a boolean indicating whether this is the final- -- output and the thing to display. Store the final outputs in a list so- -- that when we receive an updated non-final output, we can clear the- -- entire output and re-display with the updated output.- displayed <- liftIO $ newMVar []+ -- Construct a function for publishing output as this is going. This function accepts a boolean+ -- indicating whether this is the final output and the thing to display. Store the final outputs in+ -- a list so that when we receive an updated non-final output, we can clear the entire output and+ -- re-display with the updated output.+ displayed <- liftIO $ newMVar [] updateNeeded <- liftIO $ newMVar False- pagerOutput <- liftIO $ newMVar ""+ pagerOutput <- liftIO $ newMVar "" let clearOutput = do header <- dupHeader replyHeader ClearOutputMessage send $ ClearOutput header True@@ -292,12 +243,16 @@ sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts sendOutput (Display outs) = do header <- dupHeader replyHeader DisplayDataMessage- send $ PublishDisplayData header "haskell" $ map convertSvgToHtml outs+ send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg convertSvgToHtml x = x makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>" + prependCss (DisplayData MimeHtml html) =+ DisplayData MimeHtml $concat ["<style>", pack ihaskellCSS, "</style>", html]+ prependCss x = x+ startComm :: CommInfo -> IO () startComm (CommInfo widget uuid target) = do -- Send the actual comm open.@@ -312,9 +267,10 @@ publish :: EvaluationResult -> IO () publish result = do- let final = case result of- IntermediateResult {} -> False- FinalResult {} -> True+ let final =+ case result of+ IntermediateResult{} -> False+ FinalResult{} -> True outs = outputs result -- If necessary, clear all previous output and redraw.@@ -327,12 +283,11 @@ -- Draw this message. sendOutput outs - -- If this is the final message, add it to the list of completed- -- messages. If it isn't, make sure we clear it later by marking- -- update needed as true.+ -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we+ -- clear it later by marking update needed as true. modifyMVar_ updateNeeded (const $ return $ not final) when final $ do- modifyMVar_ displayed (return . (outs:))+ modifyMVar_ displayed (return . (outs :)) -- Start all comms that need to be started. mapM_ startComm $ startComms result@@ -341,8 +296,8 @@ let pager = pagerOut result unless (null pager) $ if usePager state- then modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))- else sendOutput $ Display [html pager]+ then modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))+ else sendOutput $ Display [html pager] let execCount = getExecutionCounter state -- Let all frontends know the execution count and code that's about to run@@ -358,34 +313,47 @@ -- Take pager output if we're using the pager. pager <- if usePager state- then liftIO $ readMVar pagerOutput- else return ""- return (updatedState, ExecuteReply {- header = replyHeader,- pagerOutput = pager,- executionCounter = execCount,- status = Ok- })+ then liftIO $ readMVar pagerOutput+ else return ""+ return+ (updatedState, ExecuteReply+ { header = replyHeader+ , pagerOutput = pager+ , executionCounter = execCount+ , status = Ok+ }) replyTo _ req@CompleteRequest{} replyHeader state = do- let line = getCodeLine req- (matchedText, completions) <- complete (unpack line) (getCursorPos req)+ let code = getCode req+ pos = getCursorPos req+ (matchedText, completions) <- complete (unpack code) pos - let reply = CompleteReply replyHeader (map pack completions) (pack matchedText) line True- return (state, reply)+ let start = pos - length matchedText+ end = pos+ reply = CompleteReply replyHeader (map pack completions) start end Map.empty True+ return (state, reply) --- | Reply to the object_info_request message. Given an object name, return--- | the associated type calculated by GHC.-replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do+-- Reply to the object_info_request message. Given an object name, return the associated type+-- calculated by GHC.+replyTo _ ObjectInfoRequest { objectName = oname } replyHeader state = do docs <- pack <$> info (unpack oname)- let reply = ObjectInfoReply {- header = replyHeader,- objectName = oname,- objectFound = strip docs /= "",- objectTypeString = docs,- objectDocString = docs- }+ let reply = ObjectInfoReply+ { header = replyHeader+ , objectName = oname+ , objectFound = strip docs /= ""+ , objectTypeString = docs+ , objectDocString = docs+ }+ return (state, reply)++-- TODO: Implement history_reply.+replyTo _ HistoryRequest{} replyHeader state = do+ let reply = HistoryReply+ { header = replyHeader+ -- FIXME+ , historyReply = []+ } return (state, reply) handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState