packages feed

ihaskell 0.2.0.5 → 0.3.0.0

raw patch · 30 files changed

+4069/−3062 lines, 30 filesdep +HTTPdep +HUnitdep +base64-bytestringdep −template-haskelldep −textdep −uuiddep ~classy-prelude

Dependencies added: HTTP, HUnit, base64-bytestring, filepath, haskeline, hlint, ipython-kernel, parsec, process, transformers

Dependencies removed: template-haskell, text, uuid, zeromq3-haskell

Dependency ranges changed: classy-prelude

Files

− Hspec.hs 
@@ -1,382 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-import GHC-import GHC.Paths-import Data.IORef-import Control.Monad-import Data.List-import System.Directory-import Data.String.Here-import Data.String.Utils (strip, replace)--import IHaskell.Eval.Parser-import IHaskell.Types-import IHaskell.IPython-import IHaskell.Eval.Evaluate as Eval-import IHaskell.Eval.Completion--import Test.Hspec-import Test.Hspec.HUnit--doGhc = runGhc (Just libdir)--parses = doGhc . parseString--like parser desired = parser >>= (`shouldBe` desired)--is string blockType = do-  result <- doGhc $ parseString string-  result `shouldBe` [blockType $ strip string]--eval string = do-  outputAccum <- newIORef []-  let publish _ displayDatas = modifyIORef outputAccum (displayDatas :)-  getTemporaryDirectory >>= setCurrentDirectory-  interpret $ Eval.evaluate 1 string publish-  out <- readIORef outputAccum-  return $ reverse out--becomes string expected = 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-  where -    comparison results = do-      when (length results /= length expected) $-        expectationFailure $ "Expected result to have " ++ show (length expected)-                             ++ " results. Got " ++ show results--      let isPlain (Display PlainText _) = True-          isPlain _ = False--      forM_ (zip results expected) $ \(result, expected) ->-        case find isPlain result of-          Just (Display PlainText str) -> str `shouldBe` expected-          Nothing -> expectationFailure $ "No plain-text output in " ++ show result--completes string expected = completionTarget newString cursorloc `shouldBe` expected-  where (newString, cursorloc) = case elemIndex '!' string of-          Nothing -> error "Expected cursor written as '!'."-          Just idx -> (replace "!" "" string, idx)--completionHas string expected = do-    (matched, completions) <- doGhc $ do-      initCompleter-      complete newString cursorloc-    let existsInCompletion =  (`elem` completions)-        unmatched = filter (not . existsInCompletion) expected-    unmatched `shouldBe` []-  where (newString, cursorloc) = case elemIndex '!' string of-          Nothing -> error "Expected cursor written as '!'."-          Just idx -> (replace "!" "" string, idx)--initCompleter :: GhcMonad m => m ()-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 Data.Maybe as Maybe"]-  setContext $ map IIDecl imports--main :: IO ()-main = hspec $ do-  parserTests-  ipythonTests-  evalTests-  completionTests--completionTests = do-  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." ["Data", ""]      `shouldBe` ModuleName "Data" ""-      completionType "import Prel" ["Prel"]           `shouldBe` ModuleName "" "Prel"-      completionType "import D.B.M" ["D", "B", "M"]   `shouldBe` ModuleName "D.B" "M"-      completionType " import A." ["A", ""]           `shouldBe` ModuleName "A" ""-      completionType "import a.x" ["a", "x"]          `shouldBe` Identifier "x"-      completionType "A.x" ["A", "x"]                 `shouldBe` Qualified "A" "x"-      completionType "a.x" ["a", "x"]                 `shouldBe` Identifier "x"-      completionType "pri" ["pri"]                    `shouldBe` Identifier "pri"--    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"]--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` ["forall a. Num a => a"]-      ":in String" `becomes` ["type String = [Char] \t-- Defined in `GHC.Base'"]--ipythonTests = do-  describe "Parse IPython Version" $ do-    it "parses 2.0.0-dev" $-      parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0]-    it "parses 2.0.0-alpha" $-      parseVersion "2.0.0-dev" `shouldBe` [2, 0, 0]-    it "parses 12.5.10" $-      parseVersion "12.5.10" `shouldBe` [12, 5, 10]--parserTests = do-  layoutChunkerTests-  moduleNameTests-  parseStringTests--layoutChunkerTests = describe "Layout Chunk" $ do-  it "chunks 'a string'" $-    layoutChunks "a string" `shouldBe` ["a string"]--  it "chunks 'a\\nstring'" $-    layoutChunks "a\n string" `shouldBe` ["a\n string"]--  it "chunks 'a\\n string\\nextra'" $-    layoutChunks "a\n string\nextra" `shouldBe` ["a\n string","extra"]--  it "chunks strings with too many lines" $-    layoutChunks "a\n\nstring" `shouldBe` ["a","string"]--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 HelpForSet "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` [-      ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3"-    ]--  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-
− IHaskell/Config.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}--- | Description : IPython configuration files are compiled-into IHaskell-module IHaskell.Config (ipython, notebook, console, qtconsole, customjs, notebookJavascript) where--import Data.String.Here-import ClassyPrelude--ipython :: String -> String-ipython executable = [template|config/ipython_config.py|]--notebook :: String-notebook = [template|config/ipython_notebook_config.py|]--console :: String-console = [template|config/ipython_console_config.py|]--qtconsole :: String-qtconsole = [template|config/ipython_qtconsole_config.py|]--customjs :: String-customjs = [template|config/custom.js|]--notebookJavascript :: [(FilePath, String)]-notebookJavascript = [("tooltip.js", [template|deps/tooltip.js|]),-                      ("codecell.js", [template|deps/codecell.js|])]
− IHaskell/Display.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-module IHaskell.Display (-  IHaskellDisplay(..),-  plain, html, png, jpg, svg, latex,-  serializeDisplay-  ) where--import ClassyPrelude-import Data.Serialize as Serialize-import Data.ByteString-import Data.String.Utils (rstrip) --import IHaskell.Types---- | A class for displayable Haskell types.-class IHaskellDisplay a where-  display :: a -> [DisplayData]---- | Generate a plain text display.-plain :: String -> DisplayData-plain = Display PlainText . rstrip---- | Generate an HTML display.-html :: String -> DisplayData-html = Display MimeHtml--png :: String -> DisplayData-png = Display MimePng --jpg :: String -> DisplayData-jpg = Display MimeJpg--svg :: String -> DisplayData-svg = Display MimeSvg--latex :: String -> DisplayData-latex = Display MimeLatex--serializeDisplay :: [DisplayData] -> ByteString-serializeDisplay = Serialize.encode
− IHaskell/Eval/Completion.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{- | Description : generates tab-completion options--  context-insensitive completion for what is probably-  the identifier under the cursor.-  -  [@Known issues@]--  > import Data.Lef<tab>-  > System.IO.h<tab>-  > Just.he<tab>--  The first should not complete to Left. The second should only-  include things like System.IO.hPutStrLn, not head. Qualified-  names should not be confused by the third option.---}-module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where--import Control.Applicative ((<$>))-import Data.ByteString.UTF8 hiding (drop, take)-import Data.Char-import Data.List (find, isPrefixOf, nub, findIndex, intercalate, elemIndex)-import Data.List.Split-import Data.List.Split.Internals-import Data.Maybe-import Data.String.Utils (strip, startswith, replace)-import Prelude--import GHC-import DynFlags-import GhcMonad-import PackageConfig-import Outputable (showPpr)--import IHaskell.Types---data CompletionType -     = Empty -     | Identifier String-     | Extension String-     | Qualified String String-     | ModuleName String String-     deriving (Show, Eq)--complete :: GHC.GhcMonad m => String -> Int -> m (String, [String])-complete line pos = do-  flags <- getSessionDynFlags-  rdrNames <- map (showPpr flags) <$> getRdrNamesInScope-  scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope-  let isQualified = ('.' `elem`)-      unqualNames = nub $ filter (not . isQualified) rdrNames-      qualNames = nub $ scopeNames ++ filter isQualified rdrNames--  let Just db = pkgDatabase flags-      getNames = map moduleNameString . exposedModules-      moduleNames = nub $ concatMap getNames db--  let target = completionTarget line pos-      matchedText = intercalate "." target--  options <- -        case completionType line target of-          Empty -> return []--          Identifier candidate ->-            return $ filter (candidate `isPrefixOf`) unqualNames--          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--          ModuleName previous candidate -> do-            let prefix = if null previous-                         then candidate-                         else intercalate "." [previous, candidate]-            return $ filter (prefix `isPrefixOf`) moduleNames--          Extension ext -> do-            let extName (name, _, _) = name-                names = map extName xFlags-                nonames = map ("No" ++) names-            return $ filter (ext `isPrefixOf`) $ names ++ nonames--  return (matchedText, options)--getTrueModuleName :: GhcMonad m => String -> m String-getTrueModuleName name = do-  -- Only use the things that were actually imported-  let onlyImportDecl (IIDecl decl) = Just decl-      onlyImportDecl _ = Nothing--  -- Get all imports that we use.-  imports <- 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.-  flags <- getSessionDynFlags-  let qualifiedImports = filter (isJust . ideclAs) imports-      hasName imp = name == (showPpr flags . fromJust . ideclAs) imp-  case find hasName qualifiedImports of-    Nothing -> return name  -    Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp--completionType :: String -> [String] -> CompletionType-completionType line [] = Empty-completionType line target-  | startswith "import" stripped && isModName-    = ModuleName dotted candidate-  | isModName && (not . null . init) target-    = Qualified dotted candidate-  | startswith ":e" stripped-    = Extension candidate -  | otherwise-    = Identifier candidate-  where stripped = strip line-        dotted = dots target-        candidate = last target-        dots = intercalate "." . init-        isModName = all isCapitalized (init target)-        isCapitalized = isUpper . head----- | 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],-      -- Condense multiple delimiters into one and then drop them.-      condensePolicy = Condense,-      delimPolicy = Drop-    }--    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--    -- These are never part of an identifier.-    neverIdent = " \n\t(),{}[]\\'\"`"--    expandCompletionPiece Nothing = []-    expandCompletionPiece (Just str) = splitOn "." str
− IHaskell/Eval/Evaluate.hs 
@@ -1,615 +0,0 @@-{-# LANGUAGE DoAndIfThenElse #-}-{- | 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 (liftIO, hGetContents)-import Control.Concurrent (forkIO, threadDelay)-import Prelude (putChar, head, tail, last, init, (!!))-import Data.List.Utils-import Data.List(findIndex)-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 (removeFile, createDirectoryIfMissing, removeDirectoryRecursive)-import System.Posix.IO-import System.IO (hGetChar, hFlush)-import System.Random (getStdGen, randomRs)-import Unsafe.Coerce--import NameSet-import Name-import PprTyThing-import InteractiveEval-import DynFlags-import Type-import Exception (gtry)-import HscTypes-import HscMain-import TcType-import Unify-import InstEnv-import GhcMonad (liftIO, withSession)-import GHC hiding (Stmt, TypeSig)-import GHC.Paths-import Exception hiding (evaluate)-import Outputable-import Packages-import Module--import qualified System.IO.Strict as StrictIO--import IHaskell.Types-import IHaskell.Eval.Parser-import IHaskell.Display--data ErrorOccurred = Success | Failure deriving Show--debug :: Bool-debug = False--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 x--type Interpreter = Ghc--globalImports :: [String]-globalImports = -  [ "import IHaskell.Display"-  , "import Control.Applicative ((<$>))"-  , "import GHC.IO.Handle (hDuplicateTo, hDuplicate)"-  , "import System.Posix.IO"-  , "import System.Posix.Files"-  , "import System.IO"-  ]---- | Run an interpreting action. This is effectively runGhc with--- initialization and importing.-interpret :: Interpreter a -> IO a-interpret action = runGhc (Just libdir) $ do-  -- Set the dynamic session flags-  originalFlags <- getSessionDynFlags-  let dflags = xopt_set originalFlags Opt_ExtendedDefaultRules-  void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted, ghcLink = LinkInMemory }--  initializeImports-  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-* and aren't just IHaskell.-  dflags <- getSessionDynFlags-  displayPackages <- liftIO $ do-    (dflags, _) <- initPackages dflags-    let Just db = pkgDatabase dflags-        packageNames = map (packageIdString . packageConfigId) db-        initStr = "ihaskell-"-        ihaskellPkgs = filter (startswith initStr) packageNames-        displayPkgs = filter (isAlpha . (!! (length initStr + 1))) ihaskellPkgs-    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 =-  -- 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 = (Bool -> [DisplayData] -> IO ())---- | Evaluate some IPython input code.-evaluate :: Int              -- ^ The execution counter of this evaluation.-         -> String           -- ^ Haskell code or other interpreter commands.-         -> Publisher        -- ^ Function used to publish data outputs.-         -> Interpreter ()-evaluate execCount code output = do-  cmds <- parseString (strip code)-  runUntilFailure (cmds ++ [storeItCommand execCount])-  where-    runUntilFailure :: [CodeBlock] -> Interpreter ()-    runUntilFailure [] = return ()-    runUntilFailure (cmd:rest) = do -      (success, result) <- evalCommand output cmd-      unless (null result) $ liftIO $ output True result-      case success of-        Success -> runUntilFailure rest-        Failure -> return ()--    storeItCommand execCount = Statement $ printf "let it%d = it" execCount--wrapExecution :: Interpreter [DisplayData] -> Interpreter (ErrorOccurred, [DisplayData])-wrapExecution exec = ghandle handler $ exec >>= \res ->-    return (Success, res)-  where -    handler :: SomeException -> Interpreter (ErrorOccurred, [DisplayData])-    handler exception = return (Failure, displayError $ show exception)---- | Return the display data for this command, as well as whether it--- resulted in an error.-evalCommand :: Publisher -> CodeBlock -> Interpreter (ErrorOccurred, [DisplayData])-evalCommand _ (Import importStr) = wrapExecution $ do-  write $ "Import: " ++ importStr-  importDecl <- parseImportDecl importStr-  context <- getContext--  -- If we've imported this implicitly, remove the old import.-  let noImplicit = filter (not . implicitImportOf importDecl) context-  setContext $ IIDecl importDecl : noImplicit--  flags <- getSessionDynFlags-  return []-  where-    implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool-    implicitImportOf _ (IIModule _) = False-    implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp--evalCommand _ (Module contents) = wrapExecution $ do-  write $ "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--  -- Set to use object code for fast running times, as that is the only-  -- reason you would want to use modules in IHaskell.-  flags <- getSessionDynFlags-  let objTarget = defaultObjectTarget-  setSessionDynFlags flags{ hscTarget = objTarget }--  -- Remember which modules we've loaded before.-  importedModules <- getContext--  let -- Get the dot-delimited pieces of hte 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 -> -      let prevLoaded = intercalate "." (moduleNameOf previous) in-        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 -> do-      -- Create a new target-      target <- guessTarget modName 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 []-        Failed -> return $ displayError $ "Failed to load module " ++ modName--evalCommand _ (Directive SetExtension exts) = wrapExecution $ do-  write $ "Extension: " ++ exts-  results <- mapM setExtension (words exts)-  case catMaybes results of-    [] -> return []-    errors -> return $ displayError $ intercalate "\n" errors-  where-    -- Set an extension and update flags.-    -- Return Nothing on success. On failure, return an error message.-    setExtension :: String -> Interpreter (Maybe ErrMsg)-    setExtension ext = do-      flags <- getSessionDynFlags-      -- First, try to check if this flag matches any extension name.-      let newFlags =-            case find (flagMatches ext) xFlags of-              Just (_, flag, _) -> Just $ xopt_set flags flag-              -- If it doesn't match an extension name, try matching against-              -- disabling an extension.-              Nothing -> -                case find (flagMatchesNo ext) xFlags of-                  Just (_, flag, _) -> Just $ xopt_unset flags flag-                  Nothing -> Nothing--      -- Set the flag if we need to.-      case newFlags of-        Just flags -> setSessionDynFlags flags >> return Nothing-        Nothing -> return $ Just $ "Could not parse extension name: " ++ ext--    -- Check if a FlagSpec matches an extension name.-    flagMatches ext (name, _, _) = ext == name--    -- Check if a FlagSpec matches "No<ExtensionName>".-    -- In that case, we disable the extension.-    flagMatchesNo ext (name, _, _) = ext == "No"  ++ name--evalCommand _ (Directive GetType expr) = wrapExecution $ do-  write $ "Type: " ++ expr-  result <- exprType expr-  flags <- getSessionDynFlags-  let typeStr = showSDocUnqual flags $ ppr result-  return [plain typeStr, html $ formatGetType typeStr]---- This is taken largely from GHCi's info section in InteractiveUI.-evalCommand _ (Directive HelpForSet _) = do-  write "Help for :set."-  return (Success, [out])-  where out = plain $ intercalate "\n"-          [":set is not implemented in IHaskell."-          ,"  Use :extension <Extension> to enable a GHC extension."-          ,"  Use :extension No<Extension> to disable a GHC extension."-          ]---- This is taken largely from GHCi's info section in InteractiveUI.-evalCommand _ (Directive GetHelp _) = do-  write "Help via :help or :?."-  return (Success, [out])-  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."-          ,"    :?, :help                 -  Show this help text."-          ,""-          ,"Any prefix of the commands will also suffice, e.g. use :ty for :type."-          ]---- This is taken largely from GHCi's info section in InteractiveUI.-evalCommand _ (Directive GetInfo str) = wrapExecution $ do-  write $ "Info: " ++ str-  -- Get all the info for all the names we're given.-  names     <- parseName str-  maybeInfos <- mapM getInfo names--  -- Filter out types that have parents in the same set.-  -- GHCi also does this.-  let getType (theType, _, _) = theType-      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-      filteredOutput = filter (not . hasParent) infos--  -- Convert to textual data.-  let printInfo (thing, fixity, classInstances) = -        pprTyThingInContextLoc False thing $$ showFixity fixity $$ vcat (map GHC.pprInstance classInstances)-        where-          showFixity fixity =-            if fixity == GHC.defaultFixity-            then empty-            else ppr fixity <+> pprInfixName (getName thing)-      outs = map printInfo filteredOutput--  -- Print nicely.-  unqual <- getPrintUnqual-  flags <- getSessionDynFlags-  let strings = map (showSDocForUser flags unqual) outs-  return [plain $ intercalate "\n" strings]--evalCommand output (Statement stmt) = wrapExecution $ do-  write $ "Statement:\n" ++ stmt-  let outputter str = output False [plain str]-  (printed, result) <- capturedStatement outputter stmt-  case result of-    RunOk names -> do-      dflags <- getSessionDynFlags-      write $ "Names: " ++ show (map (showPpr dflags) names)  -      let output = [plain printed | not . null $ strip printed]-      return output-    RunException exception -> throw exception-    RunBreak{} -> error "Should not break."--evalCommand output (Expression expr) = do-  write $ "Expression:\n" ++ expr-  -- Evaluate this expression as though it's just a statement.-  -- The output is bound to 'it', so we can then use it.-  (success, out) <- evalCommand output (Statement expr)--    -- Try to use `display` to convert our type into the output-  -- DisplayData. If typechecking fails and there is no appropriate-  -- typeclass, 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-  canRunDisplay <- attempt $ exprType displayExpr-  write $ printf "%s: Attempting %s" (if canRunDisplay then "Success" else "Failure") displayExpr-  write $ "Show Error: " ++ show (isShowError out)-  write $ show out--  -- If evaluation failed, return the failure.  If it was successful, we-  -- may be able to use the IHaskellDisplay typeclass.-  if not canRunDisplay-  then return (success, out)-  else case success of-    Success -> useDisplay displayExpr-    Failure -> if isShowError out-              then useDisplay displayExpr-              else return (success, out)--  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 errs = case find isPlain errs of-      Just (Display PlainText msg) -> -        startswith "No instance for (GHC.Show.Show" msg &&-        isInfixOf " arising from a use of `System.IO.print'" msg-      Nothing -> False-      where isPlain (Display mime _) = mime == PlainText--    useDisplay displayExpr = wrapExecution $ do-      -- If there are instance matches, convert the object into-      -- a [DisplayData]. We also serialize it into a bytestring. We get-      -- the bytestring 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 [DisplayData].-      runStmt displayExpr RunToCompletion-      displayedBytestring <- dynCompileExpr "IHaskell.Display.serializeDisplay it"-      case fromDynamic displayedBytestring of-        Nothing -> error "Expecting lazy Bytestring"-        Just bytestring ->-          case Serialize.decode bytestring of-            Left err -> error err-            Right displayData -> do-              write $ show displayData-              return displayData---evalCommand _ (Declaration decl) = wrapExecution $ do-  write $ "Declaration:\n" ++ decl-  runDecls decl--  -- Do not display any output-  return []--evalCommand _ (TypeSignature sig) = wrapExecution $-  -- 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) = do-  write "Parse Error."-  return (Failure, displayError $ formatParseError loc err)--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 ++ " >> return ()"-    -    -- Statements run before the thing we're evaluating.-    initStmts = -      [ printf "let %s = it" itVariable-      , printf "(%s, %s) <- createPipe" readVariable writeVariable-      , printf "%s <- dup stdOutput" oldVariable-      , voidpf "dupTo %s stdOutput" writeVariable-      , voidpf "hSetBuffering stdout NoBuffering"-      , printf "let it = %s" itVariable-      ]-    -    -- Statements run after evaluation.-    postStmts = -      [ printf "let %s = it" itVariable-      , voidpf "hFlush stdout"-      , voidpf "dupTo %s stdOutput" oldVariable-      , voidpf "closeFd %s" writeVariable-      , printf "let it = %s" itVariable-      ]-    pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable--    goStmt s = runStmt s RunToCompletion--  -- Initialize evaluation context.-  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.-    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 = printf "<span style='color: red; font-style: italic;'>%s</span>" .-            replace "\n" "<br/>" . -            replace useDashV "" .-            rstrip . -            typeCleaner-  where -        useDashV = "\nUse -v to see a list of the files searched for."--formatParseError :: StringLoc -> String -> ErrMsg-formatParseError (Loc line col) = -  printf "Parse error (line %d, column %d): %s" line col--formatGetType :: String -> String-formatGetType = printf "<span style='font-weight: bold; color: green;'>%s</span>"--displayError :: ErrMsg -> [DisplayData]-displayError msg = [plain msg, html $ formatError msg]
− IHaskell/Eval/Info.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{- | Description : Inspect type and function information and documentation.--}-module IHaskell.Eval.Info (-  info-  ) where--import ClassyPrelude hiding (liftIO)--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 -    handler :: SomeException -> Interpreter String-    handler _ = return ""
− IHaskell/Eval/Parser.hs 
@@ -1,296 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-module IHaskell.Eval.Parser (-    parseString,-    CodeBlock(..),-    StringLoc(..),-    DirectiveType(..),-    LineNumber,-    ColumnNumber,-    ErrMsg,-    layoutChunks,-    parseDirective,-    getModuleName-    ) where---- Hide 'unlines' to use our own 'joinLines' instead.-import ClassyPrelude hiding (liftIO, unlines)--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 Bag-import ErrUtils hiding (ErrMsg)-import FastString-import GHC-import Lexer-import OrdList-import Outputable hiding ((<>))-import SrcLoc-import StringBuffer--import Language.Haskell.GHC.Parser---- | 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.-  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)-  | SetExtension    -- ^ Enable or disable an extension via ':extension' (or prefixes)-  | HelpForSet      -- ^ Provide useful info if people try ':set'.-  | GetHelp         -- ^ General help via ':?' or ':help'.-  deriving (Show, Eq)---- | Parse a string into code blocks.-parseString :: GhcMonad m => String -> m [CodeBlock]-parseString codeString = do-  -- Try to parse this as a single module.-  flags <- getSessionDynFlags-  let output = runParser flags parserModule codeString-  case output of-    Parsed {} -> return [Module codeString]-    Failure {} ->-      -- Split input into chunks based on indentation.-      let chunks = layoutChunks $ dropComments codeString in-        joinFunctions <$> processChunks 1 [] chunks-  where-    parseChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock-    parseChunk chunk line =-      if isDirective chunk-      then return $ parseDirective chunk line-      else parseCodeChunk chunk line--    processChunks :: GhcMonad m => LineNumber -> [CodeBlock] -> [String] -> m [CodeBlock]-    processChunks line accum remaining =-      case remaining of-        -- If we have no more remaining lines, return the accumulated results.-        [] -> return $ reverse accum--        -- If we have more remaining, parse the current chunk and recurse.-        chunk:remaining ->  do-          block <- parseChunk chunk line-          processChunks (line + nlines chunk) (block : accum) remaining--    -- Test wither a given chunk is a directive.-    isDirective :: String -> Bool-    isDirective = startswith ":" . strip--    -- Number of lines in this string.-    nlines :: String -> Int-    nlines = length . lines---- | 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)--        -- 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--        -- If one of the parsers succeeded-        result:_ -> return result-  where-    successes :: [ParseOutput a] -> [a]-    successes [] = []-    successes (Parsed a:rest) = a : successes rest-    successes (_:rest) = successes rest--    failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]-    failures [] = []-    failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest-    failures (_:rest) = failures rest--    bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock-    bestError errors = ParseError (Loc (line + startLine - 1) col) msg-      where-        (msg, line, col) = maximumBy compareLoc errors-        compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2--    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-    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--    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--    parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]-    parsers flags =-      [ (Import,        unparser parserImport)-      , (TypeSignature, unparser parserTypeSignature)-      , (Declaration,   unparser parserDeclaration)-      , (Statement,     unparser parserStatement)-      ]-      where-        unparser :: Parser a -> String -> ParseOutput String-        unparser parser code =-          case runParser flags parser code of-            Parsed out -> Parsed code-            Partial out strs -> Partial code strs-            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.-joinFunctions :: [CodeBlock] -> [CodeBlock]-joinFunctions (Declaration decl : rest) =-    -- Find all declarations having the same name as this one.-    let (decls, other) = havingSameName rest in-      -- Convert them into a single declaration.-      Declaration (joinLines $ map undecl decls) : joinFunctions other-  where-    undecl (Declaration decl) = decl-    undecl _ = error "Expected declaration!"--    -- Get all declarations with the same name as the first declaration.-    -- The name of a declaration is the first word, which we expect to be-    -- the name of the function.-    havingSameName :: [CodeBlock] -> ([CodeBlock], [CodeBlock]) -    havingSameName blocks =-      let name = head $ words decl-          sameName = takeWhile (isNamedDecl name) rest -          others = drop (length sameName) rest in-        (Declaration decl : sameName, others)--    isNamedDecl :: String -> CodeBlock -> Bool-    isNamedDecl name (Declaration dec) = head (words dec) == name-    isNamedDecl _ _ = False---- Allow a type signature followed by declarations to be joined to the--- declarations. Parse the declaration joining separately.-joinFunctions (TypeSignature sig : Declaration decl : rest) = (Declaration $ sig ++ "\n" ++ joinedDecl):remaining-  where Declaration joinedDecl:remaining = joinFunctions $ Declaration decl : rest -        -joinFunctions (x:xs) = x : joinFunctions xs-joinFunctions [] = []----- | Parse a directive of the form :directiveName.-parseDirective :: String       -- ^ Directive string.-               -> Int          -- ^ Line number at which the directive appears.-               -> CodeBlock    -- ^ Directive code block or a parse error.-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)-    directives =-      [(GetType,      "type")-      ,(GetInfo,      "info")-      ,(SetExtension, "extension")-      ,(HelpForSet,   "set")-      ,(GetHelp,      "?")-      ,(GetHelp,      "help")-      ]-parseDirective _ _ = error "Directive must start with colon!"----- | Split an input string into chunks based on indentation.--- A chunk is a line and all lines immediately following that are indented--- beyond the indentation of the first line. This parses Haskell layout--- rules properly, and allows using multiline expressions via indentation. -layoutChunks :: String -> [String]-layoutChunks string = filter (not . null) $ map strip $ layoutLines $ lines string-  where-    layoutLines :: [String] -> [String]-    -- Empty string case.  If there's no input, output is empty.-    layoutLines [] = []--    -- Use the indent of the first line to find the end of the first block.-    layoutLines (firstLine:rest) = -      let firstIndent = indentLevel firstLine-          blockEnded line = indentLevel line <= firstIndent in-        case findIndex blockEnded rest of-          -- If the first block doesn't end, return the whole string, since-          -- that just means the block takes up the entire string. -          Nothing -> [string]--          -- We found the end of the block. Split this bit out and recurse.-          Just idx -> -              joinLines (firstLine:take idx rest) : layoutChunks (joinLines $ drop idx rest)--    -- Compute indent level of a string as number of leading spaces.-    indentLevel :: String -> Int-    indentLevel (' ':str) = 1 + indentLevel str--    -- Count a tab as two spaces.-    indentLevel ('\t':str) = 2 + indentLevel str-  -    -- Count empty lines as a large indent level, so they're always with the previous expression.-    indentLevel "" = 100000--    indentLevel _ = 0---- Not the same as 'unlines', due to trailing \n-joinLines :: [String] -> String-joinLines = intercalate "\n"---- | Drop comments from Haskell source.-dropComments :: String -> String-dropComments = removeOneLineComments . removeMultilineComments-  where-    removeOneLineComments ('-':'-':remaining) = removeOneLineComments (dropWhile (/= '\n') remaining)-    removeOneLineComments (x:xs) = x:removeOneLineComments xs-    removeOneLineComments x = x--    removeMultilineComments ('{':'-':remaining) = -      case subIndex "-}" remaining of-        Nothing -> ""-        Just idx -> removeMultilineComments $ drop (2 + idx) remaining-    removeMultilineComments (x:xs) = x:removeMultilineComments xs-    removeMultilineComments x = x---- | 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."-    Parsed mod -> -      case unLoc <$> hsmodName (unLoc mod) of-        Nothing -> error "Module must have a name."-        Just name -> return $ split "." $ moduleNameString name
− IHaskell/IPython.hs 
@@ -1,265 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse #-}--- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, @setup@, and---                 @console@ commands.-module IHaskell.IPython (-  ipythonInstalled,-  installIPython,-  removeIPython,-  runConsole,-  runNotebook,-  readInitInfo,-  defaultConfFile,-) where--import ClassyPrelude-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)-import Text.Printf--import qualified System.IO.Strict as StrictIO-import qualified Paths_ihaskell as Paths-import qualified Codec.Archive.Tar as Tar--import IHaskell.Types---- | Which commit of IPython we are on.-ipythonCommit :: Text-ipythonCommit = "1faf2f6e77fa31f4533e3edbe101c38ddf8943d8"---- | The IPython profile name.-ipythonProfile :: String-ipythonProfile = "haskell"---- | Run IPython with any arguments.-ipython :: Bool         -- ^ Whether to suppress output.-        -> [Text]       -- ^ IPython command line arguments.-        -> Sh String    -- ^ IPython output.-ipython suppress args = do-  (_, ipythonDir, _) <- ihaskellDirs-  let ipythonPath = fromText $ ipythonDir ++ "/bin/ipython"-  sub $ do-    setenv "PYTHONPATH" $ ipythonDir ++ "/lib/python2.7/site-packages"-    runHandles ipythonPath 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 ""---- | Run while suppressing all output.-quietRun path args = runHandles path args handles nothing-  where-    handles =  [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]-    nothing _ _ _ = return ()---- | Return the data directory for IHaskell and the IPython subdirectory. -ihaskellDirs :: Sh (Text, Text, Text)-ihaskellDirs = do-  home <- maybe (error "$HOME not defined.") id <$> get_env "HOME" :: Sh Text-  let ihaskellDir = home ++ "/.ihaskell"-      ipythonDir = ihaskellDir ++ "/ipython"-      notebookDir = ihaskellDir ++ "/notebooks"--  -- Make sure the directories exist.-  mkdir_p $ fromText ipythonDir-  mkdir_p $ fromText notebookDir--  return (ihaskellDir, ipythonDir, notebookDir)--defaultConfFile :: IO (Maybe String)-defaultConfFile = shellyNoDir $ do-  (ihaskellDir, _, _) <- ihaskellDirs-  let filename = ihaskellDir ++ "/rc.hs"-  exists <- test_f $ fromText filename-  return $ if exists-           then Just $ unpack filename-           else Nothing---- | Remove IPython so it can be reinstalled.-removeIPython :: IO ()-removeIPython = void . shellyNoDir $ do-  (ihaskellDir, _, _) <- ihaskellDirs-  cd $ fromText ihaskellDir-  rm_rf "ipython-src"---- | Install IPython from source.-installIPython :: IO ()-installIPython = void . shellyNoDir $ do-  (ihaskellDir, ipythonDir, _) <- ihaskellDirs--  -- Install all Python dependencies.-  pipPath <- path "pip"-  let pipDeps = ["pyzmq", "tornado", "jinja2"]-      installDep dep = do-        putStrLn $ "Installing dependency: " ++ dep -        let opt = "--install-option=--prefix=" ++ ipythonDir-        run_ pipPath ["install", opt, dep]-  mapM_ installDep pipDeps--  -- Get the IPython source.-  gitPath <- path "git"-  putStrLn "Downloading IPython... (this may take a while)"-  cd $ fromText ihaskellDir-  run_ gitPath ["clone", "--recursive", "https://github.com/ipython/ipython.git", "ipython-src"]-  cd "ipython-src"-  run_ gitPath ["checkout", ipythonCommit]--  -- Install IPython locally.-  pythonPath <- path "python"-  putStrLn "Installing IPython."-  run_ pythonPath ["setup.py", "install", "--prefix=" ++ ipythonDir]-  cd ".."---- | Check whether IPython is properly installed.-ipythonInstalled :: IO Bool-ipythonInstalled = shellyNoDir $ do-  (_, ipythonDir, _) <- ihaskellDirs-  let ipythonPath = ipythonDir ++ "/bin/ipython"-  test_f $ fromText ipythonPath---- | 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-  case path of-    Nothing -> do-      putStrLn $ "Could not find `" ++ exe ++ "` executable."-      fail $ "`" ++ unpack exe ++ "` not on $PATH."-    Just exePath -> return exePath---- | Use the `ipython --version` command to figure out the version.--- Return a tuple with (major, minor, patch).-ipythonVersion :: IO (Int, Int, Int)-ipythonVersion = shellyNoDir $ do-  [major, minor, patch] <- parseVersion <$>  ipython True ["--version"]-  return (major, minor, patch)---- | Parse an IPython version string into a list of integers.-parseVersion :: String -> [Int]-parseVersion versionStr = map read' $ split "." versionStr-    where read' x = case reads x of-                        [(n, _)] -> n-                        _ -> error $ "cannot parse version: "++ versionStr---- | Run an IHaskell application using the given profile.-runIHaskell :: String   -- ^ IHaskell profile name. -           -> String    -- ^ IPython app name.-           -> [String]  -- ^ Arguments to IPython.-           -> Sh ()-runIHaskell profile app args = void $ do-  -- Try to locate the profile. Do not die if it doesn't exist.-  errExit False $ ipython True ["locate", "profile", pack profile]--  -- If the profile doesn't exist, create it.-  exitCode <- lastExitCode-  when (exitCode /= 0) $ liftIO $ do-    putStrLn "Creating IPython profile."-    setupIPythonProfile profile--  -- Run the IHaskell command.-  ipython False $ map pack $ [app, "--profile", profile] ++ args--runConsole :: InitInfo -> IO ()-runConsole initInfo = void . shellyNoDir $ do-  writeInitInfo initInfo-  runIHaskell ipythonProfile "console" []--runNotebook :: InitInfo -> Maybe String -> IO ()-runNotebook initInfo maybeServeDir = void . shellyNoDir $ do-  (_, _, notebookDir) <- ihaskellDirs-  let args = case maybeServeDir of -               Nothing -> ["--notebook-dir", unpack notebookDir]-               Just dir -> ["--notebook-dir", dir]--  writeInitInfo initInfo-  runIHaskell ipythonProfile "notebook" args--writeInitInfo :: InitInfo -> Sh ()-writeInitInfo info = do-  (ihaskellDir, _, _) <- ihaskellDirs-  let filename = fromText $ ihaskellDir ++ "/last-arguments"-  liftIO $ writeFile filename $ show info--readInitInfo :: IO InitInfo-readInitInfo = shellyNoDir $ do-  (ihaskellDir, _, _) <- ihaskellDirs-  let filename = fromText $ ihaskellDir ++ "/last-arguments"-  read <$> liftIO (readFile filename)---- | Create the IPython profile.-setupIPythonProfile :: String -- ^ IHaskell profile name.-                    -> IO ()-setupIPythonProfile profile = shellyNoDir $ do-  -- Create the IPython profile.-  void $ ipython 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 True ["locate"]-  let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/"--  liftIO $ copyProfile profileDir-  insertIHaskellPath profileDir---- | Copy the profile files into the IPython profile. -copyProfile :: Text -> IO ()-copyProfile profileDir = do-  profileTar <- Paths.getDataFileName "profile/profile.tar"-  {--  -- Load profile from Resources directory of Mac *.app.-  ihaskellPath <- shellyNoDir getIHaskellPath-  profileTar <- if "IHaskell.app/Contents/MacOS" `isInfixOf` ihaskellPath-               then-                let pieces = split "/" ihaskellPath-                    pathPieces = init pieces ++ ["..", "Resources", "profile.tar"] in-                  return $ intercalate "/" pathPieces-               else 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---- | Get the absolute path to this IHaskell executable.-getIHaskellPath :: Sh String-getIHaskellPath = do-  --  Get the absolute filepath to the argument.-  f <- liftIO getArgv0--  -- 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.-    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
− IHaskell/Message/Parser.hs 
@@ -1,143 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}--- | Description : Parsing messages received from IPython------ This module is responsible for converting from low-level ByteStrings--- obtained from the 0MQ sockets into Messages. The only exposed function is--- `parseMessage`, which should only be used in the low-level 0MQ interface.-module IHaskell.Message.Parser (parseMessage) where--import ClassyPrelude-import Data.Aeson ((.:), decode, Result(..), Object)-import Data.Aeson.Types (parse)--import qualified Data.ByteString.Lazy as Lazy--import IHaskell.Types------- External interface --------- | Parse a message from its ByteString components into a Message.-parseMessage :: [ByteString] -- ^ The list of identifiers sent with the message.-              -> ByteString   -- ^ The header data.-              -> ByteString   -- ^ The parent header, which is just "{}" if there is no header.-              -> ByteString   -- ^ The metadata map, also "{}" for an empty map.-              -> ByteString   -- ^ The message content.-              -> Message      -- ^ A parsed message.-parseMessage idents headerData parentHeader metadata content = -  let header = parseHeader idents headerData parentHeader metadata-      messageType = msgType header-      messageWithoutHeader = parser messageType $ Lazy.fromStrict content in-    messageWithoutHeader { header = header }------- Module internals --------- | Parse a header from its ByteString components into a MessageHeader.-parseHeader :: [ByteString]  -- ^ The list of identifiers.-            -> ByteString    -- ^ The header data.-            -> ByteString    -- ^ The parent header, or "{}" for Nothing.-            -> ByteString    -- ^ The metadata, or "{}" for an empty map.-            -> MessageHeader -- The resulting message header.-parseHeader idents headerData parentHeader metadata = MessageHeader {-  identifiers = idents,-  parentHeader = parentResult,-  metadata = metadataMap,-  messageId = messageUUID,-  sessionId = sessionUUID,-  username = username,-  msgType = messageType-  } where-      -- Decode the header data and the parent header data into JSON objects.-      -- If the parent header data is absent, just have Nothing instead.-      Just result = decode $ Lazy.fromStrict headerData :: Maybe Object-      parentResult = if parentHeader == "{}"-                     then Nothing-                     else Just $ parseHeader idents parentHeader "{}" metadata--      -- Get the basic fields from the header.-      Success (messageType, username, messageUUID, sessionUUID) = flip parse result $ \obj -> do -        messType <- obj .: "msg_type"-        username <- obj .: "username"-        message <- obj .: "msg_id"-        session <- obj .: "session"-        return (messType, username, message, session)--      -- Get metadata as a simple map.-      Just metadataMap = decode $ Lazy.fromStrict metadata :: Maybe (Map ByteString ByteString)--noHeader :: MessageHeader-noHeader = error "No header created"--parser :: MessageType            -- ^ The message type being parsed.-       -> LByteString -> Message   -- The parser that converts the body into a message.-                                 -- This message should have an undefined-                                 -- header.-parser KernelInfoRequestMessage  = kernelInfoRequestParser-parser ExecuteRequestMessage     = executeRequestParser-parser CompleteRequestMessage    = completeRequestParser-parser ObjectInfoRequestMessage  = objectInfoRequestParser-parser ShutdownRequestMessage    = shutdownRequestParser-parser other = error $ "Unknown message type " ++ show other---- | Parse a kernel info request.--- A kernel info request has no auxiliary information, so ignore the body.-kernelInfoRequestParser :: LByteString -> Message-kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader }---- | Parse an execute request.--- Fields used are:---  1. "code": the code to execute.---  2. "silent": whether to execute silently.---  3. "store_history": whether to include this in history.---  4. "allow_stdin": whether to allow reading from stdin for this code.-executeRequestParser :: LByteString -> Message-executeRequestParser content = -  let parser obj = do-        code <- obj .: "code"-        silent <- obj .: "silent"-        storeHistory <- obj .: "store_history"-        allowStdin <- obj .: "allow_stdin"--        return (code, silent, storeHistory, allowStdin)-      Just decoded = decode content-      Success (code, silent, storeHistory, allowStdin) = parse parser decoded in-    ExecuteRequest {-      header = noHeader,-      getCode = code,-      getSilent = silent,-      getAllowStdin = allowStdin,-      getStoreHistory = storeHistory,-      getUserVariables = [],-      getUserExpressions = []-    }--completeRequestParser :: LByteString -> Message-completeRequestParser content = parsed-  where-  Success parsed = flip parse decoded $ \ obj -> do-        code     <- obj .: "block" <|> return ""-        codeLine <- obj .: "line"-        pos      <- obj .: "cursor_pos"-        return $ CompleteRequest noHeader code codeLine pos--  Just decoded = decode content--objectInfoRequestParser :: LByteString -> Message-objectInfoRequestParser content = parsed-  where-    Success parsed = flip parse decoded $ \obj -> do-      oname <- obj .: "oname"-      dlevel <- obj .: "detail_level"-      return $ ObjectInfoRequest noHeader oname dlevel--    Just decoded = decode content---shutdownRequestParser :: LByteString -> Message-shutdownRequestParser content = parsed-  where-  Success parsed = flip parse decoded $ \ obj -> do-        code     <- obj .: "restart"-        return $ ShutdownRequest noHeader code--  Just decoded = decode content
− IHaskell/Message/UUID.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}--- | Description : UUID generator and data structure------ Generate, parse, and pretty print UUIDs for use with IPython.-module IHaskell.Message.UUID (-  UUID,-  random, randoms,-  ) where--import ClassyPrelude-import Control.Monad (mzero)-import Data.Aeson-import Data.UUID.V4 (nextRandom)---- We use an internal string representation because for the purposes of--- IPython, it matters whether the letters are uppercase or lowercase and--- whether the dashes are present in the correct locations. For the--- purposes of new UUIDs, it does not matter, but IPython expects UUIDs--- passed to kernels to be returned unchanged, so we cannot actually parse--- them.---- | A UUID (universally unique identifier).-data UUID = UUID String deriving Eq--instance Show UUID where-  show (UUID s) = s---- | Generate a list of random UUIDs.-randoms :: Int      -- ^ Number of UUIDs to generate.-        -> IO [UUID]-randoms n = replicateM n random---- | Generate a single random UUID.-random :: IO UUID-random = UUID <$> show <$> nextRandom---- Allows reading and writing UUIDs as Strings in JSON. -instance FromJSON UUID where-  parseJSON val@(String _) = UUID <$> parseJSON val--  -- UUIDs must be Strings.-  parseJSON _ = mzero--instance ToJSON UUID where-  -- Extract the string from the UUID.-  toJSON (UUID str) = String $ pack str
− IHaskell/Message/Writer.hs 
@@ -1,119 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--- | Description : @ToJSON@ for Messages------ This module contains the @ToJSON@ instance for @Message@.-module IHaskell.Message.Writer (-  ToJSON(..)-)  where--import Prelude (read)-import ClassyPrelude-import Data.Aeson--import Language.Haskell.TH-import Shelly hiding (trace)--import IHaskell.Types---- | Compute the GHC API version number using Template Haskell.-ghcVersionInts :: [Int]-ghcVersionInts = ints . map read . words . map dotToSpace $ version-  where dotToSpace '.' = ' '-        dotToSpace x = x--        version :: String-        version = $(runIO (unpack <$> shelly (run "ghc" ["--numeric-version"])) >>= stringE)---- Convert message bodies into JSON.-instance ToJSON Message where-  toJSON KernelInfoReply{} = object [-                             "protocol_version" .= ints [4, 0], -- current protocol version, major and minor-                             "language_version" .= ghcVersionInts,-                             "language" .= string "haskell"-                           ]--  toJSON ExecuteReply{ status = status, executionCounter = counter} = object [-                             "status" .= show status,-                             "execution_count" .= counter,-                             "payload" .= emptyList,-                             "user_variables" .= emptyMap,-                             "user_expressions" .= emptyMap-                           ]-  toJSON PublishStatus{ executionState = executionState } = object [-                             "execution_state" .= executionState-                           ]-  toJSON PublishStream{ streamType = streamType, streamContent = content } = object [-                             "data" .= content,-                             "name" .= streamType-                           ]-  toJSON PublishDisplayData{ source = src, displayData = datas } = object [-                             "source" .= src,-                             "metadata" .= object [],-                             "data" .= object  (map displayDataToJson datas)-                           ]--  toJSON PublishOutput{ executionCount = execCount, reprText = reprText } = object [-                             "data" .= object ["text/plain" .= reprText],-                             "execution_count" .= execCount,-                             "metadata" .= object []-                           ]-  toJSON PublishInput{ executionCount = execCount, inCode = code } = object [-                             "execution_count" .= execCount,-                             "code" .= code-                           ]-  toJSON (CompleteReply _ m mt t s) = object [-                             "matches" .= m,-                             "matched_text" .= mt,-                             "text" .= t,-                             "status" .= if s then "ok" :: String else "error"-                           ]-  toJSON o@ObjectInfoReply{} = object [-                            "oname" .= objectName o,-                            "found" .= objectFound o,-                            "ismagic" .= False,-                            "isalias" .= False,-                            "type_name" .= objectTypeString o,-                            "docstring" .= objectDocString o-                           ]--  toJSON ShutdownReply{restartPending = restart} = object [-                            "restart" .= restart-                           ]--  toJSON ClearOutput{wait = wait} = object [-                            "wait" .= wait-                           ]---  toJSON body = error $ "Do not know how to convert to JSON for message " ++ show body----- | Print an execution state as "busy", "idle", or "starting".-instance ToJSON ExecutionState where-    toJSON Busy = String "busy"-    toJSON Idle = String "idle"-    toJSON Starting = String "starting"---- | Print a stream as "stdin" or "stdout" strings.-instance ToJSON StreamType where-    toJSON Stdin = String "stdin"-    toJSON Stdout = String "stdout"---- | Convert a MIME type and value into a JSON dictionary pair.-displayDataToJson :: DisplayData -> (Text, Value) -displayDataToJson (Display mimeType dataStr) = pack (show mimeType) .= dataStr------- Constants -------emptyMap :: Map String String-emptyMap = mempty--emptyList :: [Int]-emptyList = []--ints :: [Int] -> [Int]-ints = id--string :: String -> String-string = id
− IHaskell/Types.hs 
@@ -1,315 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}--- | Description : All message type definitions.-module IHaskell.Types (-  Profile (..),-  Message (..),-  MessageHeader (..),-  MessageType(..),-  Username,-  Metadata,-  Port,-  replyType,-  ExecutionState (..),-  StreamType(..),-  MimeType(..),-  DisplayData(..),-  ExecuteReplyStatus(..),-  InitInfo(..),-  ) where--import ClassyPrelude-import Data.Aeson-import IHaskell.Message.UUID-import Data.Serialize-import GHC.Generics (Generic)------ | A TCP port.-type Port = Int---- | A kernel profile, specifying how the kernel communicates.-data Profile = Profile {-  ip :: String,        -- ^ The IP on which to listen.-  transport :: String, -- ^ The transport mechanism.-  stdinPort :: Port,   -- ^ The stdin channel port. -  controlPort :: Port, -- ^ The control channel port.-  hbPort :: Port,      -- ^ The heartbeat channel port.-  shellPort :: Port,   -- ^ The shell command port.-  iopubPort :: Port,   -- ^ The Iopub port.-  key :: ByteString    -- ^ The HMAC encryption key.-  } deriving Show---- Convert the kernel profile to and from JSON.-instance FromJSON Profile where-  parseJSON (Object v) = -    Profile <$> v .: "ip"-            <*> v .: "transport"-            <*> v .: "stdin_port"-            <*> v .: "control_port"-            <*> v .: "hb_port"-            <*> v .: "shell_port"-            <*> v .: "iopub_port"-            <*> v .: "key"-  parseJSON _ = fail "Expecting JSON object."--instance ToJSON Profile where-  toJSON profile = object [-                    "ip"          .= ip profile,-                    "transport"   .= transport profile,-                    "stdin_port"  .= stdinPort profile,-                    "control_port".= controlPort profile,-                    "hb_port"     .= hbPort profile,-                    "shell_port"  .= shellPort profile,-                    "iopub_port"  .= iopubPort profile,-                    "key"         .= key profile-                   ]---- | Initialization information for the kernel.-data InitInfo = InitInfo {-  extensions :: [String],   -- ^ Extensions to enable at start.-  initCells :: [String]     -- ^ Code blocks to run before start.-  }-  deriving (Show, Read)---- | A message header with some metadata.  -data MessageHeader = MessageHeader {-  identifiers :: [ByteString],         -- ^ The identifiers sent with the message.-  parentHeader :: Maybe MessageHeader, -- ^ The parent header, if present.-  metadata :: Metadata,                -- ^ A dict of metadata.-  messageId :: UUID,                   -- ^ A unique message UUID.-  sessionId :: UUID,                   -- ^ A unique session UUID.-  username :: Username,                -- ^ The user who sent this message.-  msgType :: MessageType               -- ^ The message type.-  } deriving Show---- Convert a message header into the JSON field for the header.--- This field does not actually have all the record fields.-instance ToJSON MessageHeader where-  toJSON header = object [-                    "msg_id"  .= messageId header,-                    "session" .= sessionId header,-                    "username" .= username header,-                    "msg_type" .= show (msgType header)-                  ]---- | A username for the source of a message.-type Username = ByteString---- | A metadata dictionary.-type Metadata = Map ByteString ByteString---- | The type of a message, corresponding to IPython message types.-data MessageType = KernelInfoReplyMessage-                 | KernelInfoRequestMessage-                 | ExecuteReplyMessage-                 | ExecuteRequestMessage-                 | StatusMessage-                 | StreamMessage-                 | DisplayDataMessage-                 | OutputMessage-                 | InputMessage-                 | CompleteRequestMessage-                 | CompleteReplyMessage-                 | ObjectInfoRequestMessage-                 | ObjectInfoReplyMessage-                 | ShutdownRequestMessage-                 | ShutdownReplyMessage-                 | ClearOutputMessage--instance Show MessageType where-  show KernelInfoReplyMessage     = "kernel_info_reply"-  show KernelInfoRequestMessage   = "kernel_info_request"-  show ExecuteReplyMessage        = "execute_reply"-  show ExecuteRequestMessage      = "execute_request"-  show StatusMessage              = "status"-  show StreamMessage              = "stream"-  show DisplayDataMessage         = "display_data"-  show OutputMessage              = "pyout"-  show InputMessage               = "pyin"-  show CompleteRequestMessage     = "complete_request"-  show CompleteReplyMessage       = "complete_reply"-  show ObjectInfoRequestMessage   = "object_info_request"-  show ObjectInfoReplyMessage     = "object_info_reply"-  show ShutdownRequestMessage     = "shutdown_request"-  show ShutdownReplyMessage       = "shutdown_reply"-  show ClearOutputMessage         = "clear_output"--instance FromJSON MessageType where-  parseJSON (String s) = case s of-    "kernel_info_reply"   -> return KernelInfoReplyMessage-    "kernel_info_request" -> return KernelInfoRequestMessage-    "execute_reply"       -> return ExecuteReplyMessage-    "execute_request"     -> return ExecuteRequestMessage-    "status"              -> return StatusMessage-    "stream"              -> return StreamMessage-    "display_data"        -> return DisplayDataMessage-    "pyout"               -> return OutputMessage-    "pyin"                -> return InputMessage-    "complete_request"    -> return CompleteRequestMessage-    "complete_reply"      -> return CompleteReplyMessage-    "object_info_request" -> return ObjectInfoRequestMessage-    "object_info_reply"   -> return ObjectInfoReplyMessage-    "shutdown_request"    -> return ShutdownRequestMessage-    "shutdown_reply"      -> return ShutdownReplyMessage-    "clear_output"        -> return ClearOutputMessage--    _                     -> fail ("Unknown message type: " ++ show s)-  parseJSON _ = fail "Must be a string."----- | A message used to communicate with the IPython frontend.-data Message -  -- | A request from a frontend for information about the kernel.-  = KernelInfoRequest { header :: MessageHeader }-  -- | A response to a KernelInfoRequest.-  | KernelInfoReply { header :: MessageHeader }-               -  -- | A request from a frontend to execute some code.-  | ExecuteRequest {-      header :: MessageHeader,-      getCode :: ByteString,             -- ^ The code string.-      getSilent :: Bool,                 -- ^ Whether this should be silently executed.-      getStoreHistory :: Bool,           -- ^ Whether to store this in history.-      getAllowStdin :: Bool,             -- ^ Whether this code can use stdin.--      getUserVariables :: [ByteString],  -- ^ Unused.-      getUserExpressions :: [ByteString] -- ^ Unused.-    }--  -- | A reply to an execute request.-  | ExecuteReply {-      header :: MessageHeader,-      status :: ExecuteReplyStatus,         -- ^ The status of the output.-      executionCounter :: Int               -- ^ The execution count, i.e. which output this is.-    }--  | PublishStatus {-      header :: MessageHeader,-      executionState :: ExecutionState      -- ^ The execution state of the kernel.-    }--  | PublishStream {-      header :: MessageHeader,-      streamType :: StreamType,             -- ^ Which stream to publish to.-      streamContent :: String               -- ^ What to publish.-    }--  | PublishDisplayData {-      header :: MessageHeader,-      source :: String,                     -- ^ The name of the data source.-      displayData :: [DisplayData]          -- ^ A list of data representations.-    }--  | PublishOutput {-      header :: MessageHeader,-      reprText :: String,                   -- ^ Printed output text.-      executionCount :: Int                 -- ^ Which output this is for.-    }--  | PublishInput {-      header :: MessageHeader,-      inCode :: String,                     -- ^ Submitted input code.-      executionCount :: Int                 -- ^ Which input this is.-    }--  | CompleteRequest {-      header :: MessageHeader,-      getCode :: ByteString, {- ^-            The entire block of text where the line is.  This may be useful in the-            case of multiline completions where more context may be needed.  Note: if-            in practice this field proves unnecessary, remove it to lighten the-            messages. json field @block@  -}-      getCodeLine :: ByteString, -- ^ just the line with the cursor. json field @line@-      getCursorPos :: Int -- ^ position of the cursor (index into the line?). json field @cursor_pos@--    }--  | CompleteReply {-     header :: MessageHeader,-     completionMatches :: [ByteString],-     completionMatchedText :: ByteString,-     completionText :: ByteString,-     completionStatus :: Bool-  }--  | ObjectInfoRequest {-      header :: MessageHeader, -      objectName :: ByteString,  -- ^ Name of object being searched for.-      detailLevel :: Int         -- ^ Level of detail desired (defaults to 0).-                                -- 0 is equivalent to foo?, 1 is equivalent-                                -- to foo??.-    }--  | ObjectInfoReply {-      header :: MessageHeader, -      objectName :: ByteString,       -- ^ Name of object which was searched for.-      objectFound :: Bool,            -- ^ Whether the object was found.-      objectTypeString :: ByteString, -- ^ Object type.-      objectDocString  :: ByteString-    }--  | ShutdownRequest {-      header :: MessageHeader,-      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.-    }-  | ShutdownReply {-      header :: MessageHeader,-      restartPending :: Bool    -- ^ Whether this shutdown precedes a restart.-    }--  | ClearOutput {-      header :: MessageHeader,-      wait :: Bool -- ^ Whether to wait to redraw until there is more output.-  }--    deriving Show---- | Possible statuses in the execution reply messages.-data ExecuteReplyStatus = Ok | Err | Abort--instance Show ExecuteReplyStatus where-  show Ok = "ok"-  show Err = "error"-  show Abort = "abort"---- | The execution state of the kernel.-data ExecutionState = Busy | Idle | Starting deriving Show---- | Data for display: a string with associated MIME type.-data DisplayData = Display MimeType String deriving (Show, Typeable, Generic)---- Allow DisplayData serialization-instance Serialize DisplayData-instance Serialize MimeType---- | Possible MIME types for the display data.-data MimeType = PlainText-              | MimeHtml-              | MimePng-              | MimeJpg-              | MimeSvg-              | MimeLatex-              deriving (Eq, Typeable, Generic)---instance Show MimeType where-  show PlainText = "text/plain"-  show MimeHtml  = "text/html"-  show MimePng   = "image/png" -  show MimeJpg   = "image/jpeg"-  show MimeSvg   = "image/svg+xml"-  show MimeLatex = "text/latex"---- | Input and output streams.-data StreamType = Stdin | Stdout deriving Show---- | Get the reply message type for a request message type.-replyType :: MessageType -> MessageType-replyType KernelInfoRequestMessage = KernelInfoReplyMessage-replyType ExecuteRequestMessage = ExecuteReplyMessage-replyType CompleteRequestMessage = CompleteReplyMessage-replyType ObjectInfoRequestMessage = ObjectInfoReplyMessage-replyType ShutdownRequestMessage = ShutdownReplyMessage-replyType messageType = error $ "No reply for message type " ++ show messageType
− IHaskell/ZeroMQ.hs 
@@ -1,187 +0,0 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}--- | Description : Low-level ZeroMQ communication wrapper.------ The "ZeroMQ" module abstracts away the low-level 0MQ based interface with IPython,--- replacing it instead with a Haskell Channel based interface. The `serveProfile` function--- takes a IPython profile specification and returns the channel interface to use.-module IHaskell.ZeroMQ (-  ZeroMQInterface (..),-  serveProfile-  ) where--import ClassyPrelude hiding (stdin)-import Control.Concurrent-import System.ZMQ3 hiding (stdin)-import Data.Aeson (encode)--import qualified Data.ByteString.Lazy as ByteString--import IHaskell.Types-import IHaskell.Message.Parser-import IHaskell.Message.Writer---- | The channel interface to the ZeroMQ sockets. All communication is done via--- Messages, which are encoded and decoded into a lower level form before being--- transmitted to IPython. These channels should functionally serve as--- high-level sockets which speak Messages instead of ByteStrings.-data ZeroMQInterface = Channels {-  shellRequestChannel :: Chan Message,    -- ^ A channel populated with requests from the frontend.-  shellReplyChannel :: Chan Message,      -- ^ Writing to this channel causes a reply to be sent to the frontend.-  controlRequestChannel :: Chan Message,  -- ^ This channel is a duplicate of the shell request channel,-                                         -- ^ though using a different backend socket.-  controlReplyChannel :: Chan Message,    -- ^ This channel is a duplicate of the shell reply channel,-                                         -- ^ though using a different backend socket.-  iopubChannel :: Chan Message           -- ^ Writing to this channel sends an iopub message to the frontend.-  }---- | Start responding on all ZeroMQ channels used to communicate with IPython--- | via the provided profile. Return a set of channels which can be used to--- | communicate with IPython in a more structured manner. -serveProfile :: Profile            -- ^ The profile specifying which ports and transport mechanisms to use.-             -> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets.-serveProfile profile = do-  -- Create all channels which will be used for higher level communication.-  shellReqChan <- newChan-  shellRepChan <- newChan-  controlReqChan <- dupChan shellReqChan-  controlRepChan <- dupChan shellRepChan-  iopubChan <- newChan-  let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan--  -- Create the context in a separate thread that never finishes. If-  -- withContext or withSocket complete, the context or socket become invalid.-  forkIO $ withContext $ \context -> do-    -- Serve on all sockets.-    forkIO $ serveSocket context Rep    (hbPort profile)      $ heartbeat channels-    forkIO $ serveSocket context Router (controlPort profile) $ control   channels-    forkIO $ serveSocket context Router (shellPort profile)   $ shell     channels-    forkIO $ serveSocket context Router (stdinPort profile)   $ stdin     channels--    -- The context is reference counted in this thread only. Thus, the last-    -- serveSocket cannot be asynchronous, because otherwise context would-    -- be garbage collectable - since it would only be used in other-    -- threads. Thus, keep the last serveSocket in this thread.-    serveSocket context Pub    (iopubPort profile)   $ iopub     channels--  return channels---- | Serve on a given socket in a separate thread. Bind the socket in the--- | given context and then loop the provided action, which should listen--- | on the socket and respond to any events.-serveSocket :: SocketType a => Context -> a -> Port -> (Socket a -> IO b) -> IO ()-serveSocket context socketType port action = void $-  withSocket context socketType $ \socket -> do-    bind socket $ unpack $ "tcp://127.0.0.1:" ++ show port-    forever $ action socket---- | Listener on the heartbeat port. Echoes back any data it was sent.-heartbeat :: ZeroMQInterface -> Socket Rep -> IO ()-heartbeat _ socket = do-  -- Read some data.-  request <- receive socket--  -- Send it back.-  send socket [] request---- | Listener on the shell port. Reads messages and writes them to--- | the shell request channel. For each message, reads a response from the--- | shell reply channel of the interface and sends it back to the frontend. -shell :: ZeroMQInterface -> Socket Router -> IO ()-shell channels socket = do-  -- Receive a message and write it to the interface channel.-  receiveMessage socket >>= writeChan requestChannel--  -- Read the reply from the interface channel and send it.-  readChan replyChannel >>= sendMessage socket--  where-    requestChannel = shellRequestChannel channels-    replyChannel = shellReplyChannel channels---- | Listener on the shell port. Reads messages and writes them to--- | the shell request channel. For each message, reads a response from the--- | shell reply channel of the interface and sends it back to the frontend. -control :: ZeroMQInterface -> Socket Router -> IO ()-control channels socket = do-  -- Receive a message and write it to the interface channel.-  receiveMessage socket >>= writeChan requestChannel--  -- Read the reply from the interface channel and send it.-  readChan replyChannel >>= sendMessage socket--  where-    requestChannel = controlRequestChannel channels-    replyChannel =   controlReplyChannel channels---- | Send messages via the iopub channel.--- | This reads messages from the ZeroMQ iopub interface channel --- | and then writes the messages to the socket.-iopub :: ZeroMQInterface -> Socket Pub -> IO ()-iopub channels socket =-  readChan (iopubChannel channels) >>= sendMessage socket--stdin :: ZeroMQInterface -> Socket Router -> IO ()-stdin _ socket = do-  void $ receive socket-  return ()---- | Receive and parse a message from a socket.-receiveMessage :: Receiver a => Socket a -> IO Message-receiveMessage socket = do-  -- Read all identifiers until the identifier/message delimiter.-  idents <- readUntil "<IDS|MSG>"--  -- Ignore the signature for now.-  void next--  headerData <- next-  parentHeader <- next-  metadata <- next-  content <- next--  let message = parseMessage idents headerData parentHeader metadata content-  return message--  where-    -- Receive the next piece of data from the socket.-    next = receive socket--    -- Read data from the socket until we hit an ending string.-    -- Return all data as a list, which does not include the ending string.-    readUntil str = do-      line <- next-      if line /= str-      then do-        remaining <- readUntil str-        return $ line : remaining-      else return []-  --- | Encode a message in the IPython ZeroMQ communication protocol --- | and send it through the provided socket.-sendMessage :: Sender a => Socket a -> Message -> IO ()-sendMessage socket message = do-  let head = header message-      parentHeaderStr = maybe "{}" encodeStrict $ parentHeader head-      idents = identifiers head-      metadata = "{}"-      content = encodeStrict message-      headStr = encodeStrict head--  -- Send all pieces of the message.-  mapM_ sendPiece idents-  sendPiece "<IDS|MSG>"-  sendPiece ""-  sendPiece headStr-  sendPiece parentHeaderStr-  sendPiece metadata--  -- Conclude transmission with content.-  sendLast content--  where-    sendPiece = send socket [SendMore]-    sendLast = send socket []--    -- Encode to a strict bytestring.-    encodeStrict :: ToJSON a => a -> ByteString-    encodeStrict = ByteString.toStrict . encode
− Main.hs 
@@ -1,352 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--- | Description : Argument parsing and basic messaging loop, using Haskell---                 Chans to communicate with the ZeroMQ sockets. -module Main where-import ClassyPrelude hiding (liftIO)-import Prelude (last)-import Control.Concurrent.Chan-import Control.Concurrent (threadDelay)-import Data.Aeson-import Text.Printf-import System.Exit (exitSuccess)-import System.Directory-import System.Console.CmdArgs.Explicit hiding (complete)--import qualified Data.Map as Map--import IHaskell.Types-import IHaskell.ZeroMQ-import qualified IHaskell.Message.UUID as UUID-import IHaskell.Eval.Evaluate-import IHaskell.Eval.Completion (complete)-import IHaskell.Eval.Info-import qualified Data.ByteString.Char8 as Chars-import IHaskell.IPython--import GHC hiding (extensions)-import Outputable (showSDoc, ppr)---- All state stored in the kernel between executions.-data KernelState = KernelState-  { getExecutionCounter :: Int-  }---- Command line arguments to IHaskell.  A set of aruments is annotated with--- the mode being invoked.-data Args = Args IHaskellMode [Argument]--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.-  | Help                -- ^ Display help text.-  deriving (Eq, Show)---- Which mode IHaskell is being invoked in.--- `None` means no mode was specified.-data IHaskellMode-  = None-  | Notebook-  | Console-  | UpdateIPython-  | Kernel (Maybe String)-  deriving (Eq, Show)--main ::  IO ()-main = do-  stringArgs <- map unpack <$> getArgs-  case process ihaskellArgs stringArgs of-    Left errmsg -> putStrLn $ pack errmsg-    Right args ->-      ihaskell args--universalFlags :: [Flag Args]-universalFlags = [-  flagReq ["extension","e", "X"] (store Extension) "<ghc-extension>" "Extension to enable at start.",-  flagReq ["conf","c"] (store ConfFile) "<file.hs>" "File with commands to execute at start.",-  flagHelpSimple (add Help)-  ]-  where -    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.":-  universalFlags--console :: Mode Args-console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags--kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg []-  where-    kernelArg = flagArg update "<json-kernel-file>"-    update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags--update :: Mode Args-update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs []--ihaskellArgs :: Mode Args-ihaskellArgs = (modeEmpty $ Args None []) { modeGroupModes = toGroup [console, notebook, update, kernel] }--noArgs = flagArg unexpected ""-  where-    unexpected a = error $ "Unexpected argument: " ++ a--ihaskell :: Args -> IO ()--- If no mode is specified, print help text.-ihaskell (Args None _) = -  print $ helpText [] HelpFormatAll ihaskellArgs---- Update IPython: remove then reinstall.--- This is in case cabal updates IHaskell but the corresponding IPython--- isn't updated. This is hard to detect since versions of IPython might--- not change!-ihaskell (Args UpdateIPython _) = do-  removeIPython-  installIPython-  putStrLn "IPython updated."-    -ihaskell (Args Console flags) = showingHelp Console flags $ do-  installed <- ipythonInstalled-  unless installed installIPython--  flags <- addDefaultConfFile flags-  info <- initInfo flags-  runConsole info--ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do-  installed <- ipythonInstalled-  unless installed installIPython--  let server = case mapMaybe serveDir flags of-                 [] -> Nothing-                 xs -> Just $ last xs--  flags <- addDefaultConfFile flags-  info <- initInfo flags-  runNotebook info server-  where-    serveDir (ServeFrom dir) = Just dir-    serveDir _ = Nothing--ihaskell (Args (Kernel (Just filename)) _) = do-  initInfo <- readInitInfo-  runKernel filename initInfo---- | 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--showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()-showingHelp mode flags act =-  case find (==Help) flags of-    Just _ ->-      print $ helpText [] HelpFormatAll $ chooseMode mode-    Nothing ->-      act-  where-    chooseMode Console = console-    chooseMode Notebook = notebook-    chooseMode (Kernel _) = kernel-    chooseMode UpdateIPython = update- --- | Parse initialization information from the flags.-initInfo :: [Argument] -> IO InitInfo-initInfo [] = return InitInfo { extensions = [], initCells = []}-initInfo (flag:flags) = do-  info <- initInfo 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 }---- | Run the IHaskell language kernel.-runKernel :: String    -- ^ Filename of profile JSON file.-          -> InitInfo  -- ^ Initialization information from the invocation.-          -> IO ()-runKernel profileSrc initInfo = do-  -- Switch to a temporary directory so that any files we create aren't-  -- visible. On Unix, this is usually /tmp.  If there is no temporary-  -- directory available, just stay in the current one and ignore the-  -- raised exception.-  try (getTemporaryDirectory >>= setCurrentDirectory) :: IO (Either SomeException ())--  -- Parse the profile file.-  Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc--  -- Serve on all sockets and ports defined in the profile.-  interface <- serveProfile profile--  state <- initialKernelState--  -- Receive and reply to all messages on the shell socket.-  interpret $ do-    -- 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 ()       -        zero = 0   -- To please hlint-        evaluator line = evaluate zero line noPublish-    mapM_ evaluator extLines-    mapM_ evaluator $ initCells initInfo--    forever $ do-      -- Read the request from the request channel.-      request <- liftIO $ readChan $ shellRequestChannel interface--      -- Create a header for the reply.-      replyHeader <- createReplyHeader (header request)--      -- 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---- Initial kernel state.-initialKernelState :: IO (MVar KernelState)-initialKernelState =-  newMVar KernelState {-    getExecutionCounter = 1-  }---- | Duplicate a message header, giving it a new UUID and message type.-dupHeader :: MessageHeader -> MessageType -> IO MessageHeader-dupHeader header messageType = do-  uuid <- liftIO UUID.random--  return header { messageId = uuid, msgType = messageType }---- | Create a new message header, given a parent message header.-createReplyHeader :: MessageHeader -> Interpreter MessageHeader-createReplyHeader parent = do-  -- Generate a new message UUID.-  newMessageId <- liftIO UUID.random--  return MessageHeader {-    identifiers = identifiers parent,-    parentHeader = Just parent,-    metadata = Map.fromList [],-    messageId = newMessageId,-    sessionId = sessionId parent,-    username = username parent,-    msgType = replyType $ msgType parent-  }---- | 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).-replyTo _ KernelInfoRequest{} replyHeader state = return (state, KernelInfoReply { header = replyHeader })---- 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 ExecuteRequest{ getCode = code } replyHeader state = do-  let execCount = getExecutionCounter state-      -- Convenience function to send a message to the IOPub socket.-      send msg = liftIO $ writeChan (iopubChannel interface) msg--  -- 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 []-  updateNeeded <- liftIO $ newMVar False-  let clearOutput = do-        header <- dupHeader replyHeader ClearOutputMessage-        send $ ClearOutput header True--      sendOutput outs = do-        header <- dupHeader replyHeader DisplayDataMessage-        send $ PublishDisplayData header "haskell" outs--      publish :: Bool -> [DisplayData] -> IO ()-      publish final outputs = do-        -- If necessary, clear all previous output and redraw.-        clear <- readMVar updateNeeded-        when clear $ do-          clearOutput-          disps <- readMVar displayed-          mapM_ sendOutput $ reverse disps--        -- Draw this message.-        sendOutput outputs--        -- 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 $-          modifyMVar_ displayed (return . (outputs:))--  -- Run code and publish to the frontend as we go.-  evaluate execCount (Chars.unpack code) publish--  -- Notify the frontend that we're done computing.-  idleHeader <- liftIO $ dupHeader replyHeader StatusMessage-  send $ PublishStatus idleHeader Idle--  -- Increment the execution counter in the kernel state.-  let newState = state { getExecutionCounter = execCount + 1 }-  return (newState, ExecuteReply {-    header = replyHeader,-    executionCounter = execCount,-    status = Ok-  })---replyTo _ req@CompleteRequest{} replyHeader state = do-    (matchedText, completions) <- complete (Chars.unpack $ getCodeLine req) (getCursorPos req)--    let reply =  CompleteReply replyHeader (map Chars.pack completions) (Chars.pack matchedText) (getCodeLine req) 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-         docs <- info $ Chars.unpack oname-         let reply = ObjectInfoReply {-                        header = replyHeader,-                        objectName = oname, -                        objectFound = docs == "",-                        objectTypeString = Chars.pack docs,-                        objectDocString  = Chars.pack docs                    -                      }-         return (state, reply)---
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.2.0.5+version:             0.3.0.0  -- A short (one-line) description of the package. synopsis:            A Haskell backend kernel for the IPython project.@@ -40,130 +40,171 @@ build-type:          Simple  -- Constraint on the version of Cabal needed to build this package.-cabal-version:       >=1.8+cabal-version:       >=1.16  data-files:    profile/profile.tar  library-  build-depends:       base ==4.6.*,-                       cmdargs >= 0.10,-                       tar,-                       ghc-parser,-                       unix >= 2.6,-                       hspec,-                       zeromq3-haskell >=0.5,-                       aeson >=0.6,-                       MissingH >=1.2,-                       classy-prelude >=0.6,-                       bytestring >=0.10,-                       uuid >=1.2.6,-                       containers >=0.5,-                       ghc ==7.6.*,-                       ghc-paths ==0.1.*,-                       random >=1.0,-                       split >= 0.2,-                       utf8-string,-                       strict >=0.3,-                       shelly >=1.3,-                       system-argv0,-                       directory,-                       here,-                       system-filepath,-                       cereal ==0.3.*,-                       text >=0.11,-                       mtl >= 2.1,-                       template-haskell-  exposed-modules: IHaskell.Display,-                   Paths_ihaskell,-                   IHaskell.Types,-                   IHaskell.Message.UUID+  hs-source-dirs:      src+  default-language:    Haskell2010+  build-depends:       +                       base                 ==4.6.*,+                       aeson                >=0.6,+                       base64-bytestring    >=1.0,+                       bytestring           >=0.10,+                       cereal               ==0.3.*,+                       classy-prelude       >=0.7,+                       cmdargs              >=0.10,+                       containers           >=0.5,+                       directory            -any,+                       filepath             -any,+                       ghc                  ==7.6.*,+                       ghc-parser           -any,+                       ghc-paths            ==0.1.*,+                       haskeline            -any,+                       here                 -any,+                       hlint                -any,+                       hspec                -any,+                       HTTP                 -any,+                       HUnit                -any,+                       ipython-kernel       -any,+                       MissingH             >=1.2,+                       mtl                  >=2.1,+                       parsec               -any,+                       process              >=1.1,+                       random               >=1.0,+                       shelly               >=1.3,+                       split                >= 0.2,+                       strict               >=0.3,+                       system-argv0         -any,+                       system-filepath      -any,+                       tar                  -any,+                       transformers         -any,+                       unix                 >= 2.6,+                       utf8-string          -any +  exposed-modules: IHaskell.Display+                   IHaskell.Eval.Completion+                   IHaskell.Eval.Evaluate+                   IHaskell.Eval.Info+                   IHaskell.Eval.Lint+                   IHaskell.Eval.Parser+                   IHaskell.Eval.Hoogle+                   IHaskell.Eval.ParseShell+                   IHaskell.Eval.Util+                   IHaskell.IPython+                   IHaskell.Flags+                   IHaskell.Types+                   Paths_ihaskell+ executable IHaskell   -- .hs or .lhs file containing the Main module.+  hs-source-dirs:      src   main-is:             Main.hs    build-tools:         happy, cpphs      -- Modules included in this executable, other than Main.   other-modules:       +             IHaskell.Eval.Lint              IHaskell.Eval.Completion              IHaskell.Eval.Info              IHaskell.Eval.Evaluate              IHaskell.Eval.Parser+             IHaskell.Eval.Hoogle+             IHaskell.Eval.ParseShell+             IHaskell.Eval.Util              IHaskell.IPython-             IHaskell.Message.Parser-             IHaskell.Message.UUID-             IHaskell.Message.Writer+             IHaskell.Flags              IHaskell.Types-             IHaskell.ZeroMQ              IHaskell.Display-             IHaskell.Config -  extensions: DoAndIfThenElse+  default-extensions: DoAndIfThenElse      -- Other library packages from which modules are imported.-  build-depends:       base ==4.6.*,-                       cmdargs >= 0.10,-                       tar,-                       ghc-parser,-                       unix >= 2.6,-                       hspec,-                       zeromq3-haskell >=0.5,-                       aeson >=0.6,-                       MissingH >=1.2,-                       classy-prelude >=0.6,-                       bytestring >=0.10,-                       uuid >=1.2.6,-                       containers >=0.5,-                       ghc ==7.6.*,-                       ghc-paths ==0.1.*,-                       random >=1.0,-                       split >= 0.2,-                       utf8-string,-                       strict >=0.3,-                       shelly >=1.3,-                       system-argv0,-                       directory,-                       here,-                       system-filepath,-                       cereal ==0.3.*,-                       text >=0.11,-                       mtl >= 2.1,-                       template-haskell+  default-language:    Haskell2010+  build-depends:       +                       base                 ==4.6.*,+                       aeson                >=0.6,+                       base64-bytestring    >=1.0,+                       bytestring           >=0.10,+                       cereal               ==0.3.*,+                       classy-prelude       >=0.7,+                       cmdargs              >=0.10,+                       containers           >=0.5,+                       directory            -any,+                       filepath             -any,+                       ghc                  ==7.6.*,+                       ghc-parser           -any,+                       ghc-paths            ==0.1.*,+                       haskeline            -any,+                       here                 -any,+                       hlint                -any,+                       hspec                -any,+                       HTTP                 -any,+                       HUnit                -any,+                       ipython-kernel       -any,+                       MissingH             >=1.2,+                       mtl                  >=2.1,+                       parsec               -any,+                       process              >=1.1,+                       random               >=1.0,+                       shelly               >=1.3,+                       split                >= 0.2,+                       strict               >=0.3,+                       system-argv0         -any,+                       system-filepath      -any,+                       tar                  -any,+                       transformers         -any,+                       unix                 >= 2.6,+                       utf8-string          -any  Test-Suite hspec+  hs-source-dirs:      src   Type:     exitcode-stdio-1.0   Ghc-Options: -threaded   Main-Is: Hspec.hs-  build-depends:       base ==4.6.*,-                       cmdargs >= 0.10,-                       tar,-                       ghc-parser,-                       unix >= 2.6,-                       hspec,-                       zeromq3-haskell >=0.5,-                       aeson >=0.6,-                       MissingH >=1.2,-                       classy-prelude >=0.6,-                       bytestring >=0.10,-                       uuid >=1.2.6,-                       containers >=0.5,-                       ghc ==7.6.*,-                       ghc-paths ==0.1.*,-                       random >=1.0,-                       split >= 0.2,-                       utf8-string,-                       strict >=0.3,-                       shelly >=1.3,-                       system-argv0,-                       directory,-                       here,-                       system-filepath,-                       cereal ==0.3.*,-                       text >=0.11,-                       mtl >= 2.1,-                       template-haskell+  default-language:    Haskell2010+  build-depends:       +                       base                 ==4.6.*,+                       aeson                >=0.6,+                       base64-bytestring    >=1.0,+                       bytestring           >=0.10,+                       cereal               ==0.3.*,+                       classy-prelude       >=0.7,+                       cmdargs              >=0.10,+                       containers           >=0.5,+                       directory            -any,+                       filepath             -any,+                       ghc                  ==7.6.*,+                       ghc-parser           -any,+                       ghc-paths            ==0.1.*,+                       haskeline            -any,+                       here                 -any,+                       hlint                -any,+                       hspec                -any,+                       HTTP                 -any,+                       HUnit                -any,+                       ipython-kernel       -any,+                       MissingH             >=1.2,+                       mtl                  >=2.1,+                       parsec               -any,+                       process              >=1.1,+                       random               >=1.0,+                       shelly               >=1.3,+                       split                >= 0.2,+                       strict               >=0.3,+                       system-argv0         -any,+                       system-filepath      -any,+                       tar                  -any,+                       transformers         -any,+                       unix                 >= 2.6,+                       utf8-string          -any++  extensions: DoAndIfThenElse+              OverloadedStrings+              ExtendedDefaultRules  source-repository head   type:     git
profile/profile.tar view

binary file changed (83968 → 96768 bytes)

+ src/Hspec.hs view
@@ -0,0 +1,570 @@+{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules #-}+-- 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 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)++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 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) $ \(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  =  do+      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 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 noPublish = const $ return ()+            cdEvent 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 xs = map encodeString xs+         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 " $ do +      ":! cd *" `shouldHaveCompletionsInDirectory` (map encodeString ["" </> "dir/"+                                                                      , "" </> "file1.hs"+                                                                      , "" </> "file1.lhs"])+++    it "correctly interprets ~ as the environment HOME variable" $ +        let shouldHaveCompletions :: String -> [String] -> IO ()+            shouldHaveCompletions string expected = do +              (matched, completions) +                    <- withHsDirectory $ \dirPath -> +                           do setHomeEvent dirPath+                              completionEvent string +              let existsInCompletion = (`elem` completions)+                  unmatched = filter (not . existsInCompletion) expected     +              expected `shouldBeAmong` completions++            setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)+        in do +          ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"]+          ":! ~/*" `shouldHaveCompletions` ["~/dir/"]+          ":load ~/*" `shouldHaveCompletions` ["~/dir/"]+          ":l ~/*" `shouldHaveCompletions` ["~/dir/"]++    let shouldHaveMatchingText :: String -> String -> IO ()+        shouldHaveMatchingText string expected = do +          matchText +                <- withHsDirectory $ \dirPath -> +                       do setHomeEvent dirPath+                          (matchText, _) <- uncurry complete (readCompletePrompt string)+                          return matchText+          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` ["forall a. Num a => a"]+      ":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 SetOpt "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` [+      ParseError (Loc 1 10) "Illegal literal in type (use -XDataKinds to enable): 3"+    ]++  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/Display.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}+module IHaskell.Display (+  IHaskellDisplay(..),+  plain, html, png, jpg, svg, latex,+  serializeDisplay,+  Width, Height, Base64,+  encode64, base64,+  Display(..),+  DisplayData(..),+  ) where++import ClassyPrelude+import Data.Serialize as Serialize+import Data.ByteString hiding (map)+import Data.String.Utils (rstrip) +import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as Char++import IHaskell.Types++type Base64 = ByteString++-- | A class for displayable Haskell types.+--+-- 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+class IHaskellDisplay a where+  display :: a -> IO Display++-- | these instances cause the image, html etc. which look like:+--+-- > Display+-- > [Display]+-- > IO [Display]+-- > IO (IO Display)+--+-- 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 =<<)++instance IHaskellDisplay Display where+  display = return++instance IHaskellDisplay DisplayData where+  display disp = return $ Display [disp]++instance IHaskellDisplay a => IHaskellDisplay [a] where+  display disps = do+    displays <- mapM display disps+    return $ ManyDisplay displays++-- | Encode many displays into a single one. All will be output.+many :: [Display] -> Display+many = ManyDisplay++-- | Generate a plain text display.+plain :: String -> DisplayData+plain = DisplayData PlainText . Char.pack . rstrip++-- | Generate an HTML display.+html :: String -> DisplayData+html = DisplayData MimeHtml . Char.pack++-- | Genreate an SVG display.+svg :: String -> DisplayData+svg = DisplayData MimeSvg . Char.pack++-- | Genreate a LaTeX display.+latex :: String -> DisplayData+latex = DisplayData MimeLatex . Char.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.+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.+jpg :: Width -> Height -> Base64 -> DisplayData+jpg width height = DisplayData (MimeJpg width height)++-- | Convert from a string into base 64 encoded data.+encode64 :: String -> Base64+encode64 str = base64 $ Char.pack str++-- | Convert from a ByteString into base 64 encoded data.+base64 :: ByteString -> Base64+base64 = Base64.encode++-- | For internal use within IHaskell.+-- Serialize displays to a ByteString.+serializeDisplay :: Display -> ByteString+serializeDisplay = Serialize.encode
+ src/IHaskell/Eval/Completion.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}+{- |+Description : Generates tab completion options.++This has a limited amount of context sensitivity. It distinguishes between four contexts at the moment:+- import statements (completed using modules)+- identifiers (completed using in scope values)+- extensions via :ext (completed using GHC extensions)+- qualified identifiers (completed using in-scope values)++-}+module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where++import ClassyPrelude hiding (liftIO)+--import Prelude++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+import Data.String.Utils (strip, startswith, endswith, replace)+import qualified Data.String.Utils as StringUtils+import System.Environment (getEnv)++import GHC+import DynFlags+import GhcMonad+import PackageConfig+import Outputable (showPpr)+++import System.Directory+import System.FilePath+import MonadUtils (MonadIO)++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+     deriving (Show, Eq)++complete :: String -> Int -> Interpreter (String, [String])+complete line pos = do+  flags <- getSessionDynFlags+  rdrNames <- map (showPpr flags) <$> getRdrNamesInScope+  scopeNames <- nub <$> map (showPpr flags) <$> getNamesInScope+  let isQualified = ('.' `elem`)+      unqualNames = nub $ filter (not . isQualified) rdrNames+      qualNames = nub $ scopeNames ++ filter isQualified rdrNames++  let Just db = pkgDatabase flags+      getNames = map moduleNameString . exposedModules+      moduleNames = nub $ concatMap getNames db++  let target = completionTarget line pos++  let matchedText = case completionType line pos target of +        HsFilePath _ match ->  match+        FilePath   _ match ->  match+        otherwise       -> intercalate "." target++  options <-+        case completionType line pos target of+          Empty -> return []++          Identifier candidate ->+            return $ filter (candidate `isPrefixOf`) unqualNames++          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++          ModuleName previous candidate -> do+            let prefix = if null previous+                         then candidate+                         else intercalate "." [previous, candidate]+            return $ filter (prefix `isPrefixOf`) moduleNames++          DynFlag ext -> do+            let extName (name, _, _) = name+                otherNames = ["-package","-Wall","-w"] +++                            concatMap getSetName kernelOpts+                fNames = map ("-f"++) (names ++ nonames)+                    where+                    -- possibly leave out the fLangFlags? The+                    -- -XUndecidableInstances vs. obsolete+                    -- -fallow-undecidable-instances+                    names = map extName fFlags ++ +                            map extName fWarningFlags ++ +                            map extName fLangFlags+                    nonames = map ("no"++) names++                xNames = map ("-X"++) (names ++ nonames)+                    where+                    names = map extName xFlags+                    nonames = map ("No" ++) names+            return $ filter (ext `isPrefixOf`) $ fNames ++ xNames ++ otherNames++          HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor++          FilePath   lineUpToCursor match  -> completePath lineUpToCursor++          KernelOption str -> return $+                    filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts)++  return (matchedText, options)++getTrueModuleName :: String -> Interpreter String+getTrueModuleName name = do+  -- Only use the things that were actually imported+  let onlyImportDecl (IIDecl decl) = Just decl+      onlyImportDecl _ = Nothing++  -- Get all imports that we use.+  imports <- 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.+  flags <- getSessionDynFlags+  let qualifiedImports = filter (isJust . ideclAs) imports+      hasName imp = name == (showPpr flags . fromJust . ideclAs) imp+  case find hasName qualifiedImports of+    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.+               -> [String]          -- ^ The identifier being completed (pieces separated by dots).+               -> CompletionType+completionType line loc target+  -- File and directory completions are special+  | startswith ":!" stripped+    = case parseShell lineUpToCursor of +          Right xs -> FilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []+          Left  _  -> Empty+  | startswith ":l" stripped+    = case parseShell lineUpToCursor of +          Right xs -> HsFilePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then (last xs) else []+          Left  _  -> Empty+  | startswith ":s" stripped+    = DynFlag candidate+  | startswith ":o" stripped+    = KernelOption candidate+  -- Use target for other completions.+  -- If it's empty, no completion.+  | null target+    = Empty+  | startswith "import" stripped && isModName+    = ModuleName dotted candidate+  | isModName && (not . null . init) target+    = Qualified dotted candidate+  | 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+++-- | 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],+      -- Condense multiple delimiters into one and then drop them.+      condensePolicy = Condense,+      delimPolicy = Drop+    }++    isDelim :: Char -> Int -> Bool +    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++    -- These are never part of an identifier.+    neverIdent :: String+    neverIdent = " \n\t(),{}[]\\'\"`"++    expandCompletionPiece Nothing = []+    expandCompletionPiece (Just str) = splitOn "." str++getHome :: IO String+getHome = do+  homeEither <- try  $ getEnv "HOME" :: IO (Either SomeException String)+  return $ case homeEither of+    Left _ -> "~"+    Right home -> home++dirExpand :: String -> IO String+dirExpand str = do+  home <- getHome+  return $ replace "~" home str++unDirExpand :: String -> IO String+unDirExpand str = do+  home <- getHome+  return $ replace home "~" str++completePath :: String -> Interpreter [String]+completePath line = completePathFilter acceptAll acceptAll line ""+  where acceptAll = const True++completePathWithExtensions :: [String] -> String -> Interpreter [String]+completePathWithExtensions extensions line =+  completePathFilter (extensionIsOneOf extensions) acceptAll line ""+  where+    acceptAll = const True+    extensionIsOneOf exts str = any correctEnding exts+      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.+                   -> String               -- ^ Line contents to the left of the cursor.+                   -> String               -- ^ Line contents to the right of the cursor.+                   -> Interpreter [String]+completePathFilter includeFile includeDirectory left right = liftIO $ do+  -- Get the completions from Haskeline.  It has a bit of a strange API.+  expanded <- dirExpand left+  completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)++  -- 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++  -- 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+      visible = filter (not . isHidden) suggestions+      hidden  = filter isHidden suggestions+  return $ visible ++ hidden+
+ src/IHaskell/Eval/Evaluate.hs view
@@ -0,0 +1,1078 @@+{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, PatternGuards  #-}++{- | 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 (liftIO, hGetContents, 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 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 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 GHC.Paths+import Exception hiding (evaluate)+import Outputable+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 Paths_ihaskell (version)+import Data.Version (versionBranch)++data ErrorOccurred = Success | Failure deriving (Show, Eq, Ord)++debug :: Bool+debug = False++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++instance MonadIO.MonadIO Interpreter where+    liftIO = MonadUtils.liftIO++globalImports :: [String]+globalImports =+  [ "import IHaskell.Display"+  , "import qualified IPython.Stdin"+  , "import Control.Applicative ((<$>))"+  , "import GHC.IO.Handle (hDuplicateTo, hDuplicate, hClose)"+  , "import System.Posix.IO"+  , "import System.Posix.Files"+  , "import System.IO"+  ]++++-- | 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 :: Bool -> Interpreter a -> IO a+interpret allowedStdin action = runGhc (Just libdir) $ do+  -- Set the dynamic session flags+  originalFlags <- getSessionDynFlags+  let dflags = xopt_set originalFlags Opt_ExtendedDefaultRules++  -- If we're in a sandbox, add the relevant package database+  sandboxPackages <- liftIO getSandboxPackageConf+  let pkgConfs = case sandboxPackages of+        Nothing -> extraPkgConfs dflags+        Just path -> +          let pkg  = PkgConfFile path in+            (pkg:) . extraPkgConfs dflags++  void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,+                                       ghcLink = LinkInMemory,+                                       pprCols = 300,+                                       extraPkgConfs = pkgConfs }++  initializeImports++  -- Close stdin so it can't be used.+  -- Otherwise it'll block the kernel forever.+  dir <- liftIO getIHaskellDir+  let cmd = printf "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+  dflags <- getSessionDynFlags+  displayPackages <- liftIO $ do+    (dflags, _) <- initPackages dflags+    let Just db = pkgDatabase dflags+        packageNames = map (packageIdString . packageConfigId) db++        initStr = "ihaskell-"+        -- "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],+                    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+  }++-- | 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++      -- Output things only if they are non-empty.+      let result = evalResult evalOut+          helpStr = evalPager evalOut+      unless (noResults result && null helpStr) $+        liftIO $ output $ FinalResult result helpStr++      let newState = evalState evalOut+      case evalStatus evalOut of+        Success -> runUntilFailure newState rest+        Failure -> return newState++    storeItCommand execCount = Statement $ printf "let it%d = it" execCount++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 = ""+      }++    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 = ""+      }+      +doc :: GhcMonad m => SDoc -> m String+doc sdoc = do+  flags <- getSessionDynFlags+  unqual <- getPrintUnqual+  let style = mkUserStyle unqual AllTheWay+  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.PStr s1) s2 = unpackFS s1 ++ s2+    string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2+    ++wrapExecution :: KernelState+              -> Interpreter Display+              -> Interpreter EvalOut+wrapExecution state exec = safely state $ exec >>= \res ->+    return EvalOut {+      evalStatus = Success,+      evalResult = res,+      evalState = state,+      evalPager = ""+    }++-- | Set dynamic flags.+--+-- adapted from GHC's InteractiveUI.hs (newDynFlags)+setDynFlags :: [String] -> Interpreter [ErrMsg]+setDynFlags ext = do+    flags <- getSessionDynFlags+    (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)+    let restorePkg x = x { packageFlags = packageFlags flags }+    -- First, try to check if this flag matches any extension name.+    new_pkgs <- GHC.setProgramDynFlags (restorePkg flags')+    GHC.setInteractiveDynFlags (restorePkg flags')+    return $ map (("Could not parse: " ++) . unLoc) unrecognized +++             map ("Warning: " ++)+                  (map unLoc warnings +++                    [ "-package not supported yet"+                        | packageFlags flags /= packageFlags flags' ])++-- | 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+  importDecl <- parseImportDecl importStr+  context <- getContext++  -- If we've imported this implicitly, remove the old import.+  let noImplicit = filter (not . implicitImportOf importDecl) context+  setContext $ IIDecl importDecl : noImplicit++  flags <- getSessionDynFlags+  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+  where+    implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool+    implicitImportOf _ (IIModule _) = False+    implicitImportOf imp (IIDecl decl) = ideclImplicit decl && ((==) `on` (unLoc . ideclName)) decl imp++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++evalCommand a (Directive SetDynFlag flags) state+    | let f o = case filter (elem o . getSetName) kernelOpts of+                [] -> Right o+                [z] | s:_ <- getOptionName z -> Left s+                    | otherwise -> error ("evalCommand Directive SetDynFlag impossible")+                ds -> error ("kernelOpts has duplicate:"++ show (map getSetName ds)),+      (optionFlags,oo) <- partitionEithers $ map f (words flags),+      not (null optionFlags) = do+          eo1 <- evalCommand a (Directive SetOption (unwords optionFlags)) state+          eo2 <- evalCommand a (Directive SetDynFlag (unwords oo)) (evalState eo1)+          return $ EvalOut {+                evalStatus = max (evalStatus eo1) (evalStatus eo2),+                evalResult = evalResult eo1 ++ evalResult eo2,+                evalState = evalState eo2,+                evalPager = evalPager eo1 ++ evalPager eo2+          }+        +evalCommand _ (Directive SetDynFlag flags) state = wrapExecution state $ do+  write $ "DynFlag: " ++ flags+  errs <- setDynFlags (words flags)+  return $ case errs of+      [] -> mempty+      _ -> displayError $ intercalate "\n" errs++evalCommand a (Directive SetExtension opts) state = do+  write $ "Extension: " ++ opts+  evalCommand a (Directive SetDynFlag (concatMap (" -X"++) (words opts))) state++evalCommand a (Directive SetOption opts) state = do+  write $ "Option: " ++ opts+  let (lost, found) = partitionEithers+        [ case filter (any (w==) . getOptionName) kernelOpts of+                [x] -> Right (getUpdateKernelState x)+                [] -> Left w+                ds -> error ("kernelOpts has duplicate:" ++ show (map getOptionName ds))+          | w <- words opts ]+      warn+        | null lost = mempty+        | otherwise = displayError ("Could not recognize options: " ++ intercalate "," lost)+  return EvalOut {+    evalStatus = if null lost then Success else Failure,+    evalResult = warn,+    evalState = foldl' (flip ($)) state found,+    evalPager = ""+  }++evalCommand _ (Directive GetType expr) state = wrapExecution state $ do+  write $ "Type: " ++ expr+  result <- exprType expr+  flags <- getSessionDynFlags+  let typeStr = showSDocUnqual flags $ ppr result+  return $ formatType typeStr++evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do+  write $ "Load: " ++ name++  let filename = if endswith ".hs" name+                 then name+                 else name ++ ".hs"+  let modName =  replace "/" "."  $+                   if endswith ".hs" name+                   then replace ".hs" "" name+                   else name++  doLoadModule filename modName++evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $+  case words cmd of+    "cd":dirs -> do+      -- Get home so we can replace '~` with it.+      homeEither <- try  $ getEnv "HOME" :: IO (Either SomeException String)+      let home = case homeEither of+                  Left _ -> "~"+                  Right val -> val++      let directory = replace "~" home $ unwords dirs+      exists <- doesDirectoryExist directory+      if exists+      then do+        setCurrentDirectory directory+        return $ mempty+      else+        return $ displayError $ printf "No such directory: '%s'" directory+    cmd -> 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 = ""+  }+  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.+  names     <- parseName str+  maybeInfos <- mapM getInfo names++  -- Filter out types that have parents in the same set.+  -- GHCi also does this.+  let getType (theType, _, _) = theType+      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+      filteredOutput = filter (not . hasParent) infos++  -- Convert to textual data.+  let printInfo (thing, fixity, classInstances) =+        pprTyThingInContextLoc False thing $$ showFixity fixity $$ vcat (map GHC.pprInstance classInstances)+        where+          showFixity fixity =+            if fixity == GHC.defaultFixity+            then empty+            else ppr fixity <+> pprInfixName (getName thing)++  -- Print nicely.+  strings <- mapM (doc . printInfo) filteredOutput+  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+  }++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++  if canRunDisplay+  then useDisplay displayExpr+  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 disps) = Display $ filter (not . isSvg) disps+    removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps++    useDisplay displayExpr = wrapExecution state $ do+      -- If there are instance matches, convert the object into+      -- a Display. We also serialize it into a bytestring. We get+      -- the bytestring 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.+      out <- capturedStatement (const $ return ()) displayExpr++      displayedBytestring <- dynCompileExpr "IHaskell.Display.serializeDisplay it"+      case fromDynamic displayedBytestring of+        Nothing -> error "Expecting lazy Bytestring"+        Just bytestring ->+          case Serialize.decode bytestring of+            Left err -> error err+            Right display -> do+              return $+                if useSvg state+                then display+                else removeSvg display++    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+  names <- runDecls decl++  dflags <- getSessionDynFlags+  let boundNames = map (replace ":Interactive." "" . showPpr dflags) names+      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.+    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 = ""+  }+++hoogleResults :: KernelState -> [Hoogle.HoogleResult] -> EvalOut+hoogleResults state results = EvalOut {+    evalStatus = Success,+    evalResult = mempty,+    evalState = state,+    evalPager = output+  }+  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 = flip gcatch unload $ do+  -- Compile loaded modules.+  flags <- getSessionDynFlags+  let objTarget = defaultObjectTarget+  setSessionDynFlags flags{ hscTarget = objTarget }++  -- Remember which modules we've loaded before.+  importedModules <- getContext++  -- Create a 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 :: SomeException -> Ghc Display+    unload exception = do+      -- Explicitly clear targets+      setTargets []+      load LoadAllTargets++      initializeItVariable+      return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception++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 ++ " >> return ()"++    -- Statements run before the thing we're evaluating.+    initStmts =+      [ printf "let %s = it" itVariable+      , printf "(%s, %s) <- createPipe" readVariable writeVariable+      , printf "%s <- dup stdOutput" oldVariable+      , voidpf "dupTo %s stdOutput" writeVariable+      , voidpf "hSetBuffering stdout NoBuffering"+      , printf "let it = %s" itVariable+      ]++    -- Statements run after evaluation.+    postStmts =+      [ printf "let %s = it" itVariable+      , voidpf "hFlush stdout"+      , voidpf "dupTo %s stdOutput" oldVariable+      , voidpf "closeFd %s" writeVariable+      , printf "let it = %s" itVariable+      ]+    pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable++    goStmt s = runStmt s RunToCompletion++  -- Initialize evaluation context.+  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.+    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/>" .+    fixStdinError .+    replace useDashV "" .+    rstrip .+    typeCleaner+  where+    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 . fixStdinError . typeCleaner $ msg, html $ formatError msg]++fixStdinError :: ErrMsg -> ErrMsg+fixStdinError err =+  if isStdinErr err+  then "<stdin> is not available in IHaskell. Use special `inputLine` instead of `getLine`."+  else err+  where+    isStdinErr err = startswith "<stdin>" err+      && "illegal operation (handle is closed)" `isInfixOf` err++mono :: String -> String+mono = printf "<span class='mono'>%s</span>"
+ src/IHaskell/Eval/Hoogle.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}+module IHaskell.Eval.Hoogle ( +  search,+  document,+  render,+  OutputFormat(..),+  HoogleResult+  ) where++import ClassyPrelude hiding (span, div)+import Text.Printf+import Network.HTTP+import Data.Aeson+import Data.String.Utils+import Data.List (elemIndex, (!!), last)+import Control.Monad (guard)+import qualified Data.ByteString.Lazy.Char8 as Char+++import IHaskell.IPython++-- | Types of formats to render output to.+data OutputFormat+     = Plain      -- ^ Render to plain text.+     | HTML       -- ^ Render to HTML.++data HoogleResponse = HoogleResponse {+    location :: String,+    self :: String,+    docs :: String+  }+  deriving (Eq, Show)++data HoogleResult+     = SearchResult HoogleResponse+     | DocResult HoogleResponse+     | NoResult String+     deriving Show++instance FromJSON [HoogleResponse] where+  parseJSON (Object obj) = do+    results <- obj .: "results"+    mapM parseJSON results++  parseJSON _ = fail "Expected object with 'results' field."++instance FromJSON HoogleResponse where+  parseJSON (Object obj) =+    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 :: String -> IO (Either String String)+query str = do+  let request = getRequest $ queryUrl str+  response <- simpleHTTP request+  return $ case response of+    Left err -> Left $ show err+    Right resp -> Right $ rspBody resp+  where+    queryUrl :: String -> String+    queryUrl = printf "http://www.haskell.org/hoogle/?hoogle=%s&mode=json" . urlEncode++-- | 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++-- | 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+  where+    matches (SearchResult resp) = +      case split " " $ self resp of+        name:_ -> strip string == strip name+        _ -> False+    matches _ = False++    toDocResult (SearchResult resp) = DocResult resp++-- | Render a Hoogle search result into an output format.+render :: OutputFormat -> HoogleResult -> String+render Plain = renderPlain+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)++renderPlain (DocResult resp) = +  printf "%s\nURL: %s\n%s" +  (self resp)+  (location resp)+  (docs resp)++-- | Render a Hoogle result to HTML.+renderHtml :: HoogleResult -> String+renderHtml (NoResult resp) = +  printf "<span class='err-msg'>No result: %s</span>" resp++renderHtml (DocResult resp) = +  renderSelf (self resp) (location resp) +  +++  renderDocs (docs resp)++renderHtml (SearchResult resp) =+  renderSelf (self resp) (location resp) +  +++  renderDocs (docs resp)++renderSelf :: String -> String -> String+renderSelf string loc+  | 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++  | 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++  where +    extractPackage = strip . replace "package" ""+    extractModule = strip . replace "module" ""+    pkg = span "hoogle-head" "package"+    mod = span "hoogle-head" "module"++    unicodeReplace :: String -> String+    unicodeReplace =+     replace "forall" "&#x2200;" . +     replace "=>"     "&#x21D2;" . +     replace "->"     "&#x2192;" . +     replace "::"     "&#x2237;"++    packageSub Nothing = ""+    packageSub (Just package) =+      span "hoogle-sub" $ +        "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ ")"++    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 ++ ")"++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)+      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++extractPackageName :: String ->  Maybe String+extractPackageName link = do+  let pieces = split "/" link+  archiveLoc <- elemIndex "archive" pieces+  latestLoc <- elemIndex "latest" pieces+  guard $ latestLoc - archiveLoc == 2+  return $ pieces !! (latestLoc - 1)++extractModuleName :: String ->  Maybe String+extractModuleName link = do+  let pieces = split "/" link+  guard $ not $ null pieces+  let html = last pieces+      mod = replace "-" "." $ takeWhile (/= '.') html+  return mod++div :: String -> String -> String+div = printf "<div class='%s'>%s</div>"++span :: String -> String -> String+span = printf "<span class='%s'>%s</span>"++link :: String -> String -> String+link = printf "<a target='_blank' href='%s'>%s</a>"
+ src/IHaskell/Eval/Info.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{- | Description : Inspect type and function information and documentation.+-}+module IHaskell.Eval.Info (+  info+  ) where++import ClassyPrelude hiding (liftIO)++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 +    handler :: SomeException -> Interpreter String+    handler _ = return ""
+ src/IHaskell/Eval/Lint.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}+module IHaskell.Eval.Lint ( +  lint+  ) where++import Data.String.Utils (replace, startswith, strip, split)+import Prelude (head, tail)+import Language.Haskell.HLint as HLint+import ClassyPrelude+import Control.Monad+import Data.List (findIndex)+import Text.Printf+import Data.String.Here+import Data.Char+import Data.Monoid++import IHaskell.Types+import IHaskell.Display+import IHaskell.IPython+import IHaskell.Eval.Parser++data LintSeverity = LintWarning | LintError deriving (Eq, Show)++data LintSuggestion+  = Suggest {+    line :: LineNumber,+    chunkNumber :: Int,+    found :: String,+    whyNot :: String,+    severity :: LintSeverity,+    suggestion :: String+  }+  deriving (Eq, Show)++-- | Identifier used when one is needed for proper context.+lintIdent :: String+lintIdent = "lintIdentAEjlkQeh"++-- | Given parsed code chunks, perform linting and output a displayable+-- report on linting warnings and errors.+lint :: [Located CodeBlock] -> IO Display+lint blocks = do+  let validBlocks = map makeValid blocks+      fileContents = joinBlocks validBlocks+  -- Get a temporarly location to store this file.+  ihaskellDir <- getIHaskellDir+  let filename = ihaskellDir ++ "/.hlintFile.hs"++  writeFile (fromString filename) fileContents+  suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"]+  return $+    if null suggestions+    then Display []+    else Display+      [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]+  where+    -- Join together multiple valid file blocks into a single file.+    -- However, join them with padding so that the line numbers are+    -- correct.+    joinBlocks :: [Located String] -> String+    joinBlocks = unlines . zipWith addPragma [1 .. ]++    addPragma :: Int -> Located String -> String+    addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str++    linePragma = printf "{-# LINE %d \"%d\" #-}\n"++plainSuggestion :: LintSuggestion -> String+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 +  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)+      ]++      where+        severityClass = case severity suggest of+          LintWarning -> "warning"+          LintError -> "error"++    style :: String -> String -> String+    style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |]++    named :: String -> String+    named thing = [i| <div class="suggestion-name" style="clear:both;">${thing}</div> |]++    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> |]++-- | Parse a suggestion from Hlint. The suggestions look like this:+--   .ihaskell/.hlintFile.hs:1:19: Warning: Redundant bracket+--   Found:+--     ((3))+--   Why not:+--     (3)+-- We extract all the necessary fields and store them.+-- If parsing fails, return Nothing.+parseSuggestion :: Suggestion -> Maybe LintSuggestion+parseSuggestion suggestion = do+  let str = showSuggestion (show suggestion)+      severity = suggestionSeverity suggestion+  guard (severity /= HLint.Ignore)+  let lintSeverity = case severity of+        Warning -> LintWarning+        Error -> LintError++  headerLine:foundLine:rest <- Just (lines str)++  -- Expect the line after the header to have 'Found' in it.+  guard ("Found:" `isInfixOf` foundLine)++  -- Expect something like:+  -- ".hlintFile.hs:1:19: Warning: Redundant bracket"+  -- ==> +  -- [".hlintFile.hs","1","19"," Warning"," Redundant bracket"]+  [readMay -> Just chunkN,+   readMay -> Just lineNum, _col, severity, name] <- Just (split ":" headerLine)++  (before, _:after) <- Just (break ("Why not:" `isInfixOf`) rest)+  return Suggest {+    line = lineNum,+    chunkNumber = chunkN,+    found = unlines before,+    whyNot = unlines after,+    suggestion = name,+    severity = lintSeverity+  }+++showSuggestion :: String -> String+showSuggestion = +    replace ("return " ++ lintIdent) "" .+    replace (lintIdent ++ "=") "" .+    dropDo+    where++    -- drop leading '  do ', and blank spaces following+    dropDo :: String -> String+    dropDo = unlines . f . lines+        where+        f :: [String] -> [String]+        f ((stripPrefix "  do " -> Just a) : as) =+                let as' = catMaybes+                        $ takeWhile isJust+                        $ map (stripPrefix "     ") as+                in a : as' ++ f (drop (length as') as)+        f (x:xs) = x : f xs+        f [] = []++-- | Convert a code chunk into something that could go into a file.+-- The line number on the output is the same as on the input.+makeValid :: Located CodeBlock -> Located String+makeValid (Located line block) = Located line $+  case block of+    -- Expressions need to be bound to some identifier.+    Expression expr -> lintIdent ++ "=" ++ expr++    -- Statements go in a 'do' block bound to an identifier.+    --+    -- a cell can contain:+    -- > x <- readFile "foo"+    -- so add a return () to avoid a Parse error: Last statement in+    -- a do-block must be an expression+    --+    -- one place this goes wrong is when the chunk is:+    --+    -- > do+    -- >  {- a comment that has to -} let x = 1+    -- >   {- count as whitespace -}      y = 2+    -- >                              return (x+y) +    Statement stmt ->+        let expandTabs = replace "\t" "        " +            nLeading = maybe 0 (length . takeWhile isSpace)+                    $ listToMaybe+                    $ filter (not . all isSpace)+                            (lines (expandTabs stmt))+            finalReturn = replicate nLeading ' ' ++ "return " ++ lintIdent+        in intercalate ("\n ") ((lintIdent ++ " $ do") : lines stmt ++ [finalReturn])++    -- Modules, declarations, and type signatures are fine as is.+    Module mod -> mod+    Declaration decl -> decl+    TypeSignature sig -> sig+    Import imp -> imp++    -- Output nothing for directives or parse errors.+    Directive {} -> ""+    ParseError {} -> ""
+ src/IHaskell/Eval/ParseShell.hs view
@@ -0,0 +1,59 @@++-- | This module splits a shell command line into a list of strings,+--   one for each command / filename+module IHaskell.Eval.ParseShell (parseShell) where ++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 = char '\"'++-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@+manyTill :: Parser a -> Parser [a] -> Parser [a]+manyTill p end = scan+  where+    scan = end <|> do+      x <- p+      xs <- scan+      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 +  x <- noneOf "\\"+  lookAhead p+  return [x]++quotedString = do+  quote <?> "expected starting quote"+  (manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "++unquotedString = manyTill1 anyChar end  +  where end = unescapedChar space +          <|> (lookAhead eol >> return [])++word = quotedString <|> unquotedString <?> "word"++separator :: Parser String+separator = many1 space <?> "separator"++-- | 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 ++parseShell :: String -> Either ParseError [String]+parseShell string = parse words "shell" (string ++ "\n")
+ src/IHaskell/Eval/Parser.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+module IHaskell.Eval.Parser (+    parseString,+    CodeBlock(..),+    StringLoc(..),+    DirectiveType(..),+    LineNumber,+    ColumnNumber,+    ErrMsg,+    layoutChunks,+    parseDirective,+    getModuleName,+    unloc,+    Located(..),+    ) where++-- Hide 'unlines' to use our own 'joinLines' instead.+import ClassyPrelude hiding (liftIO, unlines)++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 Bag+import ErrUtils hiding (ErrMsg)+import FastString+import GHC hiding (Located)+import Lexer+import OrdList+import Outputable hiding ((<>))+import SrcLoc hiding (Located)+import StringBuffer++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.+  deriving (Show, Eq)++-- | Store locations along with a value.+data Located a = Located LineNumber a deriving (Eq, Show)+instance Functor Located where+  fmap f (Located line a) = Located line $ f a++-- | 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.+  deriving (Show, Eq)++-- | Unlocate something - drop the position.+unloc :: Located a -> a+unloc (Located _ a) = a++-- | Get the line number of a located element.+line :: Located a -> LineNumber+line (Located l _) = l++-- | Parse a string into code blocks.+parseString :: GhcMonad m => String -> m [Located CodeBlock]+parseString codeString = do+  -- Try to parse this as a single module.+  flags <- getSessionDynFlags+  let output = runParser flags parserModule codeString+  case output of+    Parsed {} -> return [Located 1 $ Module codeString]+    Failure {} -> do+      -- Split input into chunks based on indentation.+      let chunks = layoutChunks $ dropComments 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 result+  where+    parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock)+    parseChunk chunk line = Located line <$>+      if isDirective chunk+      then return $ parseDirective chunk line+      else parseCodeChunk chunk line++    processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock]+    processChunks accum remaining =+      case remaining of+        -- If we have no more remaining lines, return the accumulated results.+        [] -> return $ reverse accum++        -- If we have more remaining, parse the current chunk and recurse.+        Located line chunk:remaining ->  do+          block <- parseChunk chunk line+          activateParsingExtensions $ unloc block+          processChunks (block : accum) remaining++    -- Test wither a given chunk is a directive.+    isDirective :: String -> Bool+    isDirective = startswith ":" . strip++    -- Number of lines in this string.+    nlines :: String -> Int+    nlines = length . lines++activateParsingExtensions :: GhcMonad m => CodeBlock -> m ()+activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext+activateParsingExtensions _ = return ()++-- | 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)++        -- 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++        -- If one of the parsers succeeded+        result:_ -> return result+  where+    successes :: [ParseOutput a] -> [a]+    successes [] = []+    successes (Parsed a:rest) = a : successes rest+    successes (_:rest) = successes rest++    failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)]+    failures [] = []+    failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest+    failures (_:rest) = failures rest++    bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock+    bestError errors = ParseError (Loc (line + startLine - 1) col) msg+      where+        (msg, line, col) = maximumBy compareLoc errors+        compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2++    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+    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++    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++    parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)]+    parsers flags =+      [ (Import,        unparser parserImport)+      , (TypeSignature, unparser parserTypeSignature)+      , (Declaration,   unparser parserDeclaration)+      , (Statement,     unparser parserStatement)+      ]+      where+        unparser :: Parser a -> String -> ParseOutput String+        unparser parser code =+          case runParser flags parser code of+            Parsed out -> Parsed code+            Partial out strs -> Partial code strs+            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.+joinFunctions :: [Located CodeBlock] -> [Located CodeBlock]+joinFunctions (Located line (Declaration decl) : rest) =+    -- Find all declarations having the same name as this one.+    let (decls, other) = havingSameName rest in+      -- Convert them into a single declaration.+      Located line (Declaration (joinLines $ map (undecl . unloc) decls)) : joinFunctions other+  where+    undecl (Declaration decl) = decl+    undecl _ = error "Expected declaration!"++    -- Get all declarations with the same name as the first declaration.+    -- The name of a declaration is the first word, which we expect to be+    -- the name of the function.+    havingSameName :: [Located CodeBlock] -> ([Located CodeBlock], [Located CodeBlock]) +    havingSameName blocks =+      let name = head $ words decl+          sameName = takeWhile (isNamedDecl name) rest +          others = drop (length sameName) rest in+        (Located line (Declaration decl) : sameName, others)++    isNamedDecl :: String -> Located CodeBlock -> Bool+    isNamedDecl name (Located _ (Declaration dec)) = head (words dec) == name+    isNamedDecl _ _ = False++-- Allow a type signature followed by declarations to be joined to the+-- declarations. Parse the declaration joining separately.+joinFunctions (Located line (TypeSignature sig) : Located dl (Declaration decl) : rest) =+  Located line (Declaration $ sig ++ "\n" ++ joinedDecl):remaining+  where Located _ (Declaration joinedDecl):remaining = joinFunctions $ Located dl (Declaration decl) : rest +        +joinFunctions (x:xs) = x : joinFunctions xs+joinFunctions [] = []+++-- | Parse a directive of the form :directiveName.+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 ++ "'."+  where+    rightDirective (_, dirname) = case words directive of+      [] -> False+      dir:_ -> dir `elem` tail (inits dirname)+    directives =+      [(GetType,      "type")+      ,(GetInfo,      "info")+      ,(SearchHoogle, "hoogle")+      ,(GetDoc,       "documentation")+      ,(SetDynFlag,   "set")+      ,(LoadFile,     "load")+      ,(SetOption,    "option")+      ,(SetExtension, "extension")+      ,(GetHelp,      "?")+      ,(GetHelp,      "help")+      ]+parseDirective _ _ = error "Directive must start with colon!"+++-- | Split an input string into chunks based on indentation.+-- A chunk is a line and all lines immediately following that are indented+-- beyond the indentation of the first line. This parses Haskell layout+-- rules properly, and allows using multiline expressions via indentation. +layoutChunks :: String -> [Located String]+layoutChunks = go 1+  where+    go :: LineNumber -> String -> [Located String]+    go line = filter (not . null . unloc) . map (fmap strip) . layoutLines line . lines++    layoutLines :: LineNumber -> [String] -> [Located String]+    -- Empty string case.  If there's no input, output is empty.+    layoutLines _ [] = []++    -- Use the indent of the first line to find the end of the first block.+    layoutLines lineIdx all@(firstLine:rest) = +      let firstIndent = indentLevel firstLine+          blockEnded line = indentLevel line <= firstIndent in+        case findIndex blockEnded rest of+          -- If the first block doesn't end, return the whole string, since+          -- that just means the block takes up the entire string. +          Nothing -> [Located lineIdx $ intercalate "\n" all]++          -- We found the end of the block. Split this bit out and recurse.+          Just idx -> +            let (before, after) = splitAt idx rest in+              Located lineIdx (joinLines $ firstLine:before) : go (lineIdx + idx + 1) (joinLines after)++    -- Compute indent level of a string as number of leading spaces.+    indentLevel :: String -> Int+    indentLevel (' ':str) = 1 + indentLevel str++    -- Count a tab as two spaces.+    indentLevel ('\t':str) = 2 + indentLevel str+  +    -- Count empty lines as a large indent level, so they're always with the previous expression.+    indentLevel "" = 100000++    indentLevel _ = 0++-- Not the same as 'unlines', due to trailing \n+joinLines :: [String] -> String+joinLines = intercalate "\n"++-- | Drop comments from Haskell source.+dropComments :: String -> String+dropComments = removeOneLineComments . removeMultilineComments+  where+    -- Don't remove comments after cmd directives+    removeOneLineComments (':':'!':remaining) = ":!" ++ takeWhile (/= '\n') remaining ++ +      removeOneLineComments (dropWhile (/= '\n') remaining)+    removeOneLineComments ('-':'-':remaining) = removeOneLineComments (dropWhile (/= '\n') remaining)+    removeOneLineComments (x:xs) = x:removeOneLineComments xs+    removeOneLineComments x = x++    removeMultilineComments ('{':'-':remaining) = +      case subIndex "-}" remaining of+        Nothing -> ""+        Just idx -> removeMultilineComments $ drop (2 + idx) remaining+    removeMultilineComments (x:xs) = x:removeMultilineComments xs+    removeMultilineComments x = x++-- | 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."+    Parsed mod -> +      case unLoc <$> hsmodName (unLoc mod) of+        Nothing -> error "Module must have a name."+        Just name -> return $ split "." $ moduleNameString name
+ src/IHaskell/Eval/Util.hs view
@@ -0,0 +1,48 @@+module IHaskell.Eval.Util (+  extensionFlag, setExtension,+  ExtFlag(..),+  ) where++-- GHC imports.+import GHC+import GhcMonad+import DynFlags++import Data.List (find)++data ExtFlag+     = SetFlag   ExtensionFlag+     | UnsetFlag ExtensionFlag++extensionFlag :: String -> 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.+    Nothing ->+      case find (flagMatchesNo ext) xFlags of+        Just (_, flag, _) -> Just $ UnsetFlag flag+        Nothing -> Nothing++  where+    -- Check if a FlagSpec matches an extension name.+    flagMatches ext (name, _, _) = ext == name++    -- Check if a FlagSpec matches "No<ExtensionName>".+    -- In that case, we disable the extension.+    flagMatchesNo ext (name, _, _) = ext == "No"  ++ name++-- 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+  case extensionFlag ext of+    Nothing -> return $ Just $ "Could not parse extension name: " ++ ext+    Just flag -> do+      setSessionDynFlags $ +        case flag of+          SetFlag ghcFlag -> xopt_set flags ghcFlag+          UnsetFlag ghcFlag -> xopt_unset flags ghcFlag+      return Nothing
+ src/IHaskell/Flags.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE NoImplicitPrelude #-}+module IHaskell.Flags ( +  IHaskellMode(..),+  Argument(..),+  Args(..),+  parseFlags,+  help,+  ) where++import ClassyPrelude+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Text++import IHaskell.Types++-- Command line arguments to IHaskell.  A set of aruments is annotated with+-- the mode being invoked.+data Args = Args IHaskellMode [Argument]++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.+  | Help                -- ^ Display help text.+  deriving (Eq, Show)++-- Which mode IHaskell is being invoked in.+-- `None` means no mode was specified.+data IHaskellMode+  = ShowHelp String+  | Notebook+  | Console+  | UpdateIPython+  | 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.+parseFlags :: [String] -> Either String Args+parseFlags = process ihaskellArgs++-- | 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 (Kernel _) = kernel+    chooseMode UpdateIPython = update++universalFlags :: [Flag Args]+universalFlags = [+  flagReq ["extension","e", "X"] (store Extension) "<ghc-extension>" "Extension to enable at start.",+  flagReq ["conf","c"] (store ConfFile) "<file.hs>" "File with commands to execute at start.",+  flagHelpSimple (add Help)+  ]+  where +    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.":+  universalFlags++console :: Mode Args+console = mode "console" (Args Console []) "Console-based interactive repl." noArgs universalFlags++kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg []+  where+    kernelArg = flagArg update "<json-kernel-file>"+    update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags++update :: Mode Args+update = mode "update" (Args UpdateIPython []) "Update IPython frontends." noArgs []++view :: Mode Args+view = (modeEmpty $ Args (View Nothing Nothing) []) {+      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], Nothing)+                                                    +  }+  where+    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+  ++ihaskellArgs :: Mode Args+ihaskellArgs =+  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 [console, notebook, view, update, kernel] }+  where +    add flag (Args mode flags) = Args mode $ flag : flags++noArgs = flagArg unexpected ""+  where+    unexpected a = error $ "Unexpected argument: " ++ a
+ src/IHaskell/IPython.hs view
@@ -0,0 +1,411 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse #-}+-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, @setup@, and+--                 @console@ commands.+module IHaskell.IPython (+  ipythonInstalled,+  installIPython,+  updateIPython,+  setupIPython,+  runConsole,+  runNotebook,+  readInitInfo,+  defaultConfFile,+  getIHaskellDir,+  getSandboxPackageConf,+  nbconvert,+  ViewFormat(..),+) where++import ClassyPrelude+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)+import Text.Printf++import qualified System.IO.Strict as StrictIO+import qualified Paths_ihaskell as Paths+import qualified Codec.Archive.Tar as Tar++import IHaskell.Types++-- | Which commit of IPython we are on.+ipythonCommit :: Text+ipythonCommit = "9c922f54af799704f4000aeee94ec7c74cada194"++-- | The IPython profile name.+ipythonProfile :: String+ipythonProfile = "haskell"++-- | Run IPython with any arguments.+ipython :: Bool         -- ^ Whether to suppress output.+        -> [Text]       -- ^ IPython command line arguments.+        -> Sh String    -- ^ IPython output.+ipython suppress args = do+  ipythonPath <- ipythonExePath+  runHandles ipythonPath 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 ""++-- | Run while suppressing all output.+quietRun path args = runHandles path args handles nothing+  where+    handles =  [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]+    nothing _ _ _ = return ()++-- | Create the directory and return it.+ensure :: Sh FilePath -> Sh FilePath+ensure getDir = do+  dir <- getDir+  mkdir_p dir+  return dir++-- | Return the data directory for IHaskell.+ihaskellDir :: Sh FilePath+ihaskellDir = do+  home <- maybe (error "$HOME not defined.") fromText <$> get_env "HOME"+  ensure $ return (home </> ".ihaskell")++ipythonDir :: Sh FilePath+ipythonDir = ensure $ (</> "ipython") <$> ihaskellDir++ipythonExePath :: Sh FilePath+ipythonExePath = (</> ("bin" </> "ipython")) <$> ipythonDir++notebookDir :: Sh FilePath+notebookDir = ensure $ (</> "notebooks") <$> ihaskellDir++ipythonSourceDir :: Sh FilePath+ipythonSourceDir = ensure $ (</> "ipython-src") <$> ihaskellDir++getIHaskellDir :: IO String+getIHaskellDir = shellyNoDir $ fpToString <$> ihaskellDir++defaultConfFile :: IO (Maybe String)+defaultConfFile = shellyNoDir $ do+  filename <- (</> "rc.hs") <$> ihaskellDir+  exists <- test_f filename+  return $ if exists+           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 :: ViewFormat -> String -> IO ()+nbconvert fmt name = void . shellyNoDir $ do+  curdir <- pwd+  nbdir <- notebookDir+  -- 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 ++    Just notebook ->+      let viewArgs = case fmt of+            Pdf ->  ["--to=latex", "--post=pdf"]+            Html -> ["--to=html", "--template=ihaskell"]+            fmt ->  ["--to=" ++ show fmt] in+      void $ runIHaskell ipythonProfile "nbconvert" $ viewArgs ++ [fpToString notebook]++-- | Set up IPython properly.+setupIPython :: IO ()+setupIPython = do+  installed <- ipythonInstalled+  if installed+  then updateIPython+  else installIPython+  +  ++-- | Update the IPython source tree and rebuild.+updateIPython :: IO ()+updateIPython = void . shellyNoDir $ do+  srcDir <- ipythonSourceDir+  cd srcDir+  gitPath <- path "git"+  currentCommitHash <- silently $ pack <$> rstrip <$> unpack <$> run gitPath ["rev-parse", "HEAD"]+  when (currentCommitHash /= ipythonCommit) $ do+    putStrLn "Incorrect IPython repository commit hash."+    putStrLn $ "Found hash:  " ++ currentCommitHash +    putStrLn $ "Wanted hash: " ++ ipythonCommit +    putStrLn "Updating..."+    run_ gitPath ["pull", "origin", "master"]+    run_ gitPath ["checkout", ipythonCommit]+    installPipDependencies+    buildIPython++-- | Install IPython from source.+installIPython :: IO ()+installIPython = void . shellyNoDir $ do+  installPipDependencies++  -- Get the IPython source.+  gitPath <- path "git"+  putStrLn "Downloading IPython... (this may take a while)"+  ipythonSrcDir <- ipythonSourceDir+  run_ gitPath ["clone", "--recursive", "https://github.com/ipython/ipython.git", fpToText ipythonSrcDir]+  cd ipythonSrcDir+  run_ gitPath ["checkout", ipythonCommit]++  buildIPython++-- | Install all Python dependencies.+installPipDependencies :: Sh ()+installPipDependencies = withTmpDir $ \tmpDir -> +    mapM_ (installDependency tmpDir) +      [+        ("pyzmq", "14.0.1")+      , ("tornado","3.1.1")+      , ("jinja2","2.7.1")+      -- The following cannot go first in the dependency list, because+      -- their setup.py are broken and require the directory to exist+      -- already.+      , ("MarkupSafe", "0.18")+      --, ("setuptools", "2.0.2")+      ]+  where+    installDependency :: FilePath -> (Text, Text) -> Sh ()+    installDependency tmpDir (dep, version) = sub $ do+      let versioned = dep ++ "-" ++ version+      putStrLn $ "Installing dependency: " ++ versioned++      pipPath <- path "pip"+      tarPath <- path "tar"+      pythonPath <- path "python"++      -- Download the package.+      let downloadOpt = "--download=" ++ fpToText tmpDir+      run_ pipPath ["install", downloadOpt, dep ++ "==" ++ version]++      -- Extract it.+      cd tmpDir+      run_ tarPath ["-xzf", versioned ++ ".tar.gz"]++      -- Install it.+      cd $ fromText versioned+      dir <- fpToText <$> ipythonDir+      setenv "PYTHONPATH" $ dir ++ "/lib/python2.7/site-packages/"+      let prefixOpt =  "--prefix=" ++ dir+      run_ pythonPath ["setup.py", "install", prefixOpt]+++-- | Once things are checked out into the IPython source directory, build it and install it.+buildIPython :: Sh ()+buildIPython = do+  -- Install IPython locally.+  pythonPath <- path "python"+  prefixOpt <- ("--prefix=" ++) <$> fpToText <$> ipythonDir+  putStrLn "Installing IPython."+  run_ pythonPath ["setup.py", "install", prefixOpt]++  -- Patch the IPython executable so that it doesn't use system IPython.+  -- Using PYTHONPATH is not enough due to bugs in how `easy_install` sets+  -- things up, at least on Mac OS X.+  ipyDir <- ipythonDir+  let patchLines =+        [ "#!/usr/bin/env python"+        , "import sys"+        , "sys.path = [\"" ++ fpToText ipyDir +++         "/lib/python2.7/site-packages\"] + sys.path"]+  ipythonPath <- ipythonExePath+  contents <- readFile ipythonPath+  writeFile ipythonPath $ unlines patchLines ++ "\n" ++ contents++  -- Remove the old IPython profile so that we write a new one in its+  -- place. Users are not expected to fiddle with the profile, so we give+  -- no warning whatsoever. This may be changed eventually.+  removeIPythonProfile ipythonProfile+      ++-- | Check whether IPython is properly installed.+ipythonInstalled :: IO Bool+ipythonInstalled = shellyNoDir $ do+  ipythonPath <- ipythonExePath+  test_f ipythonPath++-- | 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+  case path of+    Nothing -> do+      putStrLn $ "Could not find `" ++ exe ++ "` executable."+      fail $ "`" ++ unpack exe ++ "` not on $PATH."+    Just exePath -> return exePath++-- | Use the `ipython --version` command to figure out the version.+-- Return a tuple with (major, minor, patch).+ipythonVersion :: IO (Int, Int, Int)+ipythonVersion = shellyNoDir $ do+  [major, minor, patch] <- parseVersion <$>  ipython True ["--version"]+  return (major, minor, patch)++-- | Parse an IPython version string into a list of integers.+parseVersion :: String -> [Int]+parseVersion versionStr = map read' $ split "." versionStr+    where read' x = case reads x of+                        [(n, _)] -> n+                        _ -> error $ "cannot parse version: "++ versionStr++-- | Run an IHaskell application using the given profile.+runIHaskell :: String   -- ^ IHaskell profile name. +           -> String    -- ^ IPython app name.+           -> [String]  -- ^ Arguments to IPython.+           -> Sh ()+runIHaskell profile app args = void $ do+  -- Try to locate the profile. Do not die if it doesn't exist.+  errExit False $ ipython True ["locate", "profile", pack profile]++  -- If the profile doesn't exist, create it.+  -- We have an ugly hack that removes the profile whenever the IPython+  -- version is updated. This means profiles get updated with IPython.+  exitCode <- lastExitCode+  when (exitCode /= 0) $ liftIO $ do+    putStrLn "Creating IPython profile."+    setupIPythonProfile profile++  -- Run the IHaskell command.+  ipython False $ map pack $ [app, "--profile", profile] ++ args++runConsole :: InitInfo -> IO ()+runConsole initInfo = void . shellyNoDir $ do+  writeInitInfo initInfo+  runIHaskell ipythonProfile "console" []++runNotebook :: InitInfo -> Maybe String -> IO ()+runNotebook initInfo maybeServeDir = void . shellyNoDir $ do+  notebookDirStr <- fpToString <$> notebookDir+  let args = case maybeServeDir of +               Nothing -> ["--notebook-dir", unpack notebookDirStr]+               Just dir -> ["--notebook-dir", dir]++  writeInitInfo initInfo+  runIHaskell ipythonProfile "notebook" args++writeInitInfo :: InitInfo -> Sh ()+writeInitInfo info = do+  filename <- (</> ".last-arguments") <$> ihaskellDir+  liftIO $ writeFile filename $ show info++readInitInfo :: IO InitInfo+readInitInfo = shellyNoDir $ do+  filename <- (</>  ".last-arguments") <$> ihaskellDir+  read <$> liftIO (readFile filename)++-- | Create the IPython profile.+setupIPythonProfile :: String -- ^ IHaskell profile name.+                    -> IO ()+setupIPythonProfile profile = shellyNoDir $ do+  -- Create the IPython profile.+  void $ ipython 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 True ["locate"]+  let profileDir = ipythonDir ++ "/profile_" ++ pack profile ++ "/"++  liftIO $ copyProfile profileDir+  insertIHaskellPath profileDir++removeIPythonProfile :: String -> Sh ()+removeIPythonProfile profile = do+  -- Try to locate the profile. Do not die if it doesn't exist.+  errExit False $ ipython True ["locate", "profile", pack profile]++  -- If the profile exists, delete it.+  exitCode <- lastExitCode+  dir <- pack <$> rstrip <$> ipython True ["locate"]+  when (exitCode == 0 && dir /= "") $ do+    putStrLn "Updating IPython profile."+    let profileDir = dir ++ "/profile_" ++ pack profile ++ "/"+    rm_rf $ fromText profileDir++-- | Copy the profile files into the IPython profile. +copyProfile :: Text -> IO ()+copyProfile profileDir = do+  profileTar <- Paths.getDataFileName "profile/profile.tar"+  {-+  -- Load profile from Resources directory of Mac *.app.+  ihaskellPath <- shellyNoDir getIHaskellPath+  profileTar <- if "IHaskell.app/Contents/MacOS" `isInfixOf` ihaskellPath+               then+                let pieces = split "/" ihaskellPath+                    pathPieces = init pieces ++ ["..", "Resources", "profile.tar"] in+                  return $ intercalate "/" pathPieces+               else 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++-- | Get the absolute path to this IHaskell executable.+getIHaskellPath :: Sh String+getIHaskellPath = do+  --  Get the absolute filepath to the argument.+  f <- liftIO getArgv0++  -- 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.+    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++getSandboxPackageConf :: IO (Maybe String)+getSandboxPackageConf = shellyNoDir $ 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
+ src/IHaskell/Types.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, PatternGuards #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}+-- | 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(..),+  ) where++import            ClassyPrelude+import qualified  Data.ByteString.Char8           as Char+import            Data.Serialize+import            GHC.Generics++import            Text.Read                       as Read hiding (pfail, String)+import            Text.ParserCombinators.ReadP++import IPython.Kernel++data ViewFormat+     = Pdf+     | Html+     | Ipynb+     | Markdown+     | Latex+     deriving Eq++instance Show ViewFormat where+  show Pdf         = "pdf"+  show Html        = "html"+  show Ipynb       = "ipynb"+  show Markdown    = "markdown"+  show Latex       = "latex"++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++-- | 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)+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]++-- | 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+  }+  deriving Show++defaultKernelState :: KernelState+defaultKernelState = KernelState+  { getExecutionCounter = 1,+    getLintStatus = LintOn,+    getFrontend = IPythonConsole,+    useSvg = True,+    useShowErrors = False,+    useShowTypes = False+  }++data FrontendType+     = IPythonConsole+     | IPythonNotebook+     deriving (Show, Eq, Read)++-- | names the ways to update the IHaskell 'KernelState' by `:set`+-- ('getSetName') and `:option` ('getOptionName') directives+data KernelOpt = KernelOpt+    { getOptionName, getSetName :: [String],+      getUpdateKernelState :: KernelState -> KernelState }++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 }]++-- | 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)+++-- | 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.+  }
+ src/Main.hs view
@@ -0,0 +1,326 @@+{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-}+-- | Description : Argument parsing and basic messaging loop, using Haskell+--                 Chans to communicate with the ZeroMQ sockets. +module Main where+import ClassyPrelude hiding (liftIO)+import Prelude (last, read)+import Control.Concurrent.Chan+import Control.Concurrent (threadDelay)+import Data.Aeson+import Text.Printf+import System.Exit (exitSuccess)+import System.Directory++import qualified Data.Map as Map++import IHaskell.Types+import IPython.ZeroMQ+import qualified IPython.Message.UUID as UUID+import IHaskell.Eval.Evaluate+import IHaskell.Eval.Completion (complete)+import IHaskell.Eval.Info+import qualified Data.ByteString.Char8 as Chars+import IHaskell.IPython+import qualified IPython.Stdin as Stdin+import IHaskell.Flags++import GHC hiding (extensions, language)+import Outputable (showSDoc, ppr)++-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h+ghcVersionInts :: [Int]+ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc+  where dotToSpace '.' = ' '+        dotToSpace x = x+++main ::  IO ()+main = do+  args <- parseFlags <$> map unpack <$> getArgs+  case args of+    Left errorMessage -> +      hPutStrLn stderr errorMessage+    Right args ->+      ihaskell args++ihaskell :: Args -> IO ()+-- If no mode is specified, print help text.+ihaskell (Args (ShowHelp help) _) = +  putStrLn $ pack help++-- Update IPython: remove then reinstall.+-- This is in case cabal updates IHaskell but the corresponding IPython+-- isn't updated. This is hard to detect since versions of IPython might+-- not change!+ihaskell (Args UpdateIPython _) = do+  setupIPython+  putStrLn "IPython updated."+    +ihaskell (Args Console flags) = showingHelp Console flags $ do+  setupIPython++  flags <- addDefaultConfFile flags+  info <- initInfo IPythonConsole flags+  runConsole info++ihaskell (Args (View (Just fmt) (Just name)) []) =+  nbconvert fmt name++ihaskell (Args Notebook flags) = showingHelp Notebook flags $ do+  setupIPython++  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 info server+  where+    serveDir (ServeFrom dir) = Just dir+    serveDir _ = Nothing++ihaskell (Args (Kernel (Just filename)) _) = do+  initInfo <- readInitInfo+  runKernel filename initInfo++-- | 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++showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()+showingHelp mode flags act =+  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++-- | Run the IHaskell language kernel.+runKernel :: String    -- ^ Filename of profile JSON file.+          -> InitInfo  -- ^ Initialization information from the invocation.+          -> IO ()+runKernel profileSrc initInfo = do+  setCurrentDirectory $ initDir initInfo++  -- Parse the profile file.+  Just profile <- liftM decode . readFile . fpFromText $ pack profileSrc++  -- Necessary for `getLine` and their ilk to work.+  dir <- getIHaskellDir+  Stdin.recordKernelProfile dir profile++  -- Serve on all sockets and ports defined in the profile.+  interface <- serveProfile profile++  -- Create initial state in the directory the kernel *should* be in.+  state <- initialKernelState+  modifyMVar_ state $ \kernelState -> return $+    kernelState { getFrontend = frontend initInfo }++  -- Receive and reply to all messages on the shell socket.+  interpret True $ do+    -- 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 ()       +        evaluator line = 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++    forever $ do+      -- Read the request from the request channel.+      request <- liftIO $ readChan $ shellRequestChannel interface++      -- Create a header for the reply.+      replyHeader <- createReplyHeader (header request)++      -- 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++-- Initial kernel state.+initialKernelState :: IO (MVar KernelState)+initialKernelState =+  newMVar defaultKernelState++-- | Duplicate a message header, giving it a new UUID and message type.+dupHeader :: MessageHeader -> MessageType -> IO MessageHeader+dupHeader header messageType = do+  uuid <- liftIO UUID.random++  return header { messageId = uuid, msgType = messageType }++-- | Create a new message header, given a parent message header.+createReplyHeader :: MessageHeader -> Interpreter MessageHeader+createReplyHeader parent = do+  -- Generate a new message UUID.+  newMessageId <- liftIO UUID.random+  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+  }++-- | 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).+replyTo _ KernelInfoRequest{} replyHeader state =+  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 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.+  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 []+  updateNeeded <- liftIO $ newMVar False+  pagerOutput  <- liftIO $ newMVar ""+  let clearOutput = do+        header <- dupHeader replyHeader ClearOutputMessage+        send $ ClearOutput header True++      sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts+      sendOutput (Display outs) = do+        header <- dupHeader replyHeader DisplayDataMessage+        send $ PublishDisplayData header "haskell" outs++      publish :: EvaluationResult -> IO ()+      publish result = do+        let final = case result of+                      IntermediateResult {} -> False+                      FinalResult {} -> True+            outs = outputs result++        -- If necessary, clear all previous output and redraw.+        clear <- readMVar updateNeeded+        when clear $ do+          clearOutput+          disps <- readMVar displayed+          mapM_ sendOutput $ reverse disps++        -- 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.+        modifyMVar_ updateNeeded (const $ return $ not final)+        when final $ do+          modifyMVar_ displayed (return . (outs:))++          -- If this has some pager output, store it for later.+          let pager = pagerOut result+          unless (null pager) $+            modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))++  -- Run code and publish to the frontend as we go.+  let execCount = getExecutionCounter state+  updatedState <- evaluate state (Chars.unpack code) publish++  -- Notify the frontend that we're done computing.+  idleHeader <- liftIO $ dupHeader replyHeader StatusMessage+  send $ PublishStatus idleHeader Idle++  pager <- liftIO $ readMVar pagerOutput+  return (updatedState, ExecuteReply {+    header = replyHeader,+    pagerOutput = pager,+    executionCounter = execCount,+    status = Ok+  })+++replyTo _ req@CompleteRequest{} replyHeader state = do+    (matchedText, completions) <- complete (Chars.unpack $ getCodeLine req) (getCursorPos req)++    let reply =  CompleteReply replyHeader (map Chars.pack completions) (Chars.pack matchedText) (getCodeLine req) 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+         docs <- info $ Chars.unpack oname+         let reply = ObjectInfoReply {+                        header = replyHeader,+                        objectName = oname, +                        objectFound = docs == "",+                        objectTypeString = Chars.pack docs,+                        objectDocString  = Chars.pack docs                    +                      }+         return (state, reply)+++