diff --git a/Hspec.hs b/Hspec.hs
--- a/Hspec.hs
+++ b/Hspec.hs
@@ -1,39 +1,53 @@
{-# LANGUAGE QuasiQuotes, OverloadedStrings, ExtendedDefaultRules, CPP #-}
-- Keep all the language pragmas here so it can be compiled separately.
module Main where
-import Prelude
-import GHC hiding (Qualified)
-import GHC.Paths
-import Data.IORef
-import Control.Monad
-import Control.Monad.IO.Class ( MonadIO, liftIO )
-import Data.List
-import System.Directory
-import Shelly (Sh, shelly, cmd, (), toTextIgnore, cd, withTmpDir, mkdir_p,
- touchfile)
+
+import Prelude
+import qualified Data.Text as T
+import GHC hiding (Qualified)
+import GHC.Paths
+import Data.IORef
+import Control.Monad
+import Control.Monad.IO.Class (MonadIO, liftIO)
+import Data.List
+import System.Directory
+import Shelly (Sh, shelly, cmd, (), toTextIgnore, cd, withTmpDir, mkdir_p, touchfile,
+ fromText)
+import qualified Data.Text as T
import qualified Shelly
-import Control.Applicative ((<$>))
-import Filesystem.Path.CurrentOS (encodeString)
-import System.SetEnv (setEnv)
-import Data.String.Here
-import Data.String.Utils (strip, replace)
-import Data.Monoid
+import Control.Applicative ((<$>))
+import System.SetEnv (setEnv)
+import Data.String.Here
+import Data.Monoid
-import IHaskell.Eval.Parser
-import IHaskell.Types
-import IHaskell.IPython
-import IHaskell.Eval.Evaluate as Eval hiding (liftIO)
+import IHaskell.Eval.Parser
+import IHaskell.Types
+import IHaskell.IPython
+import IHaskell.Eval.Evaluate as Eval hiding (liftIO)
import qualified IHaskell.Eval.Evaluate as Eval (liftIO)
-import IHaskell.Eval.Completion
-import IHaskell.Eval.ParseShell
+import IHaskell.Eval.Completion
+import IHaskell.Eval.ParseShell
-import Debug.Trace
+import Debug.Trace
-import Test.Hspec
-import Test.Hspec.HUnit
-import Test.HUnit (assertBool, assertFailure)
+import Test.Hspec
+import Test.Hspec.HUnit
+import Test.HUnit (assertBool, assertFailure)
+lstrip :: String -> String
+lstrip = dropWhile (`elem` (" \t\r\n" :: String))
+
+rstrip :: String -> String
+rstrip = reverse . lstrip . reverse
+
+strip :: String -> String
+strip = rstrip . lstrip
+
+replace :: String -> String -> String -> String
+replace needle replacement haystack =
+ T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack)
+
traceShowId x = traceShow x x
doGhc = runGhc (Just libdir)
@@ -166,7 +180,7 @@
do cd dirPath
mapM_ mkdir_p dirs
mapM_ touchfile files
- liftIO $ doGhc $ wrap (encodeString dirPath) (action dirPath)
+ liftIO $ doGhc $ wrap (T.unpack $ toTextIgnore dirPath) (action dirPath)
where cdEvent path = liftIO $ setCurrentDirectory path --Eval.evaluate defaultKernelState (":! cd " ++ path) noPublish
wrap :: FilePath -> Interpreter a -> Interpreter a
wrap path action =
@@ -241,8 +255,8 @@
"import Prel*" `completionHas` ["Prelude"]
it "properly completes haskell file paths on :load directive" $
- let loading xs = ":load " ++ encodeString xs
- paths = map encodeString
+ let loading xs = ":load " ++ T.unpack (toTextIgnore xs)
+ paths = map (T.unpack . toTextIgnore)
in do
loading ("dir" "file*") `shouldHaveCompletionsInDirectory` paths ["dir" "file2.hs",
"dir" "file2.lhs"]
@@ -258,7 +272,7 @@
, "./" "file1.lhs"]
it "provides path completions on empty shell cmds " $
- ":! cd *" `shouldHaveCompletionsInDirectory` map encodeString ["" "dir/"
+ ":! cd *" `shouldHaveCompletionsInDirectory` map (T.unpack . toTextIgnore) ["" "dir/"
, "" "file1.hs"
, "" "file1.lhs"]
@@ -268,7 +282,7 @@
result <- action
setHomeEvent $ Shelly.fromText home
return result
- setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
+ setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path)
it "correctly interprets ~ as the environment HOME variable" $
let shouldHaveCompletions :: String -> [String] -> IO ()
@@ -289,7 +303,7 @@
matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string)
matchText `shouldBe` expected
- setHomeEvent path = liftIO $ setEnv "HOME" (encodeString path)
+ setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path)
it "generates the correct matchingText on `:! cd ~/*` " $
do ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String)
diff --git a/ihaskell.cabal b/ihaskell.cabal
--- a/ihaskell.cabal
+++ b/ihaskell.cabal
@@ -7,7 +7,7 @@
-- PVP summary: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.6.3.0
+version: 0.6.4.0
-- A short (one-line) description of the package.
synopsis: A Haskell backend kernel for the IPython project.
@@ -60,8 +60,6 @@
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
- classy-prelude >=0.10.5 && <0.11,
- mono-traversable >=0.6,
cmdargs >=0.10,
containers >=0.5,
directory -any,
@@ -73,11 +71,8 @@
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,
process >=1.1,
@@ -87,8 +82,6 @@
stm -any,
strict >=0.3,
system-argv0 -any,
- system-filepath -any,
- tar -any,
text >=0.11,
transformers -any,
unix >= 2.6,
@@ -120,35 +113,50 @@
IHaskell.Types
IHaskell.BrokenPackages
Paths_ihaskell
--- other-modules:
--- Paths_ihaskell
+ other-modules:
+ IHaskellPrelude
+ StringUtils
+ 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: main
+ other-modules:
+ IHaskellPrelude
ghc-options: -threaded
-- Other library packages from which modules are imported.
default-language: Haskell2010
build-depends:
+ ihaskell -any,
base >=4.6 && < 4.9,
- aeson >=0.6 && < 0.9,
+ text >=0.11,
+ transformers -any,
+ ghc >=7.6 || < 7.11,
+ here ==1.2.*,
+ aeson >=0.7 && < 0.9,
bytestring >=0.10,
- cereal >=0.3,
- classy-prelude >=0.10.5 && <0.11,
- mono-traversable >=0.6,
containers >=0.5,
+ strict >=0.3,
+ unix >= 2.6,
directory -any,
- ghc >=7.6 && < 7.11,
- ihaskell -any,
- MissingH >=1.2,
- here ==1.2.*,
- text -any,
- ipython-kernel >= 0.6.1,
- unix >= 2.6
+ 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
@@ -161,8 +169,6 @@
base64-bytestring >=1.0,
bytestring >=0.10,
cereal >=0.3,
- classy-prelude >=0.10.5 && <0.11,
- mono-traversable >=0.6,
cmdargs >=0.10,
containers >=0.5,
directory -any,
@@ -176,7 +182,6 @@
haskell-src-exts ==1.16.*,
hspec -any,
HUnit -any,
- MissingH >=1.2,
mtl >=2.1,
parsec -any,
process >=1.1,
@@ -186,8 +191,6 @@
stm -any,
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/main/IHaskellPrelude.hs b/main/IHaskellPrelude.hs
new file mode 100644
--- /dev/null
+++ b/main/IHaskellPrelude.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE CPP #-}
+module IHaskellPrelude (
+ module IHaskellPrelude,
+ module X,
+
+ -- Select reexports
+ Data.Typeable.Typeable,
+ Data.Typeable.cast,
+
+#if MIN_VERSION_ghc(7,8,0)
+ Data.Typeable.Proxy,
+
+ GHC.Exts.IsString,
+ GHC.Exts.IsList,
+#endif
+
+ 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.Err as X hiding (absentErr)
+#if MIN_VERSION_ghc(7,10,0)
+import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>))
+#else
+import GHC.Base as X hiding (Any)
+#endif
+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/main/Main.hs b/main/Main.hs
new file mode 100644
--- /dev/null
+++ b/main/Main.hs
@@ -0,0 +1,382 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, QuasiQuotes #-}
+
+-- | Description : Argument parsing and basic messaging loop, using Haskell
+-- Chans to communicate with the ZeroMQ sockets.
+module Main (main) 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
+
+-- Standard library imports.
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Chan
+import Data.Aeson
+import System.Directory
+import System.Exit (exitSuccess)
+import System.Environment (getArgs)
+import System.Posix.Signals
+import qualified Data.Map as Map
+import Data.String.Here (hereFile)
+import qualified Data.Text.Encoding as E
+
+-- IHaskell imports.
+import IHaskell.Convert (convert)
+import IHaskell.Eval.Completion (complete)
+import IHaskell.Eval.Inspect (inspect)
+import IHaskell.Eval.Evaluate
+import IHaskell.Display
+import IHaskell.Eval.Info
+import IHaskell.Flags
+import IHaskell.IPython
+import IHaskell.Types
+import IHaskell.IPython.ZeroMQ
+import IHaskell.IPython.Types
+import qualified IHaskell.IPython.Message.UUID as UUID
+import qualified IHaskell.IPython.Stdin as Stdin
+
+-- GHC API imports.
+import GHC hiding (extensions, language)
+
+-- | Compute the GHC API version number using the dist/build/autogen/cabal_macros.h
+ghcVersionInts :: [Int]
+ghcVersionInts = map (fromJust . readMay) . words . map dotToSpace $ VERSION_ghc
+ where
+ dotToSpace '.' = ' '
+ dotToSpace x = x
+
+ihaskellCSS :: String
+ihaskellCSS = [hereFile|html/custom.css|]
+
+consoleBanner :: Text
+consoleBanner =
+ "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 <$> getArgs
+ case args of
+ Left errorMessage -> hPutStrLn stderr errorMessage
+ Right args -> ihaskell args
+
+ihaskell :: Args -> IO ()
+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
+ replaceIPythonKernelspec kernelSpecOpts
+ihaskell (Args (Kernel (Just filename)) args) = do
+ let kernelSpecOpts = parseKernelArgs args
+ runKernel kernelSpecOpts filename
+
+showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
+showingHelp mode flags act =
+ case find (== Help) flags of
+ Just _ ->
+ putStrLn $ help mode
+ Nothing ->
+ act
+
+-- | Parse initialization information from the flags.
+parseKernelArgs :: [Argument] -> KernelSpecOptions
+parseKernelArgs = foldl' addFlag defaultKernelSpecOptions
+ where
+ addFlag kernelSpecOpts (ConfFile filename) =
+ kernelSpecOpts { kernelSpecConfFile = return (Just filename) }
+ addFlag kernelSpecOpts KernelDebug =
+ kernelSpecOpts { kernelSpecDebug = True }
+ addFlag kernelSpecOpts (GhcLibDir libdir) =
+ kernelSpecOpts { kernelSpecGhcLibdir = libdir }
+ addFlag kernelSpecOpts flag = error $ "Unknown flag" ++ show flag
+
+-- | Run the IHaskell language kernel.
+runKernel :: KernelSpecOptions -- ^ Various options from when the kernel was installed.
+ -> String -- ^ File with kernel profile JSON (ports, etc).
+ -> IO ()
+runKernel kernelOpts profileSrc = do
+ let debug = kernelSpecDebug kernelOpts
+ libdir = kernelSpecGhcLibdir kernelOpts
+
+ -- Parse the profile file.
+ Just profile <- liftM decode $ LBS.readFile profileSrc
+
+ -- Necessary for `getLine` and their ilk to work.
+ dir <- getIHaskellDir
+ Stdin.recordKernelProfile dir profile
+
+ -- Serve on all sockets and ports defined in the profile.
+ interface <- serveProfile profile debug
+
+ -- Create initial state in the directory the kernel *should* be in.
+ state <- initialKernelState
+ modifyMVar_ state $ \kernelState -> return $
+ kernelState { kernelDebug = debug }
+
+ -- Receive and reply to all messages on the shell socket.
+ interpret libdir True $ do
+ -- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
+ -- signal handlers for some reason (completely unknown to me).
+ liftIO ignoreCtrlC
+
+ -- Initialize the context by evaluating everything we got from the command line flags.
+ let noPublish _ = return ()
+ evaluator line = void $ do
+ -- Create a new state each time.
+ stateVar <- liftIO initialKernelState
+ state <- liftIO $ takeMVar stateVar
+ evaluate state line noPublish
+
+ confFile <- liftIO $ kernelSpecConfFile kernelOpts
+ case confFile of
+ Just filename -> liftIO (readFile filename) >>= evaluator
+ Nothing -> return ()
+
+ forever $ do
+ -- Read the request from the request channel.
+ request <- liftIO $ readChan $ shellRequestChannel interface
+
+ -- Create a header for the reply.
+ replyHeader <- createReplyHeader (header request)
+
+ -- We handle comm messages and normal ones separately. The normal ones are a standard
+ -- request/response style, while comms can be anything, and don't necessarily require a response.
+ if isCommMessage request
+ then liftIO $ do
+ oldState <- takeMVar state
+ let replier = writeChan (iopubChannel interface)
+ newState <- handleComm replier oldState request replyHeader
+ putMVar state newState
+ writeChan (shellReplyChannel interface) SendNothing
+ else do
+ -- Create the reply, possibly modifying kernel state.
+ oldState <- liftIO $ takeMVar state
+ (newState, reply) <- replyTo interface request replyHeader oldState
+ liftIO $ putMVar state newState
+
+ -- Write the reply to the reply channel.
+ liftIO $ writeChan (shellReplyChannel interface) reply
+
+ where
+ ignoreCtrlC =
+ installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.")
+ Nothing
+
+ isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]
+
+-- Initial kernel state.
+initialKernelState :: IO (MVar KernelState)
+initialKernelState = newMVar defaultKernelState
+
+-- | Duplicate a message header, giving it a new UUID and message type.
+dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
+dupHeader header messageType = do
+ uuid <- liftIO UUID.random
+
+ return header { messageId = uuid, msgType = messageType }
+
+-- | Create a new message header, given a parent message header.
+createReplyHeader :: MessageHeader -> Interpreter MessageHeader
+createReplyHeader parent = do
+ -- Generate a new message UUID.
+ newMessageId <- liftIO UUID.random
+ let repType = fromMaybe err (replyType $ msgType parent)
+ err = error $ "No reply for message " ++ show (msgType parent)
+
+ return
+ MessageHeader
+ { identifiers = identifiers parent
+ , parentHeader = Just parent
+ , metadata = Map.fromList []
+ , messageId = newMessageId
+ , sessionId = sessionId parent
+ , username = username parent
+ , msgType = repType
+ }
+
+-- | Compute a reply to a message.
+replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
+-- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
+-- kernel info reply is a static object (all info is hard coded into the representation of that
+-- message type).
+replyTo _ KernelInfoRequest{} replyHeader state =
+ return
+ (state, KernelInfoReply
+ { header = replyHeader
+ , language = "haskell"
+ , versionList = ghcVersionInts
+ })
+
+-- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
+-- let the frontend know shutdown is happening.
+replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
+ writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
+ exitSuccess
+
+-- Reply to an execution request. The reply itself does not require computation, but this causes
+-- messages to be sent to the IOPub socket with the output of the code in the execution request.
+replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
+ -- Convenience function to send a message to the IOPub socket.
+ let send msg = liftIO $ writeChan (iopubChannel interface) msg
+
+ -- Log things so that we can use stdin.
+ dir <- liftIO getIHaskellDir
+ liftIO $ Stdin.recordParentHeader dir $ header req
+
+ -- Notify the frontend that the kernel is busy computing. All the headers are copies of the reply
+ -- header with a different message type, because this preserves the session ID, parent header, and
+ -- other important information.
+ busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
+ send $ PublishStatus busyHeader Busy
+
+ -- Construct a function for publishing output as this is going. This function accepts a boolean
+ -- indicating whether this is the final output and the thing to display. Store the final outputs in
+ -- a list so that when we receive an updated non-final output, we can clear the entire output and
+ -- re-display with the updated output.
+ displayed <- liftIO $ newMVar []
+ updateNeeded <- liftIO $ newMVar False
+ pagerOutput <- liftIO $ newMVar []
+ let clearOutput = do
+ header <- dupHeader replyHeader ClearOutputMessage
+ send $ ClearOutput header True
+
+ sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
+ sendOutput (Display outs) = do
+ header <- dupHeader replyHeader DisplayDataMessage
+ send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
+
+ convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg
+ convertSvgToHtml x = x
+
+ makeSvgImg :: Base64 -> String
+ makeSvgImg base64data = T.unpack $ "![](\"data:image/svg+xml;base64,")
+ base64data <>
+ "\"/>"
+
+ prependCss (DisplayData MimeHtml html) =
+ DisplayData MimeHtml $ mconcat ["", html]
+ prependCss x = x
+
+ startComm :: CommInfo -> IO ()
+ startComm (CommInfo widget uuid target) = do
+ -- Send the actual comm open.
+ header <- dupHeader replyHeader CommOpenMessage
+ send $ CommOpen header target uuid (Object mempty)
+
+ -- Send anything else the widget requires.
+ let communicate value = do
+ head <- dupHeader replyHeader CommDataMessage
+ writeChan (iopubChannel interface) $ CommData head uuid value
+ open widget communicate
+
+ publish :: EvaluationResult -> IO ()
+ publish result = do
+ let final =
+ case result of
+ IntermediateResult{} -> False
+ FinalResult{} -> True
+ outs = outputs result
+
+ -- If necessary, clear all previous output and redraw.
+ clear <- readMVar updateNeeded
+ when clear $ do
+ clearOutput
+ disps <- readMVar displayed
+ mapM_ sendOutput $ reverse disps
+
+ -- Draw this message.
+ sendOutput outs
+
+ -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
+ -- clear it later by marking update needed as true.
+ modifyMVar_ updateNeeded (const $ return $ not final)
+ when final $ do
+ modifyMVar_ displayed (return . (outs :))
+
+ -- Start all comms that need to be started.
+ mapM_ startComm $ startComms result
+
+ -- If this has some pager output, store it for later.
+ let pager = pagerOut result
+ unless (null pager) $
+ if usePager state
+ then modifyMVar_ pagerOutput (return . (++ pager))
+ else sendOutput $ Display pager
+
+ 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 (T.unpack code) execCount
+
+ -- Run code and publish to the frontend as we go.
+ updatedState <- evaluate state (T.unpack code) publish
+
+ -- Notify the frontend that we're done computing.
+ idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
+ send $ PublishStatus idleHeader Idle
+
+ -- Take pager output if we're using the pager.
+ pager <- if usePager state
+ then liftIO $ readMVar pagerOutput
+ else return []
+ return
+ (updatedState, ExecuteReply
+ { header = replyHeader
+ , pagerOutput = pager
+ , executionCounter = execCount
+ , status = Ok
+ })
+
+
+replyTo _ req@CompleteRequest{} replyHeader state = do
+ let code = getCode req
+ pos = getCursorPos req
+ (matchedText, completions) <- complete (T.unpack code) pos
+
+ let start = pos - length matchedText
+ end = pos
+ reply = CompleteReply replyHeader (map T.pack completions) start end Map.empty True
+ return (state, reply)
+
+replyTo _ req@InspectRequest{} replyHeader state = do
+ result <- inspect (T.unpack $ inspectCode req) (inspectCursorPos req)
+ let reply =
+ case result of
+ Just (Display datas) -> InspectReply
+ { header = replyHeader
+ , inspectStatus = True
+ , inspectData = datas
+ }
+ _ -> InspectReply { header = replyHeader, inspectStatus = False, inspectData = [] }
+ return (state, reply)
+
+-- TODO: Implement history_reply.
+replyTo _ HistoryRequest{} replyHeader state = do
+ let reply = HistoryReply
+ { header = replyHeader
+ -- FIXME
+ , historyReply = []
+ }
+ return (state, reply)
+
+handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
+handleComm replier kernelState req replyHeader = do
+ let widgets = openComms kernelState
+ uuid = commUuid req
+ dat = commData req
+ communicate value = do
+ head <- dupHeader replyHeader CommDataMessage
+ replier $ CommData head uuid value
+ case Map.lookup uuid widgets of
+ Nothing -> fail $ "no widget with uuid " ++ show uuid
+ Just (Widget widget) ->
+ case msgType $ header req of
+ CommDataMessage -> do
+ comm widget dat communicate
+ return kernelState
+ CommCloseMessage -> do
+ close widget dat
+ return kernelState { openComms = Map.delete uuid widgets }
diff --git a/src/IHaskell/BrokenPackages.hs b/src/IHaskell/BrokenPackages.hs
--- a/src/IHaskell/BrokenPackages.hs
+++ b/src/IHaskell/BrokenPackages.hs
@@ -1,15 +1,18 @@
-{-# 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
import Control.Applicative hiding ((<|>), many)
-import Data.String.Utils (startswith)
-
import Shelly
data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] }
@@ -25,9 +28,9 @@
checkOut <- lastStderr
-- Get rid of extraneous things
- let rightStart str = startswith "There are problems" str ||
- startswith " dependency" str
- ghcPkgOutput = unlines . filter rightStart . lines $ unpack checkOut
+ let rightStart str = "There are problems" `isPrefixOf` str ||
+ " dependency" `isPrefixOf` str
+ 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
--- a/src/IHaskell/Convert.hs
+++ b/src/IHaskell/Convert.hs
@@ -1,5 +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)
diff --git a/src/IHaskell/Convert/Args.hs b/src/IHaskell/Convert/Args.hs
--- a/src/IHaskell/Convert/Args.hs
+++ b/src/IHaskell/Convert/Args.hs
@@ -1,6 +1,15 @@
+{-# 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 +26,7 @@
{ convertToIpynb :: f Bool
, convertInput :: f FilePath
, convertOutput :: f FilePath
- , convertLhsStyle :: f (LhsStyle T.Text)
+ , convertLhsStyle :: f (LhsStyle LT.Text)
, convertOverwriteFiles :: Bool
}
@@ -28,7 +37,7 @@
{ 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 +72,10 @@
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
--- 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
--- 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 @@
| 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 $
- [ "cell_type" .= String "markdown"
- , "metadata" .= object ["hidden" .= Bool False]
- , "source" .= arrayFromTxt txt
- ]
+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 @@
]
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 @@
(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
--- a/src/IHaskell/Display.hs
+++ b/src/IHaskell/Display.hs
@@ -48,19 +48,27 @@
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
+import StringUtils (rstrip)
type Base64 = Text
@@ -92,23 +100,23 @@
-- | 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 @@
-- | 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
--- a/src/IHaskell/Eval/Completion.hs
+++ b/src/IHaskell/Eval/Completion.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE CPP, NoImplicitPrelude, OverloadedStrings, DoAndIfThenElse #-}
-{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+{-# LANGUAGE CPP, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-}
{- |
Description: Generates tab completion options.
@@ -13,17 +12,20 @@
-}
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)
import Data.Char
import Data.List (nub, init, last, head, elemIndex)
-import Data.List.Split
-import Data.List.Split.Internals
+import qualified Data.List.Split as Split
+import qualified Data.List.Split.Internals as Split
import Data.Maybe (fromJust)
-import Data.String.Utils (strip, startswith, endswith, replace)
-import qualified Data.String.Utils as StringUtils
import System.Environment (getEnv)
import GHC hiding (Qualified)
@@ -32,19 +34,22 @@
#endif
import DynFlags
import GhcMonad
+import qualified 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
import IHaskell.Types
import IHaskell.Eval.Evaluate (Interpreter)
import IHaskell.Eval.ParseShell (parseShell)
+import StringUtils (replace, strip, split)
data CompletionType = Empty
| Identifier String
@@ -155,7 +160,7 @@
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.
@@ -173,17 +178,17 @@
-> CompletionType
completionType line loc target
-- File and directory completions are special
- | startswith ":!" stripped =
+ | ":!" `isPrefixOf` stripped =
fileComplete FilePath
- | startswith ":l" stripped =
+ | ":l" `isPrefixOf` stripped =
fileComplete HsFilePath
-- Complete :set, :opt, and :ext
- | startswith ":s" stripped =
+ | ":s" `isPrefixOf` stripped =
DynFlag candidate
- | startswith ":o" stripped =
+ | ":o" `isPrefixOf` stripped =
KernelOption candidate
- | startswith ":e" stripped =
+ | ":e" `isPrefixOf` stripped =
Extension candidate
-- Use target for other completions. If it's empty, no completion.
@@ -195,7 +200,7 @@
FilePath (getStringTarget lineUpToCursor) (getStringTarget lineUpToCursor)
-- Complete module names in imports and elsewhere.
- | startswith "import" stripped && isModName =
+ | "import" `isPrefixOf` stripped && isModName =
ModuleName dotted candidate
| isModName && (not . null . init) target =
Qualified dotted candidate
@@ -219,7 +224,7 @@
fileComplete filePath =
case parseShell lineUpToCursor of
Right xs -> filePath lineUpToCursor $
- if endswith (last xs) lineUpToCursor
+ if last xs `isSuffixOf` lineUpToCursor
then last xs
else []
Left _ -> Empty
@@ -250,14 +255,14 @@
completionTarget code cursor = expandCompletionPiece pieceToComplete
where
pieceToComplete = map fst <$> find (elem cursor . map snd) pieces
- pieces = splitAlongCursor $ split splitter $ zip code [1 ..]
- splitter = defaultSplitter
+ pieces = splitAlongCursor $ Split.split splitter $ zip code [1 ..]
+ splitter = Split.defaultSplitter
{
-- Split using only the characters, which are the first elements of the (char, index) tuple
- delimiter = Delimiter [uncurry isDelim]
+ Split.delimiter = Split.Delimiter [uncurry isDelim]
-- Condense multiple delimiters into one and then drop them.
- , condensePolicy = Condense
- , delimPolicy = Drop
+ , Split.condensePolicy = Split.Condense
+ , Split.delimPolicy = Split.Drop
}
isDelim :: Char -> Int -> Bool
@@ -275,7 +280,7 @@
neverIdent = " \n\t(),{}[]\\'\"`"
expandCompletionPiece Nothing = []
- expandCompletionPiece (Just str) = splitOn "." str
+ expandCompletionPiece (Just str) = Split.splitOn "." str
getHome :: IO String
getHome = do
@@ -307,14 +312,14 @@
acceptAll = const True
extensionIsOneOf exts str = any correctEnding exts
where
- correctEnding ext = endswith ext str
+ correctEnding ext = ext `isSuffixOf` str
completePathFilter :: (String -> Bool) -- ^ File filter: test whether to include this file.
-> (String -> Bool) -- ^ Directory filter: test whether to include this directory.
-> String -- ^ Line contents to the left of the cursor.
-> String -- ^ Line contents to the right of the cursor.
-> Interpreter [String]
-completePathFilter includeFile includeDirectory left right = liftIO $ do
+completePathFilter includeFile includeDirectory left right = GhcMonad.liftIO $ do
-- Get the completions from Haskeline. It has a bit of a strange API.
expanded <- dirExpand left
completions <- map replacement <$> snd <$> completeFilename (reverse expanded, right)
@@ -328,8 +333,8 @@
-- everything else. If we wanted to keep original order, we could instead use
-- filter (`elem` (dirs ++ files)) completions
suggestions <- mapM unDirExpand $ dirs ++ files
- let isHidden str = startswith "." . last . StringUtils.split "/" $
- if endswith "/" str
+ let isHidden str = isPrefixOf "." . last . split "/" $
+ if "/" `isSuffixOf` str
then init str
else str
visible = filter (not . isHidden) suggestions
diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs
--- a/src/IHaskell/Eval/Evaluate.hs
+++ b/src/IHaskell/Eval/Evaluate.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DoAndIfThenElse, NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}
+{-# LANGUAGE NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-}
{- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs
a statement, declaration, import, or directive.
@@ -15,19 +15,22 @@
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
import Data.List (findIndex, and, foldl1, nubBy)
-import Data.String.Utils
import Text.Printf
import Data.Char as Char
import Data.Dynamic
import Data.Typeable
import qualified Data.Serialize as Serialize
import System.Directory
-import Filesystem.Path.CurrentOS (encodeString)
#if !MIN_VERSION_base(4,8,0)
import System.Posix.IO (createPipe)
#endif
@@ -57,7 +60,11 @@
import TcType
import Unify
import InstEnv
+#if MIN_VERSION_ghc(7, 8, 0)
import GhcMonad (liftIO, withSession)
+#else
+import GhcMonad (withSession)
+#endif
import GHC hiding (Stmt, TypeSig)
import Exception hiding (evaluate)
import Outputable hiding ((<>))
@@ -68,8 +75,6 @@
import Bag
import ErrUtils (errMsgShortDoc, errMsgExtraInfo)
-import qualified System.IO.Strict as StrictIO
-
import IHaskell.Types
import IHaskell.IPython
import IHaskell.Eval.Parser
@@ -79,6 +84,7 @@
import IHaskell.Eval.Util
import IHaskell.BrokenPackages
import qualified IHaskell.IPython.Message.UUID as UUID
+import StringUtils (replace, split, strip, rstrip)
import Paths_ihaskell (version)
import Data.Version (versionBranch)
@@ -109,7 +115,8 @@
fullPrefixes = map (++ ".") ignoreTypePrefixes
useStringType = replace "[Char]" "String"
-write :: GhcMonad m => KernelState -> String -> m ()
+-- MonadIO constraint necessary for GHC 7.6
+write :: (MonadIO m, GhcMonad m) => KernelState -> String -> m ()
write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x
type Interpreter = Ghc
@@ -332,7 +339,7 @@
extractValue expr = do
compiled <- dynCompileExpr expr
case fromDynamic compiled of
- Nothing -> error "Expecting value!"
+ Nothing -> error "Error casting types in Evaluate.hs"
Just result -> return result
safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut
@@ -562,10 +569,10 @@
write state $ "Load: " ++ names
displays <- forM (words names) $ \name -> do
- let filename = if endswith ".hs" name
+ let filename = if ".hs" `isSuffixOf` name
then name
else name ++ ".hs"
- contents <- readFile filename
+ contents <- liftIO $ readFile filename
modName <- intercalate "." <$> getModuleName contents
doLoadModule filename modName
return (ManyDisplay displays)
@@ -847,7 +854,7 @@
isShowError (Display errs) =
-- Note that we rely on this error message being 'type cleaned', so that `Show` is not displayed as
-- GHC.Show.Show. This is also very fragile!
- startswith "No instance for (Show" msg &&
+ "No instance for (Show" `isPrefixOf` msg &&
isInfixOf "print it" msg
where
msg = extractPlain errs
@@ -1016,7 +1023,7 @@
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.
@@ -1242,7 +1249,7 @@
fixDollarSigns = replace "$" "$"
useDashV = "\nUse -v to see a list of the files searched for."
isShowError err =
- startswith "No instance for (Show" err &&
+ "No instance for (Show" `isPrefixOf` err &&
isInfixOf " arising from a use of `print'" err
formatParseError :: StringLoc -> String -> ErrMsg
diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs
--- a/src/IHaskell/Eval/Hoogle.hs
+++ b/src/IHaskell/Eval/Hoogle.hs
@@ -8,19 +8,22 @@
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
+import StringUtils (split, strip, replace)
-- | Types of formats to render output to.
data OutputFormat = Plain -- ^ Render to plain text.
@@ -52,11 +55,10 @@
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 +68,25 @@
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 +96,7 @@
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
@@ -154,22 +156,22 @@
renderSelf :: String -> String -> String
renderSelf string loc
- | startswith "package" string =
+ | "package" `isPrefixOf` string =
pkg ++ " " ++ span "hoogle-package" (link loc $ extractPackage string)
- | startswith "module" string =
+ | "module" `isPrefixOf` string =
let package = extractPackageName loc
in mod ++ " " ++
span "hoogle-module" (link loc $ extractModule string) ++
packageSub package
- | startswith "class" string =
+ | "class" `isPrefixOf` string =
let package = extractPackageName loc
in cls ++ " " ++
span "hoogle-class" (link loc $ extractClass string) ++
packageSub package
- | startswith "data" string =
+ | "data" `isPrefixOf` string =
let package = extractPackageName loc
in dat ++ " " ++
span "hoogle-class" (link loc $ extractData string) ++
@@ -216,36 +218,36 @@
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) &&
- startswith ">" (strip s2)
- isCode (s:_) = startswith ">" $ strip s
+ isPrefixOf ">" (strip s1) &&
+ isPrefixOf ">" (strip s2)
+ isCode (s:_) = isPrefixOf ">" $ 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
--- 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
--- 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 @@
-}
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)
@@ -37,14 +43,13 @@
then "(" ++ lastChunk ++ ")"
else lastChunk
-
inspect :: String -- ^ Code in the cell
-> Int -- ^ Cursor position in the cell
-> Interpreter (Maybe Display)
inspect code pos = do
let identifier = getIdentifier code pos
handler :: SomeException -> Interpreter (Maybe a)
- handler _ = return Nothing
+ handler _ = return Nothing
response <- ghandle handler (Just <$> getType identifier)
let prefix = identifier ++ " :: "
fmt str = Display [plain $ prefix ++ str]
diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs
--- a/src/IHaskell/Eval/Lint.hs
+++ b/src/IHaskell/Eval/Lint.hs
@@ -1,13 +1,17 @@
-{-# LANGUAGE FlexibleContexts, NoImplicitPrelude, QuasiQuotes, ViewPatterns #-}
+{-# LANGUAGE NoImplicitPrelude, FlexibleContexts, QuasiQuotes, ViewPatterns #-}
module IHaskell.Eval.Lint (lint) where
-import Data.String.Utils (replace, startswith, strip, split)
+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 Prelude (head, tail, last)
-import ClassyPrelude hiding (last)
import Control.Monad
import Data.List (findIndex)
-import Text.Printf
import Data.String.Here
import Data.Char
import Data.Monoid
@@ -28,6 +32,7 @@
import IHaskell.Display
import IHaskell.IPython
import IHaskell.Eval.Parser hiding (line)
+import StringUtils (replace)
type ExtsModule = SrcExts.Module SrcSpanInfo
diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs
--- a/src/IHaskell/Eval/ParseShell.hs
+++ b/src/IHaskell/Eval/ParseShell.hs
@@ -1,29 +1,36 @@
+{-# 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"
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 +41,9 @@
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 +54,14 @@
separator = many1 space "separator"
-- | Input must terminate in a space character (like a \n)
-words :: Parser [String]
-words = try (eof *> return []) <|> do
- x <- word
- rest1 <- lookAhead (many anyToken)
- ss <- separator
- rest2 <- lookAhead (many anyToken)
- xs <- words
- return $ x : xs
+shellWords :: Parser [String]
+shellWords = try (eof *> return []) <|> do
+ x <- word
+ rest1 <- lookAhead (many anyToken)
+ ss <- separator
+ rest2 <- lookAhead (many anyToken)
+ 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
--- a/src/IHaskell/Eval/Parser.hs
+++ b/src/IHaskell/Eval/Parser.hs
@@ -15,10 +15,14 @@
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)
import Prelude (head, tail)
import Control.Monad (msum)
@@ -26,6 +30,7 @@
import Language.Haskell.GHC.Parser
import IHaskell.Eval.Util
+import StringUtils (strip, split)
-- | A block of code to be evaluated. Each block contains a single element - one declaration,
-- statement, expression, etc. If parsing of the block failed, the block is instead a ParseError,
@@ -108,11 +113,11 @@
-- Test whether a given chunk is a directive.
isDirective :: String -> Bool
- isDirective = startswith ":" . strip
+ isDirective = isPrefixOf ":" . strip
-- Test if a chunk is a pragma.
isPragma :: String -> Bool
- isPragma = startswith "{-#" . strip
+ isPragma = isPrefixOf "{-#" . strip
activateExtensions :: GhcMonad m => CodeBlock -> m ()
activateExtensions (Directive SetExtension ext) = void $ setExtension ext
diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs
--- 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 @@
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 HscTypes
import InteractiveEval
import Module
-import Outputable
import Packages
import RdrName
import NameSet
@@ -44,12 +48,14 @@
import Unify (tcMatchTys)
import VarSet (mkVarSet)
import qualified Pretty
+import qualified Outputable as O
import Control.Monad (void)
import Data.Function (on)
-import Data.String.Utils (replace)
import Data.List (nubBy)
+import StringUtils (replace)
+
-- | A extension flag that can be set or unset.
data ExtFlag = SetFlag ExtensionFlag
| UnsetFlag ExtensionFlag
@@ -80,15 +86,15 @@
-- | 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 +104,9 @@
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 +115,10 @@
default_dflags = defaultDynFlags (settings dflags)
- fstr str = text "-f" <> text str
+ fstr, fnostr :: String -> O.SDoc
+ fstr str = O.text "-f" O.<> O.text str
- fnostr str = text "-fno-" <> text str
+ fnostr str = O.text "-fno-" O.<> O.text str
(ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags
@@ -129,22 +136,24 @@
-- `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: " <>
- 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))]
+ O.vcat
+ [ O.text "base language is: " O.<>
+ case language dflags of
+ 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 +205,13 @@
-- 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 +307,7 @@
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 +335,7 @@
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 +372,16 @@
#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
--- a/src/IHaskell/Flags.hs
+++ b/src/IHaskell/Flags.hs
@@ -11,7 +11,13 @@
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 @@
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 @@
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
--- a/src/IHaskell/IPython.hs
+++ b/src/IHaskell/IPython.hs
@@ -1,6 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DoAndIfThenElse #-}
+{-# LANGUAGE CPP #-}
-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and
-- @console@ commands.
@@ -15,18 +13,19 @@
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 qualified Shelly as SH
+import qualified System.IO as IO
+import qualified System.FilePath as FP
import System.Directory
-import qualified Filesystem.Path.CurrentOS as FS
-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,12 +33,13 @@
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
import System.Posix.Signals
+import StringUtils (replace, split)
+
data KernelSpecOptions =
KernelSpecOptions
{ kernelSpecGhcLibdir :: String -- ^ GHC libdir.
@@ -55,81 +55,84 @@
}
-- | The IPython kernel name.
-kernelName :: IsString a => a
+kernelName :: String
kernelName = "haskell"
-kernelArgs :: IsString a => [a]
+kernelArgs :: [String]
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 :: SH.FilePath -> FilePath
+fp = T.unpack . SH.toTextIgnore
+
-- | Create the directory and return it.
-ensure :: Sh FilePath -> Sh FilePath
+ensure :: SH.Sh SH.FilePath -> SH.Sh SH.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.") SH.fromText <$> SH.get_env "HOME"
+ fp <$> ensure (return (home SH. ".ihaskell"))
-ipythonDir :: Sh FilePath
-ipythonDir = ensure $ ( "ipython") <$> ihaskellDir
+ipythonDir :: SH.Sh SH.FilePath
+ipythonDir = ensure $ (SH. "ipython") <$> ihaskellDir
-notebookDir :: Sh FilePath
-notebookDir = ensure $ ( "notebooks") <$> ihaskellDir
+notebookDir :: SH.Sh SH.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 +141,15 @@
_ -> 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,86 +170,86 @@
-- 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 (SH.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
- return $ kernelName `elem` kernelspecs
+ Just ipython <- SH.which "ipython"
+ out <- SH.silently $ SH.run ipython ["kernelspec", "list"]
+ let kernelspecs = map T.strip $ T.lines out
+ return $ T.pack 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 SH.FilePath
path exe = do
- path <- which $ fromText exe
+ path <- SH.which $ SH.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 FilePath
getIHaskellPath = do
-- Get the absolute filepath to the argument.
- f <- liftIO getArgv0
+ f <- T.unpack <$> SH.toTextIgnore <$> liftIO getArgv0
-- If we have an absolute path, that's the IHaskell we're interested in.
- if FS.absolute f
- then return $ FS.encodeString f
+ if FP.isAbsolute f
+ then return f
else
-- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
-- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
- if FS.filename f == f
+ if FP.takeFileName 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
-
+ Just path -> return $ T.unpack $ SH.toTextIgnore path
+ else liftIO $ makeAbsolute f
+#if !MIN_VERSION_directory(1, 2, 2)
+-- This is included in later versions of `directory`, but we cannot use later versions because GHC
+-- library depends on a particular version of it.
+makeAbsolute :: FilePath -> IO FilePath
+makeAbsolute = fmap FP.normalise . absolutize
+ where
+ absolutize path -- avoid the call to `getCurrentDirectory` if we can
+ | FP.isRelative path = fmap (FP. path) getCurrentDirectory
+ | otherwise = return path
+#endif
getSandboxPackageConf :: IO (Maybe String)
-getSandboxPackageConf = shelly $ do
+getSandboxPackageConf = SH.shelly $ do
myPath <- getIHaskellPath
let sandboxName = ".cabal-sandbox"
if not $ sandboxName `isInfixOf` myPath
@@ -254,8 +257,8 @@
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 (SH.fromText $ T.pack sandboxDir)
+ let confdirs = filter (isSuffixOf ("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
--- 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 @@
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 @@
-- 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
--- a/src/IHaskell/Types.hs
+++ b/src/IHaskell/Types.hs
@@ -30,11 +30,16 @@
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 @@
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 @@
, useShowErrors = False
, useShowTypes = False
, usePager = True
- , openComms = empty
+ , openComms = mempty
, kernelDebug = False
}
diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs
new file mode 100644
--- /dev/null
+++ b/src/IHaskellPrelude.hs
@@ -0,0 +1,149 @@
+{-# LANGUAGE CPP #-}
+module IHaskellPrelude (
+ module IHaskellPrelude,
+ module X,
+
+ -- Select reexports
+ Data.Typeable.Typeable,
+ Data.Typeable.cast,
+
+#if MIN_VERSION_ghc(7,8,0)
+ Data.Typeable.Proxy,
+
+ GHC.Exts.IsString,
+ GHC.Exts.IsList,
+#endif
+
+ 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.Err as X hiding (absentErr)
+#if MIN_VERSION_ghc(7,10,0)
+import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>))
+#else
+import GHC.Base as X hiding (Any)
+#endif
+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
deleted file mode 100644
--- a/src/Main.hs
+++ /dev/null
@@ -1,377 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude, CPP, OverloadedStrings, ScopedTypeVariables, QuasiQuotes #-}
-
--- | Description : Argument parsing and basic messaging loop, using Haskell
--- Chans to communicate with the ZeroMQ sockets.
-module Main (main) where
-
--- Prelude imports.
-import ClassyPrelude hiding (last, liftIO, readChan, writeChan)
-import Prelude (last, read)
-
--- 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.Posix.Signals
-import qualified Data.Map as Map
-import Data.String.Here (hereFile)
-import qualified Data.Text as T
-
--- IHaskell imports.
-import IHaskell.Convert (convert)
-import IHaskell.Eval.Completion (complete)
-import IHaskell.Eval.Inspect (inspect)
-import IHaskell.Eval.Evaluate
-import IHaskell.Display
-import IHaskell.Eval.Info
-import IHaskell.Flags
-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
-
--- GHC API imports.
-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
- where
- dotToSpace '.' = ' '
- dotToSpace x = x
-
-ihaskellCSS :: String
-ihaskellCSS = [hereFile|html/custom.css|]
-
-consoleBanner :: Text
-consoleBanner =
- "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
- case args of
- Left errorMessage -> hPutStrLn stderr errorMessage
- Right args -> ihaskell args
-
-ihaskell :: Args -> IO ()
-ihaskell (Args (ShowHelp help) _) = putStrLn $ pack help
-ihaskell (Args ConvertLhs args) = showingHelp ConvertLhs args $ convert args
-ihaskell (Args InstallKernelSpec args) = showingHelp InstallKernelSpec args $ do
- let kernelSpecOpts = parseKernelArgs args
- replaceIPythonKernelspec kernelSpecOpts
-ihaskell (Args (Kernel (Just filename)) args) = do
- let kernelSpecOpts = parseKernelArgs args
- runKernel kernelSpecOpts filename
-
-showingHelp :: IHaskellMode -> [Argument] -> IO () -> IO ()
-showingHelp mode flags act =
- case find (== Help) flags of
- Just _ ->
- putStrLn $ pack $ help mode
- Nothing ->
- act
-
--- | Parse initialization information from the flags.
-parseKernelArgs :: [Argument] -> KernelSpecOptions
-parseKernelArgs = foldl' addFlag defaultKernelSpecOptions
- where
- addFlag kernelSpecOpts (ConfFile filename) =
- kernelSpecOpts { kernelSpecConfFile = return (Just filename) }
- addFlag kernelSpecOpts KernelDebug =
- kernelSpecOpts { kernelSpecDebug = True }
- addFlag kernelSpecOpts (GhcLibDir libdir) =
- kernelSpecOpts { kernelSpecGhcLibdir = libdir }
- addFlag kernelSpecOpts flag = error $ "Unknown flag" ++ show flag
-
--- | Run the IHaskell language kernel.
-runKernel :: KernelSpecOptions -- ^ Various options from when the kernel was installed.
- -> String -- ^ File with kernel profile JSON (ports, etc).
- -> IO ()
-runKernel kernelOpts profileSrc = do
- let debug = kernelSpecDebug kernelOpts
- libdir = kernelSpecGhcLibdir kernelOpts
-
- -- Parse the profile file.
- Just profile <- liftM decode . readFile $ profileSrc
-
- -- Necessary for `getLine` and their ilk to work.
- dir <- getIHaskellDir
- Stdin.recordKernelProfile dir profile
-
- -- Serve on all sockets and ports defined in the profile.
- interface <- serveProfile profile debug
-
- -- Create initial state in the directory the kernel *should* be in.
- state <- initialKernelState
- modifyMVar_ state $ \kernelState -> return $
- kernelState { kernelDebug = debug }
-
- -- Receive and reply to all messages on the shell socket.
- interpret libdir True $ do
- -- Ignore Ctrl-C the first time. This has to go inside the `interpret`, because GHC API resets the
- -- signal handlers for some reason (completely unknown to me).
- liftIO ignoreCtrlC
-
- -- Initialize the context by evaluating everything we got from the command line flags.
- let noPublish _ = return ()
- evaluator line = void $ do
- -- Create a new state each time.
- stateVar <- liftIO initialKernelState
- state <- liftIO $ takeMVar stateVar
- evaluate state line noPublish
-
- confFile <- liftIO $ kernelSpecConfFile kernelOpts
- case confFile of
- Just filename -> liftIO (readFile filename) >>= evaluator
- Nothing -> return ()
-
- forever $ do
- -- Read the request from the request channel.
- request <- liftIO $ readChan $ shellRequestChannel interface
-
- -- Create a header for the reply.
- replyHeader <- createReplyHeader (header request)
-
- -- We handle comm messages and normal ones separately. The normal ones are a standard
- -- request/response style, while comms can be anything, and don't necessarily require a response.
- if isCommMessage request
- then liftIO $ do
- oldState <- takeMVar state
- let replier = writeChan (iopubChannel interface)
- newState <- handleComm replier oldState request replyHeader
- putMVar state newState
- writeChan (shellReplyChannel interface) SendNothing
- else do
- -- Create the reply, possibly modifying kernel state.
- oldState <- liftIO $ takeMVar state
- (newState, reply) <- replyTo interface request replyHeader oldState
- liftIO $ putMVar state newState
-
- -- Write the reply to the reply channel.
- liftIO $ writeChan (shellReplyChannel interface) reply
-
- where
- ignoreCtrlC =
- installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.")
- Nothing
-
- isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage]
-
--- Initial kernel state.
-initialKernelState :: IO (MVar KernelState)
-initialKernelState = newMVar defaultKernelState
-
--- | Duplicate a message header, giving it a new UUID and message type.
-dupHeader :: MessageHeader -> MessageType -> IO MessageHeader
-dupHeader header messageType = do
- uuid <- liftIO UUID.random
-
- return header { messageId = uuid, msgType = messageType }
-
--- | Create a new message header, given a parent message header.
-createReplyHeader :: MessageHeader -> Interpreter MessageHeader
-createReplyHeader parent = do
- -- Generate a new message UUID.
- newMessageId <- liftIO UUID.random
- let repType = fromMaybe err (replyType $ msgType parent)
- err = error $ "No reply for message " ++ show (msgType parent)
-
- return
- MessageHeader
- { identifiers = identifiers parent
- , parentHeader = Just parent
- , metadata = Map.fromList []
- , messageId = newMessageId
- , sessionId = sessionId parent
- , username = username parent
- , msgType = repType
- }
-
--- | Compute a reply to a message.
-replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message)
--- Reply to kernel info requests with a kernel info reply. No computation needs to be done, as a
--- kernel info reply is a static object (all info is hard coded into the representation of that
--- message type).
-replyTo _ KernelInfoRequest{} replyHeader state =
- return
- (state, KernelInfoReply
- { header = replyHeader
- , language = "haskell"
- , versionList = ghcVersionInts
- })
-
--- Reply to a shutdown request by exiting the main thread. Before shutdown, reply to the request to
--- let the frontend know shutdown is happening.
-replyTo interface ShutdownRequest { restartPending = restartPending } replyHeader _ = liftIO $ do
- writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader restartPending
- exitSuccess
-
--- Reply to an execution request. The reply itself does not require computation, but this causes
--- messages to be sent to the IOPub socket with the output of the code in the execution request.
-replyTo interface req@ExecuteRequest { getCode = code } replyHeader state = do
- -- Convenience function to send a message to the IOPub socket.
- let send msg = liftIO $ writeChan (iopubChannel interface) msg
-
- -- Log things so that we can use stdin.
- dir <- liftIO getIHaskellDir
- liftIO $ Stdin.recordParentHeader dir $ header req
-
- -- Notify the frontend that the kernel is busy computing. All the headers are copies of the reply
- -- header with a different message type, because this preserves the session ID, parent header, and
- -- other important information.
- busyHeader <- liftIO $ dupHeader replyHeader StatusMessage
- send $ PublishStatus busyHeader Busy
-
- -- Construct a function for publishing output as this is going. This function accepts a boolean
- -- indicating whether this is the final output and the thing to display. Store the final outputs in
- -- a list so that when we receive an updated non-final output, we can clear the entire output and
- -- re-display with the updated output.
- displayed <- liftIO $ newMVar []
- updateNeeded <- liftIO $ newMVar False
- pagerOutput <- liftIO $ newMVar []
- let clearOutput = do
- header <- dupHeader replyHeader ClearOutputMessage
- send $ ClearOutput header True
-
- sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts
- sendOutput (Display outs) = do
- header <- dupHeader replyHeader DisplayDataMessage
- send $ PublishDisplayData header "haskell" $ map (convertSvgToHtml . prependCss) outs
-
- convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ encodeUtf8 svg
- convertSvgToHtml x = x
- makeSvgImg base64data = unpack $ ""
-
- prependCss (DisplayData MimeHtml html) =
- DisplayData MimeHtml $concat ["", html]
- prependCss x = x
-
- startComm :: CommInfo -> IO ()
- startComm (CommInfo widget uuid target) = do
- -- Send the actual comm open.
- header <- dupHeader replyHeader CommOpenMessage
- send $ CommOpen header target uuid (Object mempty)
-
- -- Send anything else the widget requires.
- let communicate value = do
- head <- dupHeader replyHeader CommDataMessage
- writeChan (iopubChannel interface) $ CommData head uuid value
- open widget communicate
-
- publish :: EvaluationResult -> IO ()
- publish result = do
- let final =
- case result of
- IntermediateResult{} -> False
- FinalResult{} -> True
- outs = outputs result
-
- -- If necessary, clear all previous output and redraw.
- clear <- readMVar updateNeeded
- when clear $ do
- clearOutput
- disps <- readMVar displayed
- mapM_ sendOutput $ reverse disps
-
- -- Draw this message.
- sendOutput outs
-
- -- If this is the final message, add it to the list of completed messages. If it isn't, make sure we
- -- clear it later by marking update needed as true.
- modifyMVar_ updateNeeded (const $ return $ not final)
- when final $ do
- modifyMVar_ displayed (return . (outs :))
-
- -- Start all comms that need to be started.
- mapM_ startComm $ startComms result
-
- -- If this has some pager output, store it for later.
- let pager = pagerOut result
- unless (null pager) $
- if usePager state
- then modifyMVar_ pagerOutput (return . (++ pager))
- else sendOutput $ Display pager
-
- 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
-
- -- Run code and publish to the frontend as we go.
- updatedState <- evaluate state (unpack code) publish
-
- -- Notify the frontend that we're done computing.
- idleHeader <- liftIO $ dupHeader replyHeader StatusMessage
- send $ PublishStatus idleHeader Idle
-
- -- Take pager output if we're using the pager.
- pager <- if usePager state
- then liftIO $ readMVar pagerOutput
- else return []
- return
- (updatedState, ExecuteReply
- { header = replyHeader
- , pagerOutput = pager
- , executionCounter = execCount
- , status = Ok
- })
-
-
-replyTo _ req@CompleteRequest{} replyHeader state = do
- let code = getCode req
- pos = getCursorPos req
- (matchedText, completions) <- complete (unpack code) pos
-
- let start = pos - length matchedText
- end = pos
- reply = CompleteReply replyHeader (map pack completions) start end Map.empty True
- return (state, reply)
-
-replyTo _ req@InspectRequest{} replyHeader state = do
- result <- inspect (unpack $ inspectCode req) (inspectCursorPos req)
- let reply =
- case result of
- Just (Display datas) -> InspectReply
- { header = replyHeader
- , inspectStatus = True
- , inspectData = datas
- }
- _ -> InspectReply { header = replyHeader, inspectStatus = False, inspectData = [] }
- return (state, reply)
-
--- TODO: Implement history_reply.
-replyTo _ HistoryRequest{} replyHeader state = do
- let reply = HistoryReply
- { header = replyHeader
- -- FIXME
- , historyReply = []
- }
- return (state, reply)
-
-handleComm :: (Message -> IO ()) -> KernelState -> Message -> MessageHeader -> IO KernelState
-handleComm replier kernelState req replyHeader = do
- let widgets = openComms kernelState
- uuid = commUuid req
- dat = commData req
- communicate value = do
- head <- dupHeader replyHeader CommDataMessage
- replier $ CommData head uuid value
- case lookup uuid widgets of
- Nothing -> fail $ "no widget with uuid " ++ show uuid
- Just (Widget widget) ->
- case msgType $ header req of
- CommDataMessage -> do
- comm widget dat communicate
- return kernelState
- CommCloseMessage -> do
- close widget dat
- return kernelState { openComms = Map.delete uuid widgets }
diff --git a/src/StringUtils.hs b/src/StringUtils.hs
new file mode 100644
--- /dev/null
+++ b/src/StringUtils.hs
@@ -0,0 +1,26 @@
+module StringUtils (
+ strip,
+ lstrip,
+ rstrip,
+ replace,
+ split,
+ ) where
+
+import IHaskellPrelude
+import qualified Data.Text as T
+
+lstrip :: String -> String
+lstrip = dropWhile (`elem` (" \t\r\n" :: String))
+
+rstrip :: String -> String
+rstrip = reverse . lstrip . reverse
+
+strip :: String -> String
+strip = rstrip . lstrip
+
+replace :: String -> String -> String -> String
+replace needle replacement haystack =
+ T.unpack $ T.replace (T.pack needle) (T.pack replacement) (T.pack haystack)
+
+split :: String -> String -> [String]
+split delim = map T.unpack . T.splitOn (T.pack delim) . T.pack