ihaskell 0.6.3.0 → 0.6.4.0
raw patch · 26 files changed
+1231/−782 lines, 26 filesdep −MissingHdep −classy-preludedep −mono-traversabledep ~aesondep ~ghcdep ~text
Dependencies removed: MissingH, classy-prelude, mono-traversable, system-filepath, tar
Dependency ranges changed: aeson, ghc, text
Files
- Hspec.hs +46/−32
- ihaskell.cabal +30/−27
- main/IHaskellPrelude.hs +149/−0
- main/Main.hs +382/−0
- src/IHaskell/BrokenPackages.hs +10/−7
- src/IHaskell/Convert.hs +9/−0
- src/IHaskell/Convert/Args.hs +13/−4
- src/IHaskell/Convert/IpynbToLhs.hs +32/−27
- src/IHaskell/Convert/LhsToIpynb.hs +46/−45
- src/IHaskell/Display.hs +19/−11
- src/IHaskell/Eval/Completion.hs +31/−26
- src/IHaskell/Eval/Evaluate.hs +21/−14
- src/IHaskell/Eval/Hoogle.hs +38/−36
- src/IHaskell/Eval/Info.hs +6/−1
- src/IHaskell/Eval/Inspect.hs +9/−4
- src/IHaskell/Eval/Lint.hs +9/−4
- src/IHaskell/Eval/ParseShell.hs +26/−19
- src/IHaskell/Eval/Parser.hs +9/−4
- src/IHaskell/Eval/Util.hs +52/−43
- src/IHaskell/Flags.hs +10/−4
- src/IHaskell/IPython.hs +90/−87
- src/IHaskell/IPython/Stdin.hs +11/−4
- src/IHaskell/Types.hs +8/−6
- src/IHaskellPrelude.hs +149/−0
- src/Main.hs +0/−377
- src/StringUtils.hs +26/−0
Hspec.hs view
@@ -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)
ihaskell.cabal view
@@ -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.*,
+ main/IHaskellPrelude.hs view
@@ -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
+ main/Main.hs view
@@ -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 $ "<img src=\"data:image/svg+xml;base64," <>+ base64data <>+ "\"/>"++ prependCss (DisplayData MimeHtml html) =+ DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", 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 }
src/IHaskell/BrokenPackages.hs view
@@ -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
src/IHaskell/Convert.hs view
@@ -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)
src/IHaskell/Convert/Args.hs view
@@ -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
src/IHaskell/Convert/IpynbToLhs.hs view
@@ -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
src/IHaskell/Convert/LhsToIpynb.hs view
@@ -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 _ [] = []
src/IHaskell/Display.hs view
@@ -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
src/IHaskell/Eval/Completion.hs view
@@ -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
src/IHaskell/Eval/Evaluate.hs view
@@ -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 "$" "<span>$</span>" 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
src/IHaskell/Eval/Hoogle.hs view
@@ -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 "<div class='%s'>%s</div>"+div' :: String -> String -> String+div' = printf "<div class='%s'>%s</div>" span :: String -> String -> String span = printf "<span class='%s'>%s</span>"
src/IHaskell/Eval/Info.hs view
@@ -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)
src/IHaskell/Eval/Inspect.hs view
@@ -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]
src/IHaskell/Eval/Lint.hs view
@@ -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
src/IHaskell/Eval/ParseShell.hs view
@@ -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")
src/IHaskell/Eval/Parser.hs view
@@ -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
src/IHaskell/Eval/Util.hs view
@@ -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)
src/IHaskell/Flags.hs view
@@ -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
src/IHaskell/IPython.hs view
@@ -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:_ ->
src/IHaskell/IPython/Stdin.hs view
@@ -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
src/IHaskell/Types.hs view
@@ -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 }
+ src/IHaskellPrelude.hs view
@@ -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
− src/Main.hs
@@ -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 $ "<img src=\"data:image/svg+xml;base64," ++ base64data ++ "\"/>"-- prependCss (DisplayData MimeHtml html) =- DisplayData MimeHtml $concat ["<style>", pack ihaskellCSS, "</style>", 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 }
+ src/StringUtils.hs view
@@ -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