Commit 7ba7c4d1 authored by Andrew Gibiansky's avatar Andrew Gibiansky

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

Enforce proper formatting
parents be10d383 dadd074f
......@@ -16,3 +16,6 @@ todo
profile/profile.tar
.cabal-sandbox
cabal.sandbox.config
.tmp1
.tmp2
.tmp3
......@@ -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
......
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>))
......@@ -11,17 +12,13 @@ import Data.String.Utils (startswith)
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"]
......@@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do
startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of
return $
case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> []
Right pkgs -> map show pkgs
......
-- | 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.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import IHaskell.Flags (Argument)
......@@ -10,12 +11,15 @@ 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
......@@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file
when exists $ fail $
printf "File %s already exists. To force supply --force." file
-- | 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))
......@@ -15,35 +11,36 @@ 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.
-- | 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)
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
(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")
(Just i, Nothing)
| toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs")
(Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o)
(Nothing, Just o)
| toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o)
......@@ -53,10 +50,8 @@ 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
......@@ -68,40 +63,39 @@ 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
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
(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
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
(prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format
}
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg
-- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of
fromExt s =
case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile
_ -> Nothing
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>))
......@@ -12,7 +13,7 @@ import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
import qualified Data.Text.Lazy.IO as T (writeFile)
import Data.Vector (Vector)
import qualified Data.Vector as V (map, mapM, toList)
import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix))
import IHaskell.Flags (LhsStyle(..))
ipynbToLhs :: LhsStyle T.Text
-> FilePath -- ^ the filename of an ipython notebook
......@@ -22,8 +23,7 @@ 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
......@@ -35,19 +35,21 @@ 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 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" <>
~(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"
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>))
......@@ -19,7 +20,9 @@ lhsToIpynb sty from to = do
classed <- classifyLines sty . T.lines <$> T.readFile from
L.writeFile to . encode . encodeCells $ groupClassified classed
data CellLine a = CodeLine a | OutputLine a | MarkdownLine a
data CellLine a = CodeLine a
| OutputLine a
| MarkdownLine a
deriving Show
isCode :: CellLine t -> Bool
......@@ -38,37 +41,39 @@ isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a) = a == mempty
isEmptyMD _ = False
untag :: CellLine t -> t
untag (CodeLine a) = a
untag (OutputLine a) = a
untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a
deriving (Show)
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)) ]
["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
......@@ -76,44 +81,41 @@ arrayFromTxt i = Array (V.fromList $ map stringify i)
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"
kernelspec = "kernelspec" .= object
[ "display_name" .= String "Haskell"
, "language" .= String "haskell"
, "name" .= String "haskell"
]
lang = "language_info" .= object [
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
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
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
(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 _ [] = []
{-# 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
......@@ -23,11 +23,21 @@ module IHaskell.Display (
printDisplay,
-- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many,
plain,
html,
png,
jpg,
svg,
latex,
javascript,
many,
-- ** Image and data encoding functions
Width, Height, Base64(..),
encode64, base64,
Width,
Height,
Base64(..),
encode64,
base64,
-- ** Utilities
switchToTmpDir,
......@@ -45,7 +55,7 @@ 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 System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
......@@ -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
switchDir =
getTemporaryDirectory >>=
setCurrentDirectory
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Eval.Hoogle (
search,
document,
render,
OutputFormat(..),
HoogleResult
HoogleResult,
) where
import ClassyPrelude hiding (last, span, div)
......@@ -22,19 +23,13 @@ import qualified Prelude as P
import IHaskell.IPython
-- | Types of formats to render output to.
data OutputFormat
= Plain -- ^ Render to plain text.
data OutputFormat = Plain -- ^ Render to plain text.
| HTML -- ^ Render to HTML.
data HoogleResponse = HoogleResponse {
location :: String,
self :: String,
docs :: String
}
data HoogleResponse = HoogleResponse { location :: String, self :: String, docs :: String }
deriving (Eq, Show)
data HoogleResult
= SearchResult HoogleResponse
data HoogleResult = SearchResult HoogleResponse
| DocResult HoogleResponse
| NoResult String
deriving Show
......@@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where
instance FromJSON HoogleResponse where
parseJSON (Object obj) =
HoogleResponse <$>
obj .: "location" <*>
obj .: "self" <*>
obj .: "docs"
HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
parseJSON _ = fail "Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string.
-- This searches Hoogle using the internet. It returns either an error
-- message or the successful JSON result.
-- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- an error message or the successful JSON result.
query :: String -> IO (Either String String)
query str = do
request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of
return $
case response of
Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
where
queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
......@@ -78,27 +71,27 @@ urlEncode (ch:t)
| otherwise = escape (P.fromEnum ch) (urlEncode t)
where
escape :: Int -> String -> String
escape b rs = '%':showH (b `P.div` 16) (showH (b `mod` 16) rs)
escape b rs = '%' : showH (b `P.div` 16) (showH (b `mod` 16) rs)
showH :: Int -> String -> String
showH x xs
| x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x-10)) : xs
| otherwise = toEnum (o_A + (x - 10)) : xs
where
o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A'
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 0xff = (x:acc)
| x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle.
-- Return all search results.
-- | Search for a query on Hoogle. Return all search results.
search :: String -> IO [HoogleResult]
search string = do
response <- query string
return $ case response of
return $
case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ Char.pack json of
......@@ -108,16 +101,17 @@ search string = do
[] -> [NoResult "no matching identifiers found."]
res -> res
-- | Look up an identifier on Hoogle.
-- Return documentation for that identifier. If there are many
-- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many
-- identifiers, include documentation for all of them.
document :: String -> IO [HoogleResult]
document string = do
matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults
return $ case results of
return $
case results of
[] -> [NoResult "no matching identifiers found."]
res -> res
where
matches (SearchResult resp) =
case split " " $ self resp of
......@@ -134,21 +128,14 @@ render HTML = renderHtml
-- | Render a Hoogle result to plain text.
renderPlain :: HoogleResult -> String
renderPlain (NoResult res) =
"No response available: " ++ res
renderPlain (SearchResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
renderPlain (DocResult resp) =
printf "%s\nURL: %s\n%s"
(self resp)
(location resp)
(docs resp)
printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
-- | Render a Hoogle result to HTML.
renderHtml :: HoogleResult -> String
......@@ -167,37 +154,37 @@ renderHtml (SearchResult resp) =
renderSelf :: String -> String -> String
renderSelf string loc
| startswith "package" string
= pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "package" string =
pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "module" string
= let package = extractPackageName loc in
mod ++ " " ++
| startswith "module" string =
let package = extractPackageName loc
in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
| startswith "class" string
= let package = extractPackageName loc in
cls ++ " " ++
| startswith "class" string =
let package = extractPackageName loc
in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++
packageSub package
| startswith "data" string
= let package = extractPackageName loc in
dat ++ " " ++
| startswith "data" string =
let package = extractPackageName loc
in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++
packageSub package
| otherwise
= let [name, args] = split "::" string
| otherwise =
let [name, args] = split "::" string
package = extractPackageName loc
modname = extractModuleName loc in
span "hoogle-name" (unicodeReplace $
modname = extractModuleName loc
in span "hoogle-name"
(unicodeReplace $
link loc (strip name) ++
" :: " ++
strip args)
++ packageAndModuleSub package modname
where
extractPackage = strip . replace "package" ""
extractModule = strip . replace "module" ""
......@@ -239,8 +226,7 @@ renderDocs doc =
if isCode lines
then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines
in
div "hoogle-doc" $ unlines $ map makeBlock groups
in div "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String
extractPackageName link = do
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-}
module IHaskell.Eval.Info (
info
) where
{- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info (info) where
import ClassyPrelude hiding (liftIO)
......
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint
) where
module IHaskell.Eval.Lint (lint) where
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
......@@ -32,13 +31,13 @@ import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion
= Suggest {
line :: LineNumber,
found :: String,
whyNot :: String,
severity :: Severity,
suggestion :: String
data LintSuggestion =
Suggest
{ line :: LineNumber
, found :: String
, whyNot :: String
, severity :: Severity
, suggestion :: String
}
deriving (Eq, Show)
......@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String
lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable
-- report on linting warnings and errors.
-- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- and errors.
lint :: [Located CodeBlock] -> IO Display
lint blocks = do
-- Initialize hlint settings
......@@ -66,26 +65,25 @@ lint blocks = do
-- create 'suggestions'
let modules = mapMaybe (createModule mode) blocks
ideas = applyHints classify hint (map (\m->(m,[])) modules)
ideas = applyHints classify hint (map (\m -> (m, [])) modules)
suggestions = mapMaybe showIdea ideas
return $ Display $
if null suggestions
then []
else
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion
showIdea idea =
case ideaTo idea of
Nothing -> Nothing
Just whyNot -> Just Suggest {
line = srcSpanStartLine $ ideaSpan idea,
found = showSuggestion $ ideaFrom idea,
whyNot = showSuggestion whyNot,
severity = ideaSeverity idea,
suggestion = ideaHint idea
Just whyNot -> Just
Suggest
{ line = srcSpanStartLine $ ideaSpan idea
, found = showSuggestion $ ideaFrom idea
, whyNot = showSuggestion whyNot
, severity = ideaSeverity idea
, suggestion = ideaHint idea
}
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
......@@ -111,12 +109,12 @@ createModule mode (Located line block) =
unparse _ = Nothing
srcSpan :: SrcSpan
srcSpan = SrcSpan {
srcSpanFilename = "<interactive>",
srcSpanStartLine = line,
srcSpanStartColumn = 0,
srcSpanEndLine = line + length (lines blockStr),
srcSpanEndColumn = length $ last $ lines blockStr
srcSpan = SrcSpan
{ srcSpanFilename = "<interactive>"
, srcSpanStartLine = line
, srcSpanStartColumn = 0
, srcSpanEndLine = line + length (lines blockStr)
, srcSpanEndColumn = length $ last $ lines blockStr
}
loc :: SrcSpanInfo
......@@ -135,7 +133,8 @@ createModule mode (Located line block) =
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of
stmtToModule stmtStr =
case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b
where
......@@ -158,10 +157,7 @@ createModule mode (Located line block) =
plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s"
(line suggest)
(suggestion suggest)
(found suggest)
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest)
(whyNot suggest)
htmlSuggestions :: [LintSuggestion] -> String
......@@ -169,18 +165,17 @@ htmlSuggestions = concatMap toHtml
where
toHtml :: LintSuggestion -> String
toHtml suggest = concat
[
named $ suggestion suggest,
floating "left" $ style severityClass "Found:" ++
[ named $ suggestion suggest
, floating "left" $ style severityClass "Found:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest),
floating "left" $ style severityClass "Why Not:" ++
styleId "highlight-code" "haskell" (found suggest)
, floating "left" $ style severityClass "Why Not:" ++
-- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest)
]
where
severityClass = case severity suggest of
severityClass =
case severity suggest of
Error -> "error"
Warning -> "warning"
......@@ -199,7 +194,6 @@ htmlSuggestions = concatMap toHtml
floating :: String -> String -> String
floating dir thing = [i| <div class="suggestion-row" style="float: ${dir};">${thing}</div> |]
showSuggestion :: String -> String
showSuggestion = remove lintIdent . dropDo
where
......@@ -214,18 +208,14 @@ showSuggestion = remove lintIdent . dropDo
else string
clean :: [String] -> [String]
-- If the first line starts with a `do`...
-- Note that hlint always indents by two spaces in its output.
clean ((stripPrefix " do " -> Just a) : as) =
-- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- output.
clean ((stripPrefix " do " -> Just a):as) =
-- Take all indented lines and unindent them.
let unindented = catMaybes
$ takeWhile isJust
$ map (stripPrefix " ") as
fullDo = a:unindented
let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as
fullDo = a : unindented
afterDo = drop (length unindented) as
in
--
fullDo ++ clean afterDo
in fullDo ++ clean afterDo
-- Ignore other list elements - just proceed onwards.
clean (x:xs) = x : clean xs
......
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
......@@ -20,9 +19,10 @@ manyTill p end = scan
scan = end <|> do
x <- p
xs <- scan
return $ x:xs
return $ x : xs
manyTill1 p end = do x <- p
manyTill1 p end = do
x <- p
xs <- manyTill p end
return $ x : xs
......@@ -37,7 +37,8 @@ quotedString = do
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
where end = unescapedChar space
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word"
......
This diff is collapsed.
This diff is collapsed.
{-# 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,7 +33,9 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@
data LhsStyle string =
LhsStyle
{ lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@
......@@ -42,21 +44,18 @@ data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@
}
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,6 +154,7 @@ 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}"
ihaskellArgs :: Mode Args
......@@ -161,8 +162,8 @@ ihaskellArgs =
let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in
noMode { modeGroupModes = toGroup allModes }
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
in noMode { modeGroupModes = toGroup allModes }
where
add flag (Args mode flags) = Args mode $ flag : flags
......
......@@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types
import System.Posix.Signals
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
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
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"
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"
......@@ -185,16 +190,14 @@ kernelSpecCreated = do
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"
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
-- | Description : All message type definitions.
module IHaskell.Types (
Message (..),
MessageHeader (..),
Message(..),
MessageHeader(..),
MessageType(..),
Username,
Metadata(..),
replyType,
ExecutionState (..),
ExecutionState(..),
StreamType(..),
MimeType(..),
DisplayData(..),
......@@ -16,7 +16,8 @@ module IHaskell.Types (
ExecuteReplyStatus(..),
KernelState(..),
LintStatus(..),
Width, Height,
Width,
Height,
Display(..),
defaultKernelState,
extractPlain,
......@@ -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 ()
......@@ -89,12 +88,12 @@ 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)
instance Serialize Display
instance Monoid Display where
......@@ -102,13 +101,15 @@ instance Monoid Display where
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]
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
data KernelState =
KernelState
{ getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool
, useShowErrors :: Bool
......@@ -120,7 +121,8 @@ data KernelState = KernelState { getExecutionCounter :: Int
deriving Show
defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1
defaultKernelState = KernelState
{ getExecutionCounter = 1
, getLintStatus = LintOn
, useSvg = True
, useShowErrors = False
......@@ -131,10 +133,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1
}
-- | 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]
......@@ -152,23 +156,24 @@ kernelOpts =
]
-- | Current HLint status.
data LintStatus
= LintOn
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.
IntermediateResult
{ outputs :: Display -- ^ Display outputs.
}
| FinalResult {
outputs :: Display, -- ^ Display outputs.
pagerOut :: String, -- ^ Text to display in the IPython pager.
startComms :: [CommInfo] -- ^ Comms to start.
|
FinalResult
{ outputs :: Display -- ^ Display outputs.
, pagerOut :: String -- ^ Text to display in the IPython pager.
, startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show
This diff is collapsed.
#!/usr/bin/env python3
from __future__ import print_function
import sys
import os
import subprocess
def hindent(contents):
with open(".tmp3", "w") as f:
f.write(contents)
with open(".tmp3", "r") as f:
output = subprocess.check_output(["hindent", "--style", "gibiansky"],
stdin=f)
return output.decode('utf-8')
def diff(src1, src2):
# Ignore trailing newlines
if src1[-1] == "\n":
src1 = src1[:-1]
if src2[-1] == "\n":
src2 = src2[:-1]
with open(".tmp1", "w") as f1:
f1.write(src1)
with open(".tmp2", "w") as f2:
f2.write(src2)
try:
output = subprocess.check_output(["diff", ".tmp1", ".tmp2"])
return output.decode('utf-8')
except subprocess.CalledProcessError as e:
return e.output.decode('utf-8')
# Verify that we're in the right directory
try:
open("ihaskell.cabal", "r").close()
except:
print(sys.argv[0], "must be run from the ihaskell directory",
file=sys.stderr)
# 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))
hindent_outputs = {}
for source_file in sources:
print("Formatting file", source_file)
with open(source_file, "r") as f:
original_source = f.read()
formatted_source = hindent(original_source)
hindent_outputs[source_file] = (original_source, formatted_source)
diffs = {filename: diff(original, formatted)
for (filename, (original, formatted)) in hindent_outputs.items()}
incorrect_formatting = False
for filename, diff in diffs.items():
if diff:
incorrect_formatting = True
print('Incorrect formatting in', filename)
print('=' * 10)
print(diff)
if incorrect_formatting:
sys.exit(1)
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