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

Removing classy-prelude from dependencies, creating small custom prelude

Browse Source
This commit is contained in:
Andrew Gibiansky 2015-05-25 20:49:40 +02:00
parent 5f271a9bce
commit f7296881b7
22 changed files with 576 additions and 318 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
ihaskell.cabal
View File

@ -60,9 +60,6 @@ library
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
classy-prelude >=0.10.5 && <0.11,
chunked-data ==0.1.*,
mono-traversable >=0.6,
cmdargs >=0.10,
containers >=0.5,
directory -any,
@ -74,10 +71,8 @@ library
here ==1.2.*,
hlint >=1.9 && <2.0,
haskell-src-exts ==1.16.*,
hspec -any,
http-client == 0.4.*,
http-client-tls == 0.2.*,
HUnit -any,
MissingH >=1.2,
mtl >=2.1,
parsec -any,
@ -89,7 +84,6 @@ library
strict >=0.3,
system-argv0 -any,
system-filepath -any,
tar -any,
text >=0.11,
transformers -any,
unix >= 2.6,
@ -121,36 +115,72 @@ library
IHaskell.Types
IHaskell.BrokenPackages
Paths_ihaskell
-- other-modules:
-- Paths_ihaskell
other-modules:
IHaskellPrelude
default-extensions:
NoImplicitPrelude
DoAndIfThenElse
OverloadedStrings
ExtendedDefaultRules
executable ihaskell
-- .hs or .lhs file containing the Main module.
main-is: src/Main.hs
main-is: Main.hs
hs-source-dirs: src
other-modules:
IHaskellPrelude
ghc-options: -threaded
-- Other library packages from which modules are imported.
default-language: Haskell2010
build-depends:
aeson >=0.7 && < 0.9,
base >=4.6 && < 4.9,
aeson >=0.6 && < 0.9,
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
classy-prelude >=0.10.5 && <0.11,
chunked-data ==0.1.*,
mono-traversable >=0.6,
cmdargs >=0.10,
containers >=0.5,
directory -any,
ghc >=7.6 && < 7.11,
ihaskell -any,
MissingH >=1.2,
filepath -any,
ghc >=7.6 || < 7.11,
ghc-parser >=0.1.7,
ghc-paths ==0.1.*,
haskeline -any,
here ==1.2.*,
text -any,
ipython-kernel >= 0.6.1,
unix >= 2.6
hlint >=1.9 && <2.0,
haskell-src-exts ==1.16.*,
http-client == 0.4.*,
http-client-tls == 0.2.*,
MissingH >=1.2,
mtl >=2.1,
parsec -any,
process >=1.1,
random >=1.0,
shelly >=1.5,
split >= 0.2,
stm -any,
strict >=0.3,
system-argv0 -any,
system-filepath -any,
text >=0.11,
transformers -any,
unix >= 2.6,
unordered-containers -any,
utf8-string -any,
uuid >=1.3,
vector -any,
ipython-kernel >=0.6.1
if flag(binPkgDb)
build-depends: bin-package-db
default-extensions:
NoImplicitPrelude
DoAndIfThenElse
OverloadedStrings
ExtendedDefaultRules
Test-Suite hspec
Type: exitcode-stdio-1.0
Ghc-Options: -threaded
@ -163,9 +193,6 @@ Test-Suite hspec
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
classy-prelude >=0.10.5 && <0.11,
chunked-data ==0.1.*,
mono-traversable >=0.6,
cmdargs >=0.10,
containers >=0.5,
directory -any,
@ -190,7 +217,6 @@ Test-Suite hspec
strict >=0.3,
system-argv0 -any,
system-filepath -any,
tar -any,
text >=0.11,
http-client == 0.4.*,
http-client-tls == 0.2.*,

11
src/IHaskell/BrokenPackages.hs
View File

@ -1,8 +1,13 @@
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, FlexibleContexts #-}
module IHaskell.BrokenPackages (getBrokenPackages) where
import ClassyPrelude hiding ((<|>))
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Text.Parsec
import Text.Parsec.String
@ -27,7 +32,7 @@ getBrokenPackages = shelly $ do
-- Get rid of extraneous things
let rightStart str = startswith "There are problems" str ||
startswith " dependency" str
ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
ghcPkgOutput = unlines . filter rightStart . lines $ T.unpack checkOut
return $
case parse (many check) "ghc-pkg output" ghcPkgOutput of

8
src/IHaskell/Convert.hs
View File

@ -1,6 +1,14 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | Description : mostly reversible conversion between ipynb and lhs
module IHaskell.Convert (convert) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Monad.Identity (Identity(Identity), unless, when)
import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec)
import IHaskell.Convert.IpynbToLhs (ipynbToLhs)

16
src/IHaskell/Convert/Args.hs
View File

@ -1,6 +1,14 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | Description: interpret flags parsed by "IHaskell.Flags"
module IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Applicative ((<$>))
import Control.Monad.Identity (Identity(Identity))
import Data.Char (toLower)
@ -17,7 +25,7 @@ data ConvertSpec f =
{ convertToIpynb :: f Bool
, convertInput :: f FilePath
, convertOutput :: f FilePath
, convertLhsStyle :: f (LhsStyle T.Text)
, convertLhsStyle :: f (LhsStyle LT.Text)
, convertOverwriteFiles :: Bool
}
@ -28,7 +36,7 @@ fromJustConvertSpec convertSpec = convertSpec
{ convertToIpynb = Identity toIpynb
, convertInput = Identity inputFile
, convertOutput = Identity outputFile
, convertLhsStyle = Identity $ fromMaybe (T.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
, convertLhsStyle = Identity $ fromMaybe (LT.pack <$> lhsStyleBird) (convertLhsStyle convertSpec)
}
where
toIpynb = fromMaybe (error "Error: direction for conversion unknown")
@ -63,10 +71,10 @@ mergeArg :: Argument -> ConvertSpec Maybe -> ConvertSpec Maybe
mergeArg OverwriteFiles convertSpec = convertSpec { convertOverwriteFiles = True }
mergeArg (ConvertLhsStyle lhsStyle) convertSpec
| Just previousLhsStyle <- convertLhsStyle convertSpec,
previousLhsStyle /= fmap T.pack lhsStyle
previousLhsStyle /= fmap LT.pack lhsStyle
= error $ printf "Conflicting lhs styles requested: <%s> and <%s>" (show lhsStyle)
(show previousLhsStyle)
| otherwise = convertSpec { convertLhsStyle = Just (T.pack <$> lhsStyle) }
| otherwise = convertSpec { convertLhsStyle = Just (LT.pack <$> lhsStyle) }
mergeArg (ConvertFrom inputFile) convertSpec
| Just previousInputFile <- convertInput convertSpec,
previousInputFile /= inputFile

59
src/IHaskell/Convert/IpynbToLhs.hs
View File

@ -1,66 +1,71 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where
import Control.Applicative ((<$>))
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Aeson (decode, Object, Value(Array, Object, String))
import qualified Data.ByteString.Lazy as L (readFile)
import qualified Data.HashMap.Strict as M (lookup)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), Monoid(mempty))
import qualified Data.Text.Lazy as T (concat, fromStrict, Text, unlines)
import qualified Data.Text.Lazy.IO as T (writeFile)
import Data.Vector (Vector)
import Data.HashMap.Strict (lookup)
import qualified Data.Text.Lazy.IO as LTIO
import qualified Data.Vector as V (map, mapM, toList)
import IHaskell.Flags (LhsStyle(..))
ipynbToLhs :: LhsStyle T.Text
ipynbToLhs :: LhsStyle LText
-> FilePath -- ^ the filename of an ipython notebook
-> FilePath -- ^ the filename of the literate haskell to write
-> IO ()
ipynbToLhs sty from to = do
Just (js :: Object) <- decode <$> L.readFile from
case M.lookup "cells" js of
Just (js :: Object) <- decode <$> LBS.readFile from
case lookup "cells" js of
Just (Array cells) ->
T.writeFile to $ T.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
LTIO.writeFile to $ LT.unlines $ V.toList $ V.map (\(Object y) -> convCell sty y) cells
_ -> error "IHaskell.Convert.ipynbTolhs: json does not follow expected schema"
concatWithPrefix :: T.Text -- ^ the prefix to add to every line
concatWithPrefix :: LT.Text -- ^ the prefix to add to every line
-> Vector Value -- ^ a json array of text lines
-> Maybe T.Text
concatWithPrefix p arr = T.concat . map (p <>) . V.toList <$> V.mapM toStr arr
-> Maybe LT.Text
concatWithPrefix p arr = LT.concat . map (p <>) . V.toList <$> V.mapM toStr arr
toStr :: Value -> Maybe T.Text
toStr (String x) = Just (T.fromStrict x)
toStr :: Value -> Maybe LT.Text
toStr (String x) = Just (LT.fromStrict x)
toStr _ = Nothing
-- | @convCell sty cell@ converts a single cell in JSON into text suitable for the type of lhs file
-- described by the @sty@
convCell :: LhsStyle T.Text -> Object -> T.Text
convCell :: LhsStyle LT.Text -> Object -> LT.Text
convCell _sty object
| Just (String "markdown") <- M.lookup "cell_type" object,
Just (Array xs) <- M.lookup "source" object,
| Just (String "markdown") <- lookup "cell_type" object,
Just (Array xs) <- lookup "source" object,
~(Just s) <- concatWithPrefix "" xs
= s
convCell sty object
| Just (String "code") <- M.lookup "cell_type" object,
Just (Array i) <- M.lookup "source" object,
Just (Array o) <- M.lookup "outputs" object,
| Just (String "code") <- lookup "cell_type" object,
Just (Array i) <- lookup "source" object,
Just (Array o) <- lookup "outputs" object,
~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i,
o <- fromMaybe mempty (convOutputs sty o)
= "\n" <>
lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n"
convCell _ _ = "IHaskell.Convert.convCell: unknown cell"
convOutputs :: LhsStyle T.Text
convOutputs :: LhsStyle LT.Text
-> Vector Value -- ^ JSON array of output lines containing text or markup
-> Maybe T.Text
-> Maybe LT.Text
convOutputs sty array = do
outputLines <- V.mapM (getTexts (lhsOutputPrefix sty)) array
return $ lhsBeginOutput sty <> T.concat (V.toList outputLines) <> lhsEndOutput sty
return $ lhsBeginOutput sty <> LT.concat (V.toList outputLines) <> lhsEndOutput sty
getTexts :: T.Text -> Value -> Maybe T.Text
getTexts :: LT.Text -> Value -> Maybe LT.Text
getTexts p (Object object)
| Just (Array text) <- M.lookup "text" object = concatWithPrefix p text
| Just (Array text) <- lookup "text" object = concatWithPrefix p text
getTexts _ _ = Nothing

83
src/IHaskell/Convert/LhsToIpynb.hs
View File

@ -1,24 +1,26 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module IHaskell.Convert.LhsToIpynb (lhsToIpynb) where
import Control.Applicative ((<$>))
import Control.Monad (mplus)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Aeson ((.=), encode, object, Value(Array, Bool, Number, String, Null))
import qualified Data.ByteString.Lazy as L (writeFile)
import Data.Char (isSpace)
import Data.Monoid (Monoid(mempty))
import qualified Data.Text as TS (Text)
import qualified Data.Text.Lazy as T (dropWhile, lines, stripPrefix, Text, toStrict, snoc, strip)
import qualified Data.Text.Lazy.IO as T (readFile)
import qualified Data.Vector as V (fromList, singleton)
import qualified Data.List as List
import IHaskell.Flags (LhsStyle(LhsStyle))
lhsToIpynb :: LhsStyle T.Text -> FilePath -> FilePath -> IO ()
lhsToIpynb :: LhsStyle LText -> FilePath -> FilePath -> IO ()
lhsToIpynb sty from to = do
classed <- classifyLines sty . T.lines <$> T.readFile from
L.writeFile to . encode . encodeCells $ groupClassified classed
classed <- classifyLines sty . LT.lines . LT.pack <$> readFile from
LBS.writeFile to . encode . encodeCells $ groupClassified classed
data CellLine a = CodeLine a
| OutputLine a
@ -50,40 +52,39 @@ data Cell a = Code a a
| Markdown a
deriving Show
encodeCells :: [Cell [T.Text]] -> Value
encodeCells :: [Cell [LText]] -> Value
encodeCells xs = object $
["cells" .= Array (V.fromList (map cellToVal xs))]
++ boilerplate
"cells" .= Array (V.fromList (map cellToVal xs)) : boilerplate
cellToVal :: Cell [T.Text] -> Value
cellToVal (Code i o) = object $
[ "cell_type" .= String "code"
, "execution_count" .= Null
, "metadata" .= object ["collapsed" .= Bool False]
, "source" .= arrayFromTxt i
, "outputs" .= Array
(V.fromList
([object
[ "text" .= arrayFromTxt o
, "metadata" .= object []
, "output_type" .= String "display_data"
] | _ <- take 1 o]))
]
cellToVal (Markdown txt) = object $
cellToVal :: Cell [LText] -> Value
cellToVal (Code i o) = object
[ "cell_type" .= String "code"
, "execution_count" .= Null
, "metadata" .= object ["collapsed" .= Bool False]
, "source" .= arrayFromTxt i
, "outputs" .= Array
(V.fromList
[object
[ "text" .= arrayFromTxt o
, "metadata" .= object []
, "output_type" .= String "display_data"
] | _ <- take 1 o])
]
cellToVal (Markdown txt) = object
[ "cell_type" .= String "markdown"
, "metadata" .= object ["hidden" .= Bool False]
, "source" .= arrayFromTxt txt
]
-- | arrayFromTxt makes a JSON array of string s
arrayFromTxt :: [T.Text] -> Value
arrayFromTxt :: [LText] -> Value
arrayFromTxt i = Array (V.fromList $ map stringify i)
where
stringify = String . T.toStrict . flip T.snoc '\n'
stringify = String . LT.toStrict . flip LT.snoc '\n'
-- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and
-- output correctly.
boilerplate :: [(TS.Text, Value)]
boilerplate :: [(T.Text, Value)]
boilerplate =
["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0]
where
@ -94,18 +95,18 @@ boilerplate =
]
lang = "language_info" .= object ["name" .= String "haskell", "version" .= String VERSION_ghc]
groupClassified :: [CellLine T.Text] -> [Cell [T.Text]]
groupClassified :: [CellLine LText] -> [Cell [LText]]
groupClassified (CodeLine a:x)
| (c, x) <- span isCode x,
(_, x) <- span isEmptyMD x,
(o, x) <- span isOutput x
| (c, x) <- List.span isCode x,
(_, x) <- List.span isEmptyMD x,
(o, x) <- List.span isOutput x
= Code (a : map untag c) (map untag o) : groupClassified x
groupClassified (MarkdownLine a:x)
| (m, x) <- span isMD x = Markdown (a : map untag m) : groupClassified x
| (m, x) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x
groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x
groupClassified [] = []
classifyLines :: LhsStyle T.Text -> [T.Text] -> [CellLine T.Text]
classifyLines :: LhsStyle LText -> [LText] -> [CellLine LText]
classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =
case (sp c, sp o) of
(Just a, Nothing) -> CodeLine a : classifyLines sty ls
@ -113,9 +114,9 @@ classifyLines sty@(LhsStyle c o _ _ _ _) (l:ls) =
(Nothing, Nothing) -> MarkdownLine l : classifyLines sty ls
_ -> error "IHaskell.Convert.classifyLines"
where
sp x = T.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x
blankCodeLine x = if T.strip x == T.strip l
sp x = LT.stripPrefix (dropSpace x) (dropSpace l) `mplus` blankCodeLine x
blankCodeLine x = if LT.strip x == LT.strip l
then Just ""
else Nothing
dropSpace = T.dropWhile isSpace
dropSpace = LT.dropWhile isSpace
classifyLines _ [] = []

28
src/IHaskell/Display.hs
View File

@ -48,18 +48,26 @@ module IHaskell.Display (
Widget(..),
) where
import ClassyPrelude
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.Serialize as Serialize
import Data.ByteString hiding (map, pack)
import Data.String.Utils (rstrip)
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as Char
import Data.Aeson (Value)
import System.Directory (getTemporaryDirectory, setCurrentDirectory)
import Control.Concurrent.STM (atomically)
import Control.Exception (try)
import Control.Concurrent.STM.TChan
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text.Encoding as E
import IHaskell.Types
type Base64 = Text
@ -92,23 +100,23 @@ many = ManyDisplay
-- | Generate a plain text display.
plain :: String -> DisplayData
plain = DisplayData PlainText . pack . rstrip
plain = DisplayData PlainText . T.pack . rstrip
-- | Generate an HTML display.
html :: String -> DisplayData
html = DisplayData MimeHtml . pack
html = DisplayData MimeHtml . T.pack
-- | Generate an SVG display.
svg :: String -> DisplayData
svg = DisplayData MimeSvg . pack
svg = DisplayData MimeSvg . T.pack
-- | Generate a LaTeX display.
latex :: String -> DisplayData
latex = DisplayData MimeLatex . pack
latex = DisplayData MimeLatex . T.pack
-- | Generate a Javascript display.
javascript :: String -> DisplayData
javascript = DisplayData MimeJavascript . pack
javascript = DisplayData MimeJavascript . T.pack
-- | Generate a PNG display of the given width and height. Data must be provided in a Base64 encoded
-- manner, suitable for embedding into HTML. The @base64@ function may be used to encode data into
@ -124,11 +132,11 @@ jpg width height = DisplayData (MimeJpg width height)
-- | Convert from a string into base 64 encoded data.
encode64 :: String -> Base64
encode64 str = base64 $ Char.pack str
encode64 str = base64 $ CBS.pack str
-- | Convert from a ByteString into base 64 encoded data.
base64 :: ByteString -> Base64
base64 = decodeUtf8 . Base64.encode
base64 = E.decodeUtf8 . Base64.encode
-- | For internal use within IHaskell. Serialize displays to a ByteString.
serializeDisplay :: Display -> ByteString

14
src/IHaskell/Eval/Completion.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{- |
@ -13,7 +13,12 @@ This has a limited amount of context sensitivity. It distinguishes between four
-}
module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) where
import ClassyPrelude hiding (init, last, head, liftIO)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Applicative ((<$>))
import Data.ByteString.UTF8 hiding (drop, take, lines, length)
@ -34,11 +39,12 @@ import DynFlags
import GhcMonad
import PackageConfig
import Outputable (showPpr)
import MonadUtils (MonadIO)
import System.Directory
import System.FilePath
import MonadUtils (MonadIO)
import Control.Exception (try)
import System.Console.Haskeline.Completion
@ -155,7 +161,7 @@ getTrueModuleName name = do
onlyImportDecl _ = Nothing
-- Get all imports that we use.
imports <- ClassyPrelude.catMaybes <$> map onlyImportDecl <$> getContext
imports <- catMaybes <$> map onlyImportDecl <$> getContext
-- Find the ones that have a qualified name attached. If this name isn't one of them, it already is
-- the true name.

18
src/IHaskell/Eval/Evaluate.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}
{-# LANGUAGE NoImplicitPrelude, DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
@ -15,7 +15,13 @@ module IHaskell.Eval.Evaluate (
formatType,
) where
import ClassyPrelude hiding (init, last, liftIO, head, hGetContents, tail, try)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent (forkIO, threadDelay)
import Prelude (putChar, head, tail, last, init, (!!))
import Data.List.Utils
@ -68,8 +74,6 @@ import FastString
import Bag
import ErrUtils (errMsgShortDoc, errMsgExtraInfo)
import qualified System.IO.Strict as StrictIO
import IHaskell.Types
import IHaskell.IPython
import IHaskell.Eval.Parser
@ -403,7 +407,7 @@ evalCommand _ (Module contents) state = wrapExecution state $ do
filename = last namePieces ++ ".hs"
liftIO $ do
createDirectoryIfMissing True directory
writeFile (fpFromString $ directory ++ filename) contents
writeFile (directory ++ filename) contents
-- Clear old modules of this name
let modName = intercalate "." namePieces
@ -565,7 +569,7 @@ evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do
let filename = if endswith ".hs" name
then name
else name ++ ".hs"
contents <- readFile $ fpFromString filename
contents <- liftIO $ readFile filename
modName <- intercalate "." <$> getModuleName contents
doLoadModule filename modName
return (ManyDisplay displays)
@ -1016,7 +1020,7 @@ doLoadModule name modName = do
setSessionDynFlags
flags
{ hscTarget = objTarget flags
, log_action = \dflags sev srcspan ppr msg -> modifyIORef errRef (showSDoc flags msg :)
, log_action = \dflags sev srcspan ppr msg -> modifyIORef' errRef (showSDoc flags msg :)
}
-- Load the new target.

56
src/IHaskell/Eval/Hoogle.hs
View File

@ -8,16 +8,19 @@ module IHaskell.Eval.Hoogle (
HoogleResult,
) where
import ClassyPrelude hiding (last, span, div)
import Text.Printf
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Data.Aeson
import Data.String.Utils
import Data.List (elemIndex, (!!), last)
import qualified Data.List as List
import Data.Char (isAscii, isAlphaNum)
import qualified Data.ByteString.Lazy.Char8 as Char
import qualified Prelude as P
import IHaskell.IPython
@ -52,11 +55,8 @@ instance FromJSON HoogleResponse where
query :: String -> IO (Either String String)
query str = do
request <- parseUrl $ queryUrl $ urlEncode str
response <- try $ withManager tlsManagerSettings $ httpLbs request
return $
case response of
Left err -> Left $ show (err :: SomeException)
Right resp -> Right $ Char.unpack $ responseBody resp
catch (Right . CBS.unpack . LBS.toStrict . responseBody <$> withManager tlsManagerSettings (httpLbs request))
(\e -> return $ Left $ show (e :: SomeException))
where
queryUrl :: String -> String
@ -66,25 +66,25 @@ query str = do
urlEncode :: String -> String
urlEncode [] = []
urlEncode (ch:t)
| (isAscii ch && isAlphaNum ch) || ch `P.elem` ("-_.~" :: String) = ch : urlEncode t
| not (isAscii ch) = P.foldr escape (urlEncode t) (eightBs [] (P.fromEnum ch))
| otherwise = escape (P.fromEnum ch) (urlEncode t)
| (isAscii ch && isAlphaNum ch) || ch `elem` ("-_.~" :: String) = ch : urlEncode t
| not (isAscii ch) = foldr escape (urlEncode t) (eightBs [] (fromEnum ch))
| otherwise = escape (fromEnum ch) (urlEncode t)
where
escape :: Int -> String -> String
escape b rs = '%' : showH (b `P.div` 16) (showH (b `mod` 16) rs)
escape b rs = '%' : showH (b `div` 16) (showH (b `mod` 16) rs)
showH :: Int -> String -> String
showH x xs
| x <= 9 = toEnum (o_0 + x) : xs
| otherwise = toEnum (o_A + (x - 10)) : xs
where
o_0 = P.fromEnum '0'
o_A = P.fromEnum 'A'
o_0 = fromEnum '0'
o_A = fromEnum 'A'
eightBs :: [Int] -> Int -> [Int]
eightBs acc x
| x <= 255 = x : acc
| otherwise = eightBs ((x `mod` 256) : acc) (x `P.div` 256)
| otherwise = eightBs ((x `mod` 256) : acc) (x `div` 256)
-- | Search for a query on Hoogle. Return all search results.
search :: String -> IO [HoogleResult]
@ -94,7 +94,7 @@ search string = do
case response of
Left err -> [NoResult err]
Right json ->
case eitherDecode $ Char.pack json of
case eitherDecode $ LBS.fromStrict$ CBS.pack json of
Left err -> [NoResult err]
Right results ->
case map SearchResult results of
@ -216,7 +216,7 @@ renderSelf string loc
renderDocs :: String -> String
renderDocs doc =
let groups = groupBy bothAreCode $ lines doc
let groups = List.groupBy bothAreCode $ lines doc
nonull = filter (not . null . strip)
bothAreCode s1 s2 =
startswith ">" (strip s1) &&
@ -224,28 +224,28 @@ renderDocs doc =
isCode (s:_) = startswith ">" $ strip s
makeBlock lines =
if isCode lines
then div "hoogle-code" $ unlines $ nonull lines
else div "hoogle-text" $ unlines $ nonull lines
in div "hoogle-doc" $ unlines $ map makeBlock groups
then div' "hoogle-code" $ unlines $ nonull lines
else div' "hoogle-text" $ unlines $ nonull lines
in div' "hoogle-doc" $ unlines $ map makeBlock groups
extractPackageName :: String -> Maybe String
extractPackageName link = do
let pieces = split "/" link
archiveLoc <- elemIndex "archive" pieces
latestLoc <- elemIndex "latest" pieces
archiveLoc <- List.elemIndex "archive" pieces
latestLoc <- List.elemIndex "latest" pieces
guard $ latestLoc - archiveLoc == 2
return $ pieces !! (latestLoc - 1)
return $ pieces List.!! (latestLoc - 1)
extractModuleName :: String -> Maybe String
extractModuleName link = do
let pieces = split "/" link
guard $ not $ null pieces
let html = last pieces
let html = fromJust $ lastMay pieces
mod = replace "-" "." $ takeWhile (/= '.') html
return mod
div :: String -> String -> String
div = printf "<div class='%s'>%s</div>"
div' :: String -> String -> String
div' = printf "<div class='%s'>%s</div>"
span :: String -> String -> String
span = printf "<span class='%s'>%s</span>"

7
src/IHaskell/Eval/Info.hs
View File

@ -3,7 +3,12 @@
{- | Description : Inspect type and function information and documentation. -}
module IHaskell.Eval.Info (info) where
import ClassyPrelude hiding (liftIO)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import IHaskell.Eval.Evaluate (typeCleaner, Interpreter)

10
src/IHaskell/Eval/Inspect.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse, FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, DoAndIfThenElse, FlexibleContexts #-}
{- |
Description: Generates inspections when asked for by the frontend.
@ -6,7 +6,13 @@ Description: Generates inspections when asked for by the frontend.
-}
module IHaskell.Eval.Inspect (inspect) where
import ClassyPrelude
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import qualified Prelude as P
import Data.List.Split (splitOn)

10
src/IHaskell/Eval/Lint.hs
View File

@ -1,10 +1,16 @@
{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (lint) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.String.Utils (replace, startswith, strip, split)
import Prelude (head, tail, last)
import ClassyPrelude hiding (last)
import Control.Monad
import Data.List (findIndex)
import Text.Printf

34
src/IHaskell/Eval/ParseShell.hs
View File

@ -1,10 +1,16 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | This module splits a shell command line into a list of strings,
-- one for each command / filename
module IHaskell.Eval.ParseShell (parseShell) where
import Prelude hiding (words)
import Text.ParserCombinators.Parsec hiding (manyTill)
import Control.Applicative hiding ((<|>), many, optional)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Text.ParserCombinators.Parsec
eol :: Parser Char
eol = oneOf "\n\r" <?> "end of line"
@ -12,18 +18,18 @@ eol = oneOf "\n\r" <?> "end of line"
quote :: Parser Char
quote = char '\"'
-- | @manyTill p end@ from hidden @manyTill@ in that it appends the result of @end@
manyTill :: Parser a -> Parser [a] -> Parser [a]
manyTill p end = scan
-- | @manyTillEnd p end@ from normal @manyTill@ in that it appends the result of @end@
manyTillEnd :: Parser a -> Parser [a] -> Parser [a]
manyTillEnd p end = scan
where
scan = end <|> do
x <- p
xs <- scan
return $ x : xs
manyTill1 p end = do
manyTillEnd1 p end = do
x <- p
xs <- manyTill p end
xs <- manyTillEnd p end
return $ x : xs
unescapedChar :: Parser Char -> Parser String
@ -34,9 +40,9 @@ unescapedChar p = try $ do
quotedString = do
quote <?> "expected starting quote"
(manyTill anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
(manyTillEnd anyChar (unescapedChar quote) <* quote) <?> "unexpected in quoted String "
unquotedString = manyTill1 anyChar end
unquotedString = manyTillEnd1 anyChar end
where
end = unescapedChar space
<|> (lookAhead eol >> return [])
@ -47,14 +53,14 @@ separator :: Parser String
separator = many1 space <?> "separator"
-- | Input must terminate in a space character (like a \n)
words :: Parser [String]
words = try (eof *> return []) <|> do
shellWords :: Parser [String]
shellWords = try (eof *> return []) <|> do
x <- word
rest1 <- lookAhead (many anyToken)
ss <- separator
rest2 <- lookAhead (many anyToken)
xs <- words
xs <- shellWords
return $ x : xs
parseShell :: String -> Either ParseError [String]
parseShell string = parse words "shell" (string ++ "\n")
parseShell string = parse shellWords "shell" (string ++ "\n")

7
src/IHaskell/Eval/Parser.hs
View File

@ -15,7 +15,12 @@ module IHaskell.Eval.Parser (
PragmaType(..),
) where
import ClassyPrelude hiding (head, liftIO, maximumBy)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Data.List (maximumBy, inits)
import Data.String.Utils (startswith, strip, split)

89
src/IHaskell/Eval/Util.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude, CPP #-}
module IHaskell.Eval.Util (
-- * Initialization
@ -23,7 +23,12 @@ module IHaskell.Eval.Util (
pprLanguages,
) where
import ClassyPrelude hiding ((<>))
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
-- GHC imports.
import DynFlags
@ -34,7 +39,6 @@ import HsImpExp
import HscTypes
import InteractiveEval
import Module
import Outputable
import Packages
import RdrName
import NameSet
@ -44,6 +48,7 @@ import InstEnv (ClsInst(..))
import Unify (tcMatchTys)
import VarSet (mkVarSet)
import qualified Pretty
import qualified Outputable as O
import Control.Monad (void)
import Data.Function (on)
@ -80,15 +85,15 @@ flagSpecFlag (_, flag, _) = flag
-- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`)
pprDynFlags :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags
-> SDoc
-> O.SDoc
pprDynFlags show_all dflags =
vcat
[ text "GHCi-specific dynamic flag settings:" $$
nest 2 (vcat (map (setting opt) ghciFlags))
, text "other dynamic, non-language, flag settings:" $$
nest 2 (vcat (map (setting opt) others))
, text "warning settings:" $$
nest 2 (vcat (map (setting wopt) DynFlags.fWarningFlags))
O.vcat
[ O.text "GHCi-specific dynamic flag settings:" O.$$
O.nest 2 (O.vcat (map (setting opt) ghciFlags))
, O.text "other dynamic, non-language, flag settings:" O.$$
O.nest 2 (O.vcat (map (setting opt) others))
, O.text "warning settings:" O.$$
O.nest 2 (O.vcat (map (setting wopt) DynFlags.fWarningFlags))
]
where
@ -98,9 +103,9 @@ pprDynFlags show_all dflags =
opt = dopt
#endif
setting test flag
| quiet = empty
| is_on = fstr name
| otherwise = fnostr name
| quiet = O.empty :: O.SDoc
| is_on = fstr name :: O.SDoc
| otherwise = fnostr name :: O.SDoc
where
name = flagSpecName flag
f = flagSpecFlag flag
@ -109,9 +114,9 @@ pprDynFlags show_all dflags =
default_dflags = defaultDynFlags (settings dflags)
fstr str = text "-f" <> text str
fnostr str = text "-fno-" <> text str
fstr, fnostr :: String -> O.SDoc
fstr str = O.text "-f" O.<> O.text str
fnostr str = O.text "-fno-" O.<> O.text str
(ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags
@ -129,22 +134,22 @@ flgs3 = [Opt_PrintBindResult, Opt_BreakOnException, Opt_BreakOnError, Opt_PrintE
-- `ghc-bin`)
pprLanguages :: Bool -- ^ Whether to include flags which are on by default
-> DynFlags
-> SDoc
-> O.SDoc
pprLanguages show_all dflags =
vcat
[text "base language is: " <>
O.vcat
[O.text "base language is: " O.<>
case language dflags of
Nothing -> text "Haskell2010"
Just Haskell98 -> text "Haskell98"
Just Haskell2010 -> text "Haskell2010", (if show_all
then text "all active language options:"
else text "with the following modifiers:") $$
nest 2 (vcat (map (setting xopt) DynFlags.xFlags))]
Nothing -> O.text "Haskell2010"
Just Haskell98 -> O.text "Haskell98"
Just Haskell2010 -> O.text "Haskell2010", (if show_all
then O.text "all active language options:"
else O.text "with the following modifiers:") O.$$
O.nest 2 (O.vcat (map (setting xopt) DynFlags.xFlags))]
where
setting test flag
| quiet = empty
| is_on = text "-X" <> text name
| otherwise = text "-XNo" <> text name
| quiet = O.empty
| is_on = O.text "-X" O.<> O.text name
| otherwise = O.text "-XNo" O.<> O.text name
where
name = flagSpecName flag
f = flagSpecFlag flag
@ -196,13 +201,13 @@ setFlags ext = do
-- does not impose an arbitrary width limit on the output (in terms of number of columns). Instead,
-- it respsects the 'pprCols' field in the structure returned by 'getSessionDynFlags', and thus
-- gives a configurable width of output.
doc :: GhcMonad m => SDoc -> m String
doc :: GhcMonad m => O.SDoc -> m String
doc sdoc = do
flags <- getSessionDynFlags
unqual <- getPrintUnqual
let style = mkUserStyle unqual AllTheWay
let style = O.mkUserStyle unqual O.AllTheWay
let cols = pprCols flags
d = runSDoc sdoc (initSDocContext flags style)
d = O.runSDoc sdoc (O.initSDocContext flags style)
return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d
where
@ -298,7 +303,7 @@ evalDeclarations decl = do
names <- runDecls decl
cleanUpDuplicateInstances
flags <- getSessionDynFlags
return $ map (replace ":Interactive." "" . showPpr flags) names
return $ map (replace ":Interactive." "" . O.showPpr flags) names
cleanUpDuplicateInstances :: GhcMonad m => m ()
cleanUpDuplicateInstances = modifySession $ \hscEnv ->
@ -326,7 +331,7 @@ getType :: GhcMonad m => String -> m String
getType expr = do
result <- exprType expr
flags <- getSessionDynFlags
let typeStr = showSDocUnqual flags $ ppr result
let typeStr = O.showSDocUnqual flags $ O.ppr result
return typeStr
-- | A wrapper around @getInfo@. Return info about each name in the string.
@ -363,16 +368,16 @@ getDescription str = do
#if MIN_VERSION_ghc(7,8,0)
printInfo (thing, fixity, classInstances, famInstances) =
pprTyThingInContextLoc thing $$
showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances) $$
vcat (map GHC.pprFamInst famInstances)
pprTyThingInContextLoc thing O.$$
showFixity thing fixity O.$$
O.vcat (map GHC.pprInstance classInstances) O.$$
O.vcat (map GHC.pprFamInst famInstances)
#else
printInfo (thing, fixity, classInstances) =
pprTyThingInContextLoc False thing $$ showFixity thing fixity $$
vcat (map GHC.pprInstance classInstances)
pprTyThingInContextLoc False thing O.$$ showFixity thing fixity O.$$
O.vcat (map GHC.pprInstance classInstances)
#endif
showFixity thing fixity =
if fixity == GHC.defaultFixity
then empty
else ppr fixity <+> pprInfixName (getName thing)
then O.empty
else O.ppr fixity O.<+> pprInfixName (getName thing)

14
src/IHaskell/Flags.hs
View File

@ -11,7 +11,13 @@ module IHaskell.Flags (
help,
) where
import ClassyPrelude
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import Data.List (findIndex)
@ -63,7 +69,7 @@ parseFlags flags =
Nothing ->
-- Treat no mode as 'console'.
if "--help" `elem` flags
then Left $ pack (showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs)
then Left $ showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs
else process ihaskellArgs flags
Just 0 -> process ihaskellArgs flags
@ -139,13 +145,13 @@ convert = mode "convert" (Args ConvertLhs []) description unnamedArg convertFlag
consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev)
storeFormat constructor str (Args mode prev) =
case toLower str of
case T.toLower (T.pack str) of
"lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev
"ipynb" -> Right $ Args mode $ constructor IpynbFile : prev
_ -> Left $ "Unknown format requested: " ++ str
storeLhs str previousArgs =
case toLower str of
case T.toLower (T.pack str) of
"bird" -> success lhsStyleBird
"tex" -> success lhsStyleTex
_ -> Left $ "Unknown lhs style: " ++ str

140
src/IHaskell/IPython.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}
{-# LANGUAGE DoAndIfThenElse #-}
-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and
@ -15,18 +14,21 @@ module IHaskell.IPython (
defaultKernelSpecOptions,
) where
import ClassyPrelude
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent (threadDelay)
import Prelude (read, reads, init)
import Shelly hiding (find, trace, path, (</>))
import System.Argv0
import System.Directory
import qualified Shelly as SH
import qualified Filesystem.Path.CurrentOS as FS
import qualified System.IO as IO
import Data.List.Utils (split)
import Data.String.Utils (rstrip, endswith, strip, replace)
import Text.Printf
import qualified Data.Text as T
import Data.Maybe (fromJust)
import System.Exit (exitFailure)
import Data.Aeson (toJSON)
import Data.Aeson.Encode (encodeToTextBuilder)
@ -34,7 +36,6 @@ import Data.Text.Lazy.Builder (toLazyText)
import qualified System.IO.Strict as StrictIO
import qualified Paths_ihaskell as Paths
import qualified Codec.Archive.Tar as Tar
import qualified GHC.Paths
import IHaskell.Types
@ -64,72 +65,75 @@ kernelArgs = ["--kernel", kernelName]
-- | Run the IPython command with any arguments. The kernel is set to IHaskell.
ipython :: Bool -- ^ Whether to suppress output.
-> [Text] -- ^ IPython command line arguments.
-> Sh String -- ^ IPython output.
-> SH.Sh String -- ^ IPython output.
ipython suppress args = do
liftIO $ installHandler keyboardSignal (CatchOnce $ return ()) Nothing
-- We have this because using `run` does not let us use stdin.
runHandles "ipython" args handles doNothing
SH.runHandles "ipython" args handles doNothing
where
handles = [InHandle Inherit, outHandle suppress, errorHandle suppress]
outHandle True = OutHandle CreatePipe
outHandle False = OutHandle Inherit
errorHandle True = ErrorHandle CreatePipe
errorHandle False = ErrorHandle Inherit
handles = [SH.InHandle SH.Inherit, outHandle suppress, errorHandle suppress]
outHandle True = SH.OutHandle SH.CreatePipe
outHandle False = SH.OutHandle SH.Inherit
errorHandle True = SH.ErrorHandle SH.CreatePipe
errorHandle False = SH.ErrorHandle SH.Inherit
doNothing _ stdout _ = if suppress
then liftIO $ StrictIO.hGetContents stdout
else return ""
-- | Run while suppressing all output.
quietRun path args = runHandles path args handles nothing
quietRun path args = SH.runHandles path args handles nothing
where
handles = [InHandle Inherit, OutHandle CreatePipe, ErrorHandle CreatePipe]
handles = [SH.InHandle SH.Inherit, SH.OutHandle SH.CreatePipe, SH.ErrorHandle SH.CreatePipe]
nothing _ _ _ = return ()
fp :: FS.FilePath -> FilePath
fp = T.unpack . SH.toTextIgnore
-- | Create the directory and return it.
ensure :: Sh FilePath -> Sh FilePath
ensure :: SH.Sh FS.FilePath -> SH.Sh FS.FilePath
ensure getDir = do
dir <- getDir
mkdir_p dir
SH.mkdir_p dir
return dir
-- | Return the data directory for IHaskell.
ihaskellDir :: Sh FilePath
ihaskellDir :: SH.Sh FilePath
ihaskellDir = do
home <- maybe (error "$HOME not defined.") fromText <$> get_env "HOME"
ensure $ return (home </> ".ihaskell")
home <- maybe (error "$HOME not defined.") FS.fromText <$> SH.get_env "HOME"
fp <$> ensure (return (home SH.</> ".ihaskell"))
ipythonDir :: Sh FilePath
ipythonDir = ensure $ (</> "ipython") <$> ihaskellDir
ipythonDir :: SH.Sh FS.FilePath
ipythonDir = ensure $ (SH.</> "ipython") <$> ihaskellDir
notebookDir :: Sh FilePath
notebookDir = ensure $ (</> "notebooks") <$> ihaskellDir
notebookDir :: SH.Sh FS.FilePath
notebookDir = ensure $ (SH.</> "notebooks") <$> ihaskellDir
getIHaskellDir :: IO String
getIHaskellDir = shelly $ fpToString <$> ihaskellDir
getIHaskellDir = SH.shelly ihaskellDir
defaultConfFile :: IO (Maybe String)
defaultConfFile = shelly $ do
filename <- (</> "rc.hs") <$> ihaskellDir
exists <- test_f filename
defaultConfFile = fmap (fmap fp) . SH.shelly $ do
filename <- (SH.</> "rc.hs") <$> ihaskellDir
exists <- SH.test_f filename
return $ if exists
then Just $ fpToString filename
then Just filename
else Nothing
replaceIPythonKernelspec :: KernelSpecOptions -> IO ()
replaceIPythonKernelspec kernelSpecOpts = shelly $ do
replaceIPythonKernelspec kernelSpecOpts = SH.shelly $ do
verifyIPythonVersion
installKernelspec True kernelSpecOpts
-- | Verify that a proper version of IPython is installed and accessible.
verifyIPythonVersion :: Sh ()
verifyIPythonVersion :: SH.Sh ()
verifyIPythonVersion = do
pathMay <- which "ipython"
pathMay <- SH.which "ipython"
case pathMay of
Nothing -> badIPython "No IPython detected -- install IPython 3.0+ before using IHaskell."
Just path -> do
output <- unpack <$> silently (run path ["--version"])
output <- T.unpack <$> SH.silently (SH.run path ["--version"])
case parseVersion output of
Just (3:_) -> return ()
Just (2:_) -> oldIPython
@ -138,15 +142,15 @@ verifyIPythonVersion = do
_ -> badIPython "Detected IPython, but could not parse version number."
where
badIPython :: Text -> Sh ()
badIPython :: Text -> SH.Sh ()
badIPython message = liftIO $ do
hPutStrLn stderr message
IO.hPutStrLn IO.stderr (T.unpack message)
exitFailure
oldIPython = badIPython "Detected old version of IPython. IHaskell requires 3.0.0 or up."
-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh ()
installKernelspec replace opts = void $ do
ihaskellPath <- getIHaskellPath
confFile <- liftIO $ kernelSpecConfFile opts
@ -167,63 +171,57 @@ installKernelspec replace opts = void $ do
-- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
-- shell out to IPython to install this kernelspec directory.
withTmpDir $ \tmp -> do
let kernelDir = tmp </> kernelName
let filename = kernelDir </> "kernel.json"
SH.withTmpDir $ \tmp -> do
let kernelDir = tmp SH.</> kernelName
let filename = kernelDir SH.</> "kernel.json"
mkdir_p kernelDir
writefile filename $ toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec
SH.mkdir_p kernelDir
SH.writefile filename $ LT.toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec
let files = ["kernel.js", "logo-64x64.png"]
forM_ files $ \file -> do
src <- liftIO $ Paths.getDataFileName $ "html/" ++ file
cp (fpFromString src) (tmp </> kernelName </> fpFromString file)
SH.cp (FS.fromText $ T.pack src) (tmp SH.</> kernelName SH.</> file)
Just ipython <- which "ipython"
Just ipython <- SH.which "ipython"
let replaceFlag = ["--replace" | replace]
cmd = ["kernelspec", "install", "--user", fpToText kernelDir] ++ replaceFlag
silently $ run ipython cmd
cmd = ["kernelspec", "install", "--user", kernelDir] ++ replaceFlag
SH.silently $ SH.run ipython (map SH.toTextIgnore cmd)
kernelSpecCreated :: Sh Bool
kernelSpecCreated :: SH.Sh Bool
kernelSpecCreated = do
Just ipython <- which "ipython"
out <- silently $ run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ lines out
Just ipython <- SH.which "ipython"
out <- SH.silently $ SH.run ipython ["kernelspec", "list"]
let kernelspecs = map T.strip $ T.lines out
return $ kernelName `elem` kernelspecs
-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
subHome :: String -> IO String
subHome path = shelly $ do
home <- unpack <$> fromMaybe "~" <$> get_env "HOME"
subHome path = SH.shelly $ do
home <- T.unpack <$> fromMaybe "~" <$> SH.get_env "HOME"
return $ replace "~" home path
-- | Get the path to an executable. If it doensn't exist, fail with an error message complaining
-- about it.
path :: Text -> Sh FilePath
path :: Text -> SH.Sh FS.FilePath
path exe = do
path <- which $ fromText exe
path <- SH.which $ FS.fromText exe
case path of
Nothing -> do
putStrLn $ "Could not find `" ++ exe ++ "` executable."
fail $ "`" ++ unpack exe ++ "` not on $PATH."
liftIO $ putStrLn $ "Could not find `" ++ T.unpack exe ++ "` executable."
fail $ "`" ++ T.unpack exe ++ "` not on $PATH."
Just exePath -> return exePath
-- | Parse an IPython version string into a list of integers.
parseVersion :: String -> Maybe [Int]
parseVersion versionStr =
let versions = map read' $ split "." versionStr
let versions = map readMay $ split "." versionStr
parsed = all isJust versions
in if parsed
then Just $ map fromJust versions
else Nothing
where
read' :: String -> Maybe Int
read' x =
case reads x of
[(n, _)] -> Just n
_ -> Nothing
-- | Get the absolute path to this IHaskell executable.
getIHaskellPath :: Sh String
getIHaskellPath :: SH.Sh String
getIHaskellPath = do
-- Get the absolute filepath to the argument.
f <- liftIO getArgv0
@ -236,17 +234,17 @@ getIHaskellPath = do
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
if FS.filename f == f
then do
ihaskellPath <- which "ihaskell"
ihaskellPath <- SH.which "ihaskell"
case ihaskellPath of
Nothing -> error "ihaskell not on $PATH and not referenced relative to directory."
Just path -> return $ FS.encodeString path
else do
-- If it's actually a relative path, make it absolute.
cd <- liftIO getCurrentDirectory
return $ FS.encodeString $ FS.decodeString cd FS.</> f
return $ FS.encodeString $ FS.decodeString cd SH.</> f
getSandboxPackageConf :: IO (Maybe String)
getSandboxPackageConf = shelly $ do
getSandboxPackageConf = SH.shelly $ do
myPath <- getIHaskellPath
let sandboxName = ".cabal-sandbox"
if not $ sandboxName `isInfixOf` myPath
@ -254,8 +252,8 @@ getSandboxPackageConf = shelly $ do
else do
let pieces = split "/" myPath
sandboxDir = intercalate "/" $ takeWhile (/= sandboxName) pieces ++ [sandboxName]
subdirs <- ls $ fpFromString sandboxDir
let confdirs = filter (endswith "packages.conf.d") $ map fpToString subdirs
subdirs <- map fp <$> SH.ls (FS.fromText $ T.pack sandboxDir)
let confdirs = filter (endswith ("packages.conf.d" :: String)) subdirs
case confdirs of
[] -> return Nothing
dir:_ ->

15
src/IHaskell/IPython/Stdin.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-}
{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
-- | This module provides a way in which the Haskell standard input may be forwarded to the IPython
-- frontend and thus allows the notebook to use the standard input.
@ -12,6 +12,7 @@
-- communication. For this, use @recordKernelProfile@ once the profile is known. Both this and
-- @recordParentHeader@ take a directory name where they can store this data.
--
--
-- Finally, the module must know what @execute_request@ message is currently being replied to (which
-- will request the input). Thus, every time the language kernel receives an @execute_request@
-- message, it should inform this module via @recordParentHeader@, so that the module may generate
@ -24,13 +25,19 @@
-- the host code.
module IHaskell.IPython.Stdin (fixStdin, recordParentHeader, recordKernelProfile) where
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import Control.Concurrent
import Control.Applicative ((<$>))
import Control.Concurrent.Chan
import Control.Monad
import GHC.IO.Handle
import GHC.IO.Handle.Types
import System.IO
import System.Posix.IO
import System.IO.Unsafe
import qualified Data.Map as Map
@ -48,7 +55,7 @@ stdinInterface = unsafePerformIO newEmptyMVar
fixStdin :: String -> IO ()
fixStdin dir = do
-- Initialize the stdin interface.
profile <- read <$> readFile (dir ++ "/.kernel-profile")
profile <- fromJust . readMay <$> readFile (dir ++ "/.kernel-profile")
interface <- serveStdin profile
putMVar stdinInterface interface
void $ forkIO $ stdinOnce dir
@ -87,7 +94,7 @@ getInputLine dir = do
-- Send a request for input.
uuid <- UUID.random
parentHeader <- read <$> readFile (dir ++ "/.last-req-header")
parentHeader <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header")
let header = MessageHeader
{ username = username parentHeader
, identifiers = identifiers parentHeader

16
src/IHaskell/Types.hs
View File

@ -30,11 +30,16 @@ module IHaskell.Types (
KernelSpec(..),
) where
import ClassyPrelude
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Char8 as Char
import Data.Serialize
import GHC.Generics
import Data.Map (Map, empty)
import Data.Aeson (Value)
import IHaskell.IPython.Kernel
@ -103,9 +108,6 @@ instance Monoid Display where
a `mappend` ManyDisplay b = ManyDisplay (a : b)
a `mappend` b = ManyDisplay [a, b]
instance Semigroup Display where
a <> b = a `mappend` b
-- | All state stored in the kernel between executions.
data KernelState =
KernelState
@ -128,7 +130,7 @@ defaultKernelState = KernelState
, useShowErrors = False
, useShowTypes = False
, usePager = True
, openComms = empty
, openComms = mempty
, kernelDebug = False
}
@ -177,4 +179,4 @@ data EvaluationResult =
-- pager.
, startComms :: [CommInfo] -- ^ Comms to start.
}
deriving Show
deriving Show

138
src/IHaskellPrelude.hs Normal file
View File

@ -0,0 +1,138 @@
module IHaskellPrelude (
module IHaskellPrelude,
module X,
-- Select reexports
Data.Typeable.Proxy,
Data.Typeable.Typeable,
Data.Typeable.cast,
GHC.Exts.IsString,
GHC.Exts.IsList,
System.IO.hPutStrLn,
System.IO.hPutStr,
System.IO.hPutChar,
System.IO.hPrint,
System.IO.stdout,
System.IO.stderr,
System.IO.stdin,
System.IO.getChar,
System.IO.getLine,
System.IO.writeFile,
System.IO.Handle,
System.IO.Strict.readFile,
System.IO.Strict.getContents,
System.IO.Strict.hGetContents,
Control.Exception.catch,
Control.Exception.SomeException,
Control.Applicative.Applicative(..),
Control.Applicative.ZipList(..),
(Control.Applicative.<$>),
Control.Concurrent.MVar.MVar,
Control.Concurrent.MVar.newMVar,
Control.Concurrent.MVar.newEmptyMVar,
Control.Concurrent.MVar.isEmptyMVar,
Control.Concurrent.MVar.readMVar,
Control.Concurrent.MVar.takeMVar,
Control.Concurrent.MVar.putMVar,
Control.Concurrent.MVar.modifyMVar,
Control.Concurrent.MVar.modifyMVar_,
Data.IORef.IORef,
Data.IORef.readIORef,
Data.IORef.writeIORef,
Data.IORef.modifyIORef',
Data.IORef.newIORef,
-- Miscellaneous names
Data.Map.Map,
GHC.IO.FilePath,
Data.Text.Text,
Data.ByteString.ByteString,
Text.Printf.printf,
Data.Function.on,
) where
import Prelude
import Data.Monoid as X
import Data.Tuple as X
import Control.Monad as X
import Data.Maybe as X
import Data.Either as X
import Control.Monad.IO.Class as X
import Data.Ord as X
import GHC.Show as X
import GHC.Enum as X
import GHC.Num as X
import GHC.Real as X
import GHC.Base as X hiding (Any)
import Data.List as X hiding (head, last, tail, init, transpose, subsequences, permutations,
foldl, foldl1, maximum, minimum, scanl, scanl1, scanr, scanr1, span, break,
mapAccumL, mapAccumR, dropWhileEnd, (!!), elemIndices,
elemIndex, findIndex, findIndices, zip5, zip6, zip7, zipWith5,
zipWith6, zipWith7, unzip5, unzip6, unzip6, delete, union, lookup,
intersect, insert, deleteBy, deleteFirstBy, unionBy,
intersectBy, group, groupBy, insertBy, maximumBy, minimumBy,
genericLength, genericDrop, genericTake, genericSplitAt,
genericIndex, genericReplicate, inits, tails)
import qualified Control.Applicative
import qualified Data.Typeable
import qualified Data.IORef
import qualified Data.Map
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Data.ByteString
import qualified Data.ByteString.Lazy
import qualified Data.Function
import qualified GHC.Exts
import qualified System.IO
import qualified System.IO.Strict
import qualified GHC.IO
import qualified Text.Printf
import qualified Control.Exception
import qualified Control.Concurrent.MVar
import qualified Data.List
import qualified Prelude as P
type LByteString = Data.ByteString.Lazy.ByteString
type LText = Data.Text.Lazy.Text
(headMay, tailMay, lastMay, initMay, maximumMay, minimumMay) =
(wrapEmpty head, wrapEmpty tail, wrapEmpty last, wrapEmpty init, wrapEmpty maximum, wrapEmpty minimum)
where
wrapEmpty :: ([a] -> b) -> [a] -> Maybe b
wrapEmpty _ [] = Nothing
wrapEmpty f xs = Just (f xs)
maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
maximumByMay _ [] = Nothing
maximumByMay f xs = Just (Data.List.maximumBy f xs)
minimumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a
minimumByMay _ [] = Nothing
minimumByMay f xs = Just (Data.List.minimumBy f xs)
readMay :: Read a => String -> Maybe a
readMay = fmap fst . headMay . reads
putStrLn :: (MonadIO m) => String -> m ()
putStrLn = liftIO . P.putStrLn
putStr :: (MonadIO m) => String -> m ()
putStr = liftIO . P.putStr
putChar:: MonadIO m => Char -> m ()
putChar = liftIO . P.putChar
print :: (MonadIO m, Show a) => a -> m ()
print = liftIO . P.print

49
src/Main.hs
View File

@ -4,22 +4,24 @@
-- Chans to communicate with the ZeroMQ sockets.
module Main (main) where
-- Prelude imports.
import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
import Prelude (last, read)
import IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as CBS
-- Standard library imports.
import Control.Concurrent (threadDelay)
import Control.Concurrent.Chan
import Data.Aeson
import Data.Text (strip)
import System.Directory
import System.Exit (exitSuccess)
import Text.Printf
import System.Environment (getArgs)
import System.Posix.Signals
import qualified Data.Map as Map
import Data.String.Here (hereFile)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
-- IHaskell imports.
import IHaskell.Convert (convert)
@ -33,7 +35,6 @@ import IHaskell.IPython
import IHaskell.Types
import IHaskell.IPython.ZeroMQ
import IHaskell.IPython.Types
import qualified Data.ByteString.Char8 as Chars
import qualified IHaskell.IPython.Message.UUID as UUID
import qualified IHaskell.IPython.Stdin as Stdin
@ -42,7 +43,7 @@ import GHC hiding (extensions, language)
-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
ghcVersionInts :: [Int]
ghcVersionInts = map read . words . map dotToSpace $ VERSION_ghc
ghcVersionInts = map (fromJust . readMay) . words . map dotToSpace $ VERSION_ghc
where
dotToSpace '.' = ' '
dotToSpace x = x
@ -52,18 +53,18 @@ ihaskellCSS = [hereFile|html/custom.css|]
consoleBanner :: Text
consoleBanner =
"Welcome to IHaskell! Run `IHaskell --help` for more information.\n" ++
"Welcome to IHaskell! Run `IHaskell --help` for more information.\n" <>
"Enter `:help` to learn more about IHaskell built-ins."
main :: IO ()
main = do
args <- parseFlags <$> map unpack <$> getArgs
args <- parseFlags <$> getArgs
case args of
Left errorMessage -> hPutStrLn stderr errorMessage
Right args -> ihaskell args
ihaskell :: Args -> IO ()
ihaskell (Args (ShowHelp help) _) = putStrLn $ pack help
ihaskell (Args (ShowHelp help) _) = putStrLn help
ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args
ihaskell (Args InstallKernelSpec args) = showingHelp InstallKernelSpec args $ do
let kernelSpecOpts = parseKernelArgs args
@ -76,7 +77,7 @@ showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
showingHelp mode flags act =
case find (== Help) flags of
Just _ ->
putStrLn $ pack $ help mode
putStrLn $ help mode
Nothing ->
act
@ -101,7 +102,7 @@ runKernel kernelOpts profileSrc = do
libdir = kernelSpecGhcLibdir kernelOpts
-- Parse the profile file.
Just profile <- liftM decode . readFile . fpFromString $ profileSrc
Just profile <- liftM decode $ LBS.readFile profileSrc
-- Necessary for `getLine` and their ilk to work.
dir <- getIHaskellDir
@ -131,7 +132,7 @@ runKernel kernelOpts profileSrc = do
confFile <- liftIO $ kernelSpecConfFile kernelOpts
case confFile of
Just filename -> liftIO (readFile $ fpFromString filename) >>= evaluator
Just filename -> liftIO (readFile filename) >>= evaluator
Nothing -> return ()
forever $ do
@ -247,12 +248,14 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
header <- dupHeader replyHeader DisplayDataMessage
send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg
convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
convertSvgToHtml x = x
makeSvgImg base64data = unpack $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"
makeSvgImg :: Base64 -> String
makeSvgImg base64data = T.unpack $ "<img src=\"data:image/svg+xml;base64," <> base64data <> "\"/>"
prependCss (DisplayData MimeHtml html) =
DisplayData MimeHtml $concat ["<style>", pack ihaskellCSS, "</style>", html]
DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", html]
prependCss x = x
startComm :: CommInfo -> IO ()
@ -304,10 +307,10 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
let execCount = getExecutionCounter state
-- Let all frontends know the execution count and code that's about to run
inputHeader <- liftIO $ dupHeader replyHeader InputMessage
send $ PublishInput inputHeader (unpack code) execCount
send $ PublishInput inputHeader (T.unpack code) execCount
-- Run code and publish to the frontend as we go.
updatedState <- evaluate state (unpack code) publish
updatedState <- evaluate state (T.unpack code) publish
-- Notify the frontend that we're done computing.
idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
@ -329,15 +332,15 @@ replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
replyTo _ req@CompleteRequest{} replyHeader state = do
let code = getCode req
pos = getCursorPos req
(matchedText, completions) <- complete (unpack code) pos
(matchedText, completions) <- complete (T.unpack code) pos
let start = pos - length matchedText
end = pos
reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
reply = CompleteReply replyHeader (map T.pack completions) start end Map.empty True
return (state, reply)
replyTo _ req@InspectRequest{} replyHeader state = do
result <- inspect (unpack $ inspectCode req) (inspectCursorPos req)
result <- inspect (T.unpack $ inspectCode req) (inspectCursorPos req)
let reply =
case result of
Just (Display datas) -> InspectReply
@ -365,7 +368,7 @@ handleComm replier kernelState req replyHeader = do
communicate value = do
head <- dupHeader replyHeader CommDataMessage
replier $ CommData head uuid value
case lookup uuid widgets of
case Map.lookup uuid widgets of
Nothing -> fail $ "no widget with uuid " ++ show uuid
Just (Widget widget) ->
case msgType $ header req of