Commit 2f060497 authored by Andrew Gibiansky's avatar Andrew Gibiansky

Reformatting all of ihaskell source

parent e5e92036
...@@ -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
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>)) import ClassyPrelude hiding ((<|>))
...@@ -11,17 +12,13 @@ import Data.String.Utils (startswith) ...@@ -11,17 +12,13 @@ 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"]
...@@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do ...@@ -32,7 +29,8 @@ getBrokenPackages = shelly $ do
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 $
case parse (many check) "ghc-pkg output" ghcPkgOutput of
Left err -> [] Left err -> []
Right pkgs -> map show pkgs Right pkgs -> map show pkgs
......
-- | 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 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(ConvertSpec, convertInput, convertLhsStyle, convertOutput, convertOverwriteFiles, convertToIpynb), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs) import IHaskell.Convert.IpynbToLhs (ipynbToLhs)
...@@ -10,12 +11,15 @@ import Text.Printf (printf) ...@@ -10,12 +11,15 @@ 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
...@@ -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
-- | 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))
...@@ -15,35 +11,36 @@ import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..)) ...@@ -15,35 +11,36 @@ 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)
| toIpynb -> (i, dropExtension i <.> "ipynb")
| otherwise -> (i, dropExtension i <.> "lhs") | 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) | otherwise -> (dropExtension o <.> "ipynb", o)
(Just i, Just o) -> (i, o) (Just i, Just o) -> (i, o)
...@@ -55,8 +52,7 @@ isFormatSpec _ = False ...@@ -55,8 +52,7 @@ 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
...@@ -68,40 +64,39 @@ mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe ...@@ -68,40 +64,39 @@ 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 =
case map toLower (takeExtension s) of
".lhs" -> Just LhsMarkdown ".lhs" -> Just LhsMarkdown
".ipynb" -> Just IpynbFile ".ipynb" -> Just IpynbFile
_ -> Nothing _ -> Nothing
{-# 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 ((<$>))
...@@ -12,7 +13,8 @@ import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines) ...@@ -12,7 +13,8 @@ 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
...@@ -22,8 +24,7 @@ ipynbToLhs sty from to = do ...@@ -22,8 +24,7 @@ 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
...@@ -35,19 +36,21 @@ toStr :: Value -> Maybe T.Text ...@@ -35,19 +36,21 @@ 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)
= "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n" lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell" convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
......
{-# 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 ((<$>))
...@@ -19,7 +20,9 @@ lhsToIpynb sty from to = do ...@@ -19,7 +20,9 @@ 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
| OutputLine a
| MarkdownLine a
deriving Show deriving Show
isCode :: CellLine t -> Bool isCode :: CellLine t -> Bool
...@@ -44,31 +47,34 @@ untag (CodeLine a) = a ...@@ -44,31 +47,34 @@ 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
...@@ -76,44 +82,41 @@ arrayFromTxt i = Array (V.fromList $ map stringify i) ...@@ -76,44 +82,41 @@ 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) =
case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls (Just a, Nothing) -> CodeLine a : classifyLines sty ls
(Nothing, Just a) -> OutputLine 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" _ -> 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 _ [] = []
{-# 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
...@@ -23,11 +23,21 @@ module IHaskell.Display ( ...@@ -23,11 +23,21 @@ module IHaskell.Display (
printDisplay, printDisplay,
-- * Constructors for displays -- * Constructors for displays
plain, html, png, jpg, svg, latex, javascript, many, plain,
html,
png,
jpg,
svg,
latex,
javascript,
many,
-- ** Image and data encoding functions -- ** Image and data encoding functions
Width, Height, Base64(..), Width,
encode64, base64, Height,
Base64(..),
encode64,
base64,
-- ** Utilities -- ** Utilities
switchToTmpDir, switchToTmpDir,
...@@ -45,7 +55,7 @@ import Data.String.Utils (rstrip) ...@@ -45,7 +55,7 @@ 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)
...@@ -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
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-}
module IHaskell.Eval.Hoogle ( module IHaskell.Eval.Hoogle (
search, search,
document, document,
render, render,
OutputFormat(..), OutputFormat(..),
HoogleResult HoogleResult,
) where ) where
import ClassyPrelude hiding (last, span, div) import ClassyPrelude hiding (last, span, div)
...@@ -22,19 +23,13 @@ import qualified Prelude as P ...@@ -22,19 +23,13 @@ import qualified Prelude as P
import IHaskell.IPython import IHaskell.IPython
-- | Types of formats to render output to. -- | Types of formats to render output to.
data OutputFormat data OutputFormat = Plain -- ^ Render to plain text.
= Plain -- ^ Render to plain text.
| HTML -- ^ Render to HTML. | HTML -- ^ Render to HTML.
data HoogleResponse = HoogleResponse { data HoogleResponse = HoogleResponse { location :: String, self :: String, docs :: String }
location :: String,
self :: String,
docs :: String
}
deriving (Eq, Show) deriving (Eq, Show)
data HoogleResult data HoogleResult = SearchResult HoogleResponse
= SearchResult HoogleResponse
| DocResult HoogleResponse | DocResult HoogleResponse
| NoResult String | NoResult String
deriving Show deriving Show
...@@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where ...@@ -48,23 +43,21 @@ instance FromJSON [HoogleResponse] where
instance FromJSON HoogleResponse where instance FromJSON HoogleResponse where
parseJSON (Object obj) = parseJSON (Object obj) =
HoogleResponse <$> HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs"
obj .: "location" <*>
obj .: "self" <*>
obj .: "docs"
parseJSON _ = fail "Expected object with fields: location, self, docs" parseJSON _ = fail "Expected object with fields: location, self, docs"
-- | Query Hoogle for the given string. -- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either
-- This searches Hoogle using the internet. It returns either an error -- an error message or the successful JSON result.
-- message or the successful JSON result.
query :: String -> IO (Either String String) query :: String -> IO (Either String String)
query str = do query str = do
request <- parseUrl $ queryUrl $ urlEncode str request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request response <- try $ withManager tlsManagerSettings $ httpLbs request
return $ case response of return $
case response of
Left err -> Left $ show (err :: SomeException) Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp Right resp -> Right $ Char.unpack $ responseBody resp
where where
queryUrl :: String -> String queryUrl :: String -> String
queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json" queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json"
...@@ -78,27 +71,27 @@ urlEncode (ch:t) ...@@ -78,27 +71,27 @@ urlEncode (ch:t)
| otherwise = escape (P.fromEnum ch) (urlEncode t) | otherwise = escape (P.fromEnum ch) (urlEncode t)
where where
escape :: Int -> String -> String 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 :: Int -> String -> String
showH x xs showH x xs
| x <= 9 = toEnum (o_0 + x) : xs | x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x-10)) : xs | otherwise = toEnum (o_A + (x - 10)) : xs
where where
o_0 = P.fromEnum '0' o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A' o_A = P.fromEnum 'A'
eightBs :: [Int] -> Int -> [Int] eightBs :: [Int] -> Int -> [Int]
eightBs acc x eightBs acc x
| x <= 0xff = (x:acc) | x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256) | otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
-- | Search for a query on Hoogle. -- | Search for a query on Hoogle. Return all search results.
-- Return all search results.
search :: String -> IO [HoogleResult] search :: String -> IO [HoogleResult]
search string = do search string = do
response <- query string response <- query string
return $ case response of return $
case response of
Left err -> [NoResult err] Left err -> [NoResult err]
Right json -> Right json ->
case eitherDecode $ Char.pack json of case eitherDecode $ Char.pack json of
...@@ -108,16 +101,17 @@ search string = do ...@@ -108,16 +101,17 @@ search string = do
[] -> [NoResult "no matching identifiers found."] [] -> [NoResult "no matching identifiers found."]
res -> res res -> res
-- | Look up an identifier on Hoogle. -- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many
-- Return documentation for that identifier. If there are many
-- identifiers, include documentation for all of them. -- identifiers, include documentation for all of them.
document :: String -> IO [HoogleResult] document :: String -> IO [HoogleResult]
document string = do document string = do
matchingResults <- filter matches <$> search string matchingResults <- filter matches <$> search string
let results = map toDocResult matchingResults let results = map toDocResult matchingResults
return $ case results of return $
case results of
[] -> [NoResult "no matching identifiers found."] [] -> [NoResult "no matching identifiers found."]
res -> res res -> res
where where
matches (SearchResult resp) = matches (SearchResult resp) =
case split " " $ self resp of case split " " $ self resp of
...@@ -139,16 +133,10 @@ renderPlain (NoResult res) = ...@@ -139,16 +133,10 @@ renderPlain (NoResult res) =
"No response available: " ++ res "No response available: " ++ res
renderPlain (SearchResult resp) = renderPlain (SearchResult resp) =
printf "%s\nURL: %s\n%s" printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
(self resp)
(location resp)
(docs resp)
renderPlain (DocResult resp) = renderPlain (DocResult resp) =
printf "%s\nURL: %s\n%s" printf "%s\nURL: %s\n%s" (self resp) (location resp) (docs resp)
(self resp)
(location resp)
(docs resp)
-- | Render a Hoogle result to HTML. -- | Render a Hoogle result to HTML.
renderHtml :: HoogleResult -> String renderHtml :: HoogleResult -> String
...@@ -167,37 +155,37 @@ renderHtml (SearchResult resp) = ...@@ -167,37 +155,37 @@ renderHtml (SearchResult resp) =
renderSelf :: String -> String -> String renderSelf :: String -> String -> String
renderSelf string loc renderSelf string loc
| startswith "package" string | startswith "package" string =
= pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string) pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
| startswith "module" string | startswith "module" string =
= let package = extractPackageName loc in let package = extractPackageName loc
mod ++ " " ++ in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++ span "hoogle-module" (link loc $ extractModule string) ++
packageSub package packageSub package
| startswith "class" string | startswith "class" string =
= let package = extractPackageName loc in let package = extractPackageName loc
cls ++ " " ++ in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++ span "hoogle-class" (link loc $ extractClass string) ++
packageSub package packageSub package
| startswith "data" string | startswith "data" string =
= let package = extractPackageName loc in let package = extractPackageName loc
dat ++ " " ++ in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++ span "hoogle-class" (link loc $ extractData string) ++
packageSub package packageSub package
| otherwise | otherwise =
= let [name, args] = split "::" string let [name, args] = split "::" string
package = extractPackageName loc package = extractPackageName loc
modname = extractModuleName loc in modname = extractModuleName loc
span "hoogle-name" (unicodeReplace $ in span "hoogle-name"
(unicodeReplace $
link loc (strip name) ++ link loc (strip name) ++
" :: " ++ " :: " ++
strip args) strip args)
++ packageAndModuleSub package modname ++ packageAndModuleSub package modname
where where
extractPackage = strip . replace "package" "" extractPackage = strip . replace "package" ""
extractModule = strip . replace "module" "" extractModule = strip . replace "module" ""
...@@ -239,8 +227,7 @@ renderDocs doc = ...@@ -239,8 +227,7 @@ renderDocs doc =
if isCode lines if isCode lines
then div "hoogle-code" $ unlines $ nonull lines then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines else div "hoogle-text" $ unlines $ nonull lines
in in div "hoogle-doc" $ unlines $ map makeBlock groups
div "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String extractPackageName :: String -> Maybe String
extractPackageName link = do extractPackageName link = do
......
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{- | Description : Inspect type and function information and documentation.
-} {- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info ( module IHaskell.Eval.Info (info) where
info
) where
import ClassyPrelude hiding (liftIO) import ClassyPrelude hiding (liftIO)
......
{-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-} {-# LANGUAGE NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (
lint module IHaskell.Eval.Lint (lint) where
) where
import Data.String.Utils (replace, startswith, strip, split) import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last) import Prelude (head, tail, last)
...@@ -32,13 +31,13 @@ import IHaskell.Eval.Parser hiding (line) ...@@ -32,13 +31,13 @@ import IHaskell.Eval.Parser hiding (line)
type ExtsModule = SrcExts.Module SrcSpanInfo type ExtsModule = SrcExts.Module SrcSpanInfo
data LintSuggestion data LintSuggestion =
= Suggest { Suggest
line :: LineNumber, { line :: LineNumber
found :: String, , found :: String
whyNot :: String, , whyNot :: String
severity :: Severity, , severity :: Severity
suggestion :: String , suggestion :: String
} }
deriving (Eq, Show) deriving (Eq, Show)
...@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar ...@@ -51,8 +50,8 @@ hlintSettings = unsafePerformIO newEmptyMVar
lintIdent :: String lintIdent :: String
lintIdent = "lintIdentAEjlkQeh" lintIdent = "lintIdentAEjlkQeh"
-- | Given parsed code chunks, perform linting and output a displayable -- | Given parsed code chunks, perform linting and output a displayable report on linting warnings
-- report on linting warnings and errors. -- and errors.
lint :: [Located CodeBlock] -> IO Display lint :: [Located CodeBlock] -> IO Display
lint blocks = do lint blocks = do
-- Initialize hlint settings -- Initialize hlint settings
...@@ -66,26 +65,25 @@ lint blocks = do ...@@ -66,26 +65,25 @@ lint blocks = do
-- create 'suggestions' -- create 'suggestions'
let modules = mapMaybe (createModule mode) blocks 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 suggestions = mapMaybe showIdea ideas
return $ Display $ return $ Display $
if null suggestions if null suggestions
then [] then []
else else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]
[plain $ concatMap plainSuggestion suggestions,
html $ htmlSuggestions suggestions]
showIdea :: Idea -> Maybe LintSuggestion showIdea :: Idea -> Maybe LintSuggestion
showIdea idea = showIdea idea =
case ideaTo idea of case ideaTo idea of
Nothing -> Nothing Nothing -> Nothing
Just whyNot -> Just Suggest { Just whyNot -> Just
line = srcSpanStartLine $ ideaSpan idea, Suggest
found = showSuggestion $ ideaFrom idea, { line = srcSpanStartLine $ ideaSpan idea
whyNot = showSuggestion whyNot, , found = showSuggestion $ ideaFrom idea
severity = ideaSeverity idea, , whyNot = showSuggestion whyNot
suggestion = ideaHint idea , severity = ideaSeverity idea
, suggestion = ideaHint idea
} }
createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule
...@@ -111,12 +109,12 @@ createModule mode (Located line block) = ...@@ -111,12 +109,12 @@ createModule mode (Located line block) =
unparse _ = Nothing unparse _ = Nothing
srcSpan :: SrcSpan srcSpan :: SrcSpan
srcSpan = SrcSpan { srcSpan = SrcSpan
srcSpanFilename = "<interactive>", { srcSpanFilename = "<interactive>"
srcSpanStartLine = line, , srcSpanStartLine = line
srcSpanStartColumn = 0, , srcSpanStartColumn = 0
srcSpanEndLine = line + length (lines blockStr), , srcSpanEndLine = line + length (lines blockStr)
srcSpanEndColumn = length $ last $ lines blockStr , srcSpanEndColumn = length $ last $ lines blockStr
} }
loc :: SrcSpanInfo loc :: SrcSpanInfo
...@@ -135,7 +133,8 @@ createModule mode (Located line block) = ...@@ -135,7 +133,8 @@ createModule mode (Located line block) =
exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp
stmtToModule :: String -> ParseResult ExtsModule stmtToModule :: String -> ParseResult ExtsModule
stmtToModule stmtStr = case parseStmtWithMode mode stmtStr of stmtToModule stmtStr =
case parseStmtWithMode mode stmtStr of
ParseOk stmt -> ParseOk mod ParseOk stmt -> ParseOk mod
ParseFailed a b -> ParseFailed a b ParseFailed a b -> ParseFailed a b
where where
...@@ -158,10 +157,7 @@ createModule mode (Located line block) = ...@@ -158,10 +157,7 @@ createModule mode (Located line block) =
plainSuggestion :: LintSuggestion -> String plainSuggestion :: LintSuggestion -> String
plainSuggestion suggest = plainSuggestion suggest =
printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" printf "Line %d: %s\nFound:\n%s\nWhy not:\n%s" (line suggest) (suggestion suggest) (found suggest)
(line suggest)
(suggestion suggest)
(found suggest)
(whyNot suggest) (whyNot suggest)
htmlSuggestions :: [LintSuggestion] -> String htmlSuggestions :: [LintSuggestion] -> String
...@@ -169,18 +165,17 @@ htmlSuggestions = concatMap toHtml ...@@ -169,18 +165,17 @@ htmlSuggestions = concatMap toHtml
where where
toHtml :: LintSuggestion -> String toHtml :: LintSuggestion -> String
toHtml suggest = concat toHtml suggest = concat
[ [ named $ suggestion suggest
named $ suggestion suggest, , floating "left" $ style severityClass "Found:" ++
floating "left" $ style severityClass "Found:" ++
-- Things that look like this get highlighted. -- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (found suggest), styleId "highlight-code" "haskell" (found suggest)
floating "left" $ style severityClass "Why Not:" ++ , floating "left" $ style severityClass "Why Not:" ++
-- Things that look like this get highlighted. -- Things that look like this get highlighted.
styleId "highlight-code" "haskell" (whyNot suggest) styleId "highlight-code" "haskell" (whyNot suggest)
] ]
where where
severityClass = case severity suggest of severityClass =
case severity suggest of
Error -> "error" Error -> "error"
Warning -> "warning" Warning -> "warning"
...@@ -214,18 +209,14 @@ showSuggestion = remove lintIdent . dropDo ...@@ -214,18 +209,14 @@ showSuggestion = remove lintIdent . dropDo
else string else string
clean :: [String] -> [String] clean :: [String] -> [String]
-- If the first line starts with a `do`... -- If the first line starts with a `do`... Note that hlint always indents by two spaces in its
-- Note that hlint always indents by two spaces in its output. -- output.
clean ((stripPrefix " do " -> Just a) : as) = clean ((stripPrefix " do " -> Just a):as) =
-- Take all indented lines and unindent them. -- Take all indented lines and unindent them.
let unindented = catMaybes let unindented = catMaybes $ takeWhile isJust $ map (stripPrefix " ") as
$ takeWhile isJust fullDo = a : unindented
$ map (stripPrefix " ") as
fullDo = a:unindented
afterDo = drop (length unindented) as afterDo = drop (length unindented) as
in in fullDo ++ clean afterDo
--
fullDo ++ clean afterDo
-- Ignore other list elements - just proceed onwards. -- Ignore other list elements - just proceed onwards.
clean (x:xs) = x : clean xs clean (x:xs) = x : clean xs
......
-- | 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
...@@ -20,9 +19,10 @@ manyTill p end = scan ...@@ -20,9 +19,10 @@ manyTill p end = scan
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
x <- p
xs <- manyTill p end xs <- manyTill p end
return $ x : xs return $ x : xs
...@@ -37,7 +37,8 @@ quotedString = do ...@@ -37,7 +37,8 @@ quotedString = do
(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"
......
This diff is collapsed.
This diff is collapsed.
{-# 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,7 +33,9 @@ data Argument = ConfFile String -- ^ A file with commands to load at startup ...@@ -33,7 +33,9 @@ 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 =
LhsStyle
{ lhsCodePrefix :: string -- ^ @>@
, lhsOutputPrefix :: string -- ^ @<<@ , lhsOutputPrefix :: string -- ^ @<<@
, lhsBeginCode :: string -- ^ @\\begin{code}@ , lhsBeginCode :: string -- ^ @\\begin{code}@
, lhsEndCode :: string -- ^ @\\end{code}@ , lhsEndCode :: string -- ^ @\\end{code}@
...@@ -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
...@@ -161,8 +162,8 @@ ihaskellArgs = ...@@ -161,8 +162,8 @@ 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
......
...@@ -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
{ kernelSpecGhcLibdir :: String -- ^ GHC libdir.
, kernelSpecDebug :: Bool -- ^ Spew debugging output? , kernelSpecDebug :: Bool -- ^ Spew debugging output?
, kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file. , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
} }
defaultKernelSpecOptions :: KernelSpecOptions defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions { kernelSpecGhcLibdir = GHC.Paths.libdir defaultKernelSpecOptions = KernelSpecOptions
{ kernelSpecGhcLibdir = GHC.Paths.libdir
, kernelSpecDebug = False , kernelSpecDebug = False
, kernelSpecConfFile = defaultConfFile , 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
{ kernelDisplayName = "Haskell"
, kernelLanguage = kernelName , kernelLanguage = kernelName
, kernelCommand = [ihaskellPath, "kernel", "{connection_file}"] ++ kernelFlags , 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"
...@@ -185,16 +190,15 @@ kernelSpecCreated = do ...@@ -185,16 +190,15 @@ kernelSpecCreated = do
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"
......
{-# 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(..),
...@@ -16,7 +16,8 @@ module IHaskell.Types ( ...@@ -16,7 +16,8 @@ module IHaskell.Types (
ExecuteReplyStatus(..), ExecuteReplyStatus(..),
KernelState(..), KernelState(..),
LintStatus(..), LintStatus(..),
Width, Height, Width,
Height,
Display(..), Display(..),
defaultKernelState, defaultKernelState,
extractPlain, extractPlain,
...@@ -90,8 +91,8 @@ instance Show Widget where ...@@ -90,8 +91,8 @@ 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)
...@@ -108,7 +109,9 @@ instance Semigroup Display where ...@@ -108,7 +109,9 @@ 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 =
KernelState
{ getExecutionCounter :: Int
, getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it. , getLintStatus :: LintStatus -- Whether to use hlint, and what arguments to pass it.
, useSvg :: Bool , useSvg :: Bool
, useShowErrors :: Bool , useShowErrors :: Bool
...@@ -120,7 +123,8 @@ data KernelState = KernelState { getExecutionCounter :: Int ...@@ -120,7 +123,8 @@ data KernelState = KernelState { getExecutionCounter :: Int
deriving Show deriving Show
defaultKernelState :: KernelState defaultKernelState :: KernelState
defaultKernelState = KernelState { getExecutionCounter = 1 defaultKernelState = KernelState
{ getExecutionCounter = 1
, getLintStatus = LintOn , getLintStatus = LintOn
, useSvg = True , useSvg = True
, useShowErrors = False , useShowErrors = False
...@@ -131,10 +135,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1 ...@@ -131,10 +135,12 @@ defaultKernelState = KernelState { getExecutionCounter = 1
} }
-- | 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]
...@@ -152,23 +158,24 @@ kernelOpts = ...@@ -152,23 +158,24 @@ kernelOpts =
] ]
-- | 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
{-# 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.
...@@ -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,33 +183,34 @@ createReplyHeader parent = do ...@@ -185,33 +183,34 @@ 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. -- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
-- Before shutdown, reply to the request to let the frontend know shutdown -- let the frontend know shutdown is happening.
-- 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
...@@ -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 ()
...@@ -337,16 +337,16 @@ replyTo _ req@CompleteRequest{} replyHeader state = do ...@@ -337,16 +337,16 @@ replyTo _ req@CompleteRequest{} replyHeader state = do
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)
...@@ -354,7 +354,8 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do ...@@ -354,7 +354,8 @@ replyTo _ ObjectInfoRequest{objectName = oname} replyHeader state = do
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)
......
...@@ -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:
incorrect_formatting = True
print('Incorrect formatting in', filename)
print('=' * 10) print('=' * 10)
print(diff) 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