Skip to content

G
gargantext-ihaskell
Commit 7ba7c4d1 authored by Andrew Gibiansky's avatar Andrew Gibiansky
Browse files
Options

Merge pull request #444 from gibiansky/enforce-proper-formatting 

Enforce proper formatting
parents be10d383 dadd074f
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1985 additions and 1901 deletions
.gitignore
View file @ 7ba7c4d1
......@@ -16,3 +16,6 @@ todo
profile/profile.tar
.cabal-sandbox
cabal.sandbox.config
.tmp1
.tmp2
.tmp3
.travis.yml
View file @ 7ba7c4d1
......@@ -14,6 +14,7 @@ before_install:
- travis_retry sudo apt-get update
- travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex
- travis_retry sudo apt-get install libmagic-dev
- travis_retry sudo apt-get install python3
- travis_retry git clone http://www.github.com/zeromq/zeromq4-x.git libzmq
- export OLDPWD=$(pwd) && cd libzmq && travis_retry ./autogen.sh && travis_retry ./configure && make && travis_retry sudo make install && travis_retry sudo ldconfig && cd $OLDPWD
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH
......@@ -34,6 +35,8 @@ 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 ..
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.
......@@ -47,7 +50,10 @@ script:
# Build and run the test suite
- travis_retry cabal configure --enable-tests
- travis_retry cabal test --show-details=always
- |
if [ ${GHCVER%.*} = "7.8" ]; then
./verify_formatting.py
fi
- cabal sdist
# The following scriptlet checks that the resulting source distribution can be built & installed
......
src/IHaskell/BrokenPackages.hs
View file @ 7ba7c4d1
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>))
import ClassyPrelude hiding ((<|>))
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Text.Parsec
import Text.Parsec.String
import Control.Applicative hiding ((<|>), many)
import Data.String.Utils (startswith)
import Data.String.Utils (startswith)
import Shelly
import Shelly
data BrokenPackage = BrokenPackage {
packageID :: String,
brokenDeps :: [String]
}
data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
instance Show BrokenPackage where
show = packageID
-- | Get a list of broken packages.
-- This function internally shells out to `ghc-pkg`, and parses the output
-- in order to determine what packages are broken.
-- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- output in order to determine what packages are broken.
getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"]
checkOut <- lastStderr
-- Get rid of extraneous things
let rightStart str = startswith "There are problems" str ||
startswith " dependency" str
let rightStart str = startswith "There are problems" str ||
startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Right pkgs -> map show pkgs
return $
case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Right pkgs -> map show pkgs
check :: Parser BrokenPackage
check = string "There are problems in package "
......
src/IHaskell/Convert.hs
View file @ 7ba7c4d1
-- | Description : mostly reversible conversion between ipynb and lhs
module IHaskell.Convert (convert) where
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import IHaskell.Flags (Argument)
import System.Directory (doesFileExist)
import Text.Printf (printf)
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import IHaskell.Flags (Argument)
import System.Directory (doesFileExist)
import Text.Printf (printf)
-- | used by @IHaskell convert@
convert :: [Argument] -> IO ()
convert args = case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec { convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity lhsStyle,
convertOverwriteFiles = force }
convert args =
case fromJustConvertSpec (toConvertSpec args) of
ConvertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity lhsStyle
, convertOverwriteFiles = force
}
| toIpynb -> do
unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile
unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile
| otherwise -> do
unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile
unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile
-- | Call fail when the named file already exists.
failIfExists :: FilePath -> IO ()
......@@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file
when exists $ fail $
printf "File %s already exists. To force supply --force." file
src/IHaskell/Convert/Args.hs
View file @ 7ba7c4d1
-- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args
(ConvertSpec(..),
fromJustConvertSpec,
toConvertSpec,
) where
module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
import Data.List (partition)
import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T (pack, Text)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf)
-- | ConvertSpec is the accumulator for command line arguments
data ConvertSpec f = ConvertSpec
{ convertToIpynb :: f Bool,
convertInput :: f FilePath,
convertOutput :: f FilePath,
convertLhsStyle :: f (LhsStyle T.Text),
convertOverwriteFiles :: Bool
}
data ConvertSpec f =
ConvertSpec
{ convertToIpynb :: f Bool
, convertInput :: f FilePath
, convertOutput :: f FilePath
, convertLhsStyle :: f (LhsStyle T.Text)
, convertOverwriteFiles :: Bool
}
-- | Convert a possibly-incomplete specification for what to convert
-- into one which can be executed. Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec {
convertToIpynb = Identity toIpynb,
convertInput = Identity inputFile,
convertOutput = Identity outputFile,
convertLhsStyle = Identity $ fromMaybe
(T.pack <$> lhsStyleBird)
(convertLhsStyle convertSpec)
}
-- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
}
where
toIpynb = fromMaybe (error "Error: direction for conversion unknown")
(convertToIpynb convertSpec)
(inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of
(convertToIpynb convertSpec)
(inputFile, outputFile) =
case (convertInput convertSpec, convertOutput convertSpec) of
(Nothing, Nothing) -> error "Error: no files specified for conversion"
(Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs")
(Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Nothing)
| toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs")
(Nothing, Just o)
| toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o)
-- | Does this @Argument@ explicitly request a file format?
isFormatSpec :: Argument -> Bool
isFormatSpec :: Argument -> Bool
isFormatSpec (ConvertToFormat _) = True
isFormatSpec (ConvertFromFormat _) = True
isFormatSpec _ = False
toConvertSpec :: [Argument] -> ConvertSpec Maybe
toConvertSpec args = mergeArgs otherArgs
(mergeArgs formatSpecArgs initialConvertSpec)
toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec)
where
(formatSpecArgs, otherArgs) = partition isFormatSpec args
initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False
mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArgs :: [Argument] -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArgs args initialConvertSpec = foldr mergeArg initialConvertSpec args
mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle = error $ printf
"Conflicting lhs styles requested: <%s> and <%s>"
(show lhsStyle) (show previousLhsStyle)
previousLhsStyle /= fmap T.pack lhsStyle
= error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>"
inputFile previousInputFile
| otherwise = convertSpec {
convertInput = Just inputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev
(prev @ (Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format
}
previousInputFile /= inputFile
= error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile
| otherwise = convertSpec
{ convertInput = Just inputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format
}
mergeArg (ConvertTo outputFile) convertSpec
| Just previousOutputFile <- convertOutput convertSpec,
previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>"
outputFile previousOutputFile
| otherwise = convertSpec {
convertOutput = Just outputFile,
convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev
(prev @ (Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
previousOutputFile /= outputFile
= error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile
| otherwise = convertSpec
{ convertOutput = Just outputFile
, convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg
++ show unexpectedArg
-- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s =
case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing
src/IHaskell/Convert/IpynbToLhs.hs
View file @ 7ba7c4d1
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String))
import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String))
import qualified Data.ByteString.Lazy as L (readFile)
import qualified Data.HashMap.Strict as M (lookup)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty))
import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
import qualified Data.Text.Lazy.IO as T (writeFile)
import Data.Vector (Vector)
import Data.Vector (Vector)
import qualified Data.Vector as V (map, mapM, toList)
import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix))
import IHaskell.Flags (LhsStyle(..))
ipynbToLhs :: LhsStyle T.Text
-> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write
-> IO ()
-> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write
-> IO ()
ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of
Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList
$ V.map (\(Object y) -> convCell sty y) cells
T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line
-> Vector Value -- ^ a json array of text lines
-> Maybe T.Text
-> Vector Value -- ^ a json array of text lines
-> Maybe T.Text
concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr
toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x)
toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable
-- for the type of lhs file described by the @sty@
-- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text
convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object,
~ (Just s) <- concatWithPrefix "" xs = s
Just (Array xs) <- M.lookup "source" object,
~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o) = "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o)
= "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text
convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text
convOutputs sty array = do
outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array
return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty
getTexts :: T.Text -> Value -> Maybe T.Text
getTexts :: T.Text -> Value -> Maybe T.Text
getTexts p (Object object)
| Just (Array text) <- M.lookup "text" object = concatWithPrefix p text
getTexts _ _ = Nothing
src/IHaskell/Convert/LhsToIpynb.hs
View file @ 7ba7c4d1
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import qualified Data.ByteString.Lazy as L (writeFile)
import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty))
import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty))
import qualified Data.Text as TS (Text)
import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip)
import qualified Data.Text.Lazy.IO as T (readFile)
import qualified Data.Vector as V (fromList, singleton)
import IHaskell.Flags (LhsStyle(LhsStyle))
import IHaskell.Flags (LhsStyle(LhsStyle))
lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO ()
lhsToIpynb sty from to = do
classed <- classifyLines sty . T.lines <$> T.readFile from
classed <- classifyLines sty . T.lines <$> T.readFile from
L.writeFile to . encode . encodeCells $ groupClassified classed
data CellLine a = CodeLine a | OutputLine a | MarkdownLine a
deriving Show
data CellLine a = CodeLine a
| OutputLine a
| MarkdownLine a
deriving Show
isCode :: CellLine t -> Bool
isCode :: CellLine t -> Bool
isCode (CodeLine _) = True
isCode _ = False
isOutput :: CellLine t -> Bool
isOutput :: CellLine t -> Bool
isOutput (OutputLine _) = True
isOutput _ = False
isMD :: CellLine t -> Bool
isMD :: CellLine t -> Bool
isMD (MarkdownLine _) = True
isMD _ = False
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a) = a == mempty
isEmptyMD _ = False
untag :: CellLine t -> t
untag :: CellLine t -> t
untag (CodeLine a) = a
untag (OutputLine a) = a
untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a
deriving (Show)
data Cell a = Code a a
| Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value
encodeCells xs = object $
[ "cells" .= Array (V.fromList (map cellToVal xs)) ]
++ boilerplate
["cells" .= Array (V.fromList (map cellToVal xs))]
++ boilerplate
cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $
[ "cell_type" .= String "code",
"execution_count" .= Null,
"metadata" .= object [ "collapsed" .= Bool False ],
"source" .= arrayFromTxt i,
"outputs" .= Array
(V.fromList (
[ object ["text" .= arrayFromTxt o,
"metadata" .= object [],
"output_type" .= String "display_data" ]
| _ <- take 1 o])) ]
[ "cell_type" .= String "code"
, "execution_count" .= Null
, "metadata" .= object ["collapsed" .= Bool False]
, "source" .= arrayFromTxt i
, "outputs" .= Array
(V.fromList
([object
[ "text" .= arrayFromTxt o
, "metadata" .= object []
, "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $
[ "cell_type" .= String "markdown",
"metadata" .= object [ "hidden" .= Bool False ],
"source" .= arrayFromTxt txt ]
[ "cell_type" .= String "markdown"
, "metadata" .= object ["hidden" .= Bool False]
, "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value
arrayFromTxt :: [T.Text] -> Value
arrayFromTxt i = Array (V.fromList $ map stringify i)
where
stringify = String . T.toStrict . flip T.snoc '\n'
where
stringify = String . T.toStrict . flip T.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the
-- json describing cells and output correctly.
-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- output correctly.
boilerplate :: [(TS.Text, Value)]
boilerplate =
[ "metadata" .= object [ kernelspec, lang ]
, "nbformat" .= Number 4
, "nbformat_minor" .= Number 0
]
["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
where
kernelspec = "kernelspec" .= object [
"display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object [
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
kernelspec = "kernelspec" .= object
[ "display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified (CodeLine a : x)
| (c,x) <- span isCode x,
(_,x) <- span isEmptyMD x,
(o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a : x)
| (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x
groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x
groupClassified (CodeLine a:x)
| (c, x) <- span isCode x,
(_, x) <- span isEmptyMD x,
(o, x) <- span isOutput x
= Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a:x)
| (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = []
classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) = case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing, Just a) -> OutputLine a : classifyLines sty ls
(Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =
case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing, Just a) -> OutputLine a : classifyLines sty ls
(Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where
sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x
blankCodeLine x = if T.strip x == T.strip l then Just "" else Nothing
blankCodeLine x = if T.strip x == T.strip l
then Just ""
else Nothing
dropSpace = T.dropWhile isSpace
classifyLines _ [] = []
src/IHaskell/Display.hs
View file @ 7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of
-- augmenting the IHaskell notebook or writing your own display mechanisms
-- and widgets, this module contains all functions you need.
-- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell
-- notebook or writing your own display mechanisms and widgets, this module contains all functions
-- you need.
--
-- In order to create a display mechanism for a particular data type, write
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@.
-- (Note the capitalization - it's important!) Then, in that module, add an
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create
-- a widget, add an instance of @IHaskellWidget@.
-- In order to create a display mechanism for a particular data type, write a module named (for
-- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- your data type. Similarly, to create a widget, add an instance of @IHaskellWidget@.
--
-- An example of creating a display is provided in the <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.
-- An example of creating a display is provided in the
-- <http://gibiansky.github.io/IHaskell/demo.html demo notebook>.
--
module IHaskell.Display (
-- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..),
Display(..),
DisplayData(..),
IHaskellWidget(..),
-- ** Interactive use functions
printDisplay,
-- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many,
-- ** Image and data encoding functions
Width, Height, Base64(..),
encode64, base64,
-- ** Utilities
switchToTmpDir,
-- * Internal only use
displayFromChan,
serializeDisplay,
Widget(..),
) where
import ClassyPrelude
import Data.Serialize as Serialize
import Data.ByteString hiding (map, pack)
import Data.String.Utils (rstrip)
-- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..),
Display(..),
DisplayData(..),
IHaskellWidget(..),
-- ** Interactive use functions
printDisplay,
-- * Constructors for displays
plain,
html,
png,
jpg,
svg,
latex,
javascript,
many,
-- ** Image and data encoding functions
Width,
Height,
Base64(..),
encode64,
base64,
-- ** Utilities
switchToTmpDir,
-- * Internal only use
displayFromChan,
serializeDisplay,
Widget(..),
) where
import ClassyPrelude
import Data.Serialize as Serialize
import Data.ByteString hiding (map, pack)
import Data.String.Utils (rstrip)
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char
import Data.Aeson (Value)
import System.Directory(getTemporaryDirectory, setCurrentDirectory)
import Data.Aeson (Value)
import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Types
import IHaskell.Types
type Base64 = Text
......@@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display]
-- > IO (IO Display)
--
-- be run the IO and get rendered (if the frontend allows it) in the pretty
-- form.
-- be run the IO and get rendered (if the frontend allows it) in the pretty form.
instance IHaskellDisplay a => IHaskellDisplay (IO a) where
display = (display =<<)
......@@ -101,15 +110,15 @@ latex = DisplayData MimeLatex . pack
javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack
-- | Generate a PNG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
png :: Width -> Height -> Base64 -> DisplayData
png width height = DisplayData (MimePng width height)
-- | Generate a JPG display of the given width and height. Data must be
-- provided in a Base64 encoded manner, suitable for embedding into HTML.
-- The @base64@ function may be used to encode data into this format.
-- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- this format.
jpg :: Width -> Height -> Base64 -> DisplayData
jpg width height = DisplayData (MimeJpg width height)
......@@ -121,42 +130,37 @@ encode64 str = base64 $ Char.pack str
base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode
-- | For internal use within IHaskell.
-- Serialize displays to a ByteString.
-- | For internal use within IHaskell. Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode
-- | Items written to this chan will be included in the output sent
-- to the frontend (ultimately the browser), the next time IHaskell
-- has an item to display.
-- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- browser), the next time IHaskell has an item to display.
{-# NOINLINE displayChan #-}
displayChan :: TChan Display
displayChan = unsafePerformIO newTChanIO
-- | Take everything that was put into the 'displayChan' at that point
-- out, and make a 'Display' out of it.
-- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out
-- of it.
displayFromChan :: IO (Maybe Display)
displayFromChan =
Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action
-- until it return Nothing, and puts all the Justs in a list.
-- If you find yourself using more functionality from monad-loops, just add
-- the package dependency instead of copying more code from it.
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- just add the package dependency instead of copying more code from it.
unfoldM :: IO (Maybe a) -> IO [a]
unfoldM f = maybe (return []) (\r -> (r:) <$> unfoldM f) =<< f
unfoldM f = maybe (return []) (\r -> (r :) <$> unfoldM f) =<< f
-- | Write to the display channel. The contents will be displayed in the
-- notebook once the current execution call ends.
-- | Write to the display channel. The contents will be displayed in the notebook once the current
-- execution call ends.
printDisplay :: IHaskellDisplay a => a -> IO ()
printDisplay disp = display disp >>= atomically . writeTChan displayChan
-- | Convenience function for client libraries. Switch to a temporary
-- directory so that any files we create aren't visible. On Unix, this is
-- usually /tmp.
-- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- create aren't visible. On Unix, this is usually /tmp.
switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where
where
switchDir =
getTemporaryDirectory >>=
getTemporaryDirectory >>=
setCurrentDirectory
src/IHaskell/Eval/Completion.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Eval/Evaluate.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Eval/Hoogle.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Eval/Info.hs
View file @ 7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
module IHaskell.Eval.Info (
info
) where
import ClassyPrelude hiding (liftIO)
{- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info (info) where
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)
import ClassyPrelude hiding (liftIO)
import GHC
import Outputable
import Exception
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)
import GHC
import Outputable
import Exception
info :: String -> Interpreter String
info name = ghandle handler $ do
dflags <- getSessionDynFlags
result <- exprType name
return $ typeCleaner $ showPpr dflags result
where
return $ typeCleaner $ showPpr dflags result
where
handler :: SomeException -> Interpreter String
handler _ = return ""
src/IHaskell/Eval/Lint.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Eval/ParseShell.hs
View file @ 7ba7c4d1
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char
quote :: Parser Char
quote = char '\"'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
......@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill p end = scan
where
scan = end <|> do
x <- p
xs <- scan
return $ x:xs
x <- p
xs <- scan
return $ x : xs
manyTill1 p end = do x <- p
xs <- manyTill p end
return $ x : xs
manyTill1 p end = do
x <- p
xs <- manyTill p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do
x <- noneOf "\\"
lookAhead p
return [x]
......@@ -36,8 +36,9 @@ quotedString = do
quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
where end = unescapedChar space
unquotedString = manyTill1 anyChar end
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word"
......@@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n)
words :: Parser [String]
words = try (eof *> return []) <|> do
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
return $ x : xs
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
return $ x : xs
parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n")
src/IHaskell/Eval/Parser.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Eval/Util.hs
View file @ 7ba7c4d1
This diff is collapsed.
src/IHaskell/Flags.hs
View file @ 7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags (
IHaskellMode(..),
Argument(..),
......@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import Data.List (findIndex)
import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with
-- the mode being invoked.
-- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
data Args = Args IHaskellMode [Argument]
deriving Show
......@@ -33,30 +33,29 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
data LhsStyle string =
LhsStyle
{ lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
deriving (Eq, Functor, Show)
data NotebookFormat = LhsMarkdown
| IpynbFile
deriving (Eq, Show)
-- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String
| InstallKernelSpec
| ConvertLhs
| Kernel (Maybe String)
deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and
-- arguments to process.
-- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
parseFlags :: [String] -> Either String Args
parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags
......@@ -111,7 +110,8 @@ installKernelSpec =
[ghcLibFlag, kernelDebugFlag, confFlag, helpFlag]
kernel :: Mode Args
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg [ghcLibFlag, kernelDebugFlag, confFlag]
kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg
[ghcLibFlag, kernelDebugFlag, confFlag]
where
kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
......@@ -154,16 +154,17 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
lhsStyleBird, lhsStyleTex :: LhsStyle String
lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" ""
lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"
lhsStyleTex = LhsStyle "" "" "\\begin{code}" "\\end{code}" "\\begin{verbatim}" "\\end{verbatim}"
ihaskellArgs :: Mode Args
ihaskellArgs =
let descr = "Haskell for Interactive Computing."
let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup allModes }
where
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
in noMode { modeGroupModes = toGroup allModes }
where
add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected ""
......
src/IHaskell/IPython.hs
View file @ 7ba7c4d1
......@@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types
import System.Posix.Signals
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
data KernelSpecOptions =
KernelSpecOptions
{ kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile
}
defaultKernelSpecOptions = KernelSpecOptions
{ kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile
}
-- | The IPython kernel name.
kernelName :: IsString a => a
kernelName = "haskell"
......@@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just (1:_) -> oldIPython
Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number."
where
badIPython :: Text -> Sh ()
badIPython message = liftIO $ do
......@@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location.
-- The right location is determined by using `ipython kernelspec install --user`.
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath
......@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just file -> ["--conf", file])
++ ["--ghclib", kernelSpecGhcLibdir opts]
let kernelSpec = KernelSpec { kernelDisplayName = "Haskell"
, kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
let kernelSpec = KernelSpec
{ kernelDisplayName = "Haskell"
, kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec
-- directory; then, shell out to IPython to install this kernelspec directory.
-- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json"
......@@ -180,21 +185,19 @@ installKernelspec replace opts = void $ do
kernelSpecCreated :: Sh Bool
kernelSpecCreated = do
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined.
-- Otherwise, do nothing.
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
subHome :: String -> IO String
subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an
-- error message complaining about it.
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- about it.
path :: Text -> Sh FilePath
path exe = do
path <- which $ fromText exe
......@@ -229,9 +232,8 @@ getIHaskellPath = do
if FS.absolute f
then return $ FS.encodeString f
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH
-- variable to find where IHaskell lives.
-- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
if FS.filename f == f
then do
ihaskellPath <- which "ihaskell"
......
src/IHaskell/Types.hs
View file @ 7ba7c4d1
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
-- | Description : All message type definitions.
module IHaskell.Types (
Message (..),
MessageHeader (..),
MessageType(..),
Username,
Metadata(..),
replyType,
ExecutionState (..),
StreamType(..),
MimeType(..),
DisplayData(..),
EvaluationResult(..),
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width, Height,
Display(..),
defaultKernelState,
extractPlain,
kernelOpts,
KernelOpt(..),
IHaskellDisplay(..),
IHaskellWidget(..),
Widget(..),
CommInfo(..),
KernelSpec(..),
) where
Message(..),
MessageHeader(..),
MessageType(..),
Username,
Metadata(..),
replyType,
ExecutionState(..),
StreamType(..),
MimeType(..),
DisplayData(..),
EvaluationResult(..),
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width,
Height,
Display(..),
defaultKernelState,
extractPlain,
kernelOpts,
KernelOpt(..),
IHaskellDisplay(..),
IHaskellWidget(..),
Widget(..),
CommInfo(..),
KernelSpec(..),
) where
import ClassyPrelude
import qualified Data.ByteString.Char8 as Char
......@@ -40,8 +41,8 @@ import IHaskell.IPython.Kernel
-- | A class for displayable Haskell types.
--
-- IHaskell's displaying of results behaves as if these two
-- overlapping/undecidable instances also existed:
-- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also
-- existed:
--
-- > instance (Show a) => IHaskellDisplay a
-- > instance Show a where shows _ = id
......@@ -50,12 +51,10 @@ class IHaskellDisplay a where
-- | Display as an interactive widget.
class IHaskellDisplay a => IHaskellWidget a where
-- | Output target name for this widget.
-- The actual input parameter should be ignored.
-- | Output target name for this widget. The actual input parameter should be ignored.
targetName :: a -> String
-- | Called when the comm is opened. Allows additional messages to be sent
-- after comm open.
-- | Called when the comm is opened. Allows additional messages to be sent after comm open.
open :: a -- ^ Widget to open a comm port with.
-> (Value -> IO ()) -- ^ Way to respond to the message.
-> IO ()
......@@ -75,7 +74,7 @@ class IHaskellDisplay a => IHaskellWidget a where
close _ _ = return ()
data Widget = forall a. IHaskellWidget a => Widget a
deriving Typeable
deriving Typeable
instance IHaskellDisplay Widget where
display (Widget widget) = display widget
......@@ -89,86 +88,92 @@ instance IHaskellWidget Widget where
instance Show Widget where
show _ = "<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple
-- results from the same expression.
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- expression.
data Display = Display [DisplayData]
| ManyDisplay [Display]
deriving (Show, Typeable, Generic)
deriving (Show, Typeable, Generic)
instance Serialize Display
instance Monoid Display where
mempty = Display []
ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b)
ManyDisplay a `mappend` b = ManyDisplay (a ++ [b])
a `mappend` ManyDisplay b = ManyDisplay (a : b)
a `mappend` b = ManyDisplay [a,b]
mempty = Display []
ManyDisplay a `mappend` ManyDisplay b = ManyDisplay (a ++ b)
ManyDisplay a `mappend` b = ManyDisplay (a ++ [b])
a `mappend` ManyDisplay b = ManyDisplay (a : b)
a `mappend` b = ManyDisplay [a, b]
instance Semigroup Display where
a <> b = a `mappend` b
-- | All state stored in the kernel between executions.
data KernelState = KernelState { getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool
, useShowErrors :: Bool
, useShowTypes :: Bool
, usePager :: Bool
, openComms :: Map UUID Widget
, kernelDebug :: Bool
}
data KernelState =
KernelState
{ getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool
, useShowErrors :: Bool
, useShowTypes :: Bool
, usePager :: Bool
, openComms :: Map UUID Widget
, kernelDebug :: Bool
}
deriving Show
defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, kernelDebug = False
}
defaultKernelState = KernelState
{ getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, kernelDebug = False
}
-- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt {
getOptionName :: [String], -- ^ Ways to set this option via `:option`
getSetName :: [String], -- ^ Ways to set this option via `:set`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state.
}
data KernelOpt =
KernelOpt
{ getOptionName :: [String] -- ^ Ways to set this option via `:option`
, getSetName :: [String] -- ^ Ways to set this option via `:set`
, getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
-- state.
}
kernelOpts :: [KernelOpt]
kernelOpts =
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
]
-- | Current HLint status.
data LintStatus
= LintOn
| LintOff
deriving (Eq, Show)
data LintStatus = LintOn
| LintOff
deriving (Eq, Show)
data CommInfo = CommInfo Widget UUID String deriving Show
data CommInfo = CommInfo Widget UUID String
deriving Show
-- | Output of evaluation.
data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult {
outputs :: Display -- ^ Display outputs.
}
| FinalResult {
outputs :: Display, -- ^ Display outputs.
pagerOut :: String, -- ^ Text to display in the IPython pager.
startComms :: [CommInfo] -- ^ Comms to start.
}
-- | An intermediate result which communicates what has been printed thus
-- far.
IntermediateResult
{ outputs :: Display -- ^ Display outputs.
}
|
FinalResult
{ outputs :: Display -- ^ Display outputs.
, pagerOut :: String -- ^ Text to display in the IPython pager.
, startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show
src/Main.hs
View file @ 7ba7c4d1
This diff is collapsed.
verify_formatting.py 0 → 100755
View file @ 7ba7c4d1
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment