diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -7,7 +7,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.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 diff --git a/installation/ipython.sh b/installation/ipython.sh --- a/installation/ipython.sh +++ b/installation/ipython.sh @@ -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 diff --git a/installation/run.sh b/installation/run.sh --- a/installation/run.sh +++ b/installation/run.sh @@ -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 diff --git a/installation/update.sh b/installation/update.sh deleted file mode 100644 --- a/installation/update.sh +++ /dev/null @@ -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; diff --git a/profile/profile.tar b/profile/profile.tar Binary files a/profile/profile.tar and b/profile/profile.tar differ diff --git a/src/Hspec.hs b/src/Hspec.hs --- a/src/Hspec.hs +++ b/src/Hspec.hs @@ -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 diff --git a/src/IHaskell/BrokenPackages.hs b/src/IHaskell/BrokenPackages.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/BrokenPackages.hs @@ -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" diff --git a/src/IHaskell/Convert.hs b/src/IHaskell/Convert.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Convert.hs @@ -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 + + diff --git a/src/IHaskell/Convert/Args.hs b/src/IHaskell/Convert/Args.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Convert/Args.hs @@ -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 diff --git a/src/IHaskell/Convert/IpynbToLhs.hs b/src/IHaskell/Convert/IpynbToLhs.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Convert/IpynbToLhs.hs @@ -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 diff --git a/src/IHaskell/Convert/LhsToIpynb.hs b/src/IHaskell/Convert/LhsToIpynb.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Convert/LhsToIpynb.hs @@ -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 _ [] = [] + diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -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 . +-- 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 + diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -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 - + diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -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 "
" str ++ script - script = + 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 diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -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 "No result: %s" 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 diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -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 = "", + 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|
${thing}
|] @@ -106,52 +199,9 @@ floating :: String -> String -> String floating dir thing = [i|
${thing}
|] --- | 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 {} -> "" diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -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 diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -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 diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -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 "" 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 to read." + , flagReq ["output","o"] (store ConvertTo) "" "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) "" 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 "" filenameArg = flagArg updateFile "[.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 diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -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 diff --git a/src/IHaskell/IPython/Kernel.hs b/src/IHaskell/IPython/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Kernel.hs @@ -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 diff --git a/src/IHaskell/IPython/Message/Parser.hs b/src/IHaskell/IPython/Message/Parser.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Message/Parser.hs @@ -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 diff --git a/src/IHaskell/IPython/Message/UUID.hs b/src/IHaskell/IPython/Message/UUID.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Message/UUID.hs @@ -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 diff --git a/src/IHaskell/IPython/Message/Writer.hs b/src/IHaskell/IPython/Message/Writer.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Message/Writer.hs @@ -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 diff --git a/src/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Stdin.hs @@ -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 diff --git a/src/IHaskell/IPython/Types.hs b/src/IHaskell/IPython/Types.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/Types.hs @@ -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" diff --git a/src/IHaskell/IPython/ZeroMQ.hs b/src/IHaskell/IPython/ZeroMQ.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/IPython/ZeroMQ.hs @@ -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 "" + + -- 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 "" + 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 diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -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 _ = "" + + -- | 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. } diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 $ "" + + 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 }