mirrors/IHaskell
1
0
Fork 0
mirror of https://github.com/IHaskell/IHaskell.git synced 2025-04-19 12:56:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #445 from gibiansky/format-all-src

Browse Source 
Format all src
This commit is contained in:
Andrew Gibiansky 2015-03-24 13:18:07 -07:00
commit a489c9bb35
25 changed files with 1085 additions and 1110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.travis.yml
View File

@ -36,7 +36,7 @@ install:
if [ ${GHCVER%.*} = "7.8" ]; then
travis_retry cabal install arithmoi==0.4.* -fllvm
travis_retry git clone http://www.github.com/gibiansky/hindent
cd hindent && cabal install && cd ..
cd hindent && travis_retry cabal install && cd ..
fi
# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.

15
ihaskell-display/ihaskell-aeson/IHaskell/Display/Aeson.hs
View File

@ -1,16 +1,17 @@
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, QuasiQuotes #-}
module IHaskell.Display.Aeson () where
import ClassyPrelude
import Data.Textual.Encoding
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.String.Here
import ClassyPrelude
import Data.Textual.Encoding
import Data.Aeson
import Data.Aeson.Encode.Pretty
import Data.String.Here
import IHaskell.Display
import IHaskell.Display
instance IHaskellDisplay Value where
display renderable = return $ Display [plain json, html dom]
where
where
json = unpack $ decodeUtf8 $ encodePretty renderable
dom = [i|<div class="highlight-code" id="javascript">${json}</div>|]

16
ihaskell-display/ihaskell-basic/IHaskell/Display/Basic.hs
View File

@ -1,15 +1,19 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Basic () where
import IHaskell.Display
import IHaskell.Display
import Text.Printf
import Text.Printf
instance Show a => IHaskellDisplay (Maybe a) where
display just = return $ Display [stringDisplay, htmlDisplay]
where
where
stringDisplay = plain (show just)
htmlDisplay = html str
str = case just of
Nothing -> "<span style='color: red; font-weight: bold;'>Nothing</span>"
Just x -> printf "<span style='color: green; font-weight: bold;'>Just</span><span style='font-family: monospace;'>%s</span>" (show x)
str =
case just of
Nothing -> "<span style='color: red; font-weight: bold;'>Nothing</span>"
Just x -> printf
"<span style='color: green; font-weight: bold;'>Just</span><span style='font-family: monospace;'>%s</span>"
(show x)

15
ihaskell-display/ihaskell-blaze/IHaskell/Display/Blaze.hs
View File

@ -1,17 +1,18 @@
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Blaze () where
import IHaskell.Display
import IHaskell.Display
import Text.Printf
import Text.Blaze.Html
import Text.Blaze.Renderer.Pretty
import Text.Blaze.Internal
import Control.Monad
import Text.Printf
import Text.Blaze.Html
import Text.Blaze.Renderer.Pretty
import Text.Blaze.Internal
import Control.Monad
instance IHaskellDisplay (MarkupM a) where
display val = return $ Display [stringDisplay, htmlDisplay]
where
where
str = renderMarkup (void val)
stringDisplay = plain str
htmlDisplay = html str

41
ihaskell-display/ihaskell-charts/IHaskell/Display/Charts.hs
View File

@ -1,16 +1,17 @@
{-# LANGUAGE NoImplicitPrelude, CPP #-}
module IHaskell.Display.Charts () where
import ClassyPrelude
import ClassyPrelude
import System.Directory
import Data.Default.Class
import Graphics.Rendering.Chart.Renderable
import Graphics.Rendering.Chart.Backend.Cairo
import System.Directory
import Data.Default.Class
import Graphics.Rendering.Chart.Renderable
import Graphics.Rendering.Chart.Backend.Cairo
import qualified Data.ByteString.Char8 as Char
import System.IO.Unsafe
import System.IO.Unsafe
import IHaskell.Display
import IHaskell.Display
width :: Width
width = 450
@ -22,8 +23,8 @@ instance IHaskellDisplay (Renderable a) where
display renderable = do
pngDisp <- chartData renderable PNG
-- We can add `svg svgDisplay` to the output of `display`,
-- but SVGs are not resizable in the IPython notebook.
-- We can add `svg svgDisplay` to the output of `display`, but SVGs are not resizable in the IPython
-- notebook.
svgDisp <- chartData renderable SVG
return $ Display [pngDisp, svgDisp]
@ -34,17 +35,17 @@ chartData renderable format = do
-- Write the PNG image.
let filename = ".ihaskell-chart.png"
opts = def{_fo_format = format, _fo_size = (width, height)}
toFile = renderableToFile opts
#if MIN_VERSION_Chart_cairo(1,3,0)
toFile filename renderable
#else
toFile renderable filename
#endif
opts = def { _fo_format = format, _fo_size = (width, height) }
mkFile opts filename renderable
-- Convert to base64.
imgData <- readFile $ fpFromString filename
return $ case format of
PNG -> png width height $ base64 imgData
SVG -> svg $ Char.unpack imgData
return $
case format of
PNG -> png width height $ base64 imgData
SVG -> svg $ Char.unpack imgData
#if MIN_VERSION_Chart_cairo(1,3,0)
mkFile opts filename renderable = renderableToFile opts filename renderable
#else
mkFile opts filename renderable = renderableToFile opts renderable filename
#endif

25
ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams.hs
View File

@ -1,17 +1,18 @@
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Diagrams (diagram, animation) where
import ClassyPrelude
import ClassyPrelude
import System.Directory
import System.Directory
import qualified Data.ByteString.Char8 as Char
import System.IO.Unsafe
import System.IO.Unsafe
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import IHaskell.Display
import IHaskell.Display.Diagrams.Animation
import IHaskell.Display
import IHaskell.Display.Diagrams.Animation
instance IHaskellDisplay (QDiagram Cairo R2 Any) where
display renderable = do
@ -36,11 +37,13 @@ diagramData renderable format = do
-- Convert to base64.
imgData <- readFile $ fpFromString filename
let value = case format of
PNG -> png (floor imgWidth) (floor imgHeight) $ base64 imgData
SVG -> svg $ Char.unpack imgData
let value =
case format of
PNG -> png (floor imgWidth) (floor imgHeight) $ base64 imgData
SVG -> svg $ Char.unpack imgData
return value
where
extension SVG = "svg"
extension PNG = "png"

33
ihaskell-display/ihaskell-diagrams/IHaskell/Display/Diagrams/Animation.hs
View File

@ -1,20 +1,21 @@
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Diagrams.Animation (animation) where
import ClassyPrelude hiding (filename)
import ClassyPrelude hiding (filename)
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.CmdLine (GifOpts (..))
import Diagrams.Backend.CmdLine (DiagramOpts (..), mainRender)
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Diagrams.Backend.Cairo.CmdLine (GifOpts(..))
import Diagrams.Backend.CmdLine (DiagramOpts(..), mainRender)
import IHaskell.Display
import IHaskell.Display
instance IHaskellDisplay (QAnimation Cairo R2 Any) where
display renderable = do
gif <- animationData renderable
return $ Display [html $ "<img src=\"data:image/gif;base64,"
++ gif ++ "\" />"]
++ gif ++ "\" />"]
animationData :: Animation Cairo R2 -> IO String
animationData renderable = do
@ -37,16 +38,12 @@ animationData renderable = do
-- Write the image.
let filename = ".ihaskell-diagram.gif"
diagOpts = DiagramOpts {
_width = Just . ceiling $ imgWidth
, _height = Just . ceiling $ imgHeight
, _output = filename
}
gifOpts = GifOpts {
_dither = True
, _noLooping = False
, _loopRepeat = Nothing
}
diagOpts = DiagramOpts
{ _width = Just . ceiling $ imgWidth
, _height = Just . ceiling $ imgHeight
, _output = filename
}
gifOpts = GifOpts { _dither = True, _noLooping = False, _loopRepeat = Nothing }
mainRender (diagOpts, gifOpts) frameSet
-- Convert to ascii represented base64 encoding

7
ihaskell-display/ihaskell-hatex/IHaskell/Display/Hatex.hs
View File

@ -1,14 +1,15 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
-- | Provides 'IHaskellDisplay' instances for 'LaTeX' and 'LaTeXT'.
module IHaskell.Display.Hatex () where
import IHaskell.Display
import Text.LaTeX
import IHaskell.Display
import Text.LaTeX
import qualified Data.Text as T
instance IHaskellDisplay LaTeX where
display = display . IHaskell.Display.latex . T.unpack . render
instance (a ~ (), IO ~ io) => IHaskellDisplay (LaTeXT io a) where
display ma = display =<< execLaTeXT ma
display ma = display =<< execLaTeXT ma

101
ihaskell-display/ihaskell-juicypixels/IHaskell/Display/Juicypixels.hs
View File

@ -1,33 +1,58 @@
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Juicypixels
( module IHaskell.Display
, module Codec.Picture
) where
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, FlexibleInstances #-}
import Codec.Picture
import ClassyPrelude
import IHaskell.Display
import System.Directory
import System.IO.Unsafe
module IHaskell.Display.Juicypixels (module IHaskell.Display, module Codec.Picture) where
import Codec.Picture
import ClassyPrelude
import IHaskell.Display
import System.Directory
import System.IO.Unsafe
-- instances
instance IHaskellDisplay DynamicImage where display = displayImageAsJpg
instance IHaskellDisplay (Image Pixel8) where display = displayImageAsJpg . ImageY8
instance IHaskellDisplay (Image Pixel16) where display = displayImageAsJpg . ImageY16
instance IHaskellDisplay (Image PixelF) where display = displayImageAsJpg . ImageYF
instance IHaskellDisplay (Image PixelYA8) where display = displayImageAsJpg . ImageYA8
instance IHaskellDisplay (Image PixelYA16) where display = displayImageAsJpg . ImageYA16
instance IHaskellDisplay (Image PixelRGB8) where display = displayImageAsJpg . ImageRGB8
instance IHaskellDisplay (Image PixelRGB16) where display = displayImageAsJpg . ImageRGB16
instance IHaskellDisplay (Image PixelRGBF) where display = displayImageAsJpg . ImageRGBF
instance IHaskellDisplay (Image PixelRGBA8) where display = displayImageAsJpg . ImageRGBA8
instance IHaskellDisplay (Image PixelRGBA16) where display = displayImageAsJpg . ImageRGBA16
instance IHaskellDisplay (Image PixelYCbCr8) where display = displayImageAsJpg . ImageYCbCr8
instance IHaskellDisplay (Image PixelCMYK8) where display = displayImageAsJpg . ImageCMYK8
instance IHaskellDisplay (Image PixelCMYK16) where display = displayImageAsJpg . ImageCMYK16
instance IHaskellDisplay DynamicImage where
display = displayImageAsJpg
instance IHaskellDisplay (Image Pixel8) where
display = displayImageAsJpg . ImageY8
instance IHaskellDisplay (Image Pixel16) where
display = displayImageAsJpg . ImageY16
instance IHaskellDisplay (Image PixelF) where
display = displayImageAsJpg . ImageYF
instance IHaskellDisplay (Image PixelYA8) where
display = displayImageAsJpg . ImageYA8
instance IHaskellDisplay (Image PixelYA16) where
display = displayImageAsJpg . ImageYA16
instance IHaskellDisplay (Image PixelRGB8) where
display = displayImageAsJpg . ImageRGB8
instance IHaskellDisplay (Image PixelRGB16) where
display = displayImageAsJpg . ImageRGB16
instance IHaskellDisplay (Image PixelRGBF) where
display = displayImageAsJpg . ImageRGBF
instance IHaskellDisplay (Image PixelRGBA8) where
display = displayImageAsJpg . ImageRGBA8
instance IHaskellDisplay (Image PixelRGBA16) where
display = displayImageAsJpg . ImageRGBA16
instance IHaskellDisplay (Image PixelYCbCr8) where
display = displayImageAsJpg . ImageYCbCr8
instance IHaskellDisplay (Image PixelCMYK8) where
display = displayImageAsJpg . ImageCMYK8
instance IHaskellDisplay (Image PixelCMYK16) where
display = displayImageAsJpg . ImageCMYK16
-- main rendering function
displayImageAsJpg :: DynamicImage -> IO Display
displayImageAsJpg :: DynamicImage -> IO Display
displayImageAsJpg renderable = do
switchToTmpDir
@ -40,30 +65,30 @@ displayImageAsJpg renderable = do
-- The type DynamicImage does not have a function to extract width and height
imWidth :: DynamicImage -> Int
imWidth img = w
where (w, h) = imWidthHeight img
imWidth img = w
where
(w, h) = imWidthHeight img
imHeight :: DynamicImage -> Int
imHeight img = h
where (w, h) = imWidthHeight img
where
(w, h) = imWidthHeight img
-- Helper functions to pattern match on the DynamicImage Constructors
imWidthHeight :: DynamicImage -> (Int, Int)
imWidthHeight (ImageY8 im) = imWH im
imWidthHeight (ImageY16 im) = imWH im
imWidthHeight (ImageYF im) = imWH im
imWidthHeight (ImageYA8 im) = imWH im
imWidthHeight (ImageY8 im) = imWH im
imWidthHeight (ImageY16 im) = imWH im
imWidthHeight (ImageYF im) = imWH im
imWidthHeight (ImageYA8 im) = imWH im
imWidthHeight (ImageYA16 im) = imWH im
imWidthHeight (ImageRGB8 im) = imWH im
imWidthHeight (ImageRGB16 im) = imWH im
imWidthHeight (ImageRGBF im) = imWH im
imWidthHeight (ImageRGB8 im) = imWH im
imWidthHeight (ImageRGB16 im) = imWH im
imWidthHeight (ImageRGBF im) = imWH im
imWidthHeight (ImageRGBA8 im) = imWH im
imWidthHeight (ImageRGBA16 im) = imWH im
imWidthHeight (ImageYCbCr8 im) = imWH im
imWidthHeight (ImageYCbCr8 im) = imWH im
imWidthHeight (ImageCMYK8 im) = imWH im
imWidthHeight (ImageCMYK16 im) = imWH im
imWH :: (Image a) -> (Int, Int)
imWH im = (imageWidth im, imageHeight im)

56
ihaskell-display/ihaskell-magic/IHaskell/Display/Magic.hs
View File

@ -1,31 +1,32 @@
{-# LANGUAGE ViewPatterns, TypeSynonymInstances, FlexibleInstances #-}
module IHaskell.Display.Magic () where
import IHaskell.Display
import Magic
import IHaskell.Display
import Magic
import qualified Data.ByteString as B
import qualified Data.ByteString.Unsafe as B
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char
import qualified Data.ByteString.UTF8 as B
import Text.Read
import Data.Char
import Text.Read
import Data.Char
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import IHaskell.IPython.Types (MimeType(MimeSvg))
import Data.ByteString.UTF8
import IHaskell.IPython.Types (MimeType(MimeSvg))
import Data.ByteString.UTF8
instance IHaskellDisplay T.Text where
display = display . T.encodeUtf8
display = display . T.encodeUtf8
instance IHaskellDisplay B.ByteString where
display x = do
m <- magicOpen []
magicLoadDefault m
f <- B.unsafeUseAsCStringLen x (magicCString m)
return $ Display [withClass (parseMagic f) x]
display x = do
m <- magicOpen []
magicLoadDefault m
f <- B.unsafeUseAsCStringLen x (magicCString m)
return $ Display [withClass (parseMagic f) x]
b64 :: B.ByteString -> String
b64 = Char.unpack . Base64.encode
@ -34,7 +35,7 @@ withClass :: MagicClass -> B.ByteString -> DisplayData
withClass SVG = DisplayData MimeSvg . T.decodeUtf8
withClass (PNG w h) = png w h . T.decodeUtf8 . Base64.encode
withClass JPG = jpg 400 300 . T.decodeUtf8 . Base64.encode
withClass HTML = html . B.toString
withClass HTML = html . B.toString
withClass LaTeX = latex . B.toString
withClass _ = plain . B.toString
@ -54,17 +55,20 @@ JPG
-}
parseMagic :: String -> MagicClass
parseMagic f = case words f of
"SVG" : _ -> SVG
"PNG" : _image : _data :
(readMaybe -> Just w) : _x :
(readMaybe . takeWhile isDigit -> Just h) : _ -> PNG w h
"LaTeX" : _ -> LaTeX
"HTML" : _ -> HTML
"JPEG" : _ -> JPG
_ -> Unknown
parseMagic f =
case words f of
"SVG":_ -> SVG
"PNG":_image:_data:(readMaybe -> Just w):_x:(readMaybe . takeWhile isDigit -> Just h):_ -> PNG w
h
"LaTeX":_ -> LaTeX
"HTML":_ -> HTML
"JPEG":_ -> JPG
_ -> Unknown
data MagicClass =
SVG | PNG Int Int | JPG | HTML | LaTeX | Unknown
deriving Show
data MagicClass = SVG
| PNG Int Int
| JPG
| HTML
| LaTeX
| Unknown
deriving Show

41
ihaskell-display/ihaskell-parsec/IHaskell/Display/Parsec.hs
View File

@ -1,22 +1,23 @@
{-# LANGUAGE NoImplicitPrelude, TypeSynonymInstances, QuasiQuotes, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Display.Parsec () where
import ClassyPrelude hiding (fromList)
import System.Random
import Data.String.Here
import Data.HashMap.Strict as Map
import ClassyPrelude hiding (fromList)
import System.Random
import Data.String.Here
import Data.HashMap.Strict as Map
import Text.Parsec (parse, sourceLine, sourceColumn)
import Text.Parsec.String (Parser)
import Text.Parsec.Error (errorPos, ParseError)
import Text.Parsec (parse, sourceLine, sourceColumn)
import Text.Parsec.String (Parser)
import Text.Parsec.Error (errorPos, ParseError)
import Data.Aeson
import Data.Aeson
import IHaskell.Display
import IHaskell.Display
instance Show a => IHaskellDisplay (Parser a) where
display renderable = return $ many [Display [javascript js], Display [html dom]]
where
where
dom = [hereFile|widget.html|]
js = [hereFile|widget.js|]
@ -25,25 +26,21 @@ data ParseText = ParseText String
instance FromJSON ParseText where
parseJSON (Object v) = ParseText <$> v .: "text"
parseJSON _ = fail "Expecting object"
parseJSON _ = fail "Expecting object"
-- | Output of parsing.
instance Show a => ToJSON (Either ParseError a) where
toJSON (Left err) = object [
"status" .= ("error" :: String),
"line" .= sourceLine (errorPos err),
"col" .= sourceColumn (errorPos err),
"msg" .= show err
]
toJSON (Right result) = object [
"status" .= ("success" :: String),
"result" .= show result
]
toJSON (Left err) = object
[ "status" .= ("error" :: String)
, "line" .= sourceLine (errorPos err)
, "col" .= sourceColumn (errorPos err)
, "msg" .= show err
]
toJSON (Right result) = object ["status" .= ("success" :: String), "result" .= show result]
instance Show a => IHaskellWidget (Parser a) where
-- Name for this widget.
targetName _ = "parsec"
-- When we rece
comm widget (Object dict) publisher = do
let key = "text" :: Text

108
ihaskell-display/ihaskell-rlangqq/IHaskell/Display/Rlangqq.hs
View File

@ -1,57 +1,56 @@
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# LANGUAGE TupleSections, TemplateHaskell #-}
module IHaskell.Display.Rlangqq
( module RlangQQ,
module IHaskell.Display.Rlangqq (
module RlangQQ,
rDisp,
rDisplayAll,
rOutputParsed,
rOutput,
getPlotNames,
getCaptions,
) where
) where
import RlangQQ
import RlangQQ.ParseKnitted
import RlangQQ
import RlangQQ.ParseKnitted
import System.Directory
import System.FilePath
import Data.Maybe
import Data.List
import Text.Read
import System.Directory
import System.FilePath
import Data.Maybe
import Data.List
import Text.Read
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as Char
import qualified Data.ByteString.Base64 as Base64
import IHaskell.Display
import IHaskell.Display.Blaze () -- to confirm it's installed
import IHaskell.Display
import IHaskell.Display.Blaze () -- to confirm it's installed
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as H
import Data.Monoid
import Data.Char
import Control.Monad
import Data.Ord
import Data.List.Split
import Text.XFormat.Show hiding ((<>))
import Control.Applicative
import Control.Concurrent
import Data.Monoid
import Data.Typeable
import Data.Char
import Control.Monad
import Data.Ord
import Data.List.Split
import Text.XFormat.Show hiding ((<>))
import Control.Applicative
import Control.Concurrent
import Data.Monoid
import Data.Typeable
import Control.Concurrent.STM
import Language.Haskell.TH.Quote
import Control.Concurrent.STM
import Language.Haskell.TH.Quote
-- | same as 'RlangQQ.r', but displays plots at the end too
rDisp = QuasiQuoter { quoteExp = \s -> [| do
result <- $(quoteExp r s)
p <- rDisplayAll
printDisplay p
return result
|] }
rDisp = QuasiQuoter { quoteExp = \s -> [|do
result <- $(quoteExp r s)
p <- rDisplayAll
printDisplay p
return result|] }
rOutput :: IO [Int]
rOutput = do
fs <- mapMaybe (readMaybe <=< stripPrefix "raw" <=< stripSuffix ".md")
<$> getDirectoryContents "Rtmp"
fs' <- forM fs $ \f -> (,f) <$> getModificationTime (showf ("Rtmp/raw"%Int%".md") f)
<$> getDirectoryContents "Rtmp"
fs' <- forM fs $ \f -> (,f) <$> getModificationTime (showf ("Rtmp/raw" % Int % ".md") f)
return $ map snd $ sortBy (flip (comparing fst)) fs'
-- | like 'stripPrefix' except on the end
@ -62,35 +61,33 @@ rOutputParsed :: IO [KnitInteraction]
rOutputParsed = do
ns <- rOutput
case ns of
[] -> return []
n : _ -> parseKnitted <$> readFile (showf ("Rtmp/raw"%Int%".md") n)
[] -> return []
n:_ -> parseKnitted <$> readFile (showf ("Rtmp/raw" % Int % ".md") n)
getPlotNames :: IO [String]
getPlotNames = do
interactions <- rOutputParsed
return [ p | KnitInteraction _ is <- interactions, KnitImage _ p <- is ]
return [p | KnitInteraction _ is <- interactions
, KnitImage _ p <- is]
getCaptions :: IO [String]
getCaptions = do
interactions <- rOutputParsed
return [ c | KnitInteraction _ is <- interactions,
KnitImage c _ <- is,
not (isBoringCaption c) ]
return
[c | KnitInteraction _ is <- interactions
, KnitImage c _ <- is
, not (isBoringCaption c)]
-- | true when the caption name looks like one knitr will automatically
-- generate
-- | true when the caption name looks like one knitr will automatically generate
isBoringCaption :: String -> Bool
isBoringCaption s = maybe False
(all isDigit)
(stripPrefix "plot of chunk unnamed-chunk-" s)
isBoringCaption s = maybe False (all isDigit) (stripPrefix "plot of chunk unnamed-chunk-" s)
rDisplayAll :: IO Display
rDisplayAll = do
ns <- rOutputParsed
imgs <- sequence [ displayInteraction o | KnitInteraction _ os <- ns, o <- os]
display (mconcat imgs)
ns <- rOutputParsed
imgs <- sequence [displayInteraction o | KnitInteraction _ os <- ns
, o <- os]
display (mconcat imgs)
displayInteraction :: KnitOutput -> IO Display
displayInteraction (KnitPrint c) = display (plain c)
@ -99,10 +96,11 @@ displayInteraction (KnitError c) = display (plain c)
displayInteraction (KnitAsIs c) = display (plain c)
displayInteraction (KnitImage cap img) = do
let caption
| isBoringCaption cap = mempty
| otherwise = H.p (H.toMarkup cap)
| isBoringCaption cap = mempty
| otherwise = H.p (H.toMarkup cap)
encoded <- Base64.encode <$> B.readFile img
display $ H.img H.! H.src (H.unsafeByteStringValue
-- assumes you use the default device which is png
(Char.pack "data:image/png;base64," <> encoded))
<> caption
display $ H.img H.! H.src
(H.unsafeByteStringValue
-- assumes you use the default device which is png
(Char.pack "data:image/png;base64," <> encoded))
<> caption

5
ihaskell-display/ihaskell-static-canvas/src/IHaskell/Display/StaticCanvas.hs
View File

@ -23,10 +23,7 @@ getUniqueName = do
putMVar uniqueCounter val'
return $ pack $ "ihaskellStaticCanvasUniqueID" ++ show val
data Canvas = Canvas { width :: Int
, height :: Int
, canvas :: CanvasFree ()
}
data Canvas = Canvas { width :: Int, height :: Int, canvas :: CanvasFree () }
instance IHaskellDisplay Canvas where
display cnv = do

37
ihaskell-display/ihaskell-widgets/IHaskell/Display/Widgets.hs
View File

@ -1,12 +1,13 @@
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
module IHaskell.Display.Widgets () where
import ClassyPrelude
import ClassyPrelude
import Data.Aeson
import Data.Aeson
import IHaskell.Widgets
import IHaskell.Display
import IHaskell.Widgets
import IHaskell.Display
data WidgetName = ButtonWidget
@ -17,18 +18,19 @@ instance ToJSON WidgetName where
toJSON ButtonWidget = "ButtonView"
instance ToJSON WidgetMessage where
toJSON DisplayWidget = object [ "method" .= str "display" ]
toJSON (InitialState name) = object [
"method" .= str "update",
"state" .= object [
"_view_name" .= name,
"visible" .= True,
"_css" .= object [],
"msg_throttle" .= (3 :: Int),
"disabled" .= False,
"description" .= str "Button"
]
]
toJSON DisplayWidget = object ["method" .= str "display"]
toJSON (InitialState name) = object
[ "method" .= str "update"
, "state" .= object
[ "_view_name" .= name
, "visible" .= True
, "_css" .= object []
, "msg_throttle" .= (3 :: Int)
, "disabled" .= False
, "description" .= str "Button"
]
]
str :: String -> String
str = id
@ -40,12 +42,11 @@ data ParseText = ParseText String
instance FromJSON ParseText where
parseJSON (Object v) = ParseText <$> v .: "text"
parseJSON _ = fail "Expecting object"
parseJSON _ = fail "Expecting object"
instance IHaskellWidget Slider where
-- Name for this widget.
targetName _ = "WidgetModel"
-- Start by sending messages to set up the widget.
open widget send = do
putStrLn "Sending widgets!"

4
ihaskell-display/ihaskell-widgets/IHaskell/Widgets.hs
View File

@ -1,5 +1,3 @@
module IHaskell.Widgets (
Slider(..)
) where
module IHaskell.Widgets (Slider(..)) where
data Slider = Slider

243
ipython-kernel/examples/Calc.hs
View File

@ -1,26 +1,28 @@
{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, MultiWayIf #-}
module Main where
import Control.Applicative
import Control.Arrow
import Control.Applicative
import Control.Arrow
import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay)
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State.Strict (StateT, get, modify, runStateT)
import Control.Concurrent (MVar, newMVar, takeMVar, putMVar, threadDelay)
import Control.Monad (guard)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.State.Strict (StateT, get, modify, runStateT)
import Data.Char (isDigit)
import Data.List (isPrefixOf)
import Data.Monoid ((<>))
import Data.Char (isDigit)
import Data.List (isPrefixOf)
import Data.Monoid ((<>))
import qualified Data.Text as T
import IHaskell.IPython.Kernel
import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..))
import IHaskell.IPython.Kernel
import IHaskell.IPython.EasyKernel (installProfile, easyKernel, KernelConfig(..))
import System.Environment (getArgs)
import System.FilePath ((</>))
import System.Environment (getArgs)
import System.FilePath ((</>))
import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe, runParser, (<?>))
import Text.Parsec (Parsec, ParseError, alphaNum, char, letter, oneOf, optionMaybe,
runParser, (<?>))
import qualified Text.Parsec.Token as P
import qualified Paths_ipython_kernel as Paths
@ -28,34 +30,29 @@ import qualified Paths_ipython_kernel as Paths
---------------------------------------------------------
-- Hutton's Razor, plus time delays, plus a global state
---------------------------------------------------------
-- | This language is Hutton's Razor with two added operations that
-- are needed to demonstrate the kernel features: a global state,
-- accessed and modified using Count, and a sleep operation.
--
-- | This language is Hutton's Razor with two added operations that are needed to demonstrate the
-- kernel features: a global state, accessed and modified using Count, and a sleep operation.
data Razor = I Integer
| Plus Razor Razor
| SleepThen Double Razor
| Count
deriving (Read, Show, Eq)
---------
-- Parser
---------
-- ------- Parser -------
razorDef :: Monad m => P.GenLanguageDef String a m
razorDef = P.LanguageDef
{ P.commentStart = "(*"
, P.commentEnd = "*)"
, P.commentLine = "//"
, P.nestedComments = True
, P.identStart = letter <|> char '_'
, P.identLetter = alphaNum <|> char '_'
, P.opStart = oneOf "+"
, P.opLetter = oneOf "+"
, P.reservedNames = ["sleep", "then", "end", "count"]
{ P.commentStart = "(*"
, P.commentEnd = "*)"
, P.commentLine = "//"
, P.nestedComments = True
, P.identStart = letter <|> char '_'
, P.identLetter = alphaNum <|> char '_'
, P.opStart = oneOf "+"
, P.opLetter = oneOf "+"
, P.reservedNames = ["sleep", "then", "end", "count"]
, P.reservedOpNames = []
, P.caseSensitive = True
, P.caseSensitive = True
}
lexer :: Monad m => P.GenTokenParser String a m
@ -83,39 +80,38 @@ literal :: Parsec String a Razor
literal = I <$> integer
sleepThen :: Parsec String a Razor
sleepThen = do keyword "sleep"
delay <- float <?> "seconds"
keyword "then"
body <- expr
keyword "end" <?> ""
return $ SleepThen delay body
sleepThen = do
keyword "sleep"
delay <- float <?> "seconds"
keyword "then"
body <- expr
keyword "end" <?> ""
return $ SleepThen delay body
count :: Parsec String a Razor
count = keyword "count" >> return Count
expr :: Parsec String a Razor
expr = do one <- parens expr <|> literal <|> sleepThen <|> count
rest <- optionMaybe (do op <- operator
guard (op == "+")
expr)
case rest of
Nothing -> return one
Just other -> return $ Plus one other
expr = do
one <- parens expr <|> literal <|> sleepThen <|> count
rest <- optionMaybe
(do
op <- operator
guard (op == "+")
expr)
case rest of
Nothing -> return one
Just other -> return $ Plus one other
parse :: String -> Either ParseError Razor
parse = runParser expr () "(input)"
----------------------
-- Language operations
----------------------
-- | Completion
-- -------------------- Language operations -------------------- | Completion
langCompletion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
langCompletion _code line col =
let (before, _) = T.splitAt col line
in fmap (\word -> (map T.pack . matchesFor $ T.unpack word, word, word))
(lastMaybe (T.words before))
(lastMaybe (T.words before))
where
lastMaybe :: [a] -> Maybe a
lastMaybe [] = Nothing
@ -123,43 +119,41 @@ langCompletion _code line col =
lastMaybe (_:xs) = lastMaybe xs
matchesFor :: String -> [String]
matchesFor input = filter (isPrefixOf input) available
available = ["sleep", "then", "end", "count"] ++ map show [(-1000::Int)..1000]
available = ["sleep", "then", "end", "count"] ++ map show [(-1000 :: Int) .. 1000]
-- | Documentation lookup
langInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
langInfo obj =
if | any (T.isPrefixOf obj) ["sleep", "then", "end"] ->
Just (obj, sleepDocs, sleepType)
| T.isPrefixOf obj "count" ->
Just (obj, countDocs, countType)
if | any (T.isPrefixOf obj) ["sleep", "then", "end"] -> Just (obj, sleepDocs, sleepType)
| T.isPrefixOf obj "count" -> Just (obj, countDocs, countType)
| obj == "+" -> Just (obj, plusDocs, plusType)
| T.all isDigit obj -> Just (obj, intDocs obj, intType)
| [x, y] <- T.splitOn "." obj,
T.all isDigit x,
T.all isDigit y -> Just (obj, floatDocs obj, floatType)
| [x, y] <- T.splitOn "." obj
, T.all isDigit x
, T.all isDigit y -> Just (obj, floatDocs obj, floatType)
| otherwise -> Nothing
where
sleepDocs = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE"
sleepType = "sleep FLOAT then INT end"
plusDocs = "Perform addition"
plusType = "INT + INT"
intDocs i = "The integer " <> i
intType = "INT"
floatDocs f = "The floating point value " <> f
floatType = "FLOAT"
countDocs = "Increment and return the current counter"
countType = "INT"
sleepDocs = "sleep DURATION then VALUE end: sleep DURATION seconds, then eval VALUE"
sleepType = "sleep FLOAT then INT end"
plusDocs = "Perform addition"
plusType = "INT + INT"
intDocs i = "The integer " <> i
intType = "INT"
floatDocs f = "The floating point value " <> f
floatType = "FLOAT"
countDocs = "Increment and return the current counter"
countType = "INT"
-- | Messages sent to the frontend during evaluation will be lists of trace elements
data IntermediateEvalRes = Got Razor Integer
| Waiting Double
deriving Show
-- | Cons for lists of trace elements - in this case, "sleeping"
-- messages should replace old ones to create a countdown effect.
-- | Cons for lists of trace elements - in this case, "sleeping" messages should replace old ones to
-- create a countdown effect.
consRes :: IntermediateEvalRes -> [IntermediateEvalRes] -> [IntermediateEvalRes]
consRes r@(Waiting _) (Waiting _ : s) = r:s
consRes r s = r:s
consRes r@(Waiting _) (Waiting _:s) = r : s
consRes r s = r : s
-- | Execute an expression.
execRazor :: MVar Integer -- ^ The global counter state
@ -168,53 +162,60 @@ execRazor :: MVar Integer -- ^ The global counter state
-> ([IntermediateEvalRes] -> IO ()) -- ^ Callback for intermediate results
-> StateT ([IntermediateEvalRes], T.Text) IO Integer
execRazor _ x@(I i) _ _ =
modify (second (<> (T.pack (show x)))) >> return i
modify (second (<> T.pack (show x))) >> return i
execRazor val tm@(Plus x y) clear send =
do modify (second (<> (T.pack (show tm))))
x' <- execRazor val x clear send
modify (first $ consRes (Got x x'))
sendState
y' <- execRazor val y clear send
modify (first $ consRes (Got y y'))
sendState
let res = x' + y'
modify (first $ consRes (Got tm res))
sendState
return res
where sendState = liftIO clear >> fst <$> get >>= liftIO . send
do
modify (second (<> T.pack (show tm)))
x' <- execRazor val x clear send
modify (first $ consRes (Got x x'))
sendState
y' <- execRazor val y clear send
modify (first $ consRes (Got y y'))
sendState
let res = x' + y'
modify (first $ consRes (Got tm res))
sendState
return res
where
sendState = liftIO clear >> fst <$> get >>= liftIO . send
execRazor val (SleepThen delay body) clear send
| delay <= 0.0 = execRazor val body clear send
| delay > 0.1 = do modify (first $ consRes (Waiting delay))
sendState
liftIO $ threadDelay 100000
execRazor val (SleepThen (delay - 0.1) body) clear send
| otherwise = do modify (first $ consRes (Waiting 0))
sendState
liftIO $ threadDelay (floor (delay * 1000000))
execRazor val body clear send
where sendState = liftIO clear >> fst <$> get >>= liftIO . send
| delay > 0.1 = do
modify (first $ consRes (Waiting delay))
sendState
liftIO $ threadDelay 100000
execRazor val (SleepThen (delay - 0.1) body) clear send
| otherwise = do
modify (first $ consRes (Waiting 0))
sendState
liftIO $ threadDelay (floor (delay * 1000000))
execRazor val body clear send
where
sendState = liftIO clear >> fst <$> get >>= liftIO . send
execRazor val Count clear send = do
i <- liftIO $ takeMVar val
modify (first $ consRes (Got Count i))
sendState
liftIO $ putMVar val (i+1)
liftIO $ putMVar val (i + 1)
return i
where sendState = liftIO clear >> fst <$> get >>= liftIO . send
where
sendState = liftIO clear >> fst <$> get >>= liftIO . send
-- | Generate a language configuration for some initial state
mkConfig :: MVar Integer -- ^ The internal state of the execution
-> KernelConfig IO [IntermediateEvalRes] (Either ParseError Integer)
mkConfig var = KernelConfig
{ languageName = "expanded_huttons_razor"
, languageVersion = [0,1,0]
, profileSource = Just . (</> "calc_profile.tar") <$> Paths.getDataDir
, displayResult = displayRes
, displayOutput = displayOut
, completion = langCompletion
, objectInfo = langInfo
, run = parseAndRun
, debug = False
{ languageName = "expanded_huttons_razor"
, languageVersion = [0, 1, 0]
, profileSource = Just . (</> "calc_profile.tar") <$> Paths.getDataDir
, displayResult = displayRes
, displayOutput = displayOut
, completion = langCompletion
, objectInfo = langInfo
, run = parseAndRun
, debug = False
}
where
displayRes (Left err) =
@ -235,15 +236,17 @@ mkConfig var = KernelConfig
return (Right res, Ok, T.unpack pager)
main :: IO ()
main = do args <- getArgs
val <- newMVar 1
case args of
["kernel", profileFile] ->
easyKernel profileFile (mkConfig val)
["setup"] -> do
putStrLn "Installing profile..."
installProfile (mkConfig val)
_ -> do
putStrLn "Usage:"
putStrLn "simple-calc-example setup -- set up the profile"
putStrLn "simple-calc-example kernel FILE -- run a kernel with FILE for communication with the frontend"
main = do
args <- getArgs
val <- newMVar 1
case args of
["kernel", profileFile] ->
easyKernel profileFile (mkConfig val)
["setup"] -> do
putStrLn "Installing profile..."
installProfile (mkConfig val)
_ -> do
putStrLn "Usage:"
putStrLn "simple-calc-example setup -- set up the profile"
putStrLn
"simple-calc-example kernel FILE -- run a kernel with FILE for communication with the frontend"

293
ipython-kernel/src/IHaskell/IPython/EasyKernel.hs
View File

@ -1,32 +1,26 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Description : Easy IPython kernels
-- = Overview
-- This module provides automation for writing simple IPython
-- kernels. In particular, it provides a record type that defines
-- configurations and a function that interprets a configuration as an
-- action in some monad that can do IO.
-- | Description : Easy IPython kernels = Overview This module provides automation for writing
-- simple IPython kernels. In particular, it provides a record type that defines configurations and
-- a function that interprets a configuration as an action in some monad that can do IO.
--
-- The configuration consists primarily of functions that implement
-- the various features of a kernel, such as running code, looking up
-- documentation, and performing completion. An example for a simple
-- language that nevertheless has side effects, global state, and
-- timing effects is included in the examples directory.
-- The configuration consists primarily of functions that implement the various features of a
-- kernel, such as running code, looking up documentation, and performing completion. An example for
-- a simple language that nevertheless has side effects, global state, and timing effects is
-- included in the examples directory.
--
-- = Profiles
-- To run your kernel, you will need an IPython profile that causes
-- the frontend to run it. To generate a fresh profile, run the command
-- = Profiles To run your kernel, you will need an IPython profile that causes the frontend to run
-- it. To generate a fresh profile, run the command
--
-- > ipython profile create NAME
--
-- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@.
-- This profile must be modified in two ways:
-- This will create a fresh IPython profile in @~\/.ipython\/profile_NAME@. This profile must be
-- modified in two ways:
--
-- 1. It needs to run your kernel instead of the default ipython
-- 2. It must have message signing turned off, because 'easyKernel' doesn't support it
-- 1. It needs to run your kernel instead of the default ipython 2. It must have message signing
-- turned off, because 'easyKernel' doesn't support it
--
-- == Setting the executable
-- To set the executable, modify the configuration object's
-- == Setting the executable To set the executable, modify the configuration object's
-- @KernelManager.kernel_cmd@ property. For example:
--
-- > c.KernelManager.kernel_cmd = ['my_kernel', '{connection_file}']
@ -44,79 +38,73 @@
-- Consult the IPython documentation along with the generated profile
-- source code for further configuration of the frontend, including
-- syntax highlighting, logos, help text, and so forth.
module IHaskell.IPython.EasyKernel (easyKernel, installProfile, KernelConfig(..)) where
import Data.Aeson (decode)
import Data.Aeson (decode)
import qualified Data.ByteString.Lazy as BL
import qualified Codec.Archive.Tar as Tar
import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forever, when)
import Control.Concurrent (MVar, readChan, writeChan, newMVar, readMVar, modifyMVar_)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad (forever, when, unless)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import IHaskell.IPython.Kernel
import IHaskell.IPython.Message.UUID as UUID
import IHaskell.IPython.Kernel
import IHaskell.IPython.Message.UUID as UUID
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getHomeDirectory)
import System.FilePath ((</>))
import System.Exit (exitSuccess)
import System.IO (openFile, IOMode(ReadMode))
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist,
getHomeDirectory)
import System.FilePath ((</>))
import System.Exit (exitSuccess)
import System.IO (openFile, IOMode(ReadMode))
-- | The kernel configuration specifies the behavior that is specific
-- to your language. The type parameters provide the monad in which
-- your kernel will run, the type of intermediate outputs from running
-- cells, and the type of final results of cells, respectively.
data KernelConfig m output result = KernelConfig
{ languageName :: String
-- ^ The name of the language. This field is used to calculate
-- the name of the profile, so it should contain characters that
-- are reasonable to have in file names.
, languageVersion :: [Int] -- ^ The version of the language
, profileSource :: IO (Maybe FilePath)
-- ^ Determine the source of a profile to install using
-- 'installProfile'. The source should be a tarball whose contents
-- will be unpacked directly into the profile directory. For
-- example, the file whose name is @ipython_config.py@ in the
-- tar file for a language named @lang@ will end up in
-- @~/.ipython/profile_lang/ipython_config.py@.
, displayOutput :: output -> [DisplayData] -- ^ How to render intermediate output
, displayResult :: result -> [DisplayData] -- ^ How to render final cell results
, completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
-- ^ Perform completion. The returned tuple consists of the matches,
-- the matched text, and the completion text. The arguments are the
-- code in the cell, the current line as text, and the column at
-- which the cursor is placed.
, objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
-- ^ Return the information or documentation for its argument. The
-- returned tuple consists of the name, the documentation, and the
-- type, respectively.
, run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String)
-- ^ Execute a cell. The arguments are the contents of the cell, an
-- IO action that will clear the current intermediate output, and an
-- IO action that will add a new item to the intermediate
-- output. The result consists of the actual result, the status to
-- be sent to IPython, and the contents of the pager. Return the
-- empty string to indicate that there is no pager output. Errors
-- should be handled by defining an appropriate error constructor in
-- your result type.
, debug :: Bool -- ^ Whether to print extra debugging information to
-- the console
}
-- | The kernel configuration specifies the behavior that is specific to your language. The type
-- parameters provide the monad in which your kernel will run, the type of intermediate outputs from
-- running cells, and the type of final results of cells, respectively.
data KernelConfig m output result =
KernelConfig
{
-- | The name of the language. This field is used to calculate the name of the profile,
-- so it should contain characters that are reasonable to have in file names.
languageName :: String
-- | The version of the language
, languageVersion :: [Int]
-- | Determine the source of a profile to install using 'installProfile'. The source should be a
-- tarball whose contents will be unpacked directly into the profile directory. For example, the
-- file whose name is @ipython_config.py@ in the tar file for a language named @lang@ will end up in
-- @~/.ipython/profile_lang/ipython_config.py@.
, profileSource :: IO (Maybe FilePath)
-- | How to render intermediate output
, displayOutput :: output -> [DisplayData]
-- | How to render final cell results
, displayResult :: result -> [DisplayData]
-- | Perform completion. The returned tuple consists of the matches, the matched text, and the
-- completion text. The arguments are the code in the cell, the current line as text, and the column
-- at which the cursor is placed.
, completion :: T.Text -> T.Text -> Int -> Maybe ([T.Text], T.Text, T.Text)
-- | Return the information or documentation for its argument. The returned tuple consists of the
-- name, the documentation, and the type, respectively.
, objectInfo :: T.Text -> Maybe (T.Text, T.Text, T.Text)
-- | Execute a cell. The arguments are the contents of the cell, an IO action that will clear the
-- current intermediate output, and an IO action that will add a new item to the intermediate
-- output. The result consists of the actual result, the status to be sent to IPython, and the
-- contents of the pager. Return the empty string to indicate that there is no pager output. Errors
-- should be handled by defining an appropriate error constructor in your result type.
, run :: T.Text -> IO () -> (output -> IO ()) -> m (result, ExecuteReplyStatus, String)
, debug :: Bool -- ^ Whether to print extra debugging information to
}
-- | Attempt to install the IPython profile from the .tar file
-- indicated by the 'profileSource' field of the configuration, if it
-- is not already installed.
-- the console | Attempt to install the IPython profile from the .tar file indicated by the
-- 'profileSource' field of the configuration, if it is not already installed.
installProfile :: MonadIO m => KernelConfig m output result -> m ()
installProfile config = do
installed <- isInstalled
when (not installed) $ do
unless installed $ do
profSrc <- liftIO $ profileSource config
case profSrc of
Nothing -> liftIO (putStrLn "No IPython profile is installed or specified")
@ -124,10 +112,11 @@ installProfile config = do
profExists <- liftIO $ doesFileExist tar
profTgt <- profDir
if profExists
then do liftIO $ createDirectoryIfMissing True profTgt
liftIO $ Tar.extract profTgt tar
else liftIO . putStrLn $
"The supplied profile source '" ++ tar ++ "' does not exist"
then do
liftIO $ createDirectoryIfMissing True profTgt
liftIO $ Tar.extract profTgt tar
else liftIO . putStrLn $
"The supplied profile source '" ++ tar ++ "' does not exist"
where
profDir = do
@ -153,28 +142,29 @@ createReplyHeader parent = do
let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader {
identifiers = identifiers parent,
parentHeader = Just parent,
metadata = Map.fromList [],
messageId = newMessageId,
sessionId = sessionId parent,
username = username parent,
msgType = repType
}
return
MessageHeader
{ identifiers = identifiers parent
, parentHeader = Just parent
, metadata = Map.fromList []
, messageId = newMessageId
, sessionId = sessionId parent
, username = username parent
, msgType = repType
}
-- | Execute an IPython kernel for a config. Your 'main' action should
-- call this as the last thing it does.
-- | Execute an IPython kernel for a config. Your 'main' action should call this as the last thing
-- it does.
easyKernel :: (MonadIO m)
=> FilePath -- ^ The connection file provided by the IPython frontend
-> KernelConfig m output result -- ^ The kernel configuration specifying how to react to messages
-> KernelConfig m output result -- ^ The kernel configuration specifying how to react to
-- messages
-> m ()
easyKernel profileFile config = do
prof <- liftIO $ getProfile profileFile
zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <-
liftIO $ serveProfile prof False
zmq@(Channels shellReqChan shellRepChan ctrlReqChan ctrlRepChan iopubChan _) <- liftIO $ serveProfile
prof
False
execCount <- liftIO $ newMVar 0
forever $ do
req <- liftIO $ readChan shellReqChan
@ -183,7 +173,6 @@ easyKernel profileFile config = do
reply <- replyTo config execCount zmq req repHeader
liftIO $ writeChan shellRepChan reply
replyTo :: MonadIO m
=> KernelConfig m output result
-> MVar Integer
@ -192,97 +181,79 @@ replyTo :: MonadIO m
-> MessageHeader
-> m Message
replyTo config _ _ KernelInfoRequest{} replyHeader =
return KernelInfoReply
{ header = replyHeader
, language = languageName config
, versionList = languageVersion config
}
replyTo config _ interface ShutdownRequest{restartPending=pending} replyHeader = do
return
KernelInfoReply
{ header = replyHeader
, language = languageName config
, versionList = languageVersion config
}
replyTo config _ interface ShutdownRequest { restartPending = pending } replyHeader = do
liftIO $ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending
liftIO exitSuccess
replyTo config execCount interface req@ExecuteRequest { getCode = code } replyHeader = do
let send msg = writeChan (iopubChannel interface) msg
let send = writeChan (iopubChannel interface)
busyHeader <- dupHeader replyHeader StatusMessage
liftIO . send $ PublishStatus busyHeader Busy
outputHeader <- dupHeader replyHeader DisplayDataMessage
(res, replyStatus, pagerOut) <-
let clearOutput = do
clearHeader <- dupHeader replyHeader ClearOutputMessage
send $ ClearOutput clearHeader False
sendOutput x =
send $ PublishDisplayData outputHeader (languageName config)
(displayOutput config x)
in run config code clearOutput sendOutput
(res, replyStatus, pagerOut) <- let clearOutput = do
clearHeader <- dupHeader replyHeader
ClearOutputMessage
send $ ClearOutput clearHeader False
sendOutput x =
send $ PublishDisplayData
outputHeader
(languageName config)
(displayOutput config x)
in run config code clearOutput sendOutput
liftIO . send $ PublishDisplayData outputHeader (languageName config) (displayResult config res)
idleHeader <- dupHeader replyHeader StatusMessage
liftIO . send $ PublishStatus idleHeader Idle
liftIO $ modifyMVar_ execCount (return . (+1))
liftIO $ modifyMVar_ execCount (return . (+ 1))
counter <- liftIO $ readMVar execCount
return ExecuteReply
{ header = replyHeader
, pagerOutput = pagerOut
, executionCounter = fromIntegral counter
, status = replyStatus
}
return
ExecuteReply
{ header = replyHeader
, pagerOutput = pagerOut
, executionCounter = fromIntegral counter
, status = replyStatus
}
replyTo config _ _ req@CompleteRequest{} replyHeader = do
replyTo config _ _ req@CompleteRequest{} replyHeader =
-- TODO: FIX
error "Unimplemented in IPython 3.0"
{-
let code = getCode req
line = getCodeLine req
col = getCursorPos req
return $ case completion config code line col of
Nothing ->
CompleteReply
{ header = replyHeader
, completionMatches = []
, completionMatchedText = ""
, completionText = ""
, completionStatus = False
}
Just (matches, matchedText, cmplText) ->
CompleteReply
{ header = replyHeader
, completionMatches = matches
, completionMatchedText = matchedText
, completionText = cmplText
, completionStatus = True
}
-}
replyTo config _ _ ObjectInfoRequest { objectName = obj } replyHeader =
return $ case objectInfo config obj of
Just (name, docs, ty) -> ObjectInfoReply
{ header = replyHeader
, objectName = obj
, objectFound = True
, objectTypeString = ty
, objectDocString = docs
}
Nothing -> ObjectInfoReply
{ header = replyHeader
, objectName = obj
, objectFound = False
, objectTypeString = ""
, objectDocString = ""
}
return $
case objectInfo config obj of
Just (name, docs, ty) -> ObjectInfoReply
{ header = replyHeader
, objectName = obj
, objectFound = True
, objectTypeString = ty
, objectDocString = docs
}
Nothing -> ObjectInfoReply
{ header = replyHeader
, objectName = obj
, objectFound = False
, objectTypeString = ""
, objectDocString = ""
}
replyTo _ _ _ msg _ = do
liftIO $ putStrLn "Unknown message: "
liftIO $ print msg
return msg
dupHeader :: MonadIO m => MessageHeader -> MessageType -> m MessageHeader
dupHeader hdr mtype =
do uuid <- liftIO UUID.random
return hdr { messageId = uuid , msgType = mtype }
do
uuid <- liftIO UUID.random
return hdr { messageId = uuid, msgType = mtype }

19
ipython-kernel/src/IHaskell/IPython/Kernel.hs
View File

@ -1,12 +1,9 @@
-- | 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 X,
) where
-- | 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 X) where
import IHaskell.IPython.Types as X
import IHaskell.IPython.Message.Writer as X
import IHaskell.IPython.Message.Parser as X
import IHaskell.IPython.Message.UUID as X
import IHaskell.IPython.ZeroMQ as X
import IHaskell.IPython.Types as X
import IHaskell.IPython.Message.Writer as X
import IHaskell.IPython.Message.Parser as X
import IHaskell.IPython.Message.UUID as X
import IHaskell.IPython.ZeroMQ as X

93
ipython-kernel/src/IHaskell/IPython/Message/Parser.hs
View File

@ -1,9 +1,10 @@
{-# 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.
-- 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)
@ -17,9 +18,7 @@ import IHaskell.IPython.Types
type LByteString = Lazy.ByteString
----- External interface -----
-- | Parse a message from its ByteString components into a Message.
-- --- 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.
@ -32,26 +31,25 @@ parseMessage idents headerData parentHeader metadata content =
messageWithoutHeader = parser messageType $ Lazy.fromStrict content
in messageWithoutHeader { header = header }
----- Module internals -----
-- | Parse a header from its ByteString components into a MessageHeader.
-- --- 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
}
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.
-- 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
@ -71,27 +69,26 @@ 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.
-> 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 ExecuteRequestMessage = executeRequestParser
parser CompleteRequestMessage = completeRequestParser
parser ObjectInfoRequestMessage = objectInfoRequestParser
parser ShutdownRequestMessage = shutdownRequestParser
parser InputReplyMessage = inputReplyParser
parser CommOpenMessage = commOpenParser
parser CommDataMessage = commDataParser
parser CommCloseMessage = commCloseParser
parser HistoryRequestMessage = historyRequestParser
parser other = error $ "Unknown message type " ++ show other
parser ShutdownRequestMessage = shutdownRequestParser
parser InputReplyMessage = inputReplyParser
parser CommOpenMessage = commOpenParser
parser CommDataMessage = commDataParser
parser CommCloseMessage = commCloseParser
parser HistoryRequestMessage = historyRequestParser
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.
-- | 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:
-- | 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.
@ -99,22 +96,23 @@ kernelInfoRequestParser _ = KernelInfoRequest { header = noHeader }
executeRequestParser :: LByteString -> Message
executeRequestParser content =
let parser obj = do
code <- obj .: "code"
silent <- obj .: "silent"
storeHistory <- obj .: "store_history"
allowStdin <- obj .: "allow_stdin"
code <- obj .: "code"
silent <- obj .: "silent"
storeHistory <- obj .: "store_history"
allowStdin <- obj .: "allow_stdin"
return (code, silent, storeHistory, allowStdin)
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 = []
}
in ExecuteRequest
{ header = noHeader
, getCode = code
, getSilent = silent
, getAllowStdin = allowStdin
, getStoreHistory = storeHistory
, getUserVariables = []
, getUserExpressions = []
}
requestParser parser content = parsed
where
@ -147,7 +145,6 @@ objectInfoRequestParser = requestParser $ \obj -> do
dlevel <- obj .: "detail_level"
return $ ObjectInfoRequest noHeader oname dlevel
shutdownRequestParser :: LByteString -> Message
shutdownRequestParser = requestParser $ \obj -> do
code <- obj .: "restart"

31
ipython-kernel/src/IHaskell/IPython/Message/UUID.hs
View File

@ -1,26 +1,23 @@
-- | 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
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)
-- 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.
import Control.Monad (mzero, replicateM)
import Control.Applicative ((<$>))
import Data.Text (pack)
import Data.Aeson
import Data.UUID.V4 (nextRandom)
-- | A UUID (universally unique identifier).
data UUID = UUID String deriving (Show, Read, Eq, Ord)
data UUID =
-- 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.
UUID String
deriving (Show, Read, Eq, Ord)
-- | Generate a list of random UUIDs.
randoms :: Int -- ^ Number of UUIDs to generate.

181
ipython-kernel/src/IHaskell/IPython/Message/Writer.hs
View File

@ -1,135 +1,120 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Description : @ToJSON@ for Messages
--
-- This module contains the @ToJSON@ instance for @Message@.
module IHaskell.IPython.Message.Writer (
ToJSON(..)
) where
module IHaskell.IPython.Message.Writer (ToJSON(..)) where
import Data.Aeson
import Data.Map (Map)
import Data.Text (Text, pack)
import Data.Monoid (mempty)
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 Data.Text.Encoding
import IHaskell.IPython.Types
import IHaskell.IPython.Types
-- Convert message bodies into JSON.
instance ToJSON Message where
toJSON KernelInfoReply{ versionList = vers, language = language } = object [
"protocol_version" .= string "5.0", -- current protocol version, major and minor
"language_version" .= vers,
"language" .= language
]
toJSON KernelInfoReply { versionList = vers, language = language } =
object ["protocol_version" .= string "5.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 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 _ matches start end metadata status) = object [
"matches" .= matches,
"cursor_start" .= start,
"cursor_end" .= end,
"metadata" .= metadata,
"status" .= if status 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 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 _ matches start end metadata status) =
object
[ "matches" .= matches
, "cursor_start" .= start
, "cursor_end" .= end
, "metadata" .= metadata
, "status" .= if status
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 ShutdownReply { restartPending = restart } =
object ["restart" .= restart]
toJSON ClearOutput{wait = wait} = object [
"wait" .= wait
]
toJSON ClearOutput { wait = wait } =
object ["wait" .= wait]
toJSON RequestInput{inputPrompt = prompt} = object [
"prompt" .= prompt
]
toJSON RequestInput { inputPrompt = prompt } =
object ["prompt" .= prompt]
toJSON req@CommOpen{} = object [
"comm_id" .= commUuid req,
"target_name" .= commTargetName req,
"data" .= commData req
]
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@CommData{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@CommClose{} = object [
"comm_id" .= commUuid req,
"data" .= commData req
]
toJSON req@CommClose{} =
object ["comm_id" .= commUuid req, "data" .= commData req]
toJSON req@HistoryReply{} = object [ "history" .= map tuplify (historyReply req) ]
where tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of
Left inp -> toJSON inp
Right (inp, out) -> toJSON out)
toJSON req@HistoryReply{} =
object ["history" .= map tuplify (historyReply req)]
where
tuplify (HistoryReplyElement sess linum res) = (sess, linum, case res of
Left inp -> toJSON inp
Right (inp, out) -> toJSON out)
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"
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"
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 -> (Text, Value)
displayDataToJson (DisplayData mimeType dataStr) =
pack (show mimeType) .= String dataStr
pack (show mimeType) .= String dataStr
----- Constants -----
emptyMap :: Map String String
emptyMap = mempty

118
ipython-kernel/src/IHaskell/IPython/Stdin.hs
View File

@ -1,61 +1,50 @@
{-# 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
-- | 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 IHaskell.IPython.Types
import IHaskell.IPython.ZeroMQ
import IHaskell.IPython.Message.UUID as UUID
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.
-- | 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.
@ -78,17 +67,18 @@ stdinOnce dir = do
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
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
@ -98,15 +88,15 @@ getInputLine dir = do
-- 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 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

570
ipython-kernel/src/IHaskell/IPython/Types.hs
View File

@ -1,51 +1,52 @@
{-# LANGUAGE OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
-- | This module contains all types used to create an IPython language
-- kernel.
-- | This module contains all types used to create an IPython language kernel.
module IHaskell.IPython.Types (
-- * IPython kernel profile
Profile(..),
Transport(..),
Port(..),
IP(..),
-- * IPython kernel profile
Profile(..),
Transport(..),
Port(..),
IP(..),
-- * IPython kernelspecs
KernelSpec(..),
-- * IPython kernelspecs
KernelSpec(..),
-- * IPython messaging protocol
Message(..),
MessageHeader(..),
Username(..),
Metadata(..),
MessageType(..),
Width(..), Height(..),
StreamType(..),
ExecutionState(..),
ExecuteReplyStatus(..),
HistoryAccessType(..),
HistoryReplyElement(..),
replyType,
-- * IPython messaging protocol
Message(..),
MessageHeader(..),
Username(..),
Metadata(..),
MessageType(..),
Width(..),
Height(..),
StreamType(..),
ExecutionState(..),
ExecuteReplyStatus(..),
HistoryAccessType(..),
HistoryReplyElement(..),
replyType,
-- ** IPython display data message
DisplayData(..),
MimeType(..),
extractPlain
) where
-- ** 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)
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 ----------------------
------------------ IPython Kernel Profile Types ----------------------
--
-- | A TCP port.
type Port = Int
@ -57,15 +58,17 @@ 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.
, signatureKey :: ByteString -- ^ The HMAC encryption key.
}
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.
, signatureKey :: ByteString -- ^ The HMAC encryption key.
}
deriving (Show, Read)
-- Convert the kernel profile to and from JSON.
@ -87,35 +90,39 @@ instance FromJSON Profile where
instance ToJSON Profile where
toJSON profile = object
[ "ip" .= ip profile
, "transport" .= transport profile
, "stdin_port" .= stdinPort profile
[ "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" .= Text.decodeUtf8 (signatureKey profile)
, "hb_port" .= hbPort profile
, "shell_port" .= shellPort profile
, "iopub_port" .= iopubPort profile
, "key" .= Text.decodeUtf8 (signatureKey profile)
]
instance FromJSON Transport where
parseJSON (String mech) =
case mech of
"tcp" -> return TCP
_ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech
_ -> fail $ "Unknown transport mechanism " ++ Text.unpack mech
parseJSON _ = fail "Expected JSON string as transport."
instance ToJSON Transport where
toJSON TCP = String "tcp"
-------------------- IPython Kernelspec Types ----------------------
data KernelSpec = KernelSpec {
kernelDisplayName :: String, -- ^ Name shown to users to describe this kernel (e.g. "Haskell")
kernelLanguage :: String, -- ^ Name for the kernel; unique kernel identifier (e.g. "haskell")
kernelCommand :: [String] -- ^ Command to run to start the kernel. One of the strings may be
-- @"{connection_file}"@, which will be replaced by the path to a
-- kernel profile file (see @Profile@) when the command is run.
} deriving (Eq, Show)
data KernelSpec =
KernelSpec
{
-- | Name shown to users to describe this kernel (e.g. "Haskell")
kernelDisplayName :: String
-- | Name for the kernel; unique kernel identifier (e.g. "haskell")
, kernelLanguage :: String
-- | Command to run to start the kernel. One of the strings maybe @"{connection_file}"@, which will
-- be replaced by the path to a kernel profile file (see @Profile@) when the command is run.
, kernelCommand :: [String]
}
deriving (Eq, Show)
instance ToJSON KernelSpec where
toJSON kernelspec = object
@ -124,29 +131,31 @@ instance ToJSON KernelSpec where
, "language" .= kernelLanguage kernelspec
]
-------------------- IPython Message Types ----------------------
------------------ 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)
-- | 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.
-- 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,
"version" .= ("5.0" :: String),
"msg_type" .= showMessageType (msgType header)
]
toJSON header = object
[ "msg_id" .= messageId header
, "session" .= sessionId header
, "username" .= username header
, "version" .= ("5.0" :: String)
, "msg_type" .= showMessageType (msgType header)
]
-- | A username for the source of a message.
type Username = Text
@ -178,32 +187,32 @@ data MessageType = KernelInfoReplyMessage
| CommCloseMessage
| HistoryRequestMessage
| HistoryReplyMessage
deriving (Show, Read, Eq)
deriving (Show, Read, Eq)
showMessageType :: MessageType -> String
showMessageType KernelInfoReplyMessage = "kernel_info_reply"
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 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"
showMessageType HistoryRequestMessage = "history_request"
showMessageType HistoryReplyMessage = "history_reply"
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"
showMessageType HistoryRequestMessage = "history_request"
showMessageType HistoryReplyMessage = "history_reply"
instance FromJSON MessageType where
parseJSON (String s) =
@ -235,177 +244,161 @@ instance FromJSON MessageType where
_ -> 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, {- ^
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 @code@ -}
getCursorPos :: Int -- ^ Position of the cursor in unicode characters. json field @cursor_pos@
, getCursorPos :: Int -- ^ Position of the cursor in unicode characters. json field
-- @cursor_pos@
}
|
CompleteReply
{ header :: MessageHeader
, completionMatches :: [Text]
, completionCursorStart :: Int
, completionCursorEnd :: Int
, completionMetadata :: Metadata
, completionStatus :: Bool
}
|
ObjectInfoRequest
{ header :: MessageHeader
-- | Name of object being searched for.
, objectName :: Text
-- | Level of detail desired (defaults to 0). 0 is equivalent to foo?, 1 is equivalent to foo??.
, detailLevel :: Int
}
|
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 }
|
HistoryRequest
{ header :: MessageHeader
, historyGetOutput :: Bool -- ^ If True, also return output history in the resulting
-- dict.
, historyRaw :: Bool -- ^ If True, return the raw input history, else the
-- transformed input.
, historyAccessType :: HistoryAccessType -- ^ What history is being requested.
}
| HistoryReply { header :: MessageHeader, historyReply :: [HistoryReplyElement] }
| SendNothing -- Dummy message; nothing is sent.
deriving Show
}
| CompleteReply {
header :: MessageHeader,
completionMatches :: [Text],
completionCursorStart :: Int,
completionCursorEnd :: Int,
completionMetadata :: Metadata,
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
}
| HistoryRequest {
header :: MessageHeader,
historyGetOutput :: Bool, -- ^ If True, also return output history in the resulting dict.
historyRaw :: Bool, -- ^ If True, return the raw input history, else the transformed input.
historyAccessType :: HistoryAccessType -- ^ What history is being requested.
}
| HistoryReply {
header :: MessageHeader,
historyReply :: [HistoryReplyElement]
}
| SendNothing -- Dummy message; nothing is sent.
deriving Show
-- | Ways in which the frontend can request history.
-- TODO: Implement fields as described in messaging spec.
-- | Ways in which the frontend can request history. TODO: Implement fields as described in
-- messaging spec.
data HistoryAccessType = HistoryRange
| HistoryTail
| HistorySearch
deriving (Eq, Show)
-- | Reply to history requests.
data HistoryReplyElement = HistoryReplyElement { historyReplySession :: Int
, historyReplyLineNumber :: Int
, historyReplyContent :: Either String (String, String)
}
data HistoryReplyElement =
HistoryReplyElement
{ historyReplySession :: Int
, historyReplyLineNumber :: Int
, historyReplyContent :: Either String (String, String)
}
deriving (Eq, Show)
-- | Possible statuses in the execution reply messages.
data ExecuteReplyStatus = Ok | Err | Abort
data ExecuteReplyStatus = Ok
| Err
| Abort
instance Show ExecuteReplyStatus where
show Ok = "ok"
@ -413,40 +406,49 @@ instance Show ExecuteReplyStatus where
show Abort = "abort"
-- | The execution state of the kernel.
data ExecutionState = Busy | Idle | Starting deriving Show
data ExecutionState = Busy
| Idle
| Starting
deriving Show
-- | Input and output streams.
data StreamType = Stdin | Stdout deriving Show
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 ExecuteRequestMessage = Just ExecuteReplyMessage
replyType CompleteRequestMessage = Just CompleteReplyMessage
replyType ObjectInfoRequestMessage = Just ObjectInfoReplyMessage
replyType ShutdownRequestMessage = Just ShutdownReplyMessage
replyType HistoryRequestMessage = Just HistoryReplyMessage
replyType _ = Nothing
replyType ShutdownRequestMessage = Just ShutdownReplyMessage
replyType HistoryRequestMessage = Just HistoryReplyMessage
replyType _ = Nothing
-- | Data for display: a string with associated MIME type.
data DisplayData = DisplayData MimeType Text deriving (Typeable, Generic)
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.
-- 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
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
@ -454,22 +456,22 @@ data MimeType = PlainText
| MimeSvg
| MimeLatex
| MimeJavascript
deriving (Eq, Typeable, Generic)
deriving (Eq, Typeable, Generic)
-- Extract the plain text from a list of displays.
extractPlain :: [DisplayData] -> String
extractPlain disps =
case find isPlain disps of
Nothing -> ""
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 MimeHtml = "text/html"
show (MimePng _ _) = "image/png"
show (MimeJpg _ _) = "image/jpeg"
show MimeSvg = "image/svg+xml"
show MimeLatex = "text/latex"
show MimeJavascript = "application/javascript"

127
ipython-kernel/src/IHaskell/IPython/ZeroMQ.hs
View File

@ -1,15 +1,11 @@
{-# 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
-- 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 LBS
import Data.ByteString (ByteString)
@ -26,30 +22,37 @@ 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.
hmacKey :: ByteString -- ^ Key used to sign messages.
}
-- | 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
{
-- | A channel populated with requests from the frontend.
shellRequestChannel :: Chan Message
-- | Writing to this channel causes a reply to be sent to the frontend.
, shellReplyChannel :: Chan Message
-- | This channel is a duplicate of the shell request channel, though using a different backend
-- socket.
, controlRequestChannel :: Chan Message
-- | This channel is a duplicate of the shell reply channel, though using a different backend
-- socket.
, controlReplyChannel :: Chan Message
-- | Writing to this channel sends an iopub message to the frontend.
, iopubChannel :: Chan Message
-- | Key used to sign messages.
, hmacKey :: ByteString
}
data ZeroMQStdin = StdinChannel {
stdinRequestChannel :: Chan Message,
stdinReplyChannel :: Chan Message
}
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.
-- | 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.
-> Bool -- ^ Print debug output
-> IO ZeroMQInterface -- ^ The Message-channel based interface to the sockets.
@ -63,29 +66,28 @@ serveProfile profile debug = do
let channels = Channels shellReqChan shellRepChan controlReqChan controlRepChan iopubChan
(signatureKey profile)
-- Create the context in a separate thread that never finishes. If
-- withContext or withSocket complete, the context or socket become invalid.
-- 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 debug channels
forkIO $ serveSocket context Router (shellPort profile) $ shell debug 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.
-- 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 debug channels
return channels
serveStdin :: Profile -> IO ZeroMQStdin
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.
-- 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
@ -97,9 +99,8 @@ serveStdin profile = do
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.
-- | 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
@ -115,9 +116,9 @@ heartbeat _ socket = do
-- 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.
-- | 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 :: Bool -> ZeroMQInterface -> Socket Router -> IO ()
shell debug channels socket = do
-- Receive a message and write it to the interface channel.
@ -130,9 +131,9 @@ shell debug channels socket = do
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.
-- | 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 :: Bool -> ZeroMQInterface -> Socket Router -> IO ()
control debug channels socket = do
-- Receive a message and write it to the interface channel.
@ -143,11 +144,10 @@ control debug channels socket = do
where
requestChannel = controlRequestChannel channels
replyChannel = controlReplyChannel 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.
-- | Send messages via the iopub channel. | This reads messages from the ZeroMQ iopub interface
-- channel | and then writes the messages to the socket.
iopub :: Bool -> ZeroMQInterface -> Socket Pub -> IO ()
iopub debug channels socket =
readChan (iopubChannel channels) >>= sendMessage debug (hmacKey channels) socket
@ -179,19 +179,18 @@ receiveMessage debug socket = do
-- 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.
-- 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. Sign it using HMAC
-- with SHA-256 using the provided key.
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. Sign it using HMAC with SHA-256 using the provided key.
sendMessage :: Sender a => Bool -> ByteString -> Socket a -> Message -> IO ()
sendMessage _ _ _ SendNothing = return ()
sendMessage debug hmacKey socket message = do

14
verify_formatting.py
View File

@ -44,10 +44,16 @@ except:
# Find all the source files
sources = []
for root, dirnames, filenames in os.walk("src"):
for filename in filenames:
if filename.endswith(".hs"):
sources.append(os.path.join(root, filename))
for source_dir in ["src", "ipython-kernel", "ihaskell-display"]:
for root, dirnames, filenames in os.walk(source_dir):
# Skip cabal dist directories
if "dist" in root:
continue
for filename in filenames:
# Take Haskell files, but ignore the Cabal Setup.hs
if filename.endswith(".hs") and filename != "Setup.hs":
sources.append(os.path.join(root, filename))
hindent_outputs = {}