diff --git a/ihaskell.cabal b/ihaskell.cabal index e486a7fc..838d73be 100644 --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -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.*, diff --git a/src/IHaskell/BrokenPackages.hs b/src/IHaskell/BrokenPackages.hs index 1eb6cb63..4a1a4664 100644 --- a/src/IHaskell/BrokenPackages.hs +++ b/src/IHaskell/BrokenPackages.hs @@ -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 diff --git a/src/IHaskell/Convert.hs b/src/IHaskell/Convert.hs index ab74b1b5..75334697 100644 --- a/src/IHaskell/Convert.hs +++ b/src/IHaskell/Convert.hs @@ -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) diff --git a/src/IHaskell/Convert/Args.hs b/src/IHaskell/Convert/Args.hs index eb58a7a5..0529ca4c 100644 --- a/src/IHaskell/Convert/Args.hs +++ b/src/IHaskell/Convert/Args.hs @@ -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 diff --git a/src/IHaskell/Convert/IpynbToLhs.hs b/src/IHaskell/Convert/IpynbToLhs.hs index e390d109..103456f0 100644 --- a/src/IHaskell/Convert/IpynbToLhs.hs +++ b/src/IHaskell/Convert/IpynbToLhs.hs @@ -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 diff --git a/src/IHaskell/Convert/LhsToIpynb.hs b/src/IHaskell/Convert/LhsToIpynb.hs index dde1d66f..5ebca74c 100644 --- a/src/IHaskell/Convert/LhsToIpynb.hs +++ b/src/IHaskell/Convert/LhsToIpynb.hs @@ -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 _ [] = [] diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs index 67d1bc53..2f5e7f70 100644 --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -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 diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs index 57b53cbd..19417c8b 100644 --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -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. diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs index 895474a6..545f44db 100644 --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -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. diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs index 1ac55f3b..7308907e 100644 --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -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 "
%s
" +div' :: String -> String -> String +div' = printf "
%s
" span :: String -> String -> String span = printf "%s" diff --git a/src/IHaskell/Eval/Info.hs b/src/IHaskell/Eval/Info.hs index 499170a8..dcb87889 100644 --- a/src/IHaskell/Eval/Info.hs +++ b/src/IHaskell/Eval/Info.hs @@ -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) diff --git a/src/IHaskell/Eval/Inspect.hs b/src/IHaskell/Eval/Inspect.hs index d21f2562..b0fd4962 100644 --- a/src/IHaskell/Eval/Inspect.hs +++ b/src/IHaskell/Eval/Inspect.hs @@ -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) diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs index 53700df9..599ec2de 100644 --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -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 diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs index c6efcabc..cf03bb49 100644 --- a/src/IHaskell/Eval/ParseShell.hs +++ b/src/IHaskell/Eval/ParseShell.hs @@ -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") diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs index c408ff8b..23c21f78 100644 --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -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) diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs index 54baebf0..13976fb4 100644 --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -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) diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs index 68cb5208..96b52c51 100644 --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -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 diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs index dbb17276..134409fd 100644 --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -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:_ -> diff --git a/src/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs index ac9137ca..da4757a3 100644 --- a/src/IHaskell/IPython/Stdin.hs +++ b/src/IHaskell/IPython/Stdin.hs @@ -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 diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs index ce8340bc..63a1e208 100644 --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -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 \ No newline at end of file + deriving Show diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs new file mode 100644 index 00000000..79e1fffd --- /dev/null +++ b/src/IHaskellPrelude.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index c7f61df3..db69043f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 $ "" + + makeSvgImg :: Base64 -> String + makeSvgImg base64data = T.unpack $ " base64data <> "\"/>" prependCss (DisplayData MimeHtml html) = - DisplayData MimeHtml $concat ["", html] + DisplayData MimeHtml $ mconcat ["", 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