ihaskell 0.3.0.4 → 0.4.0.0
raw patch · 29 files changed
+2622/−528 lines, 29 filesdep +haskell-src-extsdep +ihaskelldep +mono-traversabledep −ghci-libdep −ipython-kerneldep ~aesondep ~cerealdep ~classy-prelude
Dependencies added: haskell-src-exts, ihaskell, mono-traversable, stm, text, unordered-containers, uuid, vector, zeromq4-haskell
Dependencies removed: ghci-lib, ipython-kernel
Dependency ranges changed: aeson, cereal, classy-prelude, here, hlint, setenv, shelly
Files
- ihaskell.cabal +57/−70
- installation/ipython.sh +1/−4
- installation/run.sh +5/−3
- installation/update.sh +0/−20
- profile/profile.tar binary
- src/Hspec.hs +29/−27
- src/IHaskell/BrokenPackages.hs +47/−0
- src/IHaskell/Convert.hs +33/−0
- src/IHaskell/Convert/Args.hs +107/−0
- src/IHaskell/Convert/IpynbToLhs.hs +66/−0
- src/IHaskell/Convert/LhsToIpynb.hs +103/−0
- src/IHaskell/Display.hs +87/−23
- src/IHaskell/Eval/Completion.hs +39/−10
- src/IHaskell/Eval/Evaluate.hs +231/−98
- src/IHaskell/Eval/Hoogle.hs +23/−23
- src/IHaskell/Eval/Lint.hs +118/−108
- src/IHaskell/Eval/Parser.hs +25/−35
- src/IHaskell/Eval/Util.hs +148/−4
- src/IHaskell/Flags.hs +85/−4
- src/IHaskell/IPython.hs +110/−60
- src/IHaskell/IPython/Kernel.hs +16/−0
- src/IHaskell/IPython/Message/Parser.hs +191/−0
- src/IHaskell/IPython/Message/UUID.hs +46/−0
- src/IHaskell/IPython/Message/Writer.hs +137/−0
- src/IHaskell/IPython/Stdin.hs +123/−0
- src/IHaskell/IPython/Types.hs +416/−0
- src/IHaskell/IPython/ZeroMQ.hs +208/−0
- src/IHaskell/Types.hs +75/−5
- src/Main.hs +96/−34
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.3.0.4+version: 0.4.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project.@@ -44,7 +44,6 @@ data-files: installation/ipython.sh- installation/update.sh installation/virtualenv.sh installation/run.sh profile/profile.tar@@ -52,44 +51,55 @@ library hs-source-dirs: src default-language: Haskell2010+ ghc-options: -threaded build-depends: + aeson >=0.6 && < 0.8, base ==4.6.*,- aeson >=0.6.1, base64-bytestring >=1.0, bytestring >=0.10,- cereal ==0.3.*,- classy-prelude >=0.7,+ cereal >=0.3,+ classy-prelude ==0.9.2,+ mono-traversable ==0.6.0, cmdargs >=0.10, containers >=0.5, directory -any, filepath -any, ghc ==7.6.*, ghc-parser >=0.1.1,- ghci-lib >=0.1, ghc-paths ==0.1.*, haskeline -any,- here -any,- hlint -any,+ here ==1.2.*,+ hlint ==1.8.61,+ haskell-src-exts ==1.15.*, 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,+ shelly ==1.5.*, split >= 0.2,+ stm -any, strict >=0.3, system-argv0 -any, system-filepath -any, tar -any,+ text >=0.11, transformers -any, unix >= 2.6,- utf8-string -any+ unordered-containers -any,+ utf8-string -any,+ uuid >=1.3,+ vector -any,+ zeromq4-haskell >=0.1 exposed-modules: IHaskell.Display+ IHaskell.Convert+ IHaskell.Convert.Args+ IHaskell.Convert.IpynbToLhs+ IHaskell.Convert.LhsToIpynb IHaskell.Eval.Completion IHaskell.Eval.Evaluate IHaskell.Eval.Info@@ -101,30 +111,22 @@ IHaskell.IPython IHaskell.Flags IHaskell.Types- other-modules: + IHaskell.BrokenPackages+ IHaskell.IPython.Kernel+ IHaskell.IPython.Types+ IHaskell.IPython.ZeroMQ+ IHaskell.IPython.Stdin+ IHaskell.IPython.Message.Writer+ IHaskell.IPython.Message.Parser+ IHaskell.IPython.Message.UUID Paths_ihaskell+-- other-modules: +-- 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.Flags- IHaskell.Types- IHaskell.Display+ main-is: src/Main.hs+ ghc-options: -threaded default-extensions: DoAndIfThenElse @@ -132,40 +134,18 @@ default-language: Haskell2010 build-depends: base ==4.6.*,- aeson >=0.6,- base64-bytestring >=1.0,+ aeson >=0.6 && < 0.8, bytestring >=0.10,- cereal ==0.3.*,- classy-prelude >=0.7,- cmdargs >=0.10,+ cereal >=0.3,+ classy-prelude ==0.9.2,+ mono-traversable ==0.6.0, containers >=0.5, directory -any,- filepath -any, ghc ==7.6.*,- ghc-parser >=0.1.1,- ghci-lib >=0.1,- ghc-paths ==0.1.*,- haskeline -any,- here -any,- hlint -any,- hspec -any,- HTTP -any,- HUnit -any,- ipython-kernel -any,+ ihaskell -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+ text -any,+ unix >= 2.6 Test-Suite hspec hs-source-dirs: src@@ -174,42 +154,49 @@ Main-Is: Hspec.hs default-language: Haskell2010 build-depends: + aeson >=0.6 && < 0.8, base ==4.6.*,- aeson >=0.6, base64-bytestring >=1.0, bytestring >=0.10,- cereal ==0.3.*,- classy-prelude >=0.7,+ cereal >=0.3,+ classy-prelude ==0.9.2,+ mono-traversable ==0.6.0, cmdargs >=0.10, containers >=0.5, directory -any, filepath -any, ghc ==7.6.*, ghc-parser >=0.1.1,- ghci-lib >=0.1, ghc-paths ==0.1.*, haskeline -any,- here -any,- hlint -any,+ here ==1.2.*,+ hlint ==1.8.61,+ haskell-src-exts ==1.15.*, hspec -any, HTTP -any, HUnit -any,- ipython-kernel -any, MissingH >=1.2, mtl >=2.1, parsec -any, process >=1.1, random >=1.0,- setenv -any,- shelly >=1.3,+ shelly ==1.5.*, split >= 0.2,+ stm -any, strict >=0.3, system-argv0 -any, system-filepath -any, tar -any,+ text >=0.11, transformers -any, unix >= 2.6,- utf8-string -any+ unordered-containers -any,+ utf8-string -any,+ uuid >=1.3,+ vector -any,+ zeromq4-haskell >=0.1,+ setenv ==0.1.*+ default-extensions: DoAndIfThenElse
installation/ipython.sh view
@@ -4,9 +4,6 @@ # Which virtualenv to use. VIRTUALENV=$1 -# Commit hash to install.-COMMIT=$2- # Activate the virtualenv. source $VIRTUALENV/bin/activate @@ -32,4 +29,4 @@ # Install IPython itself. echo "Installing IPython (this may take a while)."-pip install -e git+https://github.com/gibiansky/ipython.git@$COMMIT#egg=ipython-dev+pip install ipython
installation/run.sh view
@@ -5,9 +5,11 @@ VIRTUALENV=$1 shift -# Activate the virtualenv.-source $VIRTUALENV/bin/activate+# Activate the virtualenv, if it exists.+if [[ -f $VIRTUALENV/bin/activate ]]; then+ source $VIRTUALENV/bin/activate;+fi # Run IPython. # Quotes around $@ are necessary to deal properly with spaces.-ipython "$@"+ipython "$@" $IHASKELL_IPYTHON_ARGS
− installation/update.sh
@@ -1,20 +0,0 @@-#!/bin/bash-set -e--# Which virtualenv to use.-VIRTUALENV=$1--# Commit hash to install.-COMMIT=$2--# Find out current IPython commit hash.-cd $VIRTUALENV/src/ipython-CURRENT_COMMIT=`git rev-parse HEAD`-if [ $CURRENT_COMMIT != $COMMIT ]; then- # Activate the virtualenv.- source $VIRTUALENV/bin/activate-- # Update IPython.- echo "Updating IPython (this may take a while)."- pip install --upgrade -e git+https://github.com/gibiansky/ipython.git@$COMMIT#egg=ipython-dev-fi;
profile/profile.tar view
binary file changed (85504 → 73728 bytes)
src/Hspec.hs view
@@ -12,6 +12,7 @@ import Shelly (Sh, shelly, cmd, (</>), toTextIgnore, cd, withTmpDir, mkdir_p, touchfile) import qualified Shelly+import Control.Applicative ((<$>)) import Filesystem.Path.CurrentOS (encodeString) import System.SetEnv (setEnv) import Data.String.Here@@ -33,6 +34,8 @@ import Test.Hspec.HUnit import Test.HUnit (assertBool, assertFailure) +traceShowId x = traceShow x x + doGhc = runGhc (Just libdir) parses str = do@@ -50,7 +53,7 @@ pagerAccum <- newIORef [] let publish evalResult = case evalResult of IntermediateResult {} -> return ()- FinalResult outs page -> do+ FinalResult outs page [] -> do modifyIORef outputAccum (outs :) modifyIORef pagerAccum (page :) @@ -78,7 +81,7 @@ expectationFailure $ "Expected result to have " ++ show (length expected) ++ " results. Got " ++ show results - forM_ (zip results expected) $ \(Display result, expected) ->+ forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected str -> str `shouldBe` expected@@ -99,8 +102,7 @@ where (newString, cursorloc) = readCompletePrompt string completionEvent :: String -> Interpreter (String, [String])-completionEvent string = do- complete newString cursorloc+completionEvent string = complete newString cursorloc where (newString, cursorloc) = case elemIndex '*' string of Nothing -> error "Expected cursor written as '*'." Just idx -> (replace "*" "" string, idx) @@ -111,11 +113,11 @@ shouldHaveCompletionsInDirectory :: String -> [String] -> IO ()-shouldHaveCompletionsInDirectory string expected - = do (matched, completions) <- completionEventInDirectory string - let existsInCompletion = (`elem` completions)- unmatched = filter (not . existsInCompletion) expected- expected `shouldBeAmong` completions+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 @@ -133,6 +135,7 @@ imports <- mapM parseImportDecl ["import Prelude", "import qualified Control.Monad", "import qualified Data.List as List",+ "import IHaskell.Display", "import Data.Maybe as Maybe"] setContext $ map IIDecl imports @@ -147,8 +150,7 @@ 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+ where cdEvent path = liftIO $ setCurrentDirectory path --Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish wrap :: FilePath -> Interpreter a -> Interpreter a wrap path action = do initCompleter@@ -223,7 +225,7 @@ it "properly completes haskell file paths on :load directive" $ let loading xs = ":load " ++ encodeString xs- paths xs = map encodeString xs+ paths = map encodeString in do loading ("dir" </> "file*") `shouldHaveCompletionsInDirectory` paths ["dir" </> "file2.hs", "dir" </> "file2.lhs"]@@ -238,24 +240,27 @@ , "./" </> "file1.hs" , "./" </> "file1.lhs"] - it "provides path completions on empty shell cmds " $ do - ":! cd *" `shouldHaveCompletionsInDirectory` (map encodeString ["" </> "dir/"- , "" </> "file1.hs"- , "" </> "file1.lhs"])+ it "provides path completions on empty shell cmds " $+ ":! cd *" `shouldHaveCompletionsInDirectory` map encodeString ["" </> "dir/"+ , "" </> "file1.hs"+ , "" </> "file1.lhs"] + let withHsHome action = withHsDirectory $ \dirPath-> do+ home <- shelly $ Shelly.get_env_text "HOME"+ setHomeEvent dirPath+ result <- action+ setHomeEvent $ Shelly.fromText home+ return result+ setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path) it "correctly interprets ~ as the environment HOME variable" $ let shouldHaveCompletions :: String -> [String] -> IO () shouldHaveCompletions string expected = do - (matched, completions) - <- withHsDirectory $ \dirPath -> - do setHomeEvent dirPath- completionEvent string + (matched, completions) <- withHsHome $ 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/"]@@ -264,11 +269,7 @@ let shouldHaveMatchingText :: String -> String -> IO () shouldHaveMatchingText string expected = do - matchText - <- withHsDirectory $ \dirPath -> - do setHomeEvent dirPath- (matchText, _) <- uncurry complete (readCompletePrompt string)- return matchText+ matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string) matchText `shouldBe` expected setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)@@ -333,7 +334,8 @@ "import Control.Monad (when)" `becomes` [] it "evaluates directives" $ do- ":typ 3" `becomes` ["forall a. Num a => a"]+ ":typ 3" `becomes` ["3 :: forall a. Num a => a"]+ ":k Maybe" `becomes` ["Maybe :: * -> *"] ":in String" `pages` ["type String = [Char] \t-- Defined in `GHC.Base'"] parserTests = do
+ src/IHaskell/BrokenPackages.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}+module IHaskell.BrokenPackages (getBrokenPackages) where++import ClassyPrelude hiding ((<|>))++import Text.Parsec+import Text.Parsec.String+import Control.Applicative hiding ((<|>), many)++import Data.String.Utils (startswith)++import Shelly++data BrokenPackage = BrokenPackage {+ packageID :: String,+ brokenDeps :: [String]+ }++instance Show BrokenPackage where+ show = packageID++-- | Get a list of broken packages.+-- This function internally shells out to `ghc-pkg`, and parses the output+-- in order to determine what packages are broken.+getBrokenPackages :: IO [String]+getBrokenPackages = shelly $ do+ silently $ errExit False $ run "ghc-pkg" ["check"]+ checkOut <- lastStderr+ + -- Get rid of extraneous things+ let rightStart str = startswith "There are problems" str || + startswith " dependency" str + ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut++ return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of+ Left err -> []+ Right pkgs -> map show pkgs++check :: Parser BrokenPackage+check = string "There are problems in package "+ >> BrokenPackage <$> ident <* string ":\n" <*> many1 dependency++ident :: Parser String+ident = many (alphaNum <|> oneOf "-.")++dependency :: Parser String+dependency = string " dependency \"" *> ident <* string "\" doesn't exist\n"
+ src/IHaskell/Convert.hs view
@@ -0,0 +1,33 @@+-- | Description : mostly reversible conversion between ipynb and lhs +module IHaskell.Convert (convert) where+import Control.Monad.Identity (Identity(Identity), unless, when)+import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)+import IHaskell.Convert.IpynbToLhs (ipynbToLhs)+import IHaskell.Convert.LhsToIpynb (lhsToIpynb)+import IHaskell.Flags (Argument)+import System.Directory (doesFileExist)+import Text.Printf (printf)++-- | used by @IHaskell convert@+convert :: [Argument] -> IO ()+convert args = case fromJustConvertSpec (toConvertSpec args) of+ ConvertSpec { convertToIpynb = Identity toIpynb,+ convertInput = Identity inputFile,+ convertOutput = Identity outputFile,+ convertLhsStyle = Identity lhsStyle,+ convertOverwriteFiles = force }+ | toIpynb -> do+ unless force (failIfExists outputFile)+ lhsToIpynb lhsStyle inputFile outputFile+ | otherwise -> do+ unless force (failIfExists outputFile)+ ipynbToLhs lhsStyle inputFile outputFile++-- | Call fail when the named file already exists.+failIfExists :: FilePath -> IO ()+failIfExists file = do+ exists <- doesFileExist file+ when exists $ fail $+ printf "File %s already exists. To force supply --force." file++
+ src/IHaskell/Convert/Args.hs view
@@ -0,0 +1,107 @@+-- | Description: interpret flags parsed by "IHaskell.Flags"+module IHaskell.Convert.Args+ (ConvertSpec(..),+ fromJustConvertSpec,+ toConvertSpec,+ ) where++import Control.Applicative ((<$>))+import Control.Monad.Identity (Identity(Identity))+import Data.Char (toLower)+import Data.List (partition)+import Data.Maybe (fromMaybe)+import qualified Data.Text.Lazy as T (pack, Text)+import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))+import System.FilePath ((<.>), dropExtension, takeExtension)+import Text.Printf (printf)+++-- | ConvertSpec is the accumulator for command line arguments+data ConvertSpec f = ConvertSpec+ { convertToIpynb :: f Bool,+ convertInput :: f FilePath,+ convertOutput :: f FilePath,+ convertLhsStyle :: f (LhsStyle T.Text),+ convertOverwriteFiles :: Bool+ }++-- | Convert a possibly-incomplete specification for what to convert+-- into one which can be executed. Calls error when data is missing.+fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity+fromJustConvertSpec convertSpec = convertSpec {+ convertToIpynb = Identity toIpynb,+ convertInput = Identity inputFile,+ convertOutput = Identity outputFile,+ convertLhsStyle = Identity $ fromMaybe+ (T.pack <$> lhsStyleBird)+ (convertLhsStyle convertSpec)+ }+ where+ toIpynb = fromMaybe (error "Error: direction for conversion unknown")+ (convertToIpynb convertSpec)+ (inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of+ (Nothing, Nothing) -> error "Error: no files specified for conversion"+ (Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb")+ | otherwise -> (i, dropExtension i <.> "lhs")+ (Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o)+ | otherwise -> (dropExtension o <.> "ipynb", o)+ (Just i, Just o) -> (i, o)++-- | Does this @Argument@ explicitly request a file format?+isFormatSpec :: Argument -> Bool+isFormatSpec (ConvertToFormat _) = True+isFormatSpec (ConvertFromFormat _) = True+isFormatSpec _ = False+++toConvertSpec :: [Argument] -> ConvertSpec Maybe+toConvertSpec args = mergeArgs otherArgs+ (mergeArgs formatSpecArgs initialConvertSpec)+ where+ (formatSpecArgs, otherArgs) = partition isFormatSpec args+ initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False++mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe+mergeArgs args initialConvertSpec = foldr mergeArg initialConvertSpec args++mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe+mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }+mergeArg (ConvertLhsStyle lhsStyle) convertSpec+ | Just previousLhsStyle <- convertLhsStyle convertSpec,+ previousLhsStyle /= fmap T.pack lhsStyle = error $ printf+ "Conflicting lhs styles requested: <%s> and <%s>"+ (show lhsStyle) (show previousLhsStyle)+ | otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }+mergeArg (ConvertFrom inputFile) convertSpec+ | Just previousInputFile <- convertInput convertSpec,+ previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>"+ inputFile previousInputFile+ | otherwise = convertSpec {+ convertInput = Just inputFile,+ convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of+ (prev, Nothing) -> prev+ (prev @ (Just _), _) -> prev+ (Nothing, format) -> fmap (== LhsMarkdown) format+ }++mergeArg (ConvertTo outputFile) convertSpec+ | Just previousOutputFile <- convertOutput convertSpec,+ previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>"+ outputFile previousOutputFile+ | otherwise = convertSpec {+ convertOutput = Just outputFile,+ convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of+ (prev, Nothing) -> prev+ (prev @ (Just _), _) -> prev+ (Nothing, format) -> fmap (== IpynbFile) format+ }++mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "+ ++ show unexpectedArg++-- | Guess the format based on the file extension.+fromExt :: FilePath -> Maybe NotebookFormat+fromExt s = case map toLower (takeExtension s) of+ ".lhs" -> Just LhsMarkdown+ ".ipynb" -> Just IpynbFile+ _ -> Nothing
+ src/IHaskell/Convert/IpynbToLhs.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where++import Control.Applicative ((<$>))+import Data.Aeson (decode, Object, Value(Array, Object, String))+import qualified Data.ByteString.Lazy as L (readFile)+import qualified Data.HashMap.Strict as M (lookup)+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>), Monoid(mempty))+import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)+import qualified Data.Text.Lazy.IO as T (writeFile)+import Data.Vector (Vector)+import qualified Data.Vector as V (map, mapM, toList)+import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix))++ipynbToLhs :: LhsStyle T.Text+ -> FilePath -- ^ the filename of an ipython notebook+ -> FilePath -- ^ the filename of the literate haskell to write+ -> IO ()+ipynbToLhs sty from to = do+ Just (js :: Object) <- decode <$> L.readFile from+ case M.lookup "worksheets" js of+ Just (Array worksheets)+ | [ Object worksheet ] <- V.toList worksheets,+ Just (Array cells) <- M.lookup "cells" worksheet ->+ T.writeFile to $ T.unlines $ V.toList+ $ V.map (\(Object y) -> convCell sty y) cells+ _ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema" ++concatWithPrefix :: T.Text -- ^ the prefix to add to every line+ -> Vector Value -- ^ a json array of text lines+ -> Maybe T.Text+concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr++toStr :: Value -> Maybe T.Text+toStr (String x) = Just (T.fromStrict x)+toStr _ = Nothing++-- | @convCell sty cell@ converts a single cell in JSON into text suitable+-- for the type of lhs file described by the @sty@+convCell :: LhsStyle T.Text -> Object -> T.Text+convCell _sty object+ | Just (String "markdown") <- M.lookup "cell_type" object,+ Just (Array xs) <- M.lookup "source" object,+ ~ (Just s) <- concatWithPrefix "" xs = s+convCell sty object+ | Just (String "code") <- M.lookup "cell_type" object,+ Just (Array i) <- M.lookup "input" object,+ Just (Array o) <- M.lookup "outputs" object,+ ~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i,+ o <- fromMaybe mempty (convOutputs sty o) = "\n" <>+ lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"+convCell _ _ = "IHaskell.Convert.convCell: unknown cell"++convOutputs :: LhsStyle T.Text+ -> Vector Value -- ^ JSON array of output lines containing text or markup+ -> Maybe T.Text+convOutputs sty array = do+ outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array+ return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty++getTexts :: T.Text -> Value -> Maybe T.Text+getTexts p (Object object)+ | Just (Array text) <- M.lookup "text" object = concatWithPrefix p text+getTexts _ _ = Nothing
+ src/IHaskell/Convert/LhsToIpynb.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where++import Control.Applicative ((<$>))+import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String))+import qualified Data.ByteString.Lazy as L (writeFile)+import Data.Char (isSpace)+import Data.Monoid (Monoid(mempty))+import qualified Data.Text as TS (Text)+import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict)+import qualified Data.Text.Lazy.IO as T (readFile)+import qualified Data.Vector as V (fromList, singleton)+import IHaskell.Flags (LhsStyle(LhsStyle))++lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO ()+lhsToIpynb sty from to = do+ classed <- classifyLines sty . T.lines <$> T.readFile from+ L.writeFile to . encode . encodeCells $ groupClassified classed++data CellLine a = CodeLine a | OutputLine a | MarkdownLine a+ deriving Show++isCode :: CellLine t -> Bool+isCode (CodeLine _) = True+isCode _ = False++isOutput :: CellLine t -> Bool+isOutput (OutputLine _) = True+isOutput _ = False++isMD :: CellLine t -> Bool+isMD (MarkdownLine _) = True+isMD _ = False++isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool+isEmptyMD (MarkdownLine a) = a == mempty+isEmptyMD _ = False+++untag :: CellLine t -> t+untag (CodeLine a) = a+untag (OutputLine a) = a+untag (MarkdownLine a) = a++data Cell a = Code a a | Markdown a+ deriving (Show)++encodeCells :: [Cell [T.Text]] -> Value+encodeCells xs = object $+ [ "worksheets" .= Array (V.singleton (object+ [ "cells" .= Array (V.fromList (map cellToVal xs)) ] ))+ ] ++ boilerplate++cellToVal :: Cell [T.Text] -> Value+cellToVal (Code i o) = object $+ [ "cell_type" .= String "code",+ "collapsed" .= Bool False,+ "language" .= String "python", -- is what it IPython gives us+ "metadata" .= object [],+ "input" .= arrayFromTxt i,+ "outputs" .= Array + (V.fromList (+ [ object ["text" .= arrayFromTxt o,+ "metadata" .= object [],+ "output_type" .= String "display_data" ]+ | _ <- take 1 o])) ]++cellToVal (Markdown txt) = object $+ [ "cell_type" .= String "markdown",+ "metadata" .= object [],+ "source" .= arrayFromTxt txt ]++-- | arrayFromTxt makes a JSON array of string s+arrayFromTxt :: [T.Text] -> Value+arrayFromTxt i = Array (V.fromList (map (String . T.toStrict) i))++-- | ihaskell needs this boilerplate at the upper level to interpret the+-- json describing cells and output correctly.+boilerplate :: [(TS.Text, Value)]+boilerplate =+ [ "metadata" .= object [ "language" .= String "haskell", "name" .= String ""],+ "nbformat" .= Number 3,+ "nbformat_minor" .= Number 0 ]++groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]+groupClassified (CodeLine a : x)+ | (c,x) <- span isCode x,+ (_,x) <- span isEmptyMD x,+ (o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x+groupClassified (MarkdownLine a : x)+ | (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x+groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x+groupClassified [] = []++classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]+classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) = case (sp c, sp o) of+ (Just a, Nothing) -> CodeLine a : classifyLines sty ls+ (Nothing, Just a) -> OutputLine a : classifyLines sty ls+ (Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls+ _ -> error "IHaskell.Convert.classifyLines"+ where sp c = T.stripPrefix (T.dropWhile isSpace c) (T.dropWhile isSpace l)+classifyLines _ [] = [] +
src/IHaskell/Display.hs view
@@ -1,35 +1,60 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}++-- | If you are interested in the IHaskell library for the purpose of+-- augmenting the IHaskell notebook or writing your own display mechanisms+-- and widgets, this module contains all functions you need. +--+-- In order to create a display mechanism for a particular data type, write+-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.+-- (Note the capitalization - it's important!) Then, in that module, add an+-- instance of @IHaskellDisplay@ for your data type. Similarly, to create+-- a widget, add an instance of @IHaskellWidget@. +--+-- An example of creating a display is provided in the <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.+-- module IHaskell.Display (+ -- * Rich display and interactive display typeclasses and types IHaskellDisplay(..),- plain, html, png, jpg, svg, latex,- serializeDisplay,- Width, Height, Base64,- encode64, base64, Display(..), DisplayData(..),+ IHaskellWidget(..),++ -- ** Interactive use functions+ printDisplay,++ -- * Constructors for displays+ plain, html, png, jpg, svg, latex, javascript, many,++ -- ** Image and data encoding functions+ Width, Height, Base64(..),+ encode64, base64,++ -- ** Utilities+ switchToTmpDir,++ -- * Internal only use+ displayFromChan,+ serializeDisplay,+ Widget(..), ) where import ClassyPrelude import Data.Serialize as Serialize-import Data.ByteString hiding (map)+import Data.ByteString hiding (map, pack) import Data.String.Utils (rstrip) import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Char8 as Char+import Data.Aeson (Value) -import IHaskell.Types+import System.Directory(getTemporaryDirectory, setCurrentDirectory) -type Base64 = ByteString+import Control.Concurrent.STM.TChan+import System.IO.Unsafe (unsafePerformIO) --- | 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+import IHaskell.Types +type Base64 = Text+ -- | these instances cause the image, html etc. which look like: -- -- > Display@@ -59,20 +84,24 @@ -- | Generate a plain text display. plain :: String -> DisplayData-plain = DisplayData PlainText . Char.pack . rstrip+plain = DisplayData PlainText . pack . rstrip -- | Generate an HTML display. html :: String -> DisplayData-html = DisplayData MimeHtml . Char.pack+html = DisplayData MimeHtml . pack --- | Genreate an SVG display.+-- | Generate an SVG display. svg :: String -> DisplayData-svg = DisplayData MimeSvg . Char.pack+svg = DisplayData MimeSvg . pack --- | Genreate a LaTeX display.+-- | Generate a LaTeX display. latex :: String -> DisplayData-latex = DisplayData MimeLatex . Char.pack+latex = DisplayData MimeLatex . pack +-- | Generate a Javascript display.+javascript :: String -> DisplayData+javascript = DisplayData MimeJavascript . pack+ -- | Generate a PNG display of the given width and height. Data must be -- provided in a Base64 encoded manner, suitable for embedding into HTML. -- The @base64@ function may be used to encode data into this format.@@ -91,9 +120,44 @@ -- | Convert from a ByteString into base 64 encoded data. base64 :: ByteString -> Base64-base64 = Base64.encode+base64 = decodeUtf8 . Base64.encode -- | For internal use within IHaskell. -- Serialize displays to a ByteString. serializeDisplay :: Display -> ByteString serializeDisplay = Serialize.encode++-- | Items written to this chan will be included in the output sent+-- to the frontend (ultimately the browser), the next time IHaskell+-- has an item to display.+{-# NOINLINE displayChan #-}+displayChan :: TChan Display+displayChan = unsafePerformIO newTChanIO++-- | Take everything that was put into the 'displayChan' at that point+-- out, and make a 'Display' out of it.+displayFromChan :: IO (Maybe Display)+displayFromChan =+ Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)++-- | This is unfoldM from monad-loops. It repeatedly runs an IO action+-- until it return Nothing, and puts all the Justs in a list.+-- If you find yourself using more functionality from monad-loops, just add+-- the package dependency instead of copying more code from it.+unfoldM :: IO (Maybe a) -> IO [a]+unfoldM f = maybe (return []) (\r -> (r:) <$> unfoldM f) =<< f++-- | Write to the display channel. The contents will be displayed in the+-- notebook once the current execution call ends.+printDisplay :: IHaskellDisplay a => a -> IO ()+printDisplay disp = display disp >>= atomically . writeTChan displayChan++-- | Convenience function for client libraries. Switch to a temporary+-- directory so that any files we create aren't visible. On Unix, this is+-- usually /tmp.+switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))+ where + switchDir =+ getTemporaryDirectory >>=+ setCurrentDirectory+
src/IHaskell/Eval/Completion.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-} {- |-Description : Generates tab completion options.+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)@@ -11,7 +11,7 @@ -} module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where -import ClassyPrelude hiding (liftIO)+import ClassyPrelude hiding (init, last, head, liftIO) --import Prelude import Control.Applicative ((<$>))@@ -50,7 +50,7 @@ | Qualified String String | ModuleName String String | HsFilePath String String- | FilePath String String + | FilePath String String | KernelOption String | Extension String deriving (Show, Eq)@@ -69,14 +69,15 @@ moduleNames = nub $ concatMap getNames db let target = completionTarget line pos+ completion = completionType line pos target - let matchedText = case completionType line pos target of + let matchedText = case completion of HsFilePath _ match -> match FilePath _ match -> match otherwise -> intercalate "." target options <-- case completionType line pos target of+ case completion of Empty -> return [] Identifier candidate ->@@ -104,8 +105,8 @@ kernelOptNames = concatMap getSetName kernelOpts otherNames = ["-package","-Wall","-w"] - fNames = map extName fFlags ++ - map extName fWarningFlags ++ + fNames = map extName fFlags +++ map extName fWarningFlags ++ map extName fLangFlags fNoNames = map ("no"++) fNames fAllNames = map ("-f"++) (fNames ++ fNoNames)@@ -175,10 +176,18 @@ -- If it's empty, no completion. | null target = Empty++ -- When in a string, complete filenames.+ | cursorInString line loc + = FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)++ -- Complete module names in imports and elsewhere. | startswith "import" stripped && isModName = ModuleName dotted candidate | isModName && (not . null . init) target = Qualified dotted candidate++ -- Default to completing identifiers. | otherwise = Identifier candidate where stripped = strip line@@ -189,14 +198,34 @@ isModName = all isCapitalized (init target) isCapitalized = isUpper . head lineUpToCursor = take loc line- fileComplete filePath = case parseShell lineUpToCursor of + fileComplete filePath = case parseShell lineUpToCursor of Right xs -> filePath lineUpToCursor $ if endswith (last xs) lineUpToCursor then last xs else [] Left _ -> Empty + cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0 + nquotes ('\\':'"':xs) = nquotes xs+ nquotes ('"':xs) = 1 + nquotes xs+ nquotes (_:xs) = nquotes xs+ nquotes [] = 0++ -- Get the bit of a string that might be a filename completion.+ -- Logic is a bit convoluted, but basically go backwards from the+ -- end, stopping at any quote or space, unless they are escaped.+ getStringTarget :: String -> String+ getStringTarget = go "" . reverse+ where+ go acc rest = case rest of+ '"':'\\':rem -> go ('"':acc) rem+ '"':rem -> acc+ ' ':'\\':rem -> go (' ':acc) rem+ ' ':rem -> acc+ x:rem -> go (x:acc) rem+ [] -> acc+ -- | Get the word under a given cursor location. completionTarget :: String -> Int -> [String] completionTarget code cursor = expandCompletionPiece pieceToComplete@@ -212,7 +241,7 @@ delimPolicy = Drop } - isDelim :: Char -> Int -> Bool + isDelim :: Char -> Int -> Bool isDelim char idx = char `elem` neverIdent || isSymbol char splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]]@@ -286,4 +315,4 @@ visible = filter (not . isHidden) suggestions hidden = filter isHidden suggestions return $ visible ++ hidden- +
src/IHaskell/Eval/Evaluate.hs view
@@ -9,7 +9,7 @@ interpret, evaluate, Interpreter, liftIO, typeCleaner, globalImports ) where -import ClassyPrelude hiding (liftIO, hGetContents, try)+import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try) import Control.Concurrent (forkIO, threadDelay) import Prelude (putChar, head, tail, last, init, (!!)) import Data.List.Utils@@ -33,6 +33,7 @@ import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO) import qualified MonadUtils (MonadIO, liftIO) import System.Environment (getEnv)+import qualified Data.Map as Map import NameSet import Name@@ -51,7 +52,7 @@ import GHC hiding (Stmt, TypeSig) import GHC.Paths import Exception hiding (evaluate)-import Outputable+import Outputable hiding ((<>)) import Packages import Module import qualified Pretty@@ -68,13 +69,12 @@ import IHaskell.Display import qualified IHaskell.Eval.Hoogle as Hoogle import IHaskell.Eval.Util+import IHaskell.BrokenPackages+import qualified IHaskell.IPython.Message.UUID as UUID import Paths_ihaskell (version) import Data.Version (versionBranch) -import Language.Haskell.GHC.Interpret-import Language.Haskell.GHC.Util- data ErrorOccurred = Success | Failure deriving (Show, Eq) debug :: Bool@@ -102,7 +102,10 @@ globalImports :: [String] globalImports = [ "import IHaskell.Display()"- , "import qualified IPython.Stdin"+ , "import qualified Prelude as IHaskellPrelude"+ , "import qualified System.Directory as IHaskellDirectory"+ , "import qualified IHaskell.Display"+ , "import qualified IHaskell.IPython.Stdin" , "import qualified System.Posix.IO as IHaskellIO" , "import qualified System.IO as IHaskellSysIO" ]@@ -119,7 +122,7 @@ sandboxPackages <- liftIO getSandboxPackageConf let pkgConfs = case sandboxPackages of Nothing -> extraPkgConfs dflags- Just path -> + Just path -> let pkg = PkgConfFile path in (pkg:) . extraPkgConfs dflags @@ -130,7 +133,7 @@ -- 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+ let cmd = printf "IHaskell.IPython.Stdin.fixStdin \"%s\"" dir when allowedStdin $ void $ runStmt cmd RunToCompletion @@ -143,18 +146,18 @@ 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- --- -- XXX this will try to load broken packages, provided they depend- -- on the right ihaskell version+ -- and depend directly on the right version of the ihaskell library.+ -- Also verify that the packages we load are not broken. dflags <- getSessionDynFlags+ broken <- liftIO getBrokenPackages displayPackages <- liftIO $ do (dflags, _) <- initPackages dflags let Just db = pkgDatabase dflags packageNames = map (packageIdString . packageConfigId) db initStr = "ihaskell-"- -- "ihaskell-1.2.3.4"++ -- Name of the ihaskell package, e.g. "ihaskell-1.2.3.4" iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) dependsOnRight pkg = not $ null $ do@@ -169,12 +172,13 @@ -- 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")+ [] -> error ("cannot find required haskell library: " ++ iHaskellPkgName)+ _ -> error ("multiple haskell packages " ++ iHaskellPkgName ++ " found") displayPkgs = [ pkgName | pkgName <- packageNames, Just (x:_) <- [stripPrefix initStr pkgName],+ pkgName `notElem` broken, isAlpha x] return displayPkgs@@ -216,7 +220,8 @@ evalStatus :: ErrorOccurred, evalResult :: Display, evalState :: KernelState,- evalPager :: String+ evalPager :: String,+ evalComms :: [CommInfo] } -- | Evaluate some IPython input code.@@ -231,7 +236,7 @@ when (getLintStatus kernelState /= LintOff) $ liftIO $ do lintSuggestions <- lint cmds unless (noResults lintSuggestions) $- output $ FinalResult lintSuggestions ""+ output $ FinalResult lintSuggestions "" [] updated <- runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) return updated {@@ -246,19 +251,37 @@ runUntilFailure state (cmd:rest) = do evalOut <- evalCommand output cmd state - -- Output things only if they are non-empty.- let result = evalResult evalOut+ -- Get displayed channel outputs.+ -- Merge them with normal display outputs.+ dispsIO <- extractValue "IHaskell.Display.displayFromChan"+ dispsMay <- liftIO dispsIO+ let result = + case dispsMay of+ Nothing -> evalResult evalOut+ Just disps -> evalResult evalOut <> disps helpStr = evalPager evalOut- unless (noResults result && null helpStr) $- liftIO $ output $ FinalResult result helpStr - let newState = evalState evalOut+ -- Output things only if they are non-empty.+ let empty = noResults result && null helpStr && null (evalComms evalOut)+ unless empty $+ liftIO $ output $ FinalResult result helpStr (evalComms evalOut)++ -- Make sure to clear all comms we've started.+ let newState = evalState evalOut { evalComms = [] }+ case evalStatus evalOut of Success -> runUntilFailure newState rest Failure -> return newState storeItCommand execCount = Statement $ printf "let it%d = it" execCount + extractValue :: Typeable a => String -> Interpreter a+ extractValue expr = do+ compiled <- dynCompileExpr expr+ case fromDynamic compiled of+ Nothing -> error "Expecting value!"+ Just result -> return result+ safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler where@@ -268,27 +291,27 @@ evalStatus = Failure, evalResult = displayError $ show exception, evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } sourceErrorHandler :: SourceError -> Interpreter EvalOut sourceErrorHandler srcerr = do let msgs = bagToList $ srcErrorMessages srcerr errStrs <- forM msgs $ \msg -> do- shortStr <- doc $ errMsgShortDoc msg - contextStr <- doc $ errMsgExtraInfo msg + 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 = ""+ evalPager = "",+ evalComms = [] }- - wrapExecution :: KernelState -> Interpreter Display@@ -298,10 +321,10 @@ evalStatus = Success, evalResult = res, evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } - -- | Return the display data for this command, as well as whether it -- resulted in an error. evalCommand :: Publisher -> CodeBlock -> KernelState -> Interpreter EvalOut@@ -360,8 +383,8 @@ -- Since nothing prevents loading the module, compile and load it. Nothing -> doLoadModule modName modName --- | Directives set via `:set`. -evalCommand output (Directive SetDynFlag flags) state = +-- | Directives set via `:set`.+evalCommand output (Directive SetDynFlag flags) state = case words flags of -- For a single flag. [flag] -> do@@ -375,7 +398,8 @@ evalStatus = Success, evalResult = mempty, evalState = updater state,- evalPager = ""+ evalPager = "",+ evalComms = [] } -- If not a kernel option, must be a dyn flag.@@ -384,11 +408,25 @@ let display = case errs of [] -> mempty _ -> displayError $ intercalate "\n" errs++ -- For -XNoImplicitPrelude, remove the Prelude import.+ -- For -XImplicitPrelude, add it back in.+ case flag of+ "-XNoImplicitPrelude" -> + evalImport "import qualified Prelude as Prelude"+ "-XImplicitPrelude" -> do+ importDecl <- parseImportDecl "import Prelude"+ let implicitPrelude = importDecl { ideclImplicit = True }+ imports <- getContext+ setContext $ IIDecl implicitPrelude : imports+ _ -> return ()+ return EvalOut { evalStatus = Success, evalResult = display, evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } -- Apply many flags.@@ -419,7 +457,8 @@ evalStatus = Failure, evalResult = displayError err, evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } else let options = mapMaybe findOption $ words opts@@ -428,7 +467,8 @@ evalStatus = Success, evalResult = mempty, evalState = updater state,- evalPager = ""+ evalPager = "",+ evalComms = [] } where optionExists = isJust . findOption@@ -437,39 +477,51 @@ evalCommand _ (Directive GetType expr) state = wrapExecution state $ do write $ "Type: " ++ expr- formatType <$> getType expr+ formatType <$> ((expr ++ " :: ") ++ ) <$> getType expr +evalCommand _ (Directive GetKind expr) state = wrapExecution state $ do+ write $ "Kind: " ++ expr+ (_, kind) <- GHC.typeKind False expr+ flags <- getSessionDynFlags+ let typeStr = showSDocUnqual flags $ ppr kind+ return $ formatType $ expr ++ " :: " ++ typeStr+ evalCommand _ (Directive LoadFile name) state = wrapExecution state $ do write $ "Load: " ++ name let filename = if endswith ".hs" name then name else name ++ ".hs"- let modName = replace "/" "." $- if endswith ".hs" name- then replace ".hs" "" name- else name-+ contents <- readFile $ fpFromString filename+ modName <- intercalate "." <$> getModuleName contents doLoadModule filename modName -evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ liftIO $+evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ case words cmd of "cd":dirs -> do -- Get home so we can replace '~` with it.- homeEither <- try $ getEnv "HOME" :: IO (Either SomeException String)+ homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String)) let home = case homeEither of Left _ -> "~" Right val -> val let directory = replace "~" home $ unwords dirs- exists <- doesDirectoryExist directory+ exists <- liftIO $ doesDirectoryExist directory if exists then do- setCurrentDirectory directory+ -- Set the directory in IHaskell native code, for future shell+ -- commands. This doesn't set it for user code, though.+ liftIO $ setCurrentDirectory directory++ -- Set the directory for user code.+ let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $+ replace " " "\\ " $+ replace "\"" "\\\"" directory+ runStmt cmd RunToCompletion return mempty else return $ displayError $ printf "No such directory: '%s'" directory- cmd -> do+ cmd -> liftIO $ do (readEnd, writeEnd) <- createPipe handle <- fdToHandle writeEnd pipe <- fdToHandle readEnd@@ -537,7 +589,8 @@ evalStatus = Success, evalResult = Display [out], evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } where out = plain $ intercalate "\n" ["The following commands are available:"@@ -595,14 +648,15 @@ htmlify str = printf "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>%s</textarea></form></div>" str ++ script- script = + script = "<script>CodeMirror.fromTextArea(document.getElementById('code'), {mode: 'haskell', readOnly: 'nocursor'});</script>" return EvalOut { evalStatus = Success, evalResult = mempty, evalState = state,- evalPager = output+ evalPager = output,+ evalComms = [] } evalCommand _ (Directive SearchHoogle query) state = safely state $ do@@ -648,7 +702,7 @@ -- Return plain and html versions. -- Previously there was only a plain version.- text -> Display + text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text] @@ -665,8 +719,20 @@ let displayExpr = printf "(IHaskell.Display.display (%s))" expr :: String canRunDisplay <- attempt $ exprType displayExpr + -- Check if this is a widget.+ let widgetExpr = printf "(IHaskell.Display.Widget (%s))" expr :: String+ isWidget <- attempt $ exprType widgetExpr+ if canRunDisplay- then useDisplay displayExpr+ then do+ -- Use the display. As a result, `it` is set to the output.+ out <- useDisplay displayExpr++ -- Register the `it` object as a widget.+ if isWidget+ then registerWidget out+ else return out+ else do -- Evaluate this expression as though it's just a statement. -- The output is bound to 'it', so we can then use it.@@ -692,7 +758,7 @@ -- Check if the error is due to trying to print something that doesn't -- implement the Show typeclass. isShowError (ManyDisplay _) = False- isShowError (Display errs) = + 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 &&@@ -701,32 +767,69 @@ isSvg (DisplayData mime _) = mime == MimeSvg + removeSvg :: Display -> Display removeSvg (Display disps) = Display $ filter (not . isSvg) disps removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps - useDisplay displayExpr = wrapExecution state $ do+ useDisplay displayExpr = do -- If there are instance matches, convert the object into -- a Display. We also serialize it into a bytestring. We get- -- the bytestring as a dynamic and then convert back to+ -- the bytestring IO action as a dynamic and then convert back to -- a bytestring, which we promptly unserialize. Note that -- attempting to do this without the serialization to binary and -- back gives very strange errors - all the types match but it -- refuses to decode back into a Display. -- Suppress output, so as not to mess up console.- 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 ->- return $- if useSvg state- then display- else removeSvg display+ -- First, evaluate the expression in such a way that we have access to `it`.+ io <- isIO expr+ let stmtTemplate = if io+ then "it <- (%s)"+ else "let { it = %s }"+ evalOut <- evalCommand output (Statement $ printf stmtTemplate expr) state+ case evalStatus evalOut of+ Failure -> return evalOut+ Success -> wrapExecution state $ do+ -- Compile the display data into a bytestring.+ let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)"+ displayedBytestring <- dynCompileExpr compileExpr + -- Convert from the bytestring into a display.+ case fromDynamic displayedBytestring of+ Nothing -> error "Expecting lazy Bytestring"+ Just bytestringIO -> do+ bytestring <- liftIO bytestringIO+ case Serialize.decode bytestring of+ Left err -> error err+ Right display ->+ return $+ if useSvg state+ then display :: Display+ else removeSvg display++ registerWidget :: EvalOut -> Ghc EvalOut+ registerWidget evalOut =+ case evalStatus evalOut of+ Failure -> return evalOut+ Success -> do+ element <- dynCompileExpr "IHaskell.Display.Widget it"+ case fromDynamic element of+ Nothing -> error "Expecting widget"+ Just widget -> do+ -- Stick the widget in the kernel state.+ uuid <- liftIO UUID.random+ let state = evalState evalOut+ newComms = Map.insert uuid widget $ openComms state+ state' = state { openComms = newComms }++ -- Store the fact that we should start this comm.+ return evalOut {+ evalComms = CommInfo widget uuid (targetName widget) : evalComms evalOut,+ evalState = state'+ }++ isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr+ postprocessShowError :: EvalOut -> EvalOut postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps } where@@ -790,7 +893,8 @@ evalStatus = Failure, evalResult = displayError $ formatParseError loc err, evalState = state,- evalPager = ""+ evalPager = "",+ evalComms = [] } @@ -799,10 +903,11 @@ evalStatus = Success, evalResult = mempty, evalState = state,- evalPager = output+ evalPager = output,+ evalComms = [] } where- fmt = + fmt = case getFrontend state of IPythonNotebook -> Hoogle.HTML IPythonConsole -> Hoogle.Plain@@ -832,45 +937,72 @@ doLoadModule :: String -> String -> Ghc Display-doLoadModule name modName = flip gcatch unload $ do- -- Compile loaded modules.- flags <- getSessionDynFlags- let objTarget = defaultObjectTarget- setSessionDynFlags flags{ hscTarget = objTarget }-+doLoadModule name modName = do -- Remember which modules we've loaded before. importedModules <- getContext - -- Create a new target- target <- guessTarget name Nothing- addTarget target- result <- load LoadAllTargets+ flip gcatch (unload importedModules) $ do+ -- Compile loaded modules.+ flags <- getSessionDynFlags+ let objTarget = defaultObjectTarget+ setSessionDynFlags flags{ hscTarget = objTarget } - -- Reset the context, since loading things screws it up.- initializeItVariable+ -- Clear old targets to be sure.+ setTargets []+ load LoadAllTargets - -- Add imports- importDecl <- parseImportDecl $ "import " ++ modName- let implicitImport = importDecl { ideclImplicit = True }- setContext $ IIDecl implicitImport : importedModules+ -- Load the new target.+ target <- guessTarget name Nothing+ addTarget target+ result <- load LoadAllTargets - -- Switch back to interpreted mode.- flags <- getSessionDynFlags- setSessionDynFlags flags{ hscTarget = HscInterpreted }+ -- Reset the context, since loading things screws it up.+ initializeItVariable - case result of- Succeeded -> return mempty- Failed -> return $ displayError $ "Failed to load module " ++ modName+ -- 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+ unload :: [InteractiveImport] -> SomeException -> Ghc Display+ unload imported exception = do+ print $ show exception -- Explicitly clear targets setTargets [] load LoadAllTargets + -- Switch to interpreted mode!+ flags <- getSessionDynFlags+ setSessionDynFlags flags{ hscTarget = HscInterpreted }++ -- Return to old context, make sure we have `it`.+ setContext imported initializeItVariable+ return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception +keepingItVariable :: Interpreter a -> Interpreter a+keepingItVariable act = do+ -- Generate the it variable temp name+ gen <- liftIO getStdGen+ let rand = take 20 $ randomRs ('0', '9') gen+ var name = name ++ rand+ goStmt s = runStmt s RunToCompletion+ itVariable = var "it_var_temp_"+ + goStmt $ printf "let %s = it" itVariable+ val <- act+ goStmt $ printf "let it = %s" itVariable+ act+ capturedStatement :: (String -> IO ()) -- ^ Function used to publish intermediate output. -> String -- ^ Statement to evaluate. -> Interpreter (String, RunResult) -- ^ Return the output and result.@@ -893,7 +1025,7 @@ -- Variable used to store true `it` value. itVariable = var "it_var_" - voidpf str = printf $ str ++ " >> return ()"+ voidpf str = printf $ str ++ " IHaskellPrelude.>> IHaskellPrelude.return ()" -- Statements run before the thing we're evaluating. initStmts =@@ -915,10 +1047,11 @@ ] pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable + goStmt :: String -> Ghc RunResult goStmt s = runStmt s RunToCompletion -- Initialize evaluation context.- forM_ initStmts goStmt+ void $ forM initStmts goStmt -- Get the pipe to read printed output from. -- This is effectively the source code of dynCompileExpr from GHC API's@@ -1006,7 +1139,7 @@ liftIO $ modifyMVar_ completed (const $ return True) -- Finalize evaluation context.- forM_ postStmts goStmt+ void $ forM postStmts goStmt -- Once context is finalized, reading can finish. -- Wait for reading to finish to that the output accumulator is
src/IHaskell/Eval/Hoogle.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}-module IHaskell.Eval.Hoogle ( +module IHaskell.Eval.Hoogle ( search, document, render,@@ -7,7 +7,7 @@ HoogleResult ) where -import ClassyPrelude hiding (span, div)+import ClassyPrelude hiding (last, span, div) import Text.Printf import Network.HTTP import Data.Aeson@@ -93,7 +93,7 @@ [] -> [NoResult "no matching identifiers found."] res -> res where- matches (SearchResult resp) = + matches (SearchResult resp) = case split " " $ self resp of name:_ -> strip string == strip name _ -> False@@ -109,33 +109,33 @@ -- | Render a Hoogle result to plain text. renderPlain :: HoogleResult -> String -renderPlain (NoResult res) = +renderPlain (NoResult res) = "No response available: " ++ res -renderPlain (SearchResult resp) = - printf "%s\nURL: %s\n%s" +renderPlain (SearchResult resp) =+ printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp) -renderPlain (DocResult resp) = - printf "%s\nURL: %s\n%s" +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) = +renderHtml (NoResult resp) = printf "<span class='err-msg'>No result: %s</span>" resp -renderHtml (DocResult resp) = - renderSelf (self resp) (location resp) +renderHtml (DocResult resp) =+ renderSelf (self resp) (location resp) ++ renderDocs (docs resp) renderHtml (SearchResult resp) =- renderSelf (self resp) (location resp) + renderSelf (self resp) (location resp) ++ renderDocs (docs resp) @@ -156,17 +156,17 @@ span "hoogle-class" (link loc $ extractClass string) ++ packageSub package - | otherwise + | otherwise = let [name, args] = split "::" string package = extractPackageName loc modname = extractModuleName loc in- span "hoogle-name" (unicodeReplace $ + span "hoogle-name" (unicodeReplace $ link loc (strip name) ++ " :: " ++ strip args) ++ packageAndModuleSub package modname - where + where extractPackage = strip . replace "package" "" extractModule = strip . replace "module" "" extractClass = strip . replace "class" ""@@ -176,28 +176,28 @@ unicodeReplace :: String -> String unicodeReplace =- replace "forall" "∀" . - replace "=>" "⇒" . - replace "->" "→" . + replace "forall" "∀" .+ replace "=>" "⇒" .+ replace "->" "→" . replace "::" "∷" packageSub Nothing = "" packageSub (Just package) =- span "hoogle-sub" $ + 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 ++ + span "hoogle-sub" $+ "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")" renderDocs :: String -> String-renderDocs doc = +renderDocs doc = let groups = groupBy bothAreCode $ lines doc nonull = filter (not . null . strip)- bothAreCode s1 s2 = + bothAreCode s1 s2 = startswith ">" (strip s1) && startswith ">" (strip s2) isCode (s:_) = startswith ">" $ strip s
src/IHaskell/Eval/Lint.hs view
@@ -4,34 +4,49 @@ ) where import Data.String.Utils (replace, startswith, strip, split)-import Prelude (head, tail)-import Language.Haskell.HLint as HLint-import ClassyPrelude+import Prelude (head, tail, last)+import ClassyPrelude hiding (last) import Control.Monad import Data.List (findIndex) import Text.Printf import Data.String.Here import Data.Char import Data.Monoid+import Data.Maybe (mapMaybe)+import System.IO.Unsafe (unsafePerformIO) +import Language.Haskell.Exts.Annotated.Syntax hiding (Module)+import qualified Language.Haskell.Exts.Annotated.Syntax as SrcExts+import Language.Haskell.Exts.Annotated (parseFileContentsWithMode)+import Language.Haskell.Exts.Annotated.Build (doE)+import Language.Haskell.Exts.Annotated hiding (Module)+import Language.Haskell.Exts.SrcLoc++import Language.Haskell.HLint as HLint+import Language.Haskell.HLint2+ import IHaskell.Types import IHaskell.Display import IHaskell.IPython import IHaskell.Eval.Parser hiding (line) -data LintSeverity = LintWarning | LintError deriving (Eq, Show)+type ExtsModule = SrcExts.Module SrcSpanInfo data LintSuggestion = Suggest { line :: LineNumber,- chunkNumber :: Int, found :: String, whyNot :: String,- severity :: LintSeverity,+ severity :: Severity, suggestion :: String } deriving (Eq, Show) +-- Store settings for Hlint once it's initialized.+{-# NOINLINE hlintSettings #-}+hlintSettings :: MVar (ParseFlags, [Classify], Hint)+hlintSettings = unsafePerformIO newEmptyMVar+ -- | Identifier used when one is needed for proper context. lintIdent :: String lintIdent = "lintIdentAEjlkQeh"@@ -40,32 +55,107 @@ -- 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"+ -- Initialize hlint settings+ initialized <- not <$> isEmptyMVar hlintSettings+ when (not initialized) $ do+ autoSettings >>= putMVar hlintSettings - writeFile (fromString filename) fileContents- suggestions <- catMaybes <$> map parseSuggestion <$> hlint [filename, "--quiet"]+ -- Get hlint settings+ (flags, classify, hint) <- readMVar hlintSettings+ let mode = hseFlags flags++ -- create 'suggestions'+ let modules = mapMaybe (createModule mode) blocks+ ideas = applyHints classify hint modules+ suggestions = mapMaybe showIdea ideas+ return $ Display $ if null suggestions then [] else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]++showIdea :: Idea -> Maybe LintSuggestion+showIdea idea = + case ideaTo idea of+ Nothing -> Nothing+ Just whyNot -> Just Suggest {+ line = srcSpanStartLine $ ideaSpan idea,+ found = showSuggestion $ ideaFrom idea,+ whyNot = showSuggestion $ whyNot,+ severity = ideaSeverity idea,+ suggestion = ideaHint idea+ }++createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule+createModule mode (Located line block) = + case block of+ Expression expr -> unparse $ exprToModule expr+ Declaration decl -> unparse $ declToModule decl + Statement stmt -> unparse $ stmtToModule stmt+ Import impt -> unparse $ imptToModule impt+ Module mod -> unparse $ parseModule mod+ _ -> Nothing 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 .. ]+ blockStr = + case block of+ Expression expr -> expr+ Declaration decl -> decl + Statement stmt -> stmt+ Import impt -> impt+ Module mod -> mod - addPragma :: Int -> Located String -> String- addPragma i (Located desiredLine str) = linePragma desiredLine i ++ str+ unparse :: ParseResult a -> Maybe a+ unparse (ParseOk a) = Just a+ unparse _ = Nothing - linePragma = printf "{-# LINE %d \"%d\" #-}\n"+ srcSpan :: SrcSpan+ srcSpan = SrcSpan {+ srcSpanFilename = "<interactive>",+ srcSpanStartLine = line,+ srcSpanStartColumn = 0,+ srcSpanEndLine = line + length (lines blockStr),+ srcSpanEndColumn = length $ last $ lines blockStr+ } + loc :: SrcSpanInfo+ loc = SrcSpanInfo srcSpan []++ moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule + moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl]++ parseModule :: String -> ParseResult ExtsModule+ parseModule = parseFileContentsWithMode mode++ declToModule :: String -> ParseResult ExtsModule+ declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl++ exprToModule :: String -> ParseResult ExtsModule+ exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp++ stmtToModule :: String -> ParseResult ExtsModule+ stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of+ ParseOk stmt -> ParseOk mod+ ParseFailed a b -> ParseFailed a b+ where+ mod = moduleWithDecls decl++ decl :: Decl SrcSpanInfo+ decl = SpliceDecl loc expr++ expr :: Exp SrcSpanInfo+ expr = doE loc [stmt, ret]++ stmt :: Stmt SrcSpanInfo+ ParseOk stmt = parseStmtWithMode mode stmtStr++ ret :: Stmt SrcSpanInfo+ ParseOk ret = Qualifier loc <$> parseExp lintIdent++ imptToModule :: String -> ParseResult ExtsModule+ imptToModule = parseFileContentsWithMode mode+ plainSuggestion :: LintSuggestion -> String plainSuggestion suggest = printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s"@@ -91,9 +181,12 @@ where severityClass = case severity suggest of- LintWarning -> "warning"- LintError -> "error"+ Error -> "error"+ Warning -> "warning" + -- Should not occur+ _ -> "warning"+ style :: String -> String -> String style cls thing = [i| <div class="suggestion-${cls}">${thing}</div> |] @@ -106,52 +199,9 @@ 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 = - remove ("return " ++ lintIdent) .- remove (lintIdent ++ "=") .- dropDo+showSuggestion = remove lintIdent . dropDo where remove str = replace str "" @@ -159,7 +209,7 @@ dropDo :: String -> String dropDo string = -- If this is not a statement, we don't need to drop the do statement.- if ("return " ++ lintIdent) `isInfixOf` string+ if lintIdent `isInfixOf` string then unlines . clean . lines $ string else string @@ -180,43 +230,3 @@ -- Ignore other list elements - just proceed onwards. clean (x:xs) = x : clean xs clean [] = []---- | 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/Parser.hs view
@@ -10,12 +10,11 @@ layoutChunks, parseDirective, getModuleName,- unloc, Located(..), ) where -- Hide 'unlines' to use our own 'joinLines' instead.-import ClassyPrelude hiding (liftIO, unlines)+import ClassyPrelude hiding (head, tail, liftIO, unlines, maximumBy) import Data.List (findIndex, maximumBy, maximum, inits) import Data.String.Utils (startswith, strip, split)@@ -26,6 +25,7 @@ import ErrUtils hiding (ErrMsg) import FastString import GHC hiding (Located)+import GhcMonad import Lexer import OrdList import Outputable hiding ((<>))@@ -63,10 +63,11 @@ | GetHelp -- ^ General help via ':?' or ':help'. | SearchHoogle -- ^ Search for something via Hoogle. | GetDoc -- ^ Get documentation for an identifier via Hoogle.+ | GetKind -- ^ Get the kind of a type via ':kind'. deriving (Show, Eq) -- | Parse a string into code blocks.-parseString :: GhcMonad m => String -> m [Located CodeBlock]+parseString :: String -> Ghc [Located CodeBlock] parseString codeString = do -- Try to parse this as a single module. flags <- getSessionDynFlags@@ -112,7 +113,7 @@ activateParsingExtensions :: GhcMonad m => CodeBlock -> m () activateParsingExtensions (Directive SetExtension ext) = void $ setExtension ext-activateParsingExtensions (Directive SetDynFlag flags) = +activateParsingExtensions (Directive SetDynFlag flags) = case stripPrefix "-X" flags of Just ext -> void $ setExtension ext Nothing -> return ()@@ -189,38 +190,26 @@ -- 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)+joinFunctions [] = []+joinFunctions blocks = + if signatureOrDecl $ unloc $ head blocks+ then Located lnum (conjoin $ map unloc decls) : joinFunctions rest+ else head blocks : joinFunctions (tail blocks)+ where + decls = takeWhile (signatureOrDecl . unloc) blocks+ rest = drop (length decls) blocks+ lnum = line $ head decls - isNamedDecl :: String -> Located CodeBlock -> Bool- isNamedDecl name (Located _ (Declaration dec)) = head (words dec) == name- isNamedDecl _ _ = False+ signatureOrDecl (Declaration _) = True+ signatureOrDecl (TypeSignature _) = True+ signatureOrDecl _ = 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 [] = []+ str (Declaration s) = s+ str (TypeSignature s) = s+ str _ = error "Expected declaration or signature" + conjoin :: [CodeBlock] -> CodeBlock+ conjoin = Declaration . intercalate "\n" . map str -- | Parse a directive of the form :directiveName. parseDirective :: String -- ^ Directive string.@@ -232,7 +221,7 @@ Just (directiveType, _) -> Directive directiveType arg where arg = unwords restLine _:restLine = words directive- Nothing -> + Nothing -> let directiveStart = case words directive of [] -> "" first:_ -> first in@@ -243,6 +232,7 @@ dir:_ -> dir `elem` tail (inits dirname) directives = [ (GetType, "type")+ , (GetKind, "kind") , (GetInfo, "info") , (SearchHoogle, "hoogle") , (GetDoc, "documentation")@@ -264,7 +254,7 @@ let output = runParser flags parserModule moduleSrc case output of Failure {} -> error "Module parsing failed."- Parsed mod -> + 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
@@ -1,20 +1,51 @@ module IHaskell.Eval.Util (+ -- * Initialization+ initGhci,++ -- * Flags and extensions+ -- ** Set and unset flags. extensionFlag, setExtension, ExtFlag(..),+ setFlags,++ -- * Code Evaluation+ evalImport,+ evalDeclarations,+ getType,++ -- * Pretty printing+ doc, ) where -- GHC imports.+import DynFlags+import FastString import GHC import GhcMonad-import DynFlags+import HsImpExp+import HscTypes+import InteractiveEval+import Module+import Outputable+import Packages+import RdrName+import qualified Pretty +import Control.Monad (void)+import Data.Function (on) import Data.List (find)+import Data.String.Utils (replace) +-- | A extension flag that can be set or unset. data ExtFlag = SetFlag ExtensionFlag | UnsetFlag ExtensionFlag -extensionFlag :: String -> Maybe ExtFlag+-- | Find the extension that corresponds to a given flag. Create the+-- corresponding 'ExtFlag' via @SetFlag@ or @UnsetFlag@.+-- If no such extension exist, yield @Nothing@.+extensionFlag :: String -- Extension name, such as @"DataKinds"@+ -> Maybe ExtFlag extensionFlag ext = case find (flagMatches ext) xFlags of Just (_, flag, _) -> Just $ SetFlag flag@@ -33,8 +64,8 @@ -- 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.+-- | 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@@ -46,3 +77,116 @@ SetFlag ghcFlag -> xopt_set flags ghcFlag UnsetFlag ghcFlag -> xopt_unset flags ghcFlag return Nothing++-- | Set a list of flags, as per GHCi's `:set`.+-- This was adapted from GHC's InteractiveUI.hs (newDynFlags).+-- It returns a list of error messages.+setFlags :: GhcMonad m => [String] -> m [String]+setFlags ext = do+ -- Try to parse flags.+ flags <- getSessionDynFlags+ (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext)++ -- First, try to check if this flag matches any extension name.+ let restorePkg x = x { packageFlags = packageFlags flags }+ let restoredPkgs = flags' { packageFlags = packageFlags flags}+ GHC.setProgramDynFlags restoredPkgs+ GHC.setInteractiveDynFlags restoredPkgs++ -- Create the parse errors.+ let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized+ allWarns = map unLoc warnings ++ + ["-package not supported yet" | packageFlags flags /= packageFlags flags']+ warnErrs = map ("Warning: " ++) allWarns+ return $ noParseErrs ++ warnErrs++-- | Convert an 'SDoc' into a string. This is similar to the family of+-- 'showSDoc' functions, but does not impose an arbitrary width limit on+-- the output (in terms of number of columns). Instead, it respsects the+-- 'pprCols' field in the structure returned by 'getSessionDynFlags', and+-- thus gives a configurable width of output.+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++-- | Initialize the GHC API. Run this as the first thing in the `runGhc`.+-- This initializes some dyn flags (@ExtendedDefaultRules@,+-- @NoMonomorphismRestriction@), sets the target to interpreted, link in+-- memory, sets a reasonable output width, and potentially a few other+-- things. It should be invoked before other functions from this module.+initGhci :: GhcMonad m => m ()+initGhci = do+ -- Initialize dyn flags.+ -- Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction.+ originalFlags <- getSessionDynFlags+ let flag = flip xopt_set+ unflag = flip xopt_unset+ dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags++ void $ setSessionDynFlags $ dflags { hscTarget = HscInterpreted,+ ghcLink = LinkInMemory,+ pprCols = 300 }++-- | Evaluate a single import statement.+-- If this import statement is importing a module which was previously+-- imported implicitly (such as `Prelude`) or if this module has a `hiding`+-- annotation, the previous import is removed.+evalImport :: GhcMonad m => String -> m ()+evalImport imports = do+ importDecl <- parseImportDecl imports+ context <- getContext++ -- If we've imported this implicitly, remove the old import.+ let noImplicit = filter (not . implicitImportOf importDecl) context++ -- If this is a `hiding` import, remove previous non-`hiding` imports.+ oldImps = if isHiddenImport importDecl+ then filter (not . importOf importDecl) context+ else noImplicit++ -- Replace the context.+ setContext $ IIDecl importDecl : oldImps++ where+ -- Check whether an import is the same as another import (same module).+ importOf :: ImportDecl RdrName -> InteractiveImport -> Bool+ importOf _ (IIModule _) = False+ importOf imp (IIDecl decl) = ((==) `on` (unLoc . ideclName)) decl imp++ -- Check whether an import is an *implicit* import of something.+ implicitImportOf :: ImportDecl RdrName -> InteractiveImport -> Bool+ implicitImportOf _ (IIModule _) = False+ implicitImportOf imp (IIDecl decl) = ideclImplicit decl && imp `importOf` IIDecl decl++ -- Check whether an import is hidden.+ isHiddenImport :: ImportDecl RdrName -> Bool+ isHiddenImport imp = case ideclHiding imp of+ Just (True, _) -> True+ _ -> False++-- | Evaluate a series of declarations.+-- Return all names which were bound by these declarations.+evalDeclarations :: GhcMonad m => String -> m [String]+evalDeclarations decl = do+ names <- runDecls decl+ flags <- getSessionDynFlags+ return $ map (replace ":Interactive." "" . showPpr flags) names++-- | Get the type of an expression and convert it to a string.+getType :: GhcMonad m => String -> m String+getType expr = do+ result <- exprType expr+ flags <- getSessionDynFlags+ let typeStr = showSDocUnqual flags $ ppr result+ return typeStr
src/IHaskell/Flags.hs view
@@ -1,8 +1,11 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-} module IHaskell.Flags ( IHaskellMode(..), Argument(..), Args(..),+ LhsStyle(..),+ lhsStyleBird,+ NotebookFormat(..), parseFlags, help, ) where@@ -10,6 +13,7 @@ import ClassyPrelude import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Text+import Data.List (findIndex) import IHaskell.Types @@ -23,15 +27,37 @@ | Extension String -- ^ An extension to load at startup. | ConfFile String -- ^ A file with commands to load at startup. | IPythonFrom String -- ^ Which executable to use for IPython.+ | OverwriteFiles -- ^ Present when output should overwrite existing files. + | ConvertFrom String+ | ConvertTo String + | ConvertFromFormat NotebookFormat+ | ConvertToFormat NotebookFormat+ | ConvertLhsStyle (LhsStyle String) | Help -- ^ Display help text. deriving (Eq, Show) +data LhsStyle string = LhsStyle+ { lhsCodePrefix :: string, -- ^ @>@+ lhsOutputPrefix :: string, -- ^ @<<@+ lhsBeginCode :: string, -- ^ @\\begin{code}@+ lhsEndCode :: string, -- ^ @\\end{code}@+ lhsBeginOutput :: string, -- ^ @\\begin{verbatim}@+ lhsEndOutput :: string -- ^ @\\end{verbatim}@+ }+ deriving (Eq, Functor, Show)++data NotebookFormat+ = LhsMarkdown+ | IpynbFile+ deriving (Eq,Show)+ -- Which mode IHaskell is being invoked in. -- `None` means no mode was specified. data IHaskellMode = ShowHelp String | Notebook | Console+ | ConvertLhs | Kernel (Maybe String) | View (Maybe ViewFormat) (Maybe String) deriving (Eq, Show)@@ -39,8 +65,23 @@ -- | Given a list of command-line arguments, return the IHaskell mode and -- arguments to process. parseFlags :: [String] -> Either String Args-parseFlags = process ihaskellArgs+parseFlags flags = + let modeIndex = findIndex (`elem` modeFlags) flags in+ case modeIndex of+ Nothing -> Left $ "No mode provided. Modes available are: " ++ show modeFlags ++ "\n" +++ pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)+ Just 0 -> process ihaskellArgs flags + -- If mode not first, move it to be first.+ Just idx -> + let (start, first:end) = splitAt idx flags in+ process ihaskellArgs $ first:start ++ end+ where+ modeFlags = concatMap modeNames allModes++allModes :: [Mode Args]+allModes = [console, notebook, view, kernel, convert]+ -- | Get help text for a given IHaskell ode. help :: IHaskellMode -> String help mode = @@ -49,6 +90,7 @@ chooseMode Console = console chooseMode Notebook = notebook chooseMode (Kernel _) = kernel+ chooseMode ConvertLhs = convert ipythonFlag :: Flag Args ipythonFlag = @@ -75,14 +117,51 @@ console :: Mode Args console = mode "console" (Args Console []) "Console-based interactive repl." noArgs $ ipythonFlag:universalFlags +kernel :: Mode Args 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 +convert :: Mode Args+convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlags+ where+ description = "Convert between Literate Haskell (*.lhs) and Ipython notebooks (*.ipynb)."+ convertFlags = universalFlags+ ++ [ flagReq ["input","i"] (store ConvertFrom) "<file>" "File to read."+ , flagReq ["output","o"] (store ConvertTo) "<file>" "File to write."+ , flagReq ["from","f"] (storeFormat ConvertFromFormat) "lhs|ipynb" "Format of the file to read."+ , flagReq ["to","t"] (storeFormat ConvertToFormat) "lhs|ipynb" "Format of the file to write."+ , flagNone ["force"] consForce "Overwrite existing files with output."+ , flagReq ["style","s"] storeLhs "bird|tex" "Type of markup used for the literate haskell file"+ , flagNone ["bird"] (consStyle lhsStyleBird) "Literate haskell uses >"+ , flagNone ["tex"] (consStyle lhsStyleTex ) "Literate haskell uses \\begin{code}"+ ]++ consForce (Args mode prev) = Args mode (OverwriteFiles : prev)+ unnamedArg = Arg (store ConvertFrom) "<file>" False+ consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev)++ storeFormat constructor str (Args mode prev) = case toLower str of+ "lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev+ "ipynb" -> Right $ Args mode $ constructor IpynbFile : prev+ _ -> Left $ "Unknown format requested: " ++ str++ storeLhs str previousArgs = case toLower str of+ "bird" -> success lhsStyleBird+ "tex" -> success lhsStyleTex+ _ -> Left $ "Unknown lhs style: " ++ str+ where+ success lhsStyle = Right $ consStyle lhsStyle previousArgs++lhsStyleBird, lhsStyleTex :: LhsStyle String+lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" ""+lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"++ view :: Mode Args view =- let empty = mode "view" (Args (View Nothing Nothing) []) "View IHaskell notebook." noArgs [ipythonFlag] in+ let empty = mode "view" (Args (View Nothing Nothing) []) "View IHaskell notebook." noArgs flags in empty { modeNames = ["view"], modeCheck =@@ -102,6 +181,7 @@ } where+ flags = [ipythonFlag, flagHelpSimple (add Help)] formatArg = flagArg updateFmt "<format>" filenameArg = flagArg updateFile "<name>[.ipynb]" updateFmt fmtStr (Args (View _ s) flags) = @@ -109,6 +189,7 @@ Just fmt -> Right $ Args (View (Just fmt) s) flags Nothing -> Left $ "Invalid format '" ++ fmtStr ++ "'." updateFile name (Args (View f _) flags) = Right $ Args (View f (Just name)) flags+ add flag (Args mode flags) = Args mode $ flag : flags ihaskellArgs :: Mode Args ihaskellArgs =@@ -116,7 +197,7 @@ 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, kernel] }+ noMode { modeGroupModes = toGroup allModes } where add flag (Args mode flags) = Args mode $ flag : flags
src/IHaskell/IPython.hs view
@@ -26,36 +26,56 @@ import Data.List.Utils (split) import Data.String.Utils (rstrip, endswith, strip, replace) import Text.Printf+import Data.Maybe (fromJust) import qualified System.IO.Strict as StrictIO import qualified Paths_ihaskell as Paths import qualified Codec.Archive.Tar as Tar import IHaskell.Types+import System.Posix.Signals -- | Which IPython to use. data WhichIPython = DefaultIPython -- ^ Use the one that IHaskell tries to install. | ExplicitIPython String -- ^ Use the command-line flag provided one.---- | Which commit of IPython we are on.-ipythonCommit :: Text-ipythonCommit = "4a08574f74201ef7ca39a4e80d19a2d158ab6950"+ deriving Eq -- | The IPython profile name. ipythonProfile :: String ipythonProfile = "haskell" +-- | The current IPython profile version.+-- This must be the same as the file in the profile.tar.+-- The filename used is @profileVersionFile@.+profileVersion :: String+profileVersion = "0.3.0.5"++-- | Filename in the profile where the version ins kept.+profileVersionFile :: FilePath+profileVersionFile = ".profile_version"+ -- | Run IPython with any arguments. ipython :: WhichIPython -- ^ Which IPython to use (user-provided or IHaskell-installed). -> Bool -- ^ Whether to suppress output. -> [Text] -- ^ IPython command line arguments. -> Sh String -- ^ IPython output.-ipython which suppress args = do- runCmd <- liftIO $ Paths.getDataFileName "installation/run.sh"- venv <- fpToText <$> ipythonDir- let cmdArgs = [pack runCmd, venv] ++ args- runHandles "bash" cmdArgs handles doNothing+ipython which suppress args+ | which == DefaultIPython = do+ runCmd <- liftIO $ Paths.getDataFileName "installation/run.sh"+ venv <- fpToText <$> ipythonDir+ let cmdArgs = [pack runCmd, venv] ++ args+ -- If we have PYTHONDONTWRITEBYTECODE enabled, everything breaks.+ setenv "PYTHONDONTWRITEBYTECODE" ""++ liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing++ -- We have this because using `run` does not let us use stdin.+ runHandles "bash" cmdArgs handles doNothing+ | otherwise = do+ let ExplicitIPython exe = which+ runHandles (fpFromString exe) args handles doNothing+ where handles = [InHandle Inherit, outHandle suppress, errorHandle suppress] outHandle True = OutHandle CreatePipe outHandle False = OutHandle Inherit@@ -100,10 +120,10 @@ ipythonSourceDir = ensure $ (</> "ipython-src") <$> ihaskellDir getIHaskellDir :: IO String-getIHaskellDir = shellyNoDir $ fpToString <$> ihaskellDir+getIHaskellDir = shelly $ fpToString <$> ihaskellDir defaultConfFile :: IO (Maybe String)-defaultConfFile = shellyNoDir $ do+defaultConfFile = shelly $ do filename <- (</> "rc.hs") <$> ihaskellDir exists <- test_f filename return $ if exists@@ -114,7 +134,7 @@ -- Notebooks are searched in the current directory as well as the IHaskell -- notebook directory (in that order). nbconvert :: WhichIPython -> ViewFormat -> String -> IO ()-nbconvert which fmt name = void . shellyNoDir $ do+nbconvert which fmt name = void . shelly $ do curdir <- pwd nbdir <- notebookDir @@ -143,7 +163,7 @@ setupIPython :: WhichIPython -> IO () setupIPython (ExplicitIPython path) = do- exists <- shellyNoDir $+ exists <- shelly $ test_f $ fromString path unless exists $@@ -151,14 +171,33 @@ setupIPython DefaultIPython = do installed <- ipythonInstalled- if installed- then updateIPython- else installIPython+ when (not installed) $ do+ path <- shelly $ which "ipython"+ case path of+ Just ipythonPath -> checkIPythonVersion ipythonPath+ Nothing -> badIPython "Did not detect IHaskell-installed or system IPython."+ where+ checkIPythonVersion :: FilePath -> IO ()+ checkIPythonVersion path = do+ output <- unpack <$> shelly (silently $ run path ["--version"])+ case parseVersion output of+ Just (2:_) -> putStrLn "Using system-wide IPython."+ Just (1:_) -> badIPython "Detected old version of IPython. IHaskell requires 2.0.0 or up."+ Nothing -> badIPython "Detected IPython, but could not parse version number." + badIPython :: Text -> IO ()+ badIPython reason = void $ do+ putStrLn reason+ putStrLn "IHaskell will not proceed to install IPython (locally for itself)."+ putStrLn "Installing IPython in IHaskell's virtualenv in 10 seconds. Ctrl-C to cancel."+ threadDelay $ 1000 * 1000 * 10+ installIPython++ -- | Replace "~" with $HOME if $HOME is defined. -- Otherwise, do nothing. subHome :: String -> IO String-subHome path = shellyNoDir $ do+subHome path = shelly $ do home <- unpack <$> fromMaybe "~" <$> get_env "HOME" return $ replace "~" home path @@ -175,11 +214,19 @@ Just exePath -> return exePath -- | 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+parseVersion :: String -> Maybe [Int]+parseVersion versionStr = + let versions = map read' $ split "." versionStr+ parsed = all isJust versions in+ if parsed+ then Just $ map fromJust versions+ else Nothing+ where + read' :: String -> Maybe Int+ read' x = + case reads x of+ [(n, _)] -> Just n+ _ -> Nothing -- | Run an IHaskell application using the given profile. runIHaskell :: WhichIPython@@ -192,23 +239,24 @@ errExit False $ ipython which 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+ if exitCode /= 0+ then liftIO $ do putStrLn "Creating IPython profile." setupIPythonProfile which profile+ -- If the profile exists, update it if necessary.+ else updateIPythonProfile which profile -- Run the IHaskell command. ipython which False $ map pack $ [app, "--profile", profile] ++ args runConsole :: WhichIPython -> InitInfo -> IO ()-runConsole which initInfo = void . shellyNoDir $ do+runConsole which initInfo = void . shelly $ do writeInitInfo initInfo runIHaskell which ipythonProfile "console" [] runNotebook :: WhichIPython -> InitInfo -> Maybe String -> IO ()-runNotebook which initInfo maybeServeDir = void . shellyNoDir $ do+runNotebook which initInfo maybeServeDir = void . shelly $ do notebookDirStr <- fpToString <$> notebookDir let args = case maybeServeDir of Nothing -> ["--notebook-dir", unpack notebookDirStr]@@ -223,7 +271,7 @@ liftIO $ writeFile filename $ show info readInitInfo :: IO InitInfo-readInitInfo = shellyNoDir $ do+readInitInfo = shelly $ do filename <- (</> ".last-arguments") <$> ihaskellDir read <$> liftIO (readFile filename) @@ -231,7 +279,7 @@ setupIPythonProfile :: WhichIPython -> String -- ^ IHaskell profile name. -> IO ()-setupIPythonProfile which profile = shellyNoDir $ do+setupIPythonProfile which profile = shelly $ do -- Create the IPython profile. void $ ipython which True ["profile", "create", pack profile] @@ -243,18 +291,29 @@ liftIO $ copyProfile profileDir insertIHaskellPath profileDir -removeIPythonProfile :: WhichIPython -> String -> Sh ()-removeIPythonProfile which profile = do- -- Try to locate the profile. Do not die if it doesn't exist.- errExit False $ ipython which True ["locate", "profile", pack profile]-- -- If the profile exists, delete it.+-- | Update the IPython profile.+updateIPythonProfile :: WhichIPython+ -> String -- ^ IHaskell profile name.+ -> Sh ()+updateIPythonProfile which profile = do+ -- Find out whether the profile exists.+ dir <- pack <$> rstrip <$> errExit False (ipython which True ["locate", "profile", pack profile]) exitCode <- lastExitCode- dir <- pack <$> rstrip <$> ipython which True ["locate"]- when (exitCode == 0 && dir /= "") $ do+ updated <- if exitCode == 0 && dir /= ""+ then do+ let versionFile = fpFromText dir </> profileVersionFile+ fileExists <- test_f versionFile+ if not fileExists+ then return False+ else liftIO $ do+ contents <- StrictIO.readFile $ fpToString versionFile+ return $ strip contents == profileVersion+ else return False++ when (not updated) $ do putStrLn "Updating IPython profile."- let profileDir = dir ++ "/profile_" ++ pack profile ++ "/"- rm_rf $ fromText profileDir+ liftIO $ copyProfile dir+ insertIHaskellPath $ dir ++ "/" -- | Copy the profile files into the IPython profile. copyProfile :: Text -> IO ()@@ -300,7 +359,7 @@ return $ FS.encodeString $ FS.decodeString cd FS.</> f getSandboxPackageConf :: IO (Maybe String)-getSandboxPackageConf = shellyNoDir $ do+getSandboxPackageConf = shelly $ do myPath <- getIHaskellPath let sandboxName = ".cabal-sandbox" if not $ sandboxName`isInfixOf` myPath@@ -317,37 +376,28 @@ -- | Check whether IPython is properly installed. ipythonInstalled :: IO Bool-ipythonInstalled = shellyNoDir $ do+ipythonInstalled = shelly $ do ipythonPath <- ipythonExePath DefaultIPython test_f ipythonPath --- | Update the IPython source tree and rebuild.-updateIPython :: IO ()-updateIPython = do- updateScript <- Paths.getDataFileName "installation/update.sh"- venv <- fpToText <$> shellyNoDir ipythonDir- runTmp updateScript [venv, ipythonCommit]-- -- Remove the old IPython profile.- -- A new one will be regenerated when it is needed.- -- shellyNoDir $ removeIPythonProfile DefaultIPython ipythonProfile- -- | Install IPython from source. installIPython :: IO ()-installIPython = do+installIPython = shelly $ do -- Print a message and wait a little.- putStrLn "Installing IPython for IHaskell. This may take a while."- threadDelay $ 3 * 1000 * 100+ liftIO $ do+ putStrLn "Installing IPython for IHaskell. This may take a while."+ threadDelay $ 500 * 1000 -- Set up the virtualenv.- virtualenvScript <- Paths.getDataFileName "installation/virtualenv.sh"- venvDir <- fpToText <$> shellyNoDir ipythonDir+ virtualenvScript <- liftIO $ Paths.getDataFileName "installation/virtualenv.sh"+ venvDir <- fpToText <$> ipythonDir runTmp virtualenvScript [venvDir] -- Set up Python depenencies.- installScript <- Paths.getDataFileName "installation/ipython.sh"- runTmp installScript [venvDir, ipythonCommit]+ setenv "ARCHFLAGS" "-Wno-error=unused-command-line-argument-hard-error-in-future"+ installScript <- liftIO $ Paths.getDataFileName "installation/ipython.sh"+ runTmp installScript [venvDir] -runTmp script args = shellyNoDir $ withTmpDir $ \tmp -> do+runTmp script args = withTmpDir $ \tmp -> do cd tmp run_ "bash" $ pack script: args
+ src/IHaskell/IPython/Kernel.hs view
@@ -0,0 +1,16 @@+-- | This module exports all the types and functions necessary to create an+-- IPython language kernel that supports the @ipython console@ and @ipython+-- notebook@ frontends. +module IHaskell.IPython.Kernel (+ module IHaskell.IPython.Types,+ module IHaskell.IPython.Message.Writer,+ module IHaskell.IPython.Message.Parser,+ module IHaskell.IPython.Message.UUID,+ module IHaskell.IPython.ZeroMQ,+ ) where++import IHaskell.IPython.Types+import IHaskell.IPython.Message.Writer+import IHaskell.IPython.Message.Parser+import IHaskell.IPython.Message.UUID+import IHaskell.IPython.ZeroMQ
+ src/IHaskell/IPython/Message/Parser.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE OverloadedStrings #-}+-- | 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.IPython.Message.Parser (parseMessage) where++import Data.Aeson ((.:), decode, Result(..), Object)+import Control.Applicative ((<|>))+import Data.Aeson.Types (parse)+import Data.ByteString+import Data.Map (Map)+import Data.Text (Text)++import qualified Data.ByteString.Lazy as Lazy++import IHaskell.IPython.Types++type LByteString = Lazy.ByteString++----- 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 Text Text)++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 InputReplyMessage = inputReplyParser+parser CommOpenMessage = commOpenParser+parser CommDataMessage = commDataParser+parser CommCloseMessage = commCloseParser+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++inputReplyParser :: LByteString -> Message+inputReplyParser content = parsed+ where+ Success parsed = flip parse decoded $ \ obj -> do+ value <- obj .: "value"+ return $ InputReply noHeader value++ Just decoded = decode content++commOpenParser :: LByteString -> Message+commOpenParser content = parsed+ where+ Success parsed = flip parse decoded $ \ obj -> do+ uuid <- obj .: "comm_id"+ name <- obj .: "target_name"+ value <- obj .: "data"+ return $ CommOpen noHeader name uuid value++ Just decoded = decode content++commDataParser :: LByteString -> Message+commDataParser content = parsed+ where+ Success parsed = flip parse decoded $ \ obj -> do+ uuid <- obj .: "comm_id"+ value <- obj .: "data"+ return $ CommData noHeader uuid value++ Just decoded = decode content++commCloseParser :: LByteString -> Message+commCloseParser content = parsed+ where+ Success parsed = flip parse decoded $ \ obj -> do+ uuid <- obj .: "comm_id"+ value <- obj .: "data"+ return $ CommClose noHeader uuid value++ Just decoded = decode content
+ src/IHaskell/IPython/Message/UUID.hs view
@@ -0,0 +1,46 @@+-- | Description : UUID generator and data structure+--+-- Generate, parse, and pretty print UUIDs for use with IPython.+module IHaskell.IPython.Message.UUID (+ UUID,+ random, randoms,+ ) where++import Control.Monad (mzero, replicateM)+import Control.Applicative ((<$>))+import Data.Text (pack)+import Data.Aeson+import Data.UUID.V4 (nextRandom)++import Text.Read as Read hiding (pfail, String)+++-- 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 (Show, Read, Eq, Ord)++-- | 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
+ src/IHaskell/IPython/Message/Writer.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Description : @ToJSON@ for Messages+--+-- This module contains the @ToJSON@ instance for @Message@.+module IHaskell.IPython.Message.Writer (+ ToJSON(..)+) where++import Data.Aeson+import Data.Map (Map)+import Data.Text (Text, pack)+import Data.Monoid (mempty)++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B+import Data.Text.Encoding++import IHaskell.IPython.Types++-- Convert message bodies into JSON.+instance ToJSON Message where+ toJSON KernelInfoReply{ versionList = vers, language = language } = object [+ "protocol_version" .= ints [4, 0], -- current protocol version, major and minor+ "language_version" .= vers,+ "language" .= language+ ]++ toJSON ExecuteReply{ status = status, executionCounter = counter, pagerOutput = pager} = object [+ "status" .= show status,+ "execution_count" .= counter,+ "payload" .= + if null pager+ then []+ else [object [+ "source" .= string "page",+ "text" .= pager+ ]],+ "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 string "ok" 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 RequestInput{inputPrompt = prompt} = object [+ "prompt" .= prompt+ ]++ toJSON req@CommOpen{} = object [+ "comm_id" .= commUuid req,+ "target_name" .= commTargetName req,+ "data" .= commData req+ ]++ toJSON req@CommData{} = object [+ "comm_id" .= commUuid req,+ "data" .= commData req+ ]++ toJSON req@CommClose{} = object [+ "comm_id" .= commUuid req,+ "data" .= commData req+ ]++ 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 (DisplayData mimeType dataStr) =+ pack (show mimeType) .= String dataStr++----- Constants -----++emptyMap :: Map String String+emptyMap = mempty++emptyList :: [Int]+emptyList = []++ints :: [Int] -> [Int]+ints = id++string :: String -> String+string = id
+ src/IHaskell/IPython/Stdin.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}+-- | This module provides a way in which the Haskell standard input may be+-- forwarded to the IPython frontend and thus allows the notebook to use+-- the standard input.+--+-- This relies on the implementation of file handles in GHC, and is+-- generally unsafe and terrible. However, it is difficult to find another+-- way to do it, as file handles are generally meant to point to streams+-- and files, and not networked communication protocols.+--+-- In order to use this module, it must first be initialized with two+-- things. First of all, in order to know how to communicate with the+-- IPython frontend, it must know the kernel profile used for+-- communication. For this, use @recordKernelProfile@ once the profile is+-- known. Both this and @recordParentHeader@ take a directory name where+-- they can store this data.+--+-- Finally, the module must know what @execute_request@ message is+-- currently being replied to (which will request the input). Thus, every+-- time the language kernel receives an @execute_request@ message, it+-- should inform this module via @recordParentHeader@, so that the module+-- may generate messages with an appropriate parent header set. If this is+-- not done, the IPython frontends will not recognize the target of the+-- communication.+--+-- Finally, in order to activate this module, @fixStdin@ must be called+-- once. It must be passed the same directory name as @recordParentHeader@+-- and @recordKernelProfile@. Note that if this is being used from within+-- the GHC API, @fixStdin@ /must/ be called from within the GHC session+-- not from the host code.+module IHaskell.IPython.Stdin (+ fixStdin,+ recordParentHeader,+ recordKernelProfile+ ) where++import Control.Concurrent +import Control.Applicative ((<$>))+import Control.Concurrent.Chan+import Control.Monad+import GHC.IO.Handle+import GHC.IO.Handle.Types+import System.IO+import System.Posix.IO+import System.IO.Unsafe+import qualified Data.Map as Map++import IHaskell.IPython.Types+import IHaskell.IPython.ZeroMQ+import IHaskell.IPython.Message.UUID as UUID++stdinInterface :: MVar ZeroMQStdin+{-# NOINLINE stdinInterface #-}+stdinInterface = unsafePerformIO newEmptyMVar++-- | Manipulate standard input so that it is sourced from the IPython+-- frontend. This function is build on layers of deep magical hackery, so+-- be careful modifying it.+fixStdin :: String -> IO ()+fixStdin dir = do+ -- Initialize the stdin interface.+ profile <- read <$> readFile (dir ++ "/.kernel-profile")+ interface <- serveStdin profile+ putMVar stdinInterface interface+ void $ forkIO $ stdinOnce dir++stdinOnce :: String -> IO ()+stdinOnce dir = do+ -- Create a pipe using and turn it into handles.+ (readEnd, writeEnd) <- createPipe+ newStdin <- fdToHandle readEnd+ stdinInput <- fdToHandle writeEnd+ hSetBuffering newStdin NoBuffering+ hSetBuffering stdinInput NoBuffering++ -- Store old stdin and swap in new stdin.+ oldStdin <- hDuplicate stdin+ hDuplicateTo newStdin stdin++ loop stdinInput oldStdin newStdin+ where+ loop stdinInput oldStdin newStdin = do+ let FileHandle _ mvar = stdin+ threadDelay $ 150 * 1000+ empty <- isEmptyMVar mvar+ if not empty+ then loop stdinInput oldStdin newStdin+ else do+ line <- getInputLine dir+ hPutStr stdinInput $ line ++ "\n"+ loop stdinInput oldStdin newStdin++-- | Get a line of input from the IPython frontend.+getInputLine :: String -> IO String+getInputLine dir = do+ StdinChannel req rep <- readMVar stdinInterface++ -- Send a request for input.+ uuid <- UUID.random+ parentHeader <- read <$> readFile (dir ++ "/.last-req-header")+ let header = MessageHeader {+ username = username parentHeader,+ identifiers = identifiers parentHeader,+ parentHeader = Just parentHeader,+ messageId = uuid,+ sessionId = sessionId parentHeader,+ metadata = Map.fromList [],+ msgType = InputRequestMessage+ }+ let msg = RequestInput header ""+ writeChan req msg++ -- Get the reply.+ InputReply _ value <- readChan rep+ return value++recordParentHeader :: String -> MessageHeader -> IO ()+recordParentHeader dir header =+ writeFile (dir ++ "/.last-req-header") $ show header++recordKernelProfile :: String -> Profile -> IO ()+recordKernelProfile dir profile =+ writeFile (dir ++ "/.kernel-profile") $ show profile
+ src/IHaskell/IPython/Types.hs view
@@ -0,0 +1,416 @@+{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}+-- | This module contains all types used to create an IPython language+-- kernel.+module IHaskell.IPython.Types (+ -- * IPython kernel profile+ Profile(..),+ Transport(..),+ Port(..),+ IP(..),++ -- * IPython messaging protocol+ Message(..),+ MessageHeader(..),+ Username(..),+ Metadata(..),+ MessageType(..),+ Width(..), Height(..),+ StreamType(..),+ ExecutionState(..),+ ExecuteReplyStatus(..),+ replyType,++ -- ** IPython display data message+ DisplayData(..),+ MimeType(..),+ extractPlain+ + ) where++import Data.Aeson+import Control.Applicative ((<$>), (<*>))+import Data.ByteString (ByteString)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Text (Text)+import Data.Serialize+import IHaskell.IPython.Message.UUID+import GHC.Generics (Generic)+import Data.Typeable+import Data.List (find)+import Data.Map (Map)++-------------------- IPython Kernel Profile Types ----------------------+-- | A TCP port.+type Port = Int++-- | An IP address.+type IP = String++-- | The transport mechanism used to communicate with the IPython frontend.+data Transport+ = TCP -- ^ Default transport mechanism via TCP.+ deriving (Show, Read)++-- | A kernel profile, specifying how the kernel communicates.+data Profile = Profile {+ ip :: IP, -- ^ The IP on which to listen.+ transport :: Transport, -- ^ 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 :: Text -- ^ The HMAC encryption key.+ } deriving (Show, Read)++-- 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+ ]++instance FromJSON Transport where+ parseJSON (String mech) =+ case mech of+ "tcp" -> return TCP+ _ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech+ parseJSON _ = fail "Expected JSON string as transport."++instance ToJSON Transport where+ toJSON TCP = String "tcp"+++-------------------- IPython Message Types ----------------------++-- | 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, Read)++-- 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" .= showMessageType (msgType header)+ ]++-- | A username for the source of a message.+type Username = Text++-- | A metadata dictionary.+type Metadata = Map Text Text++-- | 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+ | InputRequestMessage+ | InputReplyMessage+ | CommOpenMessage+ | CommDataMessage+ | CommCloseMessage+ deriving (Show, Read, Eq)++showMessageType :: MessageType -> String+showMessageType KernelInfoReplyMessage = "kernel_info_reply"+showMessageType KernelInfoRequestMessage = "kernel_info_request"+showMessageType ExecuteReplyMessage = "execute_reply"+showMessageType ExecuteRequestMessage = "execute_request"+showMessageType StatusMessage = "status"+showMessageType StreamMessage = "stream"+showMessageType DisplayDataMessage = "display_data"+showMessageType OutputMessage = "pyout"+showMessageType InputMessage = "pyin"+showMessageType CompleteRequestMessage = "complete_request"+showMessageType CompleteReplyMessage = "complete_reply"+showMessageType ObjectInfoRequestMessage = "object_info_request"+showMessageType ObjectInfoReplyMessage = "object_info_reply"+showMessageType ShutdownRequestMessage = "shutdown_request"+showMessageType ShutdownReplyMessage = "shutdown_reply"+showMessageType ClearOutputMessage = "clear_output"+showMessageType InputRequestMessage = "input_request"+showMessageType InputReplyMessage = "input_reply"+showMessageType CommOpenMessage = "comm_open" +showMessageType CommDataMessage = "comm_msg" +showMessageType CommCloseMessage = "comm_close" ++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+ "input_request" -> return InputRequestMessage+ "input_reply" -> return InputReplyMessage+ "comm_open" -> return CommOpenMessage+ "comm_msg" -> return CommDataMessage+ "comm_close" -> return CommCloseMessage++ _ -> 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,+ versionList :: [Int], -- ^ The version of the language, e.g. [7, 6, 3] for GHC 7.6.3+ language :: String -- ^ The language name, e.g. "haskell"+ }+ + -- | A request from a frontend to execute some code.+ | ExecuteRequest {+ header :: MessageHeader,+ getCode :: Text, -- ^ 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 :: [Text], -- ^ Unused.+ getUserExpressions :: [Text] -- ^ Unused.+ }++ -- | A reply to an execute request.+ | ExecuteReply {+ header :: MessageHeader,+ status :: ExecuteReplyStatus, -- ^ The status of the output.+ pagerOutput :: String, -- ^ The help string to show in the pager.+ 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 :: Text, {- ^+ 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 :: Text, -- ^ 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 :: [Text],+ completionMatchedText :: Text,+ completionText :: Text,+ completionStatus :: Bool+ }++ | ObjectInfoRequest {+ header :: MessageHeader, + objectName :: Text, -- ^ 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 :: Text, -- ^ Name of object which was searched for.+ objectFound :: Bool, -- ^ Whether the object was found.+ objectTypeString :: Text, -- ^ Object type.+ objectDocString :: Text + }++ | 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.+ }++ | RequestInput {+ header :: MessageHeader,+ inputPrompt :: String + }++ | InputReply {+ header :: MessageHeader,+ inputValue :: String + }++ | CommOpen {+ header :: MessageHeader,+ commTargetName :: String,+ commUuid :: UUID,+ commData :: Value+ }++ | CommData {+ header :: MessageHeader,+ commUuid :: UUID,+ commData :: Value+ }++ | CommClose {+ header :: MessageHeader,+ commUuid :: UUID,+ commData :: Value+ }++ | SendNothing -- Dummy message; nothing is sent.+ 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++-- | Input and output streams.+data StreamType = Stdin | Stdout deriving Show++-- | Get the reply message type for a request message type.+replyType :: MessageType -> Maybe MessageType+replyType KernelInfoRequestMessage = Just KernelInfoReplyMessage+replyType ExecuteRequestMessage = Just ExecuteReplyMessage+replyType CompleteRequestMessage = Just CompleteReplyMessage+replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage+replyType ShutdownRequestMessage = Just ShutdownReplyMessage+replyType _ = Nothing++-- | Data for display: a string with associated MIME type.+data DisplayData = DisplayData MimeType Text deriving (Typeable, Generic)++-- We can't print the actual data, otherwise this will be printed every+-- time it gets computed because of the way the evaluator is structured.+-- See how `displayExpr` is computed.+instance Show DisplayData where+ show _ = "DisplayData"++-- Allow DisplayData serialization+instance Serialize Text where+ put str = put (Text.encodeUtf8 str)+ get = Text.decodeUtf8 <$> get+instance Serialize DisplayData+instance Serialize MimeType++-- | Possible MIME types for the display data.+type Width = Int+type Height = Int+data MimeType = PlainText+ | MimeHtml+ | MimePng Width Height+ | MimeJpg Width Height+ | MimeSvg+ | MimeLatex+ | MimeJavascript+ deriving (Eq, Typeable, Generic)++-- Extract the plain text from a list of displays.+extractPlain :: [DisplayData] -> String+extractPlain disps =+ case find isPlain disps of+ Nothing -> ""+ Just (DisplayData PlainText bytestr) -> Text.unpack bytestr+ where+ isPlain (DisplayData mime _) = mime == PlainText++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"+ show MimeJavascript = "application/javascript"
+ src/IHaskell/IPython/ZeroMQ.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}+-- | 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.IPython.ZeroMQ (+ ZeroMQInterface (..),+ ZeroMQStdin(..),+ serveProfile,+ serveStdin,+ ) where++import qualified Data.ByteString.Lazy as ByteString+import Data.ByteString (ByteString)+import Control.Concurrent+import Control.Monad +import System.IO.Unsafe+import Data.Aeson (encode)+import System.ZMQ4 hiding (stdin)++import IHaskell.IPython.Types+import IHaskell.IPython.Message.Parser+import IHaskell.IPython.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.+ }++data ZeroMQStdin = StdinChannel {+ stdinRequestChannel :: Chan Message,+ stdinReplyChannel :: Chan Message+ }++-- | 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++ -- 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++serveStdin :: Profile -> IO ZeroMQStdin +serveStdin profile = do+ reqChannel <- newChan+ repChannel <- newChan+ + -- Create the context in a separate thread that never finishes. If+ -- withContext or withSocket complete, the context or socket become invalid.+ forkIO $ withContext $ \context ->+ -- Serve on all sockets.+ serveSocket context Router (stdinPort profile) $ \socket -> do+ -- Read the request from the interface channel and send it.+ readChan reqChannel >>= sendMessage socket++ -- Receive a response and write it to the interface channel.+ receiveMessage socket >>= writeChan repChannel++ return $ StdinChannel reqChannel repChannel++-- | 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 $ "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++-- | 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 _ SendNothing = return ()+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
src/IHaskell/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}+{-# LANGUAGE ExistentialQuantification #-} -- | Description : All message type definitions. module IHaskell.Types ( Message (..),@@ -24,17 +25,23 @@ extractPlain, kernelOpts, KernelOpt(..),+ IHaskellDisplay(..),+ IHaskellWidget(..),+ Widget(..),+ CommInfo(..), ) where import ClassyPrelude import qualified Data.ByteString.Char8 as Char import Data.Serialize import GHC.Generics+import Data.Map (Map, empty)+import Data.Aeson (Value) import Text.Read as Read hiding (pfail, String) import Text.ParserCombinators.ReadP -import IPython.Kernel+import IHaskell.IPython.Kernel data ViewFormat = Pdf@@ -64,6 +71,58 @@ "md" -> return Markdown _ -> pfail +-- | 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++-- | Display as an interactive widget.+class IHaskellDisplay a => IHaskellWidget a where+ -- | Output target name for this widget.+ -- The actual input parameter should be ignored.+ targetName :: a -> String++ -- | Called when the comm is opened. Allows additional messages to be sent+ -- after comm open.+ open :: a -- ^ Widget to open a comm port with.+ -> (Value -> IO ()) -- ^ Way to respond to the message.+ -> IO ()+ open _ _ = return ()++ -- | Respond to a comm data message.+ comm :: a -- ^ Widget which is being communicated with.+ -> Value -- ^ Sent data.+ -> (Value -> IO ()) -- ^ Way to respond to the message.+ -> IO ()+ comm _ _ _ = return ()++ -- | Close the comm, releasing any resources we might need to.+ close :: a -- ^ Widget to close comm port with.+ -> Value -- ^ Sent data.+ -> IO ()+ close _ _ = return ()++data Widget = forall a. IHaskellWidget a => Widget a+ deriving Typeable++instance IHaskellDisplay Widget where+ display (Widget widget) = display widget++instance IHaskellWidget Widget where+ targetName (Widget widget) = targetName widget+ open (Widget widget) = open widget+ comm (Widget widget) = comm widget+ close (Widget widget) = close widget++instance Show Widget where+ show _ = "<Widget>"++ -- | Wrapper for ipython-kernel's DisplayData which allows sending multiple -- results from the same expression. data Display = Display [DisplayData]@@ -78,6 +137,9 @@ a `mappend` ManyDisplay b = ManyDisplay (a : b) a `mappend` b = ManyDisplay [a,b] +instance Semigroup Display where+ a <> b = a `mappend` b+ -- | All state stored in the kernel between executions. data KernelState = KernelState { getExecutionCounter :: Int,@@ -85,7 +147,9 @@ getFrontend :: FrontendType, useSvg :: Bool, useShowErrors :: Bool,- useShowTypes :: Bool+ useShowTypes :: Bool,+ usePager :: Bool,+ openComms :: Map UUID Widget } deriving Show @@ -96,7 +160,9 @@ getFrontend = IPythonConsole, useSvg = True, useShowErrors = False,- useShowTypes = False+ useShowTypes = False,+ usePager = True,+ openComms = empty } data FrontendType@@ -121,6 +187,8 @@ , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False } , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True } , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }+ , KernelOpt ["pager"] [] $ \state -> state { usePager = True }+ , KernelOpt ["no-pager"] [] $ \state -> state { usePager = False } ] -- | Initialization information for the kernel.@@ -138,6 +206,7 @@ | LintOff deriving (Eq, Show) +data CommInfo = CommInfo Widget UUID String -- | Output of evaluation. data EvaluationResult =@@ -147,6 +216,7 @@ outputs :: Display -- ^ Display outputs. } | FinalResult {- outputs :: Display, -- ^ Display outputs.- pagerOut :: String -- ^ Text to display in the IPython pager.+ outputs :: Display, -- ^ Display outputs.+ pagerOut :: String, -- ^ Text to display in the IPython pager.+ startComms :: [CommInfo] -- ^ Comms to start. }
src/Main.hs view
@@ -1,17 +1,17 @@ {-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables #-} -- | Description : Argument parsing and basic messaging loop, using Haskell--- Chans to communicate with the ZeroMQ sockets. +-- Chans to communicate with the ZeroMQ sockets. module Main where -- Prelude imports.-import ClassyPrelude hiding (liftIO)+import ClassyPrelude hiding (last, liftIO) import Prelude (last, read) -- Standard library imports. import Control.Concurrent (threadDelay) import Control.Concurrent.Chan import Data.Aeson-import Data.String.Utils (strip)+import Data.Text (strip) import System.Directory import System.Exit (exitSuccess) import Text.Printf@@ -19,20 +19,22 @@ import qualified Data.Map as Map -- IHaskell imports.+import IHaskell.Convert (convert) import IHaskell.Eval.Completion (complete) import IHaskell.Eval.Evaluate+import IHaskell.Display import IHaskell.Eval.Info import IHaskell.Flags import IHaskell.IPython import IHaskell.Types-import IPython.ZeroMQ+import IHaskell.IPython.ZeroMQ+import IHaskell.IPython.Types import qualified Data.ByteString.Char8 as Chars-import qualified IPython.Message.UUID as UUID-import qualified IPython.Stdin as Stdin+import qualified IHaskell.IPython.Message.UUID as UUID+import qualified IHaskell.IPython.Stdin as Stdin -- GHC API imports. 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]@@ -45,7 +47,7 @@ main = do args <- parseFlags <$> map unpack <$> getArgs case args of- Left errorMessage -> + Left errorMessage -> hPutStrLn stderr errorMessage Right args -> ihaskell args@@ -57,9 +59,11 @@ ihaskell :: Args -> IO () -- If no mode is specified, print help text.-ihaskell (Args (ShowHelp help) _) = +ihaskell (Args (ShowHelp help) _) = putStrLn $ pack help- ++ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args+ ihaskell (Args Console flags) = showingHelp Console flags $ do ipython <- chooseIPython flags setupIPython ipython@@ -68,7 +72,7 @@ info <- initInfo IPythonConsole flags runConsole ipython info -ihaskell (Args (View (Just fmt) (Just name)) args) = do+ihaskell (Args mode@(View (Just fmt) (Just name)) args) = showingHelp mode args $ do ipython <- chooseIPython args nbconvert ipython fmt name @@ -113,7 +117,7 @@ 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 }@@ -155,12 +159,12 @@ -- reason (completely unknown to me). liftIO ignoreCtrlC - -- Initialize the context by evaluating everything we got from the + -- 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+ noPublish _ = return ()+ evaluator line = void $ do -- Create a new state each time. stateVar <- liftIO initialKernelState state <- liftIO $ takeMVar stateVar@@ -176,17 +180,30 @@ -- 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+ -- We handle comm messages and normal ones separately.+ -- The normal ones are a standard request/response style, while comms+ -- can be anything, and don't necessarily require a response.+ if isCommMessage request+ then liftIO $ do+ oldState <- takeMVar state+ let replier = writeChan (iopubChannel interface)+ newState <- handleComm replier oldState request replyHeader+ putMVar state newState+ writeChan (shellReplyChannel interface) SendNothing+ else do+ -- Create the reply, possibly modifying kernel state.+ oldState <- liftIO $ takeMVar state+ (newState, reply) <- replyTo interface request replyHeader oldState+ liftIO $ putMVar state newState - -- Write the reply to the reply channel.- liftIO $ writeChan (shellReplyChannel interface) reply+ -- Write the reply to the reply channel.+ liftIO $ writeChan (shellReplyChannel interface) reply where ignoreCtrlC = installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing + isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]+ -- Initial kernel state. initialKernelState :: IO (MVar KernelState) initialKernelState =@@ -217,7 +234,7 @@ msgType = repType } --- | Compute a reply to a message. +-- | 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@@ -270,8 +287,24 @@ sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts sendOutput (Display outs) = do header <- dupHeader replyHeader DisplayDataMessage- send $ PublishDisplayData header "haskell" outs+ send $ PublishDisplayData header "haskell" $ map convertSvgToHtml outs + convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg+ convertSvgToHtml x = x+ makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"++ startComm :: CommInfo -> IO ()+ startComm (CommInfo widget uuid target) = do+ -- Send the actual comm open.+ header <- dupHeader replyHeader CommOpenMessage+ send $ CommOpen header target uuid (Object mempty)++ -- Send anything else the widget requires.+ let communicate value = do+ head <- dupHeader replyHeader CommDataMessage+ writeChan (iopubChannel interface) $ CommData head uuid value+ open widget communicate+ publish :: EvaluationResult -> IO () publish result = do let final = case result of@@ -296,23 +329,32 @@ when final $ do modifyMVar_ displayed (return . (outs:)) + -- Start all comms that need to be started.+ mapM_ startComm $ startComms result+ -- If this has some pager output, store it for later. let pager = pagerOut result unless (null pager) $- modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))+ if usePager state+ then modifyMVar_ pagerOutput (return . (++ pager ++ "\n"))+ else sendOutput $ Display [html pager] let execCount = getExecutionCounter state -- Let all frontends know the execution count and code that's about to run inputHeader <- liftIO $ dupHeader replyHeader InputMessage- send $ PublishInput inputHeader (Chars.unpack code) execCount+ send $ PublishInput inputHeader (unpack code) execCount+ -- Run code and publish to the frontend as we go.- updatedState <- evaluate state (Chars.unpack code) publish+ updatedState <- evaluate state (unpack code) publish -- Notify the frontend that we're done computing. idleHeader <- liftIO $ dupHeader replyHeader StatusMessage send $ PublishStatus idleHeader Idle - pager <- liftIO $ readMVar pagerOutput+ -- Take pager output if we're using the pager.+ pager <- if usePager state+ then liftIO $ readMVar pagerOutput+ else return "" return (updatedState, ExecuteReply { header = replyHeader, pagerOutput = pager,@@ -322,20 +364,40 @@ replyTo _ req@CompleteRequest{} replyHeader state = do- (matchedText, completions) <- complete (Chars.unpack $ getCodeLine req) (getCursorPos req)+ let line = getCodeLine req+ (matchedText, completions) <- complete (unpack line) (getCursorPos req) - let reply = CompleteReply replyHeader (map Chars.pack completions) (Chars.pack matchedText) (getCodeLine req) True+ let reply = CompleteReply replyHeader (map pack completions) (pack matchedText) line 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+replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do+ docs <- pack <$> info (unpack oname) let reply = ObjectInfoReply { header = replyHeader,- objectName = oname, + objectName = oname, objectFound = strip docs /= "",- objectTypeString = Chars.pack docs,- objectDocString = Chars.pack docs + objectTypeString = docs,+ objectDocString = docs } return (state, reply)++handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState+handleComm replier kernelState req replyHeader = do+ let widgets = openComms kernelState+ uuid = commUuid req+ dat = commData req+ communicate value = do+ head <- dupHeader replyHeader CommDataMessage+ replier $ CommData head uuid value+ case lookup uuid widgets of+ Nothing -> fail $ "no widget with uuid " ++ show uuid+ Just (Widget widget) ->+ case msgType $ header req of+ CommDataMessage -> do+ comm widget dat communicate+ return kernelState+ CommCloseMessage -> do+ close widget dat+ return kernelState { openComms = Map.delete uuid widgets }