Skip to content

G
gargantext-ihaskell
Commit 2f060497 authored by Andrew Gibiansky's avatar Andrew Gibiansky
Browse files
Options

Reformatting all of ihaskell source

parent e5e92036
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1658 additions and 1624 deletions
.gitignore
View file @ 2f060497
...@@ -16,3 +16,5 @@ todo ...@@ -16,3 +16,5 @@ todo
profile/profile.tar profile/profile.tar
.cabal-sandbox .cabal-sandbox
cabal.sandbox.config cabal.sandbox.config
.tmp1
.tmp2
src/IHaskell/BrokenPackages.hs
View file @ 2f060497
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>)) import ClassyPrelude hiding ((<|>))
import Text.Parsec import Text.Parsec
import Text.Parsec.String import Text.Parsec.String
import Control.Applicative hiding ((<|>), many) import Control.Applicative hiding ((<|>), many)
import Data.String.Utils (startswith) import Data.String.Utils (startswith)
import Shelly import Shelly
data BrokenPackage = BrokenPackage { data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
packageID :: String,
brokenDeps :: [String]
}
instance Show BrokenPackage where instance Show BrokenPackage where
show = packageID show = packageID
-- | Get a list of broken packages. -- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the
-- This function internally shells out to `ghc-pkg`, and parses the output -- output in order to determine what packages are broken.
-- in order to determine what packages are broken.
getBrokenPackages :: IO [String] getBrokenPackages :: IO [String]
getBrokenPackages = shelly $ do getBrokenPackages = shelly $ do
silently $ errExit False $ run "ghc-pkg" ["check"] silently $ errExit False $ run "ghc-pkg" ["check"]
checkOut <- lastStderr checkOut <- lastStderr
-- Get rid of extraneous things -- Get rid of extraneous things
let rightStart str = startswith "There are problems" str || let rightStart str = startswith "There are problems" str ||
startswith " dependency" str startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of return $
Left err -> [] case parse (many check) "ghc-pkg output" ghcPkgOutput of
Right pkgs -> map show pkgs Left err -> []
Right pkgs -> map show pkgs
check :: Parser BrokenPackage check :: Parser BrokenPackage
check = string "There are problems in package " check = string "There are problems in package "
......
src/IHaskell/Convert.hs
View file @ 2f060497
-- | Description : mostly reversible conversion between ipynb and lhs -- | Description : mostly reversible conversion between ipynb and lhs
module IHaskell.Convert (convert) where 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 Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs) import IHaskell.Convert.Args (ConvertSpec(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.LhsToIpynb (lhsToIpynb) import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
import IHaskell.Flags (Argument) import IHaskell.Convert.LhsToIpynb (lhsToIpynb)
import System.Directory (doesFileExist) import IHaskell.Flags (Argument)
import Text.Printf (printf) import System.Directory (doesFileExist)
import Text.Printf (printf)
-- | used by @IHaskell convert@ -- | used by @IHaskell convert@
convert :: [Argument] -> IO () convert :: [Argument] -> IO ()
convert args = case fromJustConvertSpec (toConvertSpec args) of convert args =
ConvertSpec { convertToIpynb = Identity toIpynb, case fromJustConvertSpec (toConvertSpec args) of
convertInput = Identity inputFile, ConvertSpec
convertOutput = Identity outputFile, { convertToIpynb = Identity toIpynb
convertLhsStyle = Identity lhsStyle, , convertInput = Identity inputFile
convertOverwriteFiles = force } , convertOutput = Identity outputFile
, convertLhsStyle = Identity lhsStyle
, convertOverwriteFiles = force
}
| toIpynb -> do | toIpynb -> do
unless force (failIfExists outputFile) unless force (failIfExists outputFile)
lhsToIpynb lhsStyle inputFile outputFile lhsToIpynb lhsStyle inputFile outputFile
| otherwise -> do | otherwise -> do
unless force (failIfExists outputFile) unless force (failIfExists outputFile)
ipynbToLhs lhsStyle inputFile outputFile ipynbToLhs lhsStyle inputFile outputFile
-- | Call fail when the named file already exists. -- | Call fail when the named file already exists.
failIfExists :: FilePath -> IO () failIfExists :: FilePath -> IO ()
...@@ -29,5 +33,3 @@ failIfExists file = do ...@@ -29,5 +33,3 @@ failIfExists file = do
exists <- doesFileExist file exists <- doesFileExist file
when exists $ fail $ when exists $ fail $
printf "File %s already exists. To force supply --force." file printf "File %s already exists. To force supply --force." file
src/IHaskell/Convert/Args.hs
View file @ 2f060497
-- | Description: interpret flags parsed by "IHaskell.Flags" -- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
(ConvertSpec(..),
fromJustConvertSpec,
toConvertSpec,
) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity)) import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower) import Data.Char (toLower)
import Data.List (partition) import Data.List (partition)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T (pack, Text) import qualified Data.Text.Lazy as T (pack, Text)
import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..)) import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..))
import System.FilePath ((<.>), dropExtension, takeExtension) import System.FilePath ((<.>), dropExtension, takeExtension)
import Text.Printf (printf) import Text.Printf (printf)
-- | ConvertSpec is the accumulator for command line arguments -- | ConvertSpec is the accumulator for command line arguments
data ConvertSpec f = ConvertSpec data ConvertSpec f =
{ convertToIpynb :: f Bool, ConvertSpec
convertInput :: f FilePath, { convertToIpynb :: f Bool
convertOutput :: f FilePath, , convertInput :: f FilePath
convertLhsStyle :: f (LhsStyle T.Text), , convertOutput :: f FilePath
convertOverwriteFiles :: Bool , convertLhsStyle :: f (LhsStyle T.Text)
} , convertOverwriteFiles :: Bool
}
-- | Convert a possibly-incomplete specification for what to convert -- | Convert a possibly-incomplete specification for what to convert into one which can be executed.
-- into one which can be executed. Calls error when data is missing. -- Calls error when data is missing.
fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity fromJustConvertSpec :: ConvertSpec Maybe -> ConvertSpec Identity
fromJustConvertSpec convertSpec = convertSpec { fromJustConvertSpec convertSpec = convertSpec
convertToIpynb = Identity toIpynb, { convertToIpynb = Identity toIpynb
convertInput = Identity inputFile, , convertInput = Identity inputFile
convertOutput = Identity outputFile, , convertOutput = Identity outputFile
convertLhsStyle = Identity $ fromMaybe , convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
(T.pack <$> lhsStyleBird) }
(convertLhsStyle convertSpec)
}
where where
toIpynb = fromMaybe (error "Error: direction for conversion unknown") toIpynb = fromMaybe (error "Error: direction for conversion unknown")
(convertToIpynb convertSpec) (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" (Nothing, Nothing) -> error "Error: no files specified for conversion"
(Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb") (Just i, Nothing)
| otherwise -> (i, dropExtension i <.> "lhs") | toIpynb -> (i, dropExtension i <.> "ipynb")
(Nothing, Just o) | toIpynb -> (dropExtension o <.> "lhs", o) | otherwise -> (i, dropExtension i <.> "lhs")
| otherwise -> (dropExtension o <.> "ipynb", o) (Nothing, Just o)
| toIpynb -> (dropExtension o <.> "lhs", o)
| otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o) (Just i, Just o) -> (i, o)
-- | Does this @Argument@ explicitly request a file format? -- | Does this @Argument@ explicitly request a file format?
isFormatSpec :: Argument -> Bool isFormatSpec :: Argument -> Bool
isFormatSpec (ConvertToFormat _) = True isFormatSpec (ConvertToFormat _) = True
isFormatSpec (ConvertFromFormat _) = True isFormatSpec (ConvertFromFormat _) = True
isFormatSpec _ = False isFormatSpec _ = False
toConvertSpec :: [Argument] -> ConvertSpec Maybe toConvertSpec :: [Argument] -> ConvertSpec Maybe
toConvertSpec args = mergeArgs otherArgs toConvertSpec args = mergeArgs otherArgs (mergeArgs formatSpecArgs initialConvertSpec)
(mergeArgs formatSpecArgs initialConvertSpec)
where where
(formatSpecArgs, otherArgs) = partition isFormatSpec args (formatSpecArgs, otherArgs) = partition isFormatSpec args
initialConvertSpec = ConvertSpec Nothing Nothing Nothing Nothing False 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 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 OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec, | Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle = error $ printf previousLhsStyle /= fmap T.pack lhsStyle
"Conflicting lhs styles requested: <%s> and <%s>" = error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show lhsStyle) (show previousLhsStyle) (show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) } | otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec, | Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile = error $ printf "Multiple input files specified: <%s> and <%s>" previousInputFile /= inputFile
inputFile previousInputFile = error $ printf "Multiple input files specified: <%s> and <%s>" inputFile previousInputFile
| otherwise = convertSpec { | otherwise = convertSpec
convertInput = Just inputFile, { convertInput = Just inputFile
convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of , convertToIpynb = case (convertToIpynb convertSpec, fromExt inputFile) of
(prev, Nothing) -> prev (prev, Nothing) -> prev
(prev @ (Just _), _) -> prev (prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== LhsMarkdown) format (Nothing, format) -> fmap (== LhsMarkdown) format
} }
mergeArg (ConvertTo outputFile) convertSpec mergeArg (ConvertTo outputFile) convertSpec
| Just previousOutputFile <- convertOutput convertSpec, | Just previousOutputFile <- convertOutput convertSpec,
previousOutputFile /= outputFile = error $ printf "Multiple output files specified: <%s> and <%s>" previousOutputFile /= outputFile
outputFile previousOutputFile = error $ printf "Multiple output files specified: <%s> and <%s>" outputFile previousOutputFile
| otherwise = convertSpec { | otherwise = convertSpec
convertOutput = Just outputFile, { convertOutput = Just outputFile
convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of , convertToIpynb = case (convertToIpynb convertSpec, fromExt outputFile) of
(prev, Nothing) -> prev (prev, Nothing) -> prev
(prev @ (Just _), _) -> prev (prev@(Just _), _) -> prev
(Nothing, format) -> fmap (== IpynbFile) format (Nothing, format) -> fmap (== IpynbFile) format
} }
mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: " mergeArg unexpectedArg _ = error $ "IHaskell.Convert.mergeArg: impossible argument: "
++ show unexpectedArg ++ show unexpectedArg
-- | Guess the format based on the file extension. -- | Guess the format based on the file extension.
fromExt :: FilePath -> Maybe NotebookFormat fromExt :: FilePath -> Maybe NotebookFormat
fromExt s = case map toLower (takeExtension s) of fromExt s =
".lhs" -> Just LhsMarkdown case map toLower (takeExtension s) of
".ipynb" -> Just IpynbFile ".lhs" -> Just LhsMarkdown
_ -> Nothing ".ipynb" -> Just IpynbFile
_ -> Nothing
src/IHaskell/Convert/IpynbToLhs.hs
View file @ 2f060497
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Data.Aeson (decode, Object, Value(Array, Object, String)) import Data.Aeson (decode, Object, Value(Array, Object, String))
import qualified Data.ByteString.Lazy as L (readFile) import qualified Data.ByteString.Lazy as L (readFile)
import qualified Data.HashMap.Strict as M (lookup) import qualified Data.HashMap.Strict as M (lookup)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty)) import Data.Monoid ((<>), Monoid(mempty))
import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines) import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
import qualified Data.Text.Lazy.IO as T (writeFile) 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 qualified Data.Vector as V (map, mapM, toList)
import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode, lhsEndOutput, lhsOutputPrefix)) import IHaskell.Flags (LhsStyle(lhsBeginCode, lhsBeginOutput, lhsCodePrefix, lhsEndCode,
lhsEndOutput, lhsOutputPrefix))
ipynbToLhs :: LhsStyle T.Text ipynbToLhs :: LhsStyle T.Text
-> FilePath -- ^ the filename of an ipython notebook -> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write -> FilePath -- ^ the filename of the literate haskell to write
-> IO () -> IO ()
ipynbToLhs sty from to = do ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of case M.lookup "cells" js of
Just (Array cells) -> Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
$ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema" _ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line concatWithPrefix :: T.Text -- ^ the prefix to add to every line
-> Vector Value -- ^ a json array of text lines -> Vector Value -- ^ a json array of text lines
-> Maybe T.Text -> Maybe T.Text
concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr
toStr :: Value -> Maybe T.Text toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x) toStr (String x) = Just (T.fromStrict x)
toStr _ = Nothing toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable -- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- for the type of lhs file described by the @sty@ -- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text convCell :: LhsStyle T.Text -> Object -> T.Text
convCell _sty object convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object, | Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object, Just (Array xs) <- M.lookup "source" object,
~ (Just s) <- concatWithPrefix "" xs = s ~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object convCell sty object
| Just (String "code") <- M.lookup "cell_type" object, | Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object, Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object, Just (Array o) <- M.lookup "outputs" object,
~ (Just i) <- concatWithPrefix (lhsCodePrefix sty) i, ~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o) = "\n" <> o <- fromMaybe mempty (convOutputs sty o)
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n" = "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell" convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle T.Text convOutputs :: LhsStyle T.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup -> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text -> Maybe T.Text
convOutputs sty array = do convOutputs sty array = do
outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array
return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty 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) getTexts p (Object object)
| Just (Array text) <- M.lookup "text" object = concatWithPrefix p text | Just (Array text) <- M.lookup "text" object = concatWithPrefix p text
getTexts _ _ = Nothing getTexts _ _ = Nothing
src/IHaskell/Convert/LhsToIpynb.hs
View file @ 2f060497
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (mplus) import Control.Monad (mplus)
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null)) import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import qualified Data.ByteString.Lazy as L (writeFile) import qualified Data.ByteString.Lazy as L (writeFile)
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty)) import Data.Monoid (Monoid(mempty))
import qualified Data.Text as TS (Text) 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 as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip)
import qualified Data.Text.Lazy.IO as T (readFile) import qualified Data.Text.Lazy.IO as T (readFile)
import qualified Data.Vector as V (fromList, singleton) 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 :: LhsStyle T.Text -> FilePath -> FilePath -> IO ()
lhsToIpynb sty from to = do 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 L.writeFile to . encode . encodeCells $ groupClassified classed
data CellLine a = CodeLine a | OutputLine a | MarkdownLine a data CellLine a = CodeLine a
deriving Show | OutputLine a
| MarkdownLine a
deriving Show
isCode :: CellLine t -> Bool isCode :: CellLine t -> Bool
isCode (CodeLine _) = True isCode (CodeLine _) = True
isCode _ = False isCode _ = False
isOutput :: CellLine t -> Bool isOutput :: CellLine t -> Bool
isOutput (OutputLine _) = True isOutput (OutputLine _) = True
isOutput _ = False isOutput _ = False
isMD :: CellLine t -> Bool isMD :: CellLine t -> Bool
isMD (MarkdownLine _) = True isMD (MarkdownLine _) = True
isMD _ = False isMD _ = False
isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool isEmptyMD :: (Eq a, Monoid a) => CellLine a -> Bool
isEmptyMD (MarkdownLine a) = a == mempty isEmptyMD (MarkdownLine a) = a == mempty
isEmptyMD _ = False isEmptyMD _ = False
untag :: CellLine t -> t untag :: CellLine t -> t
untag (CodeLine a) = a untag (CodeLine a) = a
untag (OutputLine a) = a untag (OutputLine a) = a
untag (MarkdownLine a) = a untag (MarkdownLine a) = a
data Cell a = Code a a | Markdown a data Cell a = Code a a
deriving (Show) | Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value encodeCells :: [Cell [T.Text]] -> Value
encodeCells xs = object $ encodeCells xs = object $
[ "cells" .= Array (V.fromList (map cellToVal xs)) ] ["cells" .= Array (V.fromList (map cellToVal xs))]
++ boilerplate ++ boilerplate
cellToVal :: Cell [T.Text] -> Value cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $ cellToVal (Code i o) = object $
[ "cell_type" .= String "code", [ "cell_type" .= String "code"
"execution_count" .= Null, , "execution_count" .= Null
"metadata" .= object [ "collapsed" .= Bool False ], , "metadata" .= object ["collapsed" .= Bool False]
"source" .= arrayFromTxt i, , "source" .= arrayFromTxt i
"outputs" .= Array , "outputs" .= Array
(V.fromList ( (V.fromList
[ object ["text" .= arrayFromTxt o, ([object
"metadata" .= object [], [ "text" .= arrayFromTxt o
"output_type" .= String "display_data" ] , "metadata" .= object []
| _ <- take 1 o])) ] , "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $ cellToVal (Markdown txt) = object $
[ "cell_type" .= String "markdown", [ "cell_type" .= String "markdown"
"metadata" .= object [ "hidden" .= Bool False ], , "metadata" .= object ["hidden" .= Bool False]
"source" .= arrayFromTxt txt ] , "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s -- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value arrayFromTxt :: [T.Text] -> Value
arrayFromTxt i = Array (V.fromList $ map stringify i) arrayFromTxt i = Array (V.fromList $ map stringify i)
where where
stringify = String . T.toStrict . flip T.snoc '\n' stringify = String . T.toStrict . flip T.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the -- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- json describing cells and output correctly. -- output correctly.
boilerplate :: [(TS.Text, Value)] boilerplate :: [(TS.Text, Value)]
boilerplate = boilerplate =
[ "metadata" .= object [ kernelspec, lang ] ["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
, "nbformat" .= Number 4
, "nbformat_minor" .= Number 0
]
where where
kernelspec = "kernelspec" .= object [ kernelspec = "kernelspec" .= object
"display_name" .= String "Haskell" [ "display_name" .= String "Haskell"
, "language" .= String "haskell" , "language" .= String "haskell"
, "name" .= String "haskell" , "name" .= String "haskell"
] ]
lang = "language_info" .= object [ lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
"name" .= String "haskell"
, "version" .= String VERSION_ghc
]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]] groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified (CodeLine a : x) groupClassified (CodeLine a:x)
| (c,x) <- span isCode x, | (c, x) <- span isCode x,
(_,x) <- span isEmptyMD x, (_, x) <- span isEmptyMD x,
(o,x) <- span isOutput x = Code (a : map untag c) (map untag o) : groupClassified x (o, x) <- span isOutput x
groupClassified (MarkdownLine a : x) = Code (a : map untag c) (map untag o) : groupClassified x
| (m,x) <- span isMD x = Markdown (a: map untag m) : groupClassified x groupClassified (MarkdownLine a:x)
groupClassified (OutputLine a : x ) = Markdown [a] : groupClassified x | (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = [] groupClassified [] = []
classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text] 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) =
(Just a, Nothing) -> CodeLine a : classifyLines sty ls case (sp c, sp o) of
(Nothing, Just a) -> OutputLine a : classifyLines sty ls (Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing,Nothing) -> MarkdownLine l : classifyLines sty ls (Nothing, Just a) -> OutputLine a : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines" (Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where where
sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x 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 dropSpace = T.dropWhile isSpace
classifyLines _ [] = [] classifyLines _ [] = []
src/IHaskell/Display.hs
View file @ 2f060497
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleInstances #-}
-- | If you are interested in the IHaskell library for the purpose of -- | If you are interested in the IHaskell library for the purpose of augmenting the IHaskell
-- augmenting the IHaskell notebook or writing your own display mechanisms -- notebook or writing your own display mechanisms and widgets, this module contains all functions
-- and widgets, this module contains all functions you need. -- you need.
-- --
-- In order to create a display mechanism for a particular data type, write -- In order to create a display mechanism for a particular data type, write a module named (for
-- a module named (for example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. -- example) @IHaskell.Display.YourThing@ in a package named @ihaskell-yourThing@. (Note the
-- (Note the capitalization - it's important!) Then, in that module, add an -- capitalization - it's important!) Then, in that module, add an instance of @IHaskellDisplay@ for
-- instance of @IHaskellDisplay@ for your data type. Similarly, to create -- your data type. Similarly, to create a widget, add an instance of @IHaskellWidget@.
-- 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 ( module IHaskell.Display (
-- * Rich display and interactive display typeclasses and types -- * Rich display and interactive display typeclasses and types
IHaskellDisplay(..), IHaskellDisplay(..),
Display(..), Display(..),
DisplayData(..), DisplayData(..),
IHaskellWidget(..), IHaskellWidget(..),
-- ** Interactive use functions -- ** Interactive use functions
printDisplay, printDisplay,
-- * Constructors for displays -- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many, plain,
html,
-- ** Image and data encoding functions png,
Width, Height, Base64(..), jpg,
encode64, base64, svg,
latex,
-- ** Utilities javascript,
switchToTmpDir, many,
-- * Internal only use -- ** Image and data encoding functions
displayFromChan, Width,
serializeDisplay, Height,
Widget(..), Base64(..),
) where encode64,
base64,
import ClassyPrelude
import Data.Serialize as Serialize -- ** Utilities
import Data.ByteString hiding (map, pack) switchToTmpDir,
import Data.String.Utils (rstrip)
-- * 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.Base64 as Base64
import qualified Data.ByteString.Char8 as Char import qualified Data.ByteString.Char8 as Char
import Data.Aeson (Value) import Data.Aeson (Value)
import System.Directory(getTemporaryDirectory, setCurrentDirectory) import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM.TChan import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import IHaskell.Types import IHaskell.Types
type Base64 = Text type Base64 = Text
...@@ -61,8 +71,7 @@ type Base64 = Text ...@@ -61,8 +71,7 @@ type Base64 = Text
-- > IO [Display] -- > IO [Display]
-- > IO (IO Display) -- > IO (IO Display)
-- --
-- be run the IO and get rendered (if the frontend allows it) in the pretty -- be run the IO and get rendered (if the frontend allows it) in the pretty form.
-- form.
instance IHaskellDisplay a => IHaskellDisplay (IO a) where instance IHaskellDisplay a => IHaskellDisplay (IO a) where
display = (display =<<) display = (display =<<)
...@@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where ...@@ -77,6 +86,8 @@ instance IHaskellDisplay a => IHaskellDisplay [a] where
displays <- mapM display disps displays <- mapM display disps
return $ ManyDisplay displays return $ ManyDisplay displays
-- | Encode many displays into a single one. All will be output. -- | Encode many displays into a single one. All will be output.
many :: [Display] -> Display many :: [Display] -> Display
many = ManyDisplay many = ManyDisplay
...@@ -101,15 +112,15 @@ latex = DisplayData MimeLatex . pack ...@@ -101,15 +112,15 @@ latex = DisplayData MimeLatex . pack
javascript :: String -> DisplayData javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack javascript = DisplayData MimeJavascript . pack
-- | Generate a PNG display of the given width and height. Data must be -- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- provided in a Base64 encoded manner, suitable for embedding into HTML. -- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- The @base64@ function may be used to encode data into this format. -- this format.
png :: Width -> Height -> Base64 -> DisplayData png :: Width -> Height -> Base64 -> DisplayData
png width height = DisplayData (MimePng width height) png width height = DisplayData (MimePng width height)
-- | Generate a JPG display of the given width and height. Data must be -- | Generate a JPG display of the given width and height. Data must be provided in a Base64 encoded
-- provided in a Base64 encoded manner, suitable for embedding into HTML. -- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
-- The @base64@ function may be used to encode data into this format. -- this format.
jpg :: Width -> Height -> Base64 -> DisplayData jpg :: Width -> Height -> Base64 -> DisplayData
jpg width height = DisplayData (MimeJpg width height) jpg width height = DisplayData (MimeJpg width height)
...@@ -121,42 +132,37 @@ encode64 str = base64 $ Char.pack str ...@@ -121,42 +132,37 @@ encode64 str = base64 $ Char.pack str
base64 :: ByteString -> Base64 base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode base64 = decodeUtf8 . Base64.encode
-- | For internal use within IHaskell. -- | For internal use within IHaskell. Serialize displays to a ByteString.
-- Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString serializeDisplay :: Display -> ByteString
serializeDisplay = Serialize.encode serializeDisplay = Serialize.encode
-- | Items written to this chan will be included in the output sent -- | Items written to this chan will be included in the output sent to the frontend (ultimately the
-- to the frontend (ultimately the browser), the next time IHaskell -- browser), the next time IHaskell has an item to display.
-- has an item to display.
{-# NOINLINE displayChan #-} {-# NOINLINE displayChan #-}
displayChan :: TChan Display displayChan :: TChan Display
displayChan = unsafePerformIO newTChanIO displayChan = unsafePerformIO newTChanIO
-- | Take everything that was put into the 'displayChan' at that point -- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out
-- out, and make a 'Display' out of it. -- of it.
displayFromChan :: IO (Maybe Display) displayFromChan :: IO (Maybe Display)
displayFromChan = displayFromChan =
Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) Just . many <$> unfoldM (atomically $ tryReadTChan displayChan)
-- | This is unfoldM from monad-loops. It repeatedly runs an IO action -- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and
-- until it return Nothing, and puts all the Justs in a list. -- puts all the Justs in a list. If you find yourself using more functionality from monad-loops,
-- If you find yourself using more functionality from monad-loops, just add -- just add the package dependency instead of copying more code from it.
-- the package dependency instead of copying more code from it.
unfoldM :: IO (Maybe a) -> IO [a] 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 -- | Write to the display channel. The contents will be displayed in the notebook once the current
-- notebook once the current execution call ends. -- execution call ends.
printDisplay :: IHaskellDisplay a => a -> IO () printDisplay :: IHaskellDisplay a => a -> IO ()
printDisplay disp = display disp >>= atomically . writeTChan displayChan printDisplay disp = display disp >>= atomically . writeTChan displayChan
-- | Convenience function for client libraries. Switch to a temporary -- | Convenience function for client libraries. Switch to a temporary directory so that any files we
-- directory so that any files we create aren't visible. On Unix, this is -- create aren't visible. On Unix, this is usually /tmp.
-- usually /tmp.
switchToTmpDir = void (try switchDir :: IO (Either SomeException ())) switchToTmpDir = void (try switchDir :: IO (Either SomeException ()))
where where
switchDir = switchDir =
getTemporaryDirectory >>= getTemporaryDirectory >>=
setCurrentDirectory setCurrentDirectory
src/IHaskell/Eval/Completion.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Eval/Evaluate.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Eval/Hoogle.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Eval/Info.hs
View file @ 2f060497
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# 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 IHaskell.Eval.Evaluate (typeCleaner, Interpreter)
import Outputable
import Exception import GHC
import Outputable
import Exception
info :: String -> Interpreter String info :: String -> Interpreter String
info name = ghandle handler $ do info name = ghandle handler $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
result <- exprType name result <- exprType name
return $ typeCleaner $ showPpr dflags result return $ typeCleaner $ showPpr dflags result
where where
handler :: SomeException -> Interpreter String handler :: SomeException -> Interpreter String
handler _ = return "" handler _ = return ""
src/IHaskell/Eval/Lint.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Eval/ParseShell.hs
View file @ 2f060497
-- | This module splits a shell command line into a list of strings, -- | This module splits a shell command line into a list of strings,
-- one for each command / filename -- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words) import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill) import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional) import Control.Applicative hiding ((<|>), many, optional)
eol :: Parser Char eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line" eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char quote :: Parser Char
quote = char '\"' quote = char '\"'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@ -- | @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] ...@@ -18,16 +17,17 @@ manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill p end = scan manyTill p end = scan
where where
scan = end <|> do scan = end <|> do
x <- p x <- p
xs <- scan xs <- scan
return $ x:xs return $ x : xs
manyTill1 p end = do x <- p manyTill1 p end = do
xs <- manyTill p end x <- p
return $ x : xs xs <- manyTill p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String unescapedChar :: Parser Char -> Parser String
unescapedChar p = try $ do unescapedChar p = try $ do
x <- noneOf "\\" x <- noneOf "\\"
lookAhead p lookAhead p
return [x] return [x]
...@@ -36,8 +36,9 @@ quotedString = do ...@@ -36,8 +36,9 @@ quotedString = do
quote <?> "expected starting quote" quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String " (manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end unquotedString = manyTill1 anyChar end
where end = unescapedChar space where
end = unescapedChar space
<|> (lookAhead eol >> return []) <|> (lookAhead eol >> return [])
word = quotedString <|> unquotedString <?> "word" word = quotedString <|> unquotedString <?> "word"
...@@ -48,12 +49,12 @@ separator = many1 space <?> "separator" ...@@ -48,12 +49,12 @@ separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n) -- | Input must terminate in a space character (like a \n)
words :: Parser [String] words :: Parser [String]
words = try (eof *> return []) <|> do words = try (eof *> return []) <|> do
x <- word x <- word
rest1 <- lookAhead (many anyToken) rest1 <- lookAhead (many anyToken)
ss <- separator ss <- separator
rest2 <- lookAhead (many anyToken) rest2 <- lookAhead (many anyToken)
xs <- words xs <- words
return $ x : xs return $ x : xs
parseShell :: String -> Either ParseError [String] parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n") parseShell string = parse words "shell" (string ++ "\n")
src/IHaskell/Eval/Parser.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Eval/Util.hs
View file @ 2f060497
This diff is collapsed.
src/IHaskell/Flags.hs
View file @ 2f060497
{-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude, DeriveFunctor #-}
module IHaskell.Flags ( module IHaskell.Flags (
IHaskellMode(..), IHaskellMode(..),
Argument(..), Argument(..),
...@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text ...@@ -16,8 +17,7 @@ import System.Console.CmdArgs.Text
import Data.List (findIndex) import Data.List (findIndex)
import IHaskell.Types import IHaskell.Types
-- Command line arguments to IHaskell. A set of aruments is annotated with -- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked.
-- the mode being invoked.
data Args = Args IHaskellMode [Argument] data Args = Args IHaskellMode [Argument]
deriving Show deriving Show
...@@ -33,13 +33,15 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup ...@@ -33,13 +33,15 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup
| ConvertLhsStyle (LhsStyle String) | ConvertLhsStyle (LhsStyle String)
deriving (Eq, Show) deriving (Eq, Show)
data LhsStyle string = LhsStyle { lhsCodePrefix :: string -- ^ @>@ data LhsStyle string =
, lhsOutputPrefix :: string -- ^ @<<@ LhsStyle
, lhsBeginCode :: string -- ^ @\\begin{code}@ { lhsCodePrefix :: string -- ^ @>@
, lhsEndCode :: string -- ^ @\\end{code}@ , lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginOutput :: string -- ^ @\\begin{verbatim}@ , lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@ , lhsEndCode :: string -- ^ @\\end{code}@
} , lhsBeginOutput :: string -- ^ @\\begin{verbatim}@
, lhsEndOutput :: string -- ^ @\\end{verbatim}@
}
deriving (Eq, Functor, Show) deriving (Eq, Functor, Show)
...@@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown ...@@ -48,15 +50,13 @@ data NotebookFormat = LhsMarkdown
deriving (Eq, Show) deriving (Eq, Show)
-- Which mode IHaskell is being invoked in. -- Which mode IHaskell is being invoked in.
-- `None` means no mode was specified.
data IHaskellMode = ShowHelp String data IHaskellMode = ShowHelp String
| InstallKernelSpec | InstallKernelSpec
| ConvertLhs | ConvertLhs
| Kernel (Maybe String) | Kernel (Maybe String)
deriving (Eq, Show) deriving (Eq, Show)
-- | Given a list of command-line arguments, return the IHaskell mode and -- | Given a list of command-line arguments, return the IHaskell mode and arguments to process.
-- arguments to process.
parseFlags :: [String] -> Either String Args parseFlags :: [String] -> Either String Args
parseFlags flags = parseFlags flags =
let modeIndex = findIndex (`elem` modeFlags) flags let modeIndex = findIndex (`elem` modeFlags) flags
...@@ -111,7 +111,8 @@ installKernelSpec = ...@@ -111,7 +111,8 @@ installKernelSpec =
[ghcLibFlag, kernelDebugFlag, confFlag, helpFlag] [ghcLibFlag, kernelDebugFlag, confFlag, helpFlag]
kernel :: Mode Args 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 where
kernelArg = flagArg update "<json-kernel-file>" kernelArg = flagArg update "<json-kernel-file>"
update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
...@@ -154,16 +155,16 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag ...@@ -154,16 +155,16 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
lhsStyleBird, lhsStyleTex :: LhsStyle String lhsStyleBird, lhsStyleTex :: LhsStyle String
lhsStyleBird = LhsStyle "> " "\n<< " "" "" "" "" 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 :: Mode Args
ihaskellArgs = ihaskellArgs =
let descr = "Haskell for Interactive Computing." let descr = "Haskell for Interactive Computing."
helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
onlyHelp = [flagHelpSimple (add Help)] onlyHelp = [flagHelpSimple (add Help)]
noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp in noMode = mode "IHaskell" (Args (ShowHelp helpStr) []) descr noArgs onlyHelp
noMode { modeGroupModes = toGroup allModes } in noMode { modeGroupModes = toGroup allModes }
where where
add flag (Args mode flags) = Args mode $ flag : flags add flag (Args mode flags) = Args mode $ flag : flags
noArgs = flagArg unexpected "" noArgs = flagArg unexpected ""
......
src/IHaskell/IPython.hs
View file @ 2f060497
...@@ -40,17 +40,20 @@ import qualified GHC.Paths ...@@ -40,17 +40,20 @@ import qualified GHC.Paths
import IHaskell.Types import IHaskell.Types
import System.Posix.Signals import System.Posix.Signals
data KernelSpecOptions =
data KernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir :: String -- ^ GHC libdir. KernelSpecOptions
, kernelSpecDebug :: Bool -- ^ Spew debugging output? { kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file. , kernelSpecDebug :: Bool -- ^ Spew debugging output?
} , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
}
defaultKernelSpecOptions :: KernelSpecOptions defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir defaultKernelSpecOptions = KernelSpecOptions
, kernelSpecDebug = False { kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecConfFile = defaultConfFile , kernelSpecDebug = False
} , kernelSpecConfFile = defaultConfFile
}
-- | The IPython kernel name. -- | The IPython kernel name.
kernelName :: IsString a => a kernelName :: IsString a => a
kernelName = "haskell" kernelName = "haskell"
...@@ -133,6 +136,7 @@ verifyIPythonVersion = do ...@@ -133,6 +136,7 @@ verifyIPythonVersion = do
Just (1:_) -> oldIPython Just (1:_) -> oldIPython
Just (0:_) -> oldIPython Just (0:_) -> oldIPython
_ -> badIPython "Detected IPython, but could not parse version number." _ -> badIPython "Detected IPython, but could not parse version number."
where where
badIPython :: Text -> Sh () badIPython :: Text -> Sh ()
badIPython message = liftIO $ do badIPython message = liftIO $ do
...@@ -140,8 +144,8 @@ verifyIPythonVersion = do ...@@ -140,8 +144,8 @@ verifyIPythonVersion = do
exitFailure exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up." oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location. -- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- The right location is determined by using `ipython kernelspec install --user`. -- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh () installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec replace opts = void $ do installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath ihaskellPath <- getIHaskellPath
...@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do ...@@ -155,13 +159,14 @@ installKernelspec replace opts = void $ do
Just file -> ["--conf", file]) Just file -> ["--conf", file])
++ ["--ghclib", kernelSpecGhcLibdir opts] ++ ["--ghclib", kernelSpecGhcLibdir opts]
let kernelSpec = KernelSpec { kernelDisplayName = "Haskell" let kernelSpec = KernelSpec
, kernelLanguage = kernelName { kernelDisplayName = "Haskell"
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags , kernelLanguage = kernelName
} , kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags
}
-- Create a temporary directory. Use this temporary directory to make a kernelspec -- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- directory; then, shell out to IPython to install this kernelspec directory. -- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json" let filename = kernelDir </> "kernel.json"
...@@ -180,21 +185,20 @@ installKernelspec replace opts = void $ do ...@@ -180,21 +185,20 @@ installKernelspec replace opts = void $ do
kernelSpecCreated :: Sh Bool kernelSpecCreated :: Sh Bool
kernelSpecCreated = do kernelSpecCreated = do
Just ipython <- which "ipython" Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"] out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out let kernelspecs = map T.strip $ lines out
return $ kernelName `elem` kernelspecs return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined. -- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
-- Otherwise, do nothing.
subHome :: String -> IO String subHome :: String -> IO String
subHome path = shelly $ do subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME" home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
return $ replace "~" home path return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an -- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- error message complaining about it. -- about it.
path :: Text -> Sh FilePath path :: Text -> Sh FilePath
path exe = do path exe = do
path <- which $ fromText exe path <- which $ fromText exe
...@@ -229,9 +233,8 @@ getIHaskellPath = do ...@@ -229,9 +233,8 @@ getIHaskellPath = do
if FS.absolute f if FS.absolute f
then return $ FS.encodeString f then return $ FS.encodeString f
else else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH -- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- resolution done by the shell. If it's just 'IHaskell', use the $PATH -- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
-- variable to find where IHaskell lives.
if FS.filename f == f if FS.filename f == f
then do then do
ihaskellPath <- which "ihaskell" ihaskellPath <- which "ihaskell"
......
src/IHaskell/Types.hs
View file @ 2f060497
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DeriveDataTypeable, DeriveGeneric, ExistentialQuantification #-}
{-# LANGUAGE ExistentialQuantification #-}
-- | Description : All message type definitions. -- | Description : All message type definitions.
module IHaskell.Types ( module IHaskell.Types (
Message (..), Message(..),
MessageHeader (..), MessageHeader(..),
MessageType(..), MessageType(..),
Username, Username,
Metadata(..), Metadata(..),
replyType, replyType,
ExecutionState (..), ExecutionState(..),
StreamType(..), StreamType(..),
MimeType(..), MimeType(..),
DisplayData(..), DisplayData(..),
EvaluationResult(..), EvaluationResult(..),
ExecuteReplyStatus(..), ExecuteReplyStatus(..),
KernelState(..), KernelState(..),
LintStatus(..), LintStatus(..),
Width, Height, Width,
Display(..), Height,
defaultKernelState, Display(..),
extractPlain, defaultKernelState,
kernelOpts, extractPlain,
KernelOpt(..), kernelOpts,
IHaskellDisplay(..), KernelOpt(..),
IHaskellWidget(..), IHaskellDisplay(..),
Widget(..), IHaskellWidget(..),
CommInfo(..), Widget(..),
KernelSpec(..), CommInfo(..),
) where KernelSpec(..),
) where
import ClassyPrelude import ClassyPrelude
import qualified Data.ByteString.Char8 as Char import qualified Data.ByteString.Char8 as Char
...@@ -90,11 +91,11 @@ instance Show Widget where ...@@ -90,11 +91,11 @@ instance Show Widget where
show _ = "<Widget>" show _ = "<Widget>"
-- | Wrapper for ipython-kernel's DisplayData which allows sending multiple -- | Wrapper for ipython-kernel's DisplayData which allows sending multiple results from the same
-- results from the same expression. -- expression.
data Display = Display [DisplayData] data Display = Display [DisplayData]
| ManyDisplay [Display] | ManyDisplay [Display]
deriving (Show, Typeable, Generic) deriving (Show, Typeable, Generic)
instance Serialize Display instance Serialize Display
instance Monoid Display where instance Monoid Display where
...@@ -108,67 +109,73 @@ instance Semigroup Display where ...@@ -108,67 +109,73 @@ instance Semigroup Display where
a <> b = a `mappend` b a <> b = a `mappend` b
-- | All state stored in the kernel between executions. -- | All state stored in the kernel between executions.
data KernelState = KernelState { getExecutionCounter :: Int data KernelState =
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. KernelState
, useSvg :: Bool { getExecutionCounter :: Int
, useShowErrors :: Bool , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useShowTypes :: Bool , useSvg :: Bool
, usePager :: Bool , useShowErrors :: Bool
, openComms :: Map UUID Widget , useShowTypes :: Bool
, kernelDebug :: Bool , usePager :: Bool
} , openComms :: Map UUID Widget
, kernelDebug :: Bool
}
deriving Show deriving Show
defaultKernelState :: KernelState defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1 defaultKernelState = KernelState
, getLintStatus = LintOn { getExecutionCounter = 1
, useSvg = True , getLintStatus = LintOn
, useShowErrors = False , useSvg = True
, useShowTypes = False , useShowErrors = False
, usePager = True , useShowTypes = False
, openComms = empty , usePager = True
, kernelDebug = False , openComms = empty
} , kernelDebug = False
}
-- | Kernel options to be set via `:set` and `:option`. -- | Kernel options to be set via `:set` and `:option`.
data KernelOpt = KernelOpt { data KernelOpt =
getOptionName :: [String], -- ^ Ways to set this option via `:option` KernelOpt
getSetName :: [String], -- ^ Ways to set this option via `:set` { getOptionName :: [String] -- ^ Ways to set this option via `:option`
getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel state. , getSetName :: [String] -- ^ Ways to set this option via `:set`
} , getUpdateKernelState :: KernelState -> KernelState -- ^ Function to update the kernel
-- state.
}
kernelOpts :: [KernelOpt] kernelOpts :: [KernelOpt]
kernelOpts = kernelOpts =
[ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn } [ KernelOpt ["lint"] [] $ \state -> state { getLintStatus = LintOn }
, KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff } , KernelOpt ["no-lint"] [] $ \state -> state { getLintStatus = LintOff }
, KernelOpt ["svg"] [] $ \state -> state { useSvg = True } , KernelOpt ["svg"] [] $ \state -> state { useSvg = True }
, KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False } , KernelOpt ["no-svg"] [] $ \state -> state { useSvg = False }
, KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True } , KernelOpt ["show-types"] ["+t"] $ \state -> state { useShowTypes = True }
, KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False } , KernelOpt ["no-show-types"] ["-t"] $ \state -> state { useShowTypes = False }
, KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True } , KernelOpt ["show-errors"] [] $ \state -> state { useShowErrors = True }
, KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False } , KernelOpt ["no-show-errors"] [] $ \state -> state { useShowErrors = False }
, KernelOpt ["pager"] [] $ \state -> state { usePager = True } , KernelOpt ["pager"] [] $ \state -> state { usePager = True }
, KernelOpt ["no-pager"] [] $ \state -> state { usePager = False } , KernelOpt ["no-pager"] [] $ \state -> state { usePager = False }
] ]
-- | Current HLint status. -- | Current HLint status.
data LintStatus data LintStatus = LintOn
= LintOn | LintOff
| LintOff deriving (Eq, Show)
deriving (Eq, Show)
data CommInfo = CommInfo Widget UUID String deriving Show data CommInfo = CommInfo Widget UUID String
deriving Show
-- | Output of evaluation. -- | Output of evaluation.
data EvaluationResult = data EvaluationResult =
-- | An intermediate result which communicates what has been printed thus -- | An intermediate result which communicates what has been printed thus
-- far. -- far.
IntermediateResult { IntermediateResult
outputs :: Display -- ^ Display outputs. { outputs :: Display -- ^ Display outputs.
} }
| FinalResult { |
outputs :: Display, -- ^ Display outputs. FinalResult
pagerOut :: String, -- ^ Text to display in the IPython pager. { outputs :: Display -- ^ Display outputs.
startComms :: [CommInfo] -- ^ Comms to start. , pagerOut :: String -- ^ Text to display in the IPython pager.
} , startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show deriving Show
src/Main.hs
View file @ 2f060497
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-- | Description : Argument parsing and basic messaging loop, using Haskell -- | Description : Argument parsing and basic messaging loop, using Haskell
-- Chans to communicate with the ZeroMQ sockets. -- Chans to communicate with the ZeroMQ sockets.
module Main where module Main (main) where
-- Prelude imports. -- Prelude imports.
import ClassyPrelude hiding (last, liftIO, readChan, writeChan) import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
...@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do ...@@ -71,7 +72,7 @@ ihaskell (Args (Kernel (Just filename)) args) = do
showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO () showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act = showingHelp mode flags act =
case find (==Help) flags of case find (== Help) flags of
Just _ -> Just _ ->
putStrLn $ pack $ help mode putStrLn $ pack $ help mode
Nothing -> Nothing ->
...@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do ...@@ -114,13 +115,11 @@ runKernel kernelOpts profileSrc = do
-- Receive and reply to all messages on the shell socket. -- Receive and reply to all messages on the shell socket.
interpret libdir True $ do interpret libdir True $ do
-- Ignore Ctrl-C the first time. This has to go inside the -- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
-- `interpret`, because GHC API resets the signal handlers for some -- signal handlers for some reason (completely unknown to me).
-- reason (completely unknown to me).
liftIO ignoreCtrlC liftIO ignoreCtrlC
-- Initialize the context by evaluating everything we got from the -- Initialize the context by evaluating everything we got from the command line flags.
-- command line flags.
let noPublish _ = return () let noPublish _ = return ()
evaluator line = void $ do evaluator line = void $ do
-- Create a new state each time. -- Create a new state each time.
...@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do ...@@ -131,7 +130,7 @@ runKernel kernelOpts profileSrc = do
confFile <- liftIO $ kernelSpecConfFile kernelOpts confFile <- liftIO $ kernelSpecConfFile kernelOpts
case confFile of case confFile of
Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator
Nothing -> return () Nothing -> return ()
forever $ do forever $ do
-- Read the request from the request channel. -- Read the request from the request channel.
...@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do ...@@ -140,9 +139,8 @@ runKernel kernelOpts profileSrc = do
-- Create a header for the reply. -- Create a header for the reply.
replyHeader <- createReplyHeader (header request) replyHeader <- createReplyHeader (header request)
-- We handle comm messages and normal ones separately. -- We handle comm messages and normal ones separately. The normal ones are a standard
-- The normal ones are a standard request/response style, while comms -- request/response style, while comms can be anything, and don't necessarily require a response.
-- can be anything, and don't necessarily require a response.
if isCommMessage request if isCommMessage request
then liftIO $ do then liftIO $ do
oldState <- takeMVar state oldState <- takeMVar state
...@@ -185,35 +183,36 @@ createReplyHeader parent = do ...@@ -185,35 +183,36 @@ createReplyHeader parent = do
let repType = fromMaybe err (replyType $ msgType parent) let repType = fromMaybe err (replyType $ msgType parent)
err = error $ "No reply for message " ++ show (msgType parent) err = error $ "No reply for message " ++ show (msgType parent)
return MessageHeader { return
identifiers = identifiers parent, MessageHeader
parentHeader = Just parent, { identifiers = identifiers parent
metadata = Map.fromList [], , parentHeader = Just parent
messageId = newMessageId, , metadata = Map.fromList []
sessionId = sessionId parent, , messageId = newMessageId
username = username parent, , sessionId = sessionId parent
msgType = repType , username = username parent
} , msgType = repType
}
-- | Compute a reply to a message. -- | Compute a reply to a message.
replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
-- Reply to kernel info requests with a kernel info reply. No computation -- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
-- needs to be done, as a kernel info reply is a static object (all info is -- kernel info reply is a static object (all info is hard coded into the representation of that
-- hard coded into the representation of that message type). -- message type).
replyTo _ KernelInfoRequest{} replyHeader state = replyTo _ KernelInfoRequest{} replyHeader state =
return (state, KernelInfoReply { return
header = replyHeader, (state, KernelInfoReply
language = "haskell", { header = replyHeader
versionList = ghcVersionInts , language = "haskell"
}) , versionList = ghcVersionInts
})
-- Reply to a shutdown request by exiting the main thread.
-- Before shutdown, reply to the request to let the frontend know shutdown -- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- is happening. -- let the frontend know shutdown is happening.
replyTo interface ShutdownRequest{restartPending = restartPending} replyHeader _ = liftIO $ do replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
exitSuccess exitSuccess
-- Reply to an execution request. The reply itself does not require -- Reply to an execution request. The reply itself does not require
-- computation, but this causes messages to be sent to the IOPub socket -- computation, but this causes messages to be sent to the IOPub socket
...@@ -254,7 +253,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do ...@@ -254,7 +253,8 @@ replyTo interface req@ExecuteRequest{ getCode = code } replyHeader state = do
convertSvgToHtml x = x convertSvgToHtml x = x
makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>" makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
prependCss (DisplayData MimeHtml html) = DisplayData MimeHtml $ concat ["<style>", pack ihaskellCSS, "</style>", html] prependCss (DisplayData MimeHtml html) =
DisplayData MimeHtml $concat ["<style>", pack ihaskellCSS, "</style>", html]
prependCss x = x prependCss x = x
startComm :: CommInfo -> IO () startComm :: CommInfo -> IO ()
...@@ -334,27 +334,28 @@ replyTo _ req@CompleteRequest{} replyHeader state = do ...@@ -334,27 +334,28 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
let start = pos - length matchedText let start = pos - length matchedText
end = pos end = pos
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
return (state, reply) return (state, reply)
-- Reply to the object_info_request message. Given an object name, return -- Reply to the object_info_request message. Given an object name, return the associated type
-- the associated type calculated by GHC. -- calculated by GHC.
replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do replyTo _ ObjectInfoRequest { objectName = oname } replyHeader state = do
docs <- pack <$> info (unpack oname) docs <- pack <$> info (unpack oname)
let reply = ObjectInfoReply { let reply = ObjectInfoReply
header = replyHeader, { header = replyHeader
objectName = oname, , objectName = oname
objectFound = strip docs /= "", , objectFound = strip docs /= ""
objectTypeString = docs, , objectTypeString = docs
objectDocString = docs , objectDocString = docs
} }
return (state, reply) return (state, reply)
-- TODO: Implement history_reply. -- TODO: Implement history_reply.
replyTo _ HistoryRequest{} replyHeader state = do replyTo _ HistoryRequest{} replyHeader state = do
let reply = HistoryReply { let reply = HistoryReply {
header = replyHeader, header = replyHeader,
historyReply = [] -- FIXME -- FIXME
historyReply = []
} }
return (state, reply) return (state, reply)
......
verify_formatting.py
View file @ 2f060497
...@@ -8,8 +8,9 @@ import subprocess ...@@ -8,8 +8,9 @@ import subprocess
def hindent(contents): def hindent(contents):
return subprocess.check_output(["hindent", "--style", "gibiansky"], output = subprocess.check_output(["hindent", "--style", "gibiansky"],
input=bytes(contents, 'utf-8')) input=bytes(contents, 'utf-8'))
return output.decode('utf-8')
def diff(src1, src2): def diff(src1, src2):
...@@ -20,7 +21,11 @@ def diff(src1, src2): ...@@ -20,7 +21,11 @@ def diff(src1, src2):
with open(".tmp2", "w") as f2: with open(".tmp2", "w") as f2:
f2.write(src2) f2.write(src2)
return subprocess.check_output(["diff", ".tmp1", ".tmp2"]) 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 # Verify that we're in the right directory
try: try:
...@@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"): ...@@ -35,6 +40,8 @@ for root, dirnames, filenames in os.walk("src"):
for filename in filenames: for filename in filenames:
if filename.endswith(".hs"): if filename.endswith(".hs"):
sources.append(os.path.join(root, filename)) sources.append(os.path.join(root, filename))
break
break
hindent_outputs = {} hindent_outputs = {}
...@@ -47,9 +54,15 @@ for source_file in sources: ...@@ -47,9 +54,15 @@ for source_file in sources:
hindent_outputs[source_file] = (original_source, formatted_source) hindent_outputs[source_file] = (original_source, formatted_source)
diffs = {filename: diff(original, formatted) diffs = {filename: diff(original, formatted)
for (filename, (original, formatted)) in hindent_outputs.values()} for (filename, (original, formatted)) in hindent_outputs.items()}
incorrect_formatting = False
for filename, diff in diffs.items(): for filename, diff in diffs.items():
print(filename) if diff:
print('=' * 10) incorrect_formatting = True
print(diff) 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