diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -1,20 +1,20 @@ -- The name of the package. name: ihaskell --- The package version. See the Haskell package versioning policy (PVP) +-- The package version. See the Haskell package versioning policy (PVP) -- for standards guiding when and how versions should be incremented. -- http://www.haskell.org/haskellwiki/Package_versioning_policy --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change -version: 0.9.1.0 +-- PVP summary: +--+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.10.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. -- A longer description of the package. -description: IHaskell is a Haskell backend kernel for the IPython project. This allows using Haskell via - a console or notebook interface. Additional packages may be installed to provide richer data visualizations. +description: IHaskell is a Haskell backend kernel for the IPython project. This allows using Haskell via + a console or notebook interface. Additional packages may be installed to provide richer data visualizations. -- URL for the project homepage or repository. homepage: http://github.com/gibiansky/IHaskell @@ -28,12 +28,12 @@ -- The package author(s). author: Andrew Gibiansky --- An email address to which users can send suggestions, bug reports, and +-- An email address to which users can send suggestions, bug reports, and -- patches. maintainer: andrew.gibiansky@gmail.com -- A copyright notice. --- copyright: +-- copyright: category: Development @@ -42,17 +42,18 @@ -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.16 -data-files: +data-files: html/kernel.js html/logo-64x64.svg -flag binPkgDb - default: False - description: bin-package-db package needed (needed for GHC >= 7.10) - library hs-source-dirs: src default-language: Haskell2010 + ghc-options: -Wall + + if impl (ghc >= 8.4) + ghc-options: -Wpartial-fields + build-depends: aeson >=1.0, base >=4.9, @@ -81,18 +82,15 @@ strict >=0.3, system-argv0 -any, text >=0.11, + time >= 1.6, transformers -any, unix >= 2.6, unordered-containers -any, utf8-string -any, uuid >=1.3, vector -any, - ipython-kernel >=0.9.1 - if flag(binPkgDb) - build-depends: bin-package-db - - if impl(ghc >= 8.0) - build-depends: ghc-boot >=8.0 && <8.5 + ipython-kernel >=0.9.1, + ghc-boot >=8.0 && <8.7 exposed-modules: IHaskell.Display IHaskell.Convert @@ -117,42 +115,50 @@ IHaskell.BrokenPackages IHaskell.CSS Paths_ihaskell - other-modules: IHaskellPrelude + other-modules: StringUtils executable ihaskell -- .hs or .lhs file containing the Main module. main-is: Main.hs hs-source-dirs: main - other-modules: - IHaskellPrelude + other-modules: Paths_ihaskell - ghc-options: -threaded -rtsopts - + ghc-options: -threaded -rtsopts -Wall + + if os(darwin) + ghc-options: -optP-Wno-nonportable-include-path + + if impl (ghc >= 8.4) + ghc-options: -Wpartial-fields + -- Other library packages from which modules are imported. default-language: Haskell2010 - build-depends: + build-depends: ihaskell -any, - base >=4.6 && < 4.12, + base >=4.9 && < 4.13, text >=0.11, transformers -any, - ghc >=7.6 || < 7.11, + ghc >=8.0 && < 8.7, process >=1.1, aeson >=0.7, bytestring >=0.10, + unordered-containers -any, containers >=0.5, strict >=0.3, unix >= 2.6, directory -any, - ipython-kernel >=0.7 - - if flag(binPkgDb) - build-depends: bin-package-db + ipython-kernel >=0.7, + unordered-containers -any Test-Suite hspec Type: exitcode-stdio-1.0 - Ghc-Options: -threaded + Ghc-Options: -threaded -Wall + + if impl (ghc >= 8.4) + ghc-options: -Wpartial-fields + Main-Is: Hspec.hs hs-source-dirs: src/tests other-modules: @@ -160,6 +166,7 @@ IHaskell.Test.Completion IHaskell.Test.Util IHaskell.Test.Parser + IHaskell.Test.Hoogle default-language: Haskell2010 build-depends: base, @@ -174,10 +181,8 @@ directory, text, shelly, + raw-strings-qq, setenv - - if flag(binPkgDb) - build-depends: bin-package-db source-repository head type: git diff --git a/main/IHaskellPrelude.hs b/main/IHaskellPrelude.hs deleted file mode 100644 --- a/main/IHaskellPrelude.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}{-# 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(8,0,0) -import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..)) -#elif MIN_VERSION_ghc(7,10,0) -import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>)) -#else -import GHC.Base as X hiding (Any) -#endif -import Data.List as X hiding (head, last, tail, init, transpose, subsequences, permutations, - foldl, foldl1, maximum, minimum, scanl, scanl1, scanr, scanr1, - span, break, mapAccumL, mapAccumR, dropWhileEnd, (!!), - elemIndices, elemIndex, findIndex, findIndices, zip5, zip6, - zip7, zipWith5, zipWith6, zipWith7, unzip5, unzip6, unzip6, - delete, union, lookup, intersect, insert, deleteBy, - deleteFirstBy, unionBy, intersectBy, group, groupBy, insertBy, - maximumBy, minimumBy, genericLength, genericDrop, genericTake, - genericSplitAt, genericIndex, genericReplicate, inits, tails) - -import qualified Control.Applicative -import qualified Data.Typeable -import qualified Data.IORef -import qualified Data.Map -import qualified Data.Text -import qualified Data.Text.Lazy -import qualified Data.ByteString -import qualified Data.ByteString.Lazy -import qualified Data.Function -import qualified GHC.Exts -import qualified System.IO -import qualified System.IO.Strict -import qualified GHC.IO -import qualified Text.Printf -import qualified Control.Exception -import qualified Control.Concurrent.MVar - -import qualified Data.List -import qualified Prelude as P - -type LByteString = Data.ByteString.Lazy.ByteString - -type LText = Data.Text.Lazy.Text - -(headMay, tailMay, lastMay, initMay, maximumMay, minimumMay) = - (wrapEmpty head, wrapEmpty tail, wrapEmpty last, - wrapEmpty init, wrapEmpty maximum, wrapEmpty minimum) - where - wrapEmpty :: ([a] -> b) -> [a] -> Maybe b - wrapEmpty _ [] = Nothing - wrapEmpty f xs = Just (f xs) - -maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a -maximumByMay _ [] = Nothing -maximumByMay f xs = Just (Data.List.maximumBy f xs) - -minimumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a -minimumByMay _ [] = Nothing -minimumByMay f xs = Just (Data.List.minimumBy f xs) - -readMay :: Read a => String -> Maybe a -readMay = fmap fst . headMay . reads - -putStrLn :: (MonadIO m) => String -> m () -putStrLn = liftIO . P.putStrLn - -putStr :: (MonadIO m) => String -> m () -putStr = liftIO . P.putStr - -putChar :: MonadIO m => Char -> m () -putChar = liftIO . P.putChar - -print :: (MonadIO m, Show a) => a -> m () -print = liftIO . P.print diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -7,27 +7,20 @@ 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 Control.Arrow (second) -import Data.Aeson -import System.Directory +import Data.Aeson hiding (Success) import System.Process (readProcess, readProcessWithExitCode) import System.Exit (exitSuccess, ExitCode(ExitSuccess)) import Control.Exception (try, SomeException) import System.Environment (getArgs) -#if MIN_VERSION_ghc(7,8,0) import System.Environment (setEnv) -#endif import System.Posix.Signals import qualified Data.Map as Map -import qualified Data.Text.Encoding as E +import qualified Data.HashMap.Strict as HashMap import Data.List (break, last) import Data.Version (showVersion) @@ -37,7 +30,6 @@ import IHaskell.Eval.Inspect (inspect) import IHaskell.Eval.Evaluate import IHaskell.Display -import IHaskell.Eval.Info import IHaskell.Eval.Widgets (widgetHandler) import IHaskell.Flags import IHaskell.IPython @@ -51,31 +43,12 @@ -- Cabal imports. import Paths_ihaskell(version) --- GHC API imports. -#if MIN_VERSION_ghc(8,4,0) -import GHC hiding (extensions, language, convert) -#else -import GHC hiding (extensions, language) -#endif - --- | 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 - -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 + Right xs -> ihaskell xs ihaskell :: Args -> IO () ihaskell (Args (ShowDefault helpStr) args) = showDefault helpStr args @@ -123,16 +96,16 @@ kernelSpecOpts { kernelSpecInstallPrefix = Just prefix } addFlag kernelSpecOpts KernelspecUseStack = kernelSpecOpts { kernelSpecUseStack = True } - addFlag kernelSpecOpts flag = error $ "Unknown flag" ++ show flag + 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 - useStack = kernelSpecUseStack kernelOpts +runKernel kOpts profileSrc = do + let debug = kernelSpecDebug kOpts + libdir = kernelSpecGhcLibdir kOpts + useStack = kernelSpecUseStack kOpts -- Parse the profile file. let profileErr = error $ "ihaskell: "++profileSrc++": Failed to parse profile file" @@ -142,12 +115,11 @@ dir <- getIHaskellDir Stdin.recordKernelProfile dir profile -#if MIN_VERSION_ghc(7,8,0) when useStack $ do -- Detect if we have stack runResult <- try $ readProcessWithExitCode "stack" [] "" - let stack = - case runResult :: Either SomeException (ExitCode, String, String) of + let stack = + case runResult :: Either SomeException (ExitCode, String, String) of Left _ -> False Right (exitCode, stackStdout, _) -> exitCode == ExitSuccess && "The Haskell Tool Stack" `isInfixOf` stackStdout @@ -160,7 +132,6 @@ in case tailMay val of Nothing -> return () Just val' -> setEnv var val' -#endif -- Serve on all sockets and ports defined in the profile. interface <- serveProfile profile debug @@ -174,21 +145,21 @@ interpret libdir True $ \hasSupportLibraries -> 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 + _ <- liftIO ignoreCtrlC liftIO $ modifyMVar_ state $ \kernelState -> return $ kernelState { supportLibrariesAvailable = hasSupportLibraries } -- Initialize the context by evaluating everything we got from the command line flags. - let noPublish _ = return () + let noPublish _ _ = return () noWidget s _ = return s evaluator line = void $ do -- Create a new state each time. stateVar <- liftIO initialKernelState - state <- liftIO $ takeMVar stateVar - evaluate state line noPublish noWidget + st <- liftIO $ takeMVar stateVar + evaluate st line noPublish noWidget - confFile <- liftIO $ kernelSpecConfFile kernelOpts + confFile <- liftIO $ kernelSpecConfFile kOpts case confFile of Just filename -> liftIO (readFile filename) >>= evaluator Nothing -> return () @@ -225,7 +196,7 @@ installHandler keyboardSignal (CatchOnce $ putStrLn "Press Ctrl-C again to quit kernel.") Nothing - isCommMessage req = msgType (header req) `elem` [CommDataMessage, CommCloseMessage] + isCommMessage req = mhMsgType (header req) `elem` [CommDataMessage, CommCloseMessage] -- Initial kernel state. initialKernelState :: IO (MVar KernelState) @@ -236,19 +207,11 @@ 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) + let repType = fromMaybe err (replyType $ mhMsgType parent) + err = error $ "No reply for message " ++ show (mhMsgType parent) - return - MessageHeader - { identifiers = identifiers parent - , parentHeader = Just parent - , metadata = Map.fromList [] - , messageId = newMessageId - , sessionId = sessionId parent - , username = username parent - , msgType = repType - } + return $ MessageHeader (mhIdentifiers parent) (Just parent) mempty + newMessageId (mhSessionId parent) (mhUsername parent) repType -- | Compute a reply to a message. replyTo :: ZeroMQInterface -> Message -> MessageHeader -> KernelState -> Interpreter (KernelState, Message) @@ -258,7 +221,7 @@ replyTo interface KernelInfoRequest{} replyHeader state = do let send msg = liftIO $ writeChan (iopubChannel interface) msg - -- Notify the frontend that the Kernel is idle + -- Notify the frontend that the Kernel is idle idleHeader <- liftIO $ dupHeader replyHeader StatusMessage send $ PublishStatus idleHeader Idle @@ -289,8 +252,8 @@ -- 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 +replyTo interface ShutdownRequest { restartPending = pending } replyHeader _ = liftIO $ do + writeChan (shellReplyChannel interface) $ ShutdownReply replyHeader pending exitSuccess -- Reply to an execution request. The reply itself does not require computation, but this causes @@ -315,7 +278,7 @@ -- re-display with the updated output. displayed <- liftIO $ newMVar [] updateNeeded <- liftIO $ newMVar False - pagerOutput <- liftIO $ newMVar [] + pOut <- liftIO $ newMVar [] let execCount = getExecutionCounter state -- Let all frontends know the execution count and code that's about to run @@ -324,7 +287,7 @@ -- Run code and publish to the frontend as we go. let widgetMessageHandler = widgetHandler send replyHeader - publish = publishResult send replyHeader displayed updateNeeded pagerOutput (usePager state) + publish = publishResult send replyHeader displayed updateNeeded pOut (usePager state) updatedState <- evaluate state (T.unpack code) publish widgetMessageHandler -- Notify the frontend that we're done computing. @@ -333,7 +296,7 @@ -- Take pager output if we're using the pager. pager <- if usePager state - then liftIO $ readMVar pagerOutput + then liftIO $ readMVar pOut else return [] return (updatedState, ExecuteReply @@ -366,7 +329,7 @@ let start = pos - length matchedText end = pos - reply = CompleteReply replyHeader (map T.pack completions) start end Map.empty True + reply = CompleteReply replyHeader (map T.pack completions) start end (Metadata HashMap.empty) True return (state, reply) replyTo _ req@InspectRequest{} replyHeader state = do @@ -401,14 +364,14 @@ -- -- Sending the message only on the shell_reply channel doesn't work, so we send it as a comm message -- on the iopub channel and return the SendNothing message. -replyTo interface open@CommOpen{} replyHeader state = do - let send msg = liftIO $ writeChan (iopubChannel interface) msg +replyTo interface ocomm@CommOpen{} replyHeader state = do + let send = liftIO . writeChan (iopubChannel interface) - incomingUuid = commUuid open - target = commTargetName open + incomingUuid = commUuid ocomm + target = commTargetName ocomm targetMatches = target == "ipython.widget" - valueMatches = commData open == object ["widget_class" .= "ipywidgets.CommInfo"] + valueMatches = commData ocomm == object ["widget_class" .= ("ipywidgets.CommInfo" :: Text)] commMap = openComms state uuidTargetPairs = map (second targetName) $ Map.toList commMap @@ -417,11 +380,11 @@ currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs - replyValue = object [ "method" .= "custom" + replyValue = object [ "method" .= ("custom" :: Text) , "content" .= object ["comms" .= currentComms] ] - msg = CommData replyHeader (commUuid open) replyValue + msg = CommData replyHeader (commUuid ocomm) replyValue -- To the iopub channel you go when (targetMatches && valueMatches) $ send msg @@ -439,7 +402,7 @@ -- MVars to hold intermediate data during publishing displayed <- liftIO $ newMVar [] updateNeeded <- liftIO $ newMVar False - pagerOutput <- liftIO $ newMVar [] + pOut <- liftIO $ newMVar [] let widgets = openComms kernelState uuid = commUuid req @@ -453,7 +416,7 @@ -- a function that executes an IO action and publishes the output to -- the frontend simultaneously. let run = capturedIO publish kernelState - publish = publishResult send replyHeader displayed updateNeeded pagerOutput toUsePager + publish = publishResult send replyHeader displayed updateNeeded pOut toUsePager -- Notify the frontend that the kernel is busy busyHeader <- liftIO $ dupHeader replyHeader StatusMessage @@ -462,17 +425,20 @@ newState <- case Map.lookup uuid widgets of Nothing -> return kernelState Just (Widget widget) -> - case msgType $ header req of + case mhMsgType $ header req of CommDataMessage -> do disp <- run $ comm widget dat communicate - pgrOut <- liftIO $ readMVar pagerOutput - liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) [] + pgrOut <- liftIO $ readMVar pOut + liftIO $ publish (FinalResult disp (if toUsePager then pgrOut else []) []) Success return kernelState CommCloseMessage -> do disp <- run $ close widget dat - pgrOut <- liftIO $ readMVar pagerOutput - liftIO $ publish $ FinalResult disp (if toUsePager then pgrOut else []) [] + pgrOut <- liftIO $ readMVar pOut + liftIO $ publish (FinalResult disp (if toUsePager then pgrOut else []) []) Success return kernelState { openComms = Map.delete uuid widgets } + _ -> + -- Only sensible thing to do. + return kernelState -- Notify the frontend that the kernel is idle once again idleHeader <- liftIO $ dupHeader replyHeader StatusMessage diff --git a/src/IHaskell/BrokenPackages.hs b/src/IHaskell/BrokenPackages.hs --- a/src/IHaskell/BrokenPackages.hs +++ b/src/IHaskell/BrokenPackages.hs @@ -4,27 +4,22 @@ 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 Shelly -data BrokenPackage = BrokenPackage { packageID :: String, brokenDeps :: [String] } +data BrokenPackage = BrokenPackage String [String] instance Show BrokenPackage where - show = packageID + show (BrokenPackage packageID _) = packageID -- | Get a list of broken packages. This function internally shells out to `ghc-pkg`, and parses the -- output in order to determine what packages are broken. getBrokenPackages :: IO [String] getBrokenPackages = shelly $ do - silently $ errExit False $ run "ghc-pkg" ["check"] + _ <- silently $ errExit False $ run "ghc-pkg" ["check"] checkOut <- lastStderr -- Get rid of extraneous things @@ -34,7 +29,7 @@ return $ case parse (many check) "ghc-pkg output" ghcPkgOutput of - Left err -> [] + Left _ -> [] Right pkgs -> map show pkgs check :: Parser BrokenPackage diff --git a/src/IHaskell/CSS.hs b/src/IHaskell/CSS.hs --- a/src/IHaskell/CSS.hs +++ b/src/IHaskell/CSS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module IHaskell.CSS (ihaskellCSS) where import IHaskellPrelude @@ -5,7 +6,7 @@ ihaskellCSS :: String ihaskellCSS = unlines - [ + [ -- Custom IHaskell CSS "/* Styles used for the Hoogle display in the pager */" , ".hoogle-doc {" @@ -42,7 +43,7 @@ , ".hoogle-class {" , "font-weight: bold;" , "}" - , + , -- Styles used for basic displays ".get-type {" , "color: green;" @@ -75,13 +76,13 @@ , ".err-msg.in.collapse {" , "padding-top: 0.7em;" , "}" - , + , -- Code that will get highlighted before it is highlighted ".highlight-code {" , "white-space: pre;" , "font-family: monospace;" , "}" - , + , -- Hlint styles ".suggestion-warning { " , "font-weight: bold;" diff --git a/src/IHaskell/Convert.hs b/src/IHaskell/Convert.hs --- a/src/IHaskell/Convert.hs +++ b/src/IHaskell/Convert.hs @@ -1,14 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} --- | Description : mostly reversible conversion between ipynb and lhs +-- | Description : mostly reversible conversion between ipynb and lhs module IHaskell.Convert (convert) where import IHaskellPrelude -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Char8 as CBS import Control.Monad.Identity (Identity(Identity), unless, when) import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) diff --git a/src/IHaskell/Convert/Args.hs b/src/IHaskell/Convert/Args.hs --- a/src/IHaskell/Convert/Args.hs +++ b/src/IHaskell/Convert/Args.hs @@ -4,18 +4,13 @@ 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) import Data.List (partition) import Data.Maybe (fromMaybe) -import qualified Data.Text.Lazy as T (pack, Text) import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..)) import System.FilePath ((<.>), dropExtension, takeExtension) import Text.Printf (printf) @@ -40,11 +35,11 @@ , convertLhsStyle = Identity $ fromMaybe (LT.pack <$> lhsStyleBird) (convertLhsStyle convertSpec) } where - toIpynb = fromMaybe (error "Error: direction for conversion unknown") + toIpynb = fromMaybe (error "fromJustConvertSpec: direction for conversion unknown") (convertToIpynb convertSpec) (inputFile, outputFile) = case (convertInput convertSpec, convertOutput convertSpec) of - (Nothing, Nothing) -> error "Error: no files specified for conversion" + (Nothing, Nothing) -> error "fromJustConvertSpec: no files specified for conversion" (Just i, Nothing) | toIpynb -> (i, dropExtension i <.> "ipynb") | otherwise -> (i, dropExtension i <.> "lhs") diff --git a/src/IHaskell/Convert/IpynbToLhs.hs b/src/IHaskell/Convert/IpynbToLhs.hs --- a/src/IHaskell/Convert/IpynbToLhs.hs +++ b/src/IHaskell/Convert/IpynbToLhs.hs @@ -4,11 +4,8 @@ module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where import IHaskellPrelude -import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Char8 as CBS import Data.Aeson (decode, Object, Value(Array, Object, String)) import Data.Vector (Vector) @@ -49,12 +46,12 @@ = s convCell sty object | Just (String "code") <- lookup "cell_type" object, - Just (Array i) <- lookup "source" object, + Just (Array a) <- lookup "source" object, Just (Array o) <- lookup "outputs" object, - ~(Just i) <- concatWithPrefix (lhsCodePrefix sty) i, - o <- fromMaybe mempty (convOutputs sty o) + ~(Just i) <- concatWithPrefix (lhsCodePrefix sty) a, + o2 <- fromMaybe mempty (convOutputs sty o) = "\n" <> - lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o <> "\n" + lhsBeginCode sty <> i <> lhsEndCode sty <> "\n" <> o2 <> "\n" convCell _ _ = "IHaskell.Convert.convCell: unknown cell" convOutputs :: LhsStyle LT.Text diff --git a/src/IHaskell/Convert/LhsToIpynb.hs b/src/IHaskell/Convert/LhsToIpynb.hs --- a/src/IHaskell/Convert/LhsToIpynb.hs +++ b/src/IHaskell/Convert/LhsToIpynb.hs @@ -6,13 +6,11 @@ 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 Data.Char (isSpace) -import qualified Data.Vector as V (fromList, singleton) +import qualified Data.Vector as V import qualified Data.List as List import IHaskell.Flags (LhsStyle(LhsStyle)) @@ -97,12 +95,12 @@ groupClassified :: [CellLine LText] -> [Cell [LText]] groupClassified (CodeLine a: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 + | (c, x1) <- List.span isCode x, + (_, x2) <- List.span isEmptyMD x1, + (o, x3) <- List.span isOutput x2 + = Code (a : map untag c) (map untag o) : groupClassified x3 groupClassified (MarkdownLine a:x) - | (m, x) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x + | (m, x1) <- List.span isMD x = Markdown (a : map untag m) : groupClassified x1 groupClassified (OutputLine a:x) = Markdown [a] : groupClassified x groupClassified [] = [] diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -42,7 +42,7 @@ -- ** Image and data encoding functions Width, Height, - Base64(..), + Base64, encode64, base64, @@ -57,14 +57,10 @@ 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 qualified Data.ByteString.Base64 as Base64 -import Data.Aeson (Value) import System.Directory (getTemporaryDirectory, setCurrentDirectory) import Control.Concurrent.STM (atomically) @@ -80,28 +76,6 @@ type Base64 = Text --- | these instances cause the image, html etc. which look like: --- --- > Display --- > [Display] --- > IO [Display] --- > IO (IO Display) --- --- be run the IO and get rendered (if the frontend allows it) in the pretty form. -instance IHaskellDisplay a => IHaskellDisplay (IO a) where - display = (display =<<) - -instance IHaskellDisplay Display where - display = return - -instance IHaskellDisplay DisplayData where - display disp = return $ Display [disp] - -instance IHaskellDisplay a => IHaskellDisplay [a] where - display disps = do - displays <- mapM display disps - return $ ManyDisplay displays - -- | Encode many displays into a single one. All will be output. many :: [Display] -> Display many = ManyDisplay @@ -201,6 +175,7 @@ -- | Convenience function for client libraries. Switch to a temporary directory so that any files we -- create aren't visible. On Unix, this is usually /tmp. +switchToTmpDir :: IO () switchToTmpDir = void (try switchDir :: IO (Either SomeException ())) where switchDir = diff --git a/src/IHaskell/Eval/Completion.hs b/src/IHaskell/Eval/Completion.hs --- a/src/IHaskell/Eval/Completion.hs +++ b/src/IHaskell/Eval/Completion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE CPP, NoImplicitPrelude, DoAndIfThenElse, TypeFamilies, FlexibleContexts #-} {- | Description: Generates tab completion options. @@ -13,37 +13,21 @@ module IHaskell.Eval.Completion (complete, completionTarget, completionType, CompletionType(..)) 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 Data.ByteString.UTF8 hiding (drop, take, lines, length) import Data.Char -import Data.List (nub, init, last, head, elemIndex, concatMap) +import Data.List (nub, init, last, elemIndex, concatMap) import qualified Data.List.Split as Split import qualified Data.List.Split.Internals as Split -import Data.Maybe (fromJust) import System.Environment (getEnv) -import GHC hiding (Qualified) -#if MIN_VERSION_ghc(8,2,0) +import GHC import GHC.PackageDb -#elif MIN_VERSION_ghc(7,10,0) -import GHC.PackageDb (ExposedModule(exposedName)) -#endif import DynFlags import GhcMonad -import qualified GhcMonad -import PackageConfig import Outputable (showPpr) -import MonadUtils (MonadIO) - import System.Directory -import System.FilePath import Control.Exception (try) import System.Console.Haskeline.Completion @@ -63,16 +47,15 @@ | KernelOption String | Extension String deriving (Show, Eq) + #if MIN_VERSION_ghc(8,2,0) +exposedName :: (a, b) -> a exposedName = fst #endif -#if MIN_VERSION_ghc(7,10,0) + +extName :: FlagSpec flag -> String extName (FlagSpec { flagSpecName = name }) = name -#else -extName (name, _, _) = name -exposedName = id -#endif complete :: String -> Int -> Interpreter (String, [String]) complete code posOffset = do -- Get the line of code which is being completed and offset within that line @@ -93,11 +76,7 @@ let Just db = pkgDatabase flags getNames = map (moduleNameString . exposedName) . exposedModules -#if MIN_VERSION_ghc(8,0,0) moduleNames = nub $ concatMap getNames $ concatMap snd db -#else - moduleNames = nub $ concatMap getNames db -#endif let target = completionTarget line pos completion = completionType line pos target @@ -106,7 +85,7 @@ case completion of HsFilePath _ match -> match FilePath _ match -> match - otherwise -> intercalate "." target + _ -> intercalate "." target options <- case completion of Empty -> return [] @@ -114,9 +93,8 @@ Identifier candidate -> return $ filter (candidate `isPrefixOf`) unqualNames - Qualified moduleName candidate -> do - trueName <- getTrueModuleName moduleName - let prefix = intercalate "." [moduleName, candidate] + Qualified mName candidate -> do + let prefix = intercalate "." [mName, candidate] completions = filter (prefix `isPrefixOf`) qualNames return completions @@ -127,17 +105,11 @@ return $ filter (prefix `isPrefixOf`) moduleNames DynFlag ext -> do - -- Possibly leave out the fLangFlags? The -XUndecidableInstances vs. obsolete - -- -fallow-undecidable-instances. - let kernelOptNames = concatMap getSetName kernelOpts - otherNames = ["-package", "-Wall", "-w"] + -- Possibly leave out the fLangFlags? + let otherNames = ["-package", "-Wall", "-w"] fNames = map extName fFlags ++ -#if MIN_VERSION_ghc(8,0,0) map extName wWarningFlags ++ -#else - map extName fWarningFlags ++ -#endif map extName fLangFlags fNoNames = map ("no" ++) fNames fAllNames = map ("-f" ++) (fNames ++ fNoNames) @@ -155,34 +127,17 @@ xNoNames = map ("No" ++) xNames return $ filter (ext `isPrefixOf`) $ xNames ++ xNoNames - HsFilePath lineUpToCursor match -> completePathWithExtensions [".hs", ".lhs"] + HsFilePath lineUpToCursor _match -> completePathWithExtensions [".hs", ".lhs"] lineUpToCursor - FilePath lineUpToCursor match -> completePath lineUpToCursor + FilePath lineUpToCursor _match -> completePath lineUpToCursor KernelOption str -> return $ filter (str `isPrefixOf`) (concatMap getOptionName kernelOpts) return (matchedText, options) -getTrueModuleName :: String -> Interpreter String -getTrueModuleName name = do - -- Only use the things that were actually imported - let onlyImportDecl (IIDecl decl) = Just decl - onlyImportDecl _ = Nothing - -- Get all imports that we use. - 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. - flags <- getSessionDynFlags - let qualifiedImports = filter (isJust . ideclAs) imports - hasName imp = name == (showPpr flags . fromJust . ideclAs) imp - case find hasName qualifiedImports of - Nothing -> return name - Just trueImp -> return $ showPpr flags $ unLoc $ ideclName trueImp - -- | Get which type of completion this is from the surrounding context. completionType :: String -- ^ The line on which the completion is being done. -> Int -- ^ Location of the cursor in the line. @@ -241,7 +196,7 @@ else [] Left _ -> Empty - cursorInString str loc = nquotes (take loc str) `mod` 2 /= 0 + cursorInString str lcn = nquotes (take lcn str) `mod` 2 /= (0 :: Int) nquotes ('\\':'"':xs) = nquotes xs nquotes ('"':xs) = 1 + nquotes xs @@ -255,12 +210,12 @@ where go acc rest = case rest of - '"':'\\':rem -> go ('"' : acc) rem - '"':rem -> acc - ' ':'\\':rem -> go (' ' : acc) rem - ' ':rem -> acc - x:rem -> go (x : acc) rem - [] -> acc + '"':'\\':xs -> go ('"' : acc) xs + '"':_ -> acc + ' ':'\\':xs -> go (' ' : acc) xs + ' ':_ -> acc + x:xs -> go (x : acc) xs + [] -> acc -- | Get the word under a given cursor location. completionTarget :: String -> Int -> [String] @@ -269,7 +224,7 @@ pieceToComplete = map fst <$> find (elem cursor . map snd) pieces 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 Split.delimiter = Split.Delimiter [uncurry isDelim] -- Condense multiple delimiters into one and then drop them. @@ -278,7 +233,7 @@ } isDelim :: Char -> Int -> Bool - isDelim char idx = char `elem` neverIdent || isSymbol char + isDelim char _idx = char `elem` neverIdent || isSymbol char splitAlongCursor :: [[(Char, Int)]] -> [[(Char, Int)]] splitAlongCursor [] = [] @@ -318,8 +273,8 @@ acceptAll = const True completePathWithExtensions :: [String] -> String -> Interpreter [String] -completePathWithExtensions extensions line = - completePathFilter (extensionIsOneOf extensions) acceptAll line "" +completePathWithExtensions extns line = + completePathFilter (extensionIsOneOf extns) acceptAll line "" where acceptAll = const True extensionIsOneOf exts str = any correctEnding exts diff --git a/src/IHaskell/Eval/Evaluate.hs b/src/IHaskell/Eval/Evaluate.hs --- a/src/IHaskell/Eval/Evaluate.hs +++ b/src/IHaskell/Eval/Evaluate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE NoOverloadedStrings, TypeSynonymInstances, GADTs, CPP #-} +{-# LANGUAGE NoOverloadedStrings, NoImplicitPrelude, TypeSynonymInstances, GADTs, CPP #-} {- | Description : Wrapper around GHC API, exposing a single `evaluate` interface that runs a statement, declaration, import, or directive. @@ -19,64 +19,36 @@ ) 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 (forkIO, threadDelay) import Data.Foldable (foldMap) -import Prelude (putChar, head, tail, last, init, (!!)) -import Data.List (findIndex, and, foldl1, nubBy) -import Text.Printf +import Prelude (head, tail, last, init) +import Data.List (nubBy) import Data.Char as Char import Data.Dynamic -import Data.Typeable import qualified Data.Serialize as Serialize import System.Directory #if !MIN_VERSION_base(4,8,0) import System.Posix.IO (createPipe) #endif import System.Posix.IO (fdToHandle) -import System.IO (hGetChar, hSetEncoding, utf8, hFlush) +import System.IO (hGetChar, hSetEncoding, utf8) import System.Random (getStdGen, randomRs) -import Unsafe.Coerce -import Control.Monad (guard) import System.Process import System.Exit -import Data.Maybe (fromJust) -import qualified Control.Monad.IO.Class as MonadIO (MonadIO, liftIO) -import qualified MonadUtils (MonadIO, liftIO) +import Data.Maybe (mapMaybe) import System.Environment (getEnv) -import qualified Data.Map as Map import qualified GHC.Paths -import NameSet -import Name -import PprTyThing import InteractiveEval import DynFlags -import Type import Exception (gtry) import HscTypes -import HscMain -import qualified Linker -import TcType -import Unify -import InstEnv -#if MIN_VERSION_ghc(7, 8, 0) -import GhcMonad (liftIO, withSession) -#else -import GhcMonad (withSession) -#endif +import GhcMonad (liftIO) import GHC hiding (Stmt, TypeSig) import Exception hiding (evaluate) import Outputable hiding ((<>)) import Packages -import Module hiding (Module) -import qualified Pretty -import FastString import Bag import qualified ErrUtils @@ -87,18 +59,18 @@ import IHaskell.Display import qualified IHaskell.Eval.Hoogle as Hoogle import IHaskell.Eval.Util -import IHaskell.Eval.Widgets import IHaskell.BrokenPackages -import qualified IHaskell.IPython.Message.UUID as UUID import StringUtils (replace, split, strip, rstrip) +#if MIN_VERSION_ghc(8,2,0) +import FastString (unpackFS) +#else import Paths_ihaskell (version) import Data.Version (versionBranch) +#endif -data ErrorOccurred = Success - | Failure - deriving (Show, Eq) + -- | Set GHC's verbosity for debugging ghcVerbosity :: Maybe Int ghcVerbosity = Nothing -- Just 5 @@ -126,12 +98,7 @@ write state x = when (kernelDebug state) $ liftIO $ hPutStrLn stderr $ "DEBUG: " ++ x type Interpreter = Ghc -#if MIN_VERSION_ghc(7, 8, 0) - -- GHC 7.8 exports a MonadIO instance for Ghc -#else -instance MonadIO.MonadIO Interpreter where - liftIO = MonadUtils.liftIO -#endif + requiredGlobalImports :: [String] requiredGlobalImports = [ "import qualified Prelude as IHaskellPrelude" @@ -151,12 +118,12 @@ -- | Interpreting function for testing. testInterpret :: Interpreter a -> IO a -testInterpret val = interpret GHC.Paths.libdir False (const val) +testInterpret v = interpret GHC.Paths.libdir False (const v) -- | Evaluation function for testing. testEvaluate :: String -> IO () testEvaluate str = void $ testInterpret $ - evaluate defaultKernelState str (const $ return ()) (\state _ -> return state) + evaluate defaultKernelState str (\_ _ -> return ()) (\state _ -> return state) -- | Run an interpreting action. This is effectively runGhc with initialization and importing. First -- argument indicates whether `stdin` is handled specially, which cannot be done in a testing @@ -194,23 +161,13 @@ Just cfg -> let PackageName name = packageName cfg in unpackFS name -#elif MIN_VERSION_ghc(8,0,0) - fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg) -#elif MIN_VERSION_ghc(7,10,2) - fromMaybe "(unknown)" (packageKeyPackageIdString dflags $ packageConfigId pkg_cfg) -#elif MIN_VERSION_ghc(7,10,0) - packageKeyPackageIdString dflags . packageConfigId #else - packageIdString . packageConfigId + fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg) #endif getPackageConfigs :: DynFlags -> [PackageConfig] getPackageConfigs dflags = -#if MIN_VERSION_ghc(8,0,0) foldMap snd pkgDb -#else - pkgDb -#endif where Just pkgDb = pkgDatabase dflags @@ -222,9 +179,9 @@ -- version of the ihaskell library. Also verify that the packages we load are not broken. dflags <- getSessionDynFlags broken <- liftIO getBrokenPackages - (dflags, _) <- liftIO $ initPackages dflags - let db = getPackageConfigs dflags - packageNames = map (packageIdString' dflags) db + (dflgs, _) <- liftIO $ initPackages dflags + let db = getPackageConfigs dflgs + packageNames = map (packageIdString' dflgs) db initStr = "ihaskell-" @@ -236,17 +193,6 @@ iHaskellPkgName = initStr ++ intercalate "." (map show (versionBranch version)) #endif -#if !MIN_VERSION_ghc(8,0,0) - unitId = packageId -#endif - - dependsOnRight pkg = not $ null $ do - pkg <- db - depId <- depends pkg - dep <- filter ((== depId) . unitId) db - let idString = packageIdString' dflags dep - guard (iHaskellPkgName `isPrefixOf` idString) - displayPkgs = [ pkgName | pkgName <- packageNames , Just (x:_) <- [stripPrefix initStr pkgName] @@ -257,17 +203,20 @@ -- Generate import statements all Display modules. let capitalize :: String -> String + capitalize [] = [] capitalize (first:rest) = Char.toUpper first : rest importFmt = "import IHaskell.Display.%s" - dropFirstAndLast :: [a] -> [a] - dropFirstAndLast = reverse . drop 1 . reverse . drop 1 - toImportStmt :: String -> String #if MIN_VERSION_ghc(8,2,0) + toImportStmt :: String -> String toImportStmt = printf importFmt . concatMap capitalize . drop 1 . split "-" #else + dropFirstAndLast :: [a] -> [a] + dropFirstAndLast = reverse . drop 1 . reverse . drop 1 + + toImportStmt :: String -> String toImportStmt = printf importFmt . concatMap capitalize . dropFirstAndLast . split "-" #endif @@ -297,8 +246,9 @@ void $ execStmt "let it = ()" execOptions -- | Publisher for IHaskell outputs. The first argument indicates whether this output is final --- (true) or intermediate (false). -type Publisher = (EvaluationResult -> IO ()) +-- (true) or intermediate (false). The second argument indicates whether the evaluation +-- completed successfully (Success) or an error occurred (Failure). +type Publisher = (EvaluationResult -> ErrorOccurred -> IO ()) -- | Output of a command evaluation. data EvalOut = @@ -311,11 +261,11 @@ } cleanString :: String -> String -cleanString x = if allBrackets +cleanString istr = if allBrackets then clean - else str + else istr where - str = strip x + str = strip istr l = lines str allBrackets = all (fAny [isPrefixOf ">", null]) l fAny fs x = any ($ x) fs @@ -346,14 +296,16 @@ when (getLintStatus kernelState /= LintOff) $ liftIO $ do lintSuggestions <- lint cmds unless (noResults lintSuggestions) $ - output $ FinalResult lintSuggestions [] [] + output (FinalResult lintSuggestions [] []) Success runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) -- Print all parse errors. - errs -> do + _ -> do forM_ errs $ \err -> do out <- evalCommand output err kernelState - liftIO $ output $ FinalResult (evalResult out) [] [] + liftIO $ output + (FinalResult (evalResult out) [] []) + (evalStatus out) return kernelState return updated { getExecutionCounter = execCount + 1 } @@ -385,9 +337,10 @@ Just disps -> evalResult evalOut <> disps -- Output things only if they are non-empty. - let empty = noResults result && null (evalPager evalOut) - unless empty $ - liftIO $ output $ FinalResult result (evalPager evalOut) [] + unless (noResults result && null (evalPager evalOut)) $ + liftIO $ output + (FinalResult result (evalPager evalOut) []) + (evalStatus evalOut) let tempMsgs = evalMsgs evalOut tempState = evalState evalOut { evalMsgs = [] } @@ -431,7 +384,7 @@ -> [WidgetMsg] -> (KernelState -> [WidgetMsg] -> IO KernelState) -> Interpreter KernelState -flushWidgetMessages state evalMsgs widgetHandler = do +flushWidgetMessages state evalmsgs widgetHandler = do -- Capture all widget messages queued during code execution extracted <- extractValue "IHaskell.Eval.Widgets.relayWidgetMessages" liftIO $ @@ -444,16 +397,12 @@ messages <- messagesIO -- Handle all the widget messages - let commMessages = evalMsgs ++ messages + let commMessages = evalmsgs ++ messages widgetHandler state commMessages getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc -#if MIN_VERSION_ghc(8,0,0) getErrMsgDoc = ErrUtils.pprLocErrMsg -#else -getErrMsgDoc msg = ErrUtils.errMsgShortString msg $$ ErrUtils.errMsgContext msg -#endif safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler @@ -534,8 +483,8 @@ -- Return whether this module prevents the loading of the one we're trying to load. If a module B -- exist, we cannot load A.B. All modules must have unique last names (where A.B has last name B). -- However, we *can* just reload a module. - preventsLoading mod = - let pieces = moduleNameOf mod + preventsLoading md = + let pieces = moduleNameOf md in last namePieces == last pieces && namePieces /= pieces -- If we've loaded anything with the same last name, we can't use this. Otherwise, GHC tries to load @@ -551,7 +500,7 @@ Nothing -> doLoadModule modName modName -- | Directives set via `:set`. -evalCommand output (Directive SetDynFlag flagsStr) state = safely state $ do +evalCommand _output (Directive SetDynFlag flagsStr) state = safely state $ do write state $ "All Flags: " ++ flagsStr -- Find which flags are IHaskell flags, and which are GHC flags @@ -569,14 +518,14 @@ if null flags then do - flags <- getSessionDynFlags + flgs <- getSessionDynFlags return EvalOut { evalStatus = Success , evalResult = Display - [ plain $ showSDoc flags $ vcat - [ pprDynFlags False flags - , pprLanguages False flags + [ plain $ showSDoc flgs $ vcat + [ pprDynFlags False flgs + , pprLanguages False flgs ] ] , evalState = state @@ -585,9 +534,9 @@ } else do -- Apply all IHaskell flag updaters to the state to get the new state - let state' = foldl' (.) id (map (fromJust . ihaskellFlagUpdater) ihaskellFlags) state + let state' = foldl' (.) id (mapMaybe ihaskellFlagUpdater ihaskellFlags) state errs <- setFlags ghcFlags - let display = + let disp = case errs of [] -> mempty _ -> displayError $ intercalate "\n" errs @@ -604,7 +553,7 @@ return EvalOut { evalStatus = Success - , evalResult = display + , evalResult = disp , evalState = state' , evalPager = [] , evalMsgs = [] @@ -615,7 +564,7 @@ let set = concatMap (" -X" ++) $ words opts evalCommand output (Directive SetDynFlag set) state -evalCommand output (Directive LoadModule mods) state = wrapExecution state $ do +evalCommand _output (Directive LoadModule mods) state = wrapExecution state $ do write state $ "Load Module: " ++ mods let stripped@(firstChar:remainder) = mods (modules, removeModule) = @@ -630,9 +579,9 @@ return mempty -evalCommand a (Directive SetOption opts) state = do +evalCommand _output (Directive SetOption opts) state = do write state $ "Option: " ++ opts - let (existing, nonExisting) = partition optionExists $ words opts + let nonExisting = filter (not . optionExists) $ words opts if not $ null nonExisting then let err = "No such options: " ++ intercalate ", " nonExisting in return @@ -682,15 +631,16 @@ doLoadModule filename modName return (ManyDisplay displays) -evalCommand publish (Directive ShellCmd ('!':cmd)) state = wrapExecution state $ - case words cmd of +evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $ + -- Assume the first character of 'cmd' is '!'. + case words $ drop 1 cmd of "cd":dirs -> do -- Get home so we can replace '~` with it. homeEither <- liftIO (try $ getEnv "HOME" :: IO (Either SomeException String)) let home = case homeEither of - Left _ -> "~" - Right val -> val + Left _ -> "~" + Right v -> v let directory = replace "~" home $ unwords dirs exists <- liftIO $ doesDirectoryExist directory @@ -701,19 +651,19 @@ liftIO $ setCurrentDirectory directory -- Set the directory for user code. - let cmd = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ + let cmd1 = printf "IHaskellDirectory.setCurrentDirectory \"%s\"" $ replace " " "\\ " $ replace "\"" "\\\"" directory - execStmt cmd execOptions + _ <- execStmt cmd1 execOptions return mempty else return $ displayError $ printf "No such directory: '%s'" directory - cmd -> liftIO $ do - (pipe, handle) <- createPipe' - let initProcSpec = shell $ unwords cmd + cmd1 -> liftIO $ do + (pipe, hdl) <- createPipe' + let initProcSpec = shell $ unwords cmd1 procSpec = initProcSpec { std_in = Inherit - , std_out = UseHandle handle - , std_err = UseHandle handle + , std_out = UseHandle hdl + , std_err = UseHandle hdl } (_, _, _, process) <- createProcess procSpec @@ -741,21 +691,17 @@ modifyMVar_ outputAccum (return . (++ nextChunk)) -- Check if we're done. - exitCode <- getProcessExitCode process - let computationDone = isJust exitCode - - when computationDone $ do - nextChunk <- readChars pipe "" maxSize - modifyMVar_ outputAccum (return . (++ nextChunk)) - - if not computationDone - then do + mExitCode <- getProcessExitCode process + case mExitCode of + Nothing -> do -- Write to frontend and repeat. - readMVar outputAccum >>= output + readMVar outputAccum >>= flip output Success loop - else do + Just exitCode -> do + next <- readChars pipe "" maxSize + modifyMVar_ outputAccum (return . (++ next)) out <- readMVar outputAccum - case fromJust exitCode of + case exitCode of ExitSuccess -> return $ Display [plain out] ExitFailure code -> do let errMsg = "Process exited with error code " ++ show code @@ -819,11 +765,11 @@ strings <- unlines <$> getDescription str -- Make pager work without html by porting to newer architecture - let htmlify str = + let htmlify str1 = html $ concat [ "
" , "" @@ -888,8 +834,8 @@ -- If it typechecks as a DecsQ, we do not want to display the DecsQ, we just want the -- declaration made. do - write state "Suppressing display for template haskell declaration" - GHC.runDecls expr + _ <- write state "Suppressing display for template haskell declaration" + _ <- GHC.runDecls expr return EvalOut { evalStatus = Success @@ -941,7 +887,7 @@ removeSvg (Display disps) = Display $ filter (not . isSvg) disps removeSvg (ManyDisplay disps) = ManyDisplay $ map removeSvg disps - useDisplay displayExpr = do + useDisplay _displayExpr = do -- If there are instance matches, convert the object into a Display. We also serialize it into a -- bytestring. We get the bytestring IO action as a dynamic and then convert back to a bytestring, -- which we promptly unserialize. Note that attempting to do this without the serialization to @@ -957,8 +903,8 @@ Failure -> return evalOut Success -> wrapExecution state $ do -- Compile the display data into a bytestring. - let compileExpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)" - displayedBytestring <- dynCompileExpr compileExpr + let cexpr = "fmap IHaskell.Display.serializeDisplay (IHaskell.Display.display it)" + displayedBytestring <- dynCompileExpr cexpr -- Convert from the bytestring into a display. case fromDynamic displayedBytestring of @@ -967,30 +913,27 @@ bytestring <- liftIO bytestringIO case Serialize.decode bytestring of Left err -> error err - Right display -> + Right disp -> return $ if useSvg state - then display :: Display - else removeSvg display + then disp :: Display + else removeSvg disp #if MIN_VERSION_ghc(8,2,0) - isIO expr = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr + isIO exp = attempt $ exprType TM_Inst $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp #else - isIO expr = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" expr + isIO exp = attempt $ exprType $ printf "((\\x -> x) :: IO a -> IO a) (%s)" exp #endif postprocessShowError :: EvalOut -> EvalOut postprocessShowError evalOut = evalOut { evalResult = Display $ map postprocess disps } where Display disps = evalResult evalOut - text = extractPlain disps + txt = extractPlain disps - postprocess (DisplayData MimeHtml _) = html $ printf - fmt - unshowableType - (formatErrorWithClass "err-msg collapse" - text) - script + postprocess (DisplayData MimeHtml _) = + html $ printf fmt unshowableType + (formatErrorWithClass "err-msg collapse" txt) script where fmt = "
Unshowable:%s%s
" script = unlines @@ -1005,7 +948,7 @@ postprocess other = other unshowableType = fromMaybe "" $ do - let pieces = words text + let pieces = words txt before = takeWhile (/= "arising") pieces after = init $ unwords $ tail $ dropWhile (/= "(Show") before @@ -1052,7 +995,7 @@ , evalMsgs = [] } -evalCommand _ (Pragma (PragmaUnsupported pragmaType) pragmas) state = wrapExecution state $ +evalCommand _ (Pragma (PragmaUnsupported pragmaType) _pragmas) state = wrapExecution state $ return $ displayError $ "Pragmas of type " ++ pragmaType ++ "\nare not supported." evalCommand output (Pragma PragmaLanguage pragmas) state = do @@ -1080,14 +1023,10 @@ -- Compile loaded modules. flags <- getSessionDynFlags errRef <- liftIO $ newIORef [] - setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo + _ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo flags { hscTarget = objTarget flags -#if MIN_VERSION_ghc(8,0,0) - , log_action = \dflags sev srcspan ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) -#else - , log_action = \dflags sev srcspan ppr msg -> modifyIORef' errRef (showSDoc flags msg :) -#endif + , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) } -- Load the new target. @@ -1113,7 +1052,7 @@ Succeeded -> IIDecl (simpleImportDecl $ mkModuleName modName) : importedModules -- Switch back to interpreted mode. - setSessionDynFlags flags + _ <- setSessionDynFlags flags case result of Succeeded -> return mempty @@ -1127,35 +1066,20 @@ print $ show exception -- Explicitly clear targets setTargets [] - load LoadAllTargets + _ <- load LoadAllTargets -- Switch to interpreted mode! flags <- getSessionDynFlags - setSessionDynFlags flags { hscTarget = HscInterpreted } + _ <- setSessionDynFlags flags { hscTarget = HscInterpreted } -- Return to old context, make sure we have `it`. setContext imported initializeItVariable return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception -#if MIN_VERSION_ghc(7,8,0) -objTarget flags = defaultObjectTarget $ targetPlatform flags -#else -objTarget flags = defaultObjectTarget -#endif -keepingItVariable :: Interpreter a -> Interpreter a -keepingItVariable act = do - -- Generate the it variable temp name - gen <- liftIO getStdGen - let rand = take 20 $ randomRs ('0', '9') gen - var name = name ++ rand - goStmt s = execStmt s execOptions - itVariable = var "it_var_temp_" - goStmt $ printf "let %s = it" itVariable - val <- act - goStmt $ printf "let it = %s" itVariable - act +objTarget :: DynFlags -> HscTarget +objTarget flags = defaultObjectTarget $ targetPlatform flags data Captured a = CapturedStmt String | CapturedIO (IO a) @@ -1208,44 +1132,24 @@ runWithResult (CapturedStmt str) = goStmt str runWithResult (CapturedIO io) = do - status <- gcatch (liftIO io >> return NoException) (return . AnyException) + stat <- gcatch (liftIO io >> return NoException) (return . AnyException) return $ - case status of + case stat of NoException -> ExecComplete (Right []) 0 AnyException e -> ExecComplete (Left e) 0 -- Initialize evaluation context. - results <- forM initStmts goStmt + forM_ initStmts goStmt -#if __GLASGOW_HASKELL__ >= 800 -- This works fine on GHC 8.0 and newer dyn <- dynCompileExpr readVariable pipe <- case fromDynamic dyn of Nothing -> fail "Evaluate: Bad pipe" Just fd -> liftIO $ do - handle <- fdToHandle fd - hSetEncoding handle utf8 - return handle -#else - -- Get the pipe to read printed output from. This is effectively the source code of dynCompileExpr - -- from GHC API's InteractiveEval. However, instead of using a `Dynamic` as an intermediary, it just - -- directly reads the value. This is incredibly unsafe! However, for some reason the `getContext` - -- and `setContext` required by dynCompileExpr (to import and clear Data.Dynamic) cause issues with - -- data declarations being updated (e.g. it drops newer versions of data declarations for older ones - -- for unknown reasons). First, compile down to an HValue. - let pipeExpr = printf "let %s = %s" (var "pipe_var_") readVariable - Just (_, hValues, _) <- withSession $ liftIO . flip hscStmt pipeExpr - -- Then convert the HValue into an executable bit, and read the value. - pipe <- liftIO $ do - fds <- unsafeCoerce hValues - fd <- case fds of - fd : _ -> return fd - [] -> fail "Failed to evaluate pipes" - _ -> fail $ "Expected one fd, saw "++show (length fds) - handle <- fdToHandle fd - hSetEncoding handle utf8 - return handle -#endif + hdl <- fdToHandle fd + hSetEncoding hdl utf8 + return hdl + -- Keep track of whether execution has completed. completed <- liftIO $ newMVar False finishedReading <- liftIO newEmptyMVar @@ -1258,9 +1162,6 @@ ms = 1000 delay = 100 * ms - -- How much to read each time. - chunkSize = 100 - -- Maximum size of the output (after which we truncate). maxSize = 100 * 1000 @@ -1286,7 +1187,7 @@ -- We're done reading. putMVar finishedReading True - liftIO $ forkIO loop + _ <- liftIO $ forkIO loop result <- gfinally (runWithResult stmt) $ do -- Execution is done. @@ -1320,10 +1221,10 @@ case cmd of CapturedStmt stmt -> write state $ "Statement:\n" ++ stmt - CapturedIO io -> + CapturedIO _ -> write state "Evaluating Action" - (printed, result) <- capturedEval output cmd + (printed, result) <- capturedEval (flip output Success) cmd case result of ExecComplete (Right names) _ -> do dflags <- getSessionDynFlags @@ -1333,14 +1234,14 @@ name == "it" || name == "it" ++ show (getExecutionCounter state) nonItNames = filter (not . isItName) allNames - output = [ plain printed + oput = [ plain printed | not . null $ strip printed ] write state $ "Names: " ++ show allNames -- Display the types of all bound names if the option is on. This is similar to GHCi :set +t. if not $ useShowTypes state - then return $ Display output + then return $ Display oput else do -- Get all the type strings. types <- forM nonItNames $ \name -> do @@ -1355,11 +1256,11 @@ htmled = unlines $ map formatGetType types return $ - case extractPlain output of + case extractPlain oput of "" -> Display [html htmled] -- Return plain and html versions. Previously there was only a plain version. - text -> Display [plain $ joined ++ "\n" ++ text, html $ htmled ++ mono text] + txt -> Display [plain $ joined ++ "\n" ++ txt, html $ htmled ++ mono txt] ExecComplete (Left exception) _ -> throw exception ExecBreak{} -> error "Should not break." @@ -1367,20 +1268,20 @@ -- Read from a file handle until we hit a delimiter or until we've read as many characters as -- requested readChars :: Handle -> String -> Int -> IO String -readChars handle delims 0 = +readChars _handle _delims 0 = -- If we're done reading, return nothing. return [] -readChars handle delims nchars = do +readChars hdl delims nchars = do -- Try reading a single character. It will throw an exception if the handle is already closed. - tryRead <- gtry $ hGetChar handle :: IO (Either SomeException Char) + tryRead <- gtry $ hGetChar hdl :: IO (Either SomeException Char) case tryRead of - Right char -> + Right ch -> -- If this is a delimiter, stop reading. - if char `elem` delims - then return [char] + if ch `elem` delims + then return [ch] else do - next <- readChars handle delims (nchars - 1) - return $ char : next + next <- readChars hdl delims (nchars - 1) + return $ ch : next -- An error occurs at the end of the stream, so just stop reading. Left _ -> return [] @@ -1403,13 +1304,10 @@ where fixDollarSigns = replace "$" "$" useDashV = "\n Use -v to see a list of the files searched for." - isShowError err = - "No instance for (Show" `isPrefixOf` err && - isInfixOf " arising from a use of `print'" err formatParseError :: StringLoc -> String -> ErrMsg -formatParseError (Loc line col) = - printf "Parse error (line %d, column %d): %s" line col +formatParseError (Loc ln col) = + printf "Parse error (line %d, column %d): %s" ln col formatGetType :: String -> String formatGetType = printf "%s" diff --git a/src/IHaskell/Eval/Hoogle.hs b/src/IHaskell/Eval/Hoogle.hs --- a/src/IHaskell/Eval/Hoogle.hs +++ b/src/IHaskell/Eval/Hoogle.hs @@ -1,29 +1,31 @@ -{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module IHaskell.Eval.Hoogle ( search, document, render, OutputFormat(..), - HoogleResult, + HoogleResult(..), + HoogleResponse(..), + parseResponse, ) where +import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy as LBS +import Data.Either (either) 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 +import Data.Char (isAlphaNum, isAscii) +import qualified Data.List as List +import qualified Data.Text as T +import Data.Vector (toList) import Network.HTTP.Client import Network.HTTP.Client.TLS -import Data.Aeson -import qualified Data.List as List -import Data.Char (isAscii, isAlphaNum) - -import IHaskell.IPython -import StringUtils (split, strip, replace) +import StringUtils (replace, split, strip) -- | Types of formats to render output to. data OutputFormat = Plain -- ^ Render to plain text. @@ -40,17 +42,19 @@ data HoogleResponseList = HoogleResponseList [HoogleResponse] instance FromJSON HoogleResponseList where - parseJSON (Object obj) = do - results <- obj .: "results" - HoogleResponseList <$> mapM parseJSON results + parseJSON (Array arr) = + HoogleResponseList <$> mapM parseJSON (toList arr) - parseJSON _ = fail "Expected object with 'results' field." + parseJSON _ = fail "Expected array." instance FromJSON HoogleResponse where parseJSON (Object obj) = - HoogleResponse <$> obj .: "location" <*> obj .: "self" <*> obj .: "docs" + HoogleResponse + <$> obj .: "url" + <*> (removeMarkup <$> obj .: "item") + <*> obj .: "docs" - parseJSON _ = fail "Expected object with fields: location, self, docs" + parseJSON _ = fail "Expected object with fields: url, item, docs" -- | Query Hoogle for the given string. This searches Hoogle using the internet. It returns either -- an error message or the successful JSON result. @@ -64,7 +68,7 @@ where queryUrl :: String -> String - queryUrl = printf "https://www.haskell.org/hoogle/?hoogle=%s&mode=json" + queryUrl = printf "http://hoogle.haskell.org/?hoogle=%s&mode=json" -- | Copied from the HTTP package. urlEncode :: String -> String @@ -92,27 +96,24 @@ -- | Search for a query on Hoogle. Return all search results. search :: String -> IO [HoogleResult] -search string = do - response <- query string - return $ - case response of - Left err -> [NoResult err] - Right json -> - case eitherDecode $ LBS.fromStrict $ CBS.pack json of - Left err -> [NoResult err] - Right results -> - case map SearchResult $ (\(HoogleResponseList l) -> l) results of - [] -> [NoResult "no matching identifiers found."] - res -> res +search string = either ((:[]) . NoResult) parseResponse <$> query string +parseResponse :: String -> [HoogleResult] +parseResponse jsn = + case eitherDecode $ LBS.fromStrict $ CBS.pack jsn of + Left err -> [NoResult err] + Right results -> + case map SearchResult $ (\(HoogleResponseList l) -> l) results of + [] -> [NoResult "no matching identifiers found."] + res -> res + -- | Look up an identifier on Hoogle. Return documentation for that identifier. If there are many -- identifiers, include documentation for all of them. document :: String -> IO [HoogleResult] document string = do matchingResults <- filter matches <$> search string - let results = map toDocResult matchingResults return $ - case results of + case mapMaybe toDocResult matchingResults of [] -> [NoResult "no matching identifiers found."] res -> res @@ -123,12 +124,14 @@ _ -> False matches _ = False - toDocResult (SearchResult resp) = DocResult resp + toDocResult (SearchResult resp) = Just $ DocResult resp + toDocResult (DocResult _) = Nothing + toDocResult (NoResult _) = Nothing -- | Render a Hoogle search result into an output format. render :: OutputFormat -> HoogleResult -> String render Plain = renderPlain -render HTML = renderHtml +render HTML = renderHtml -- | Render a Hoogle result to plain text. renderPlain :: HoogleResult -> String @@ -163,7 +166,7 @@ | "module" `isPrefixOf` string = let package = extractPackageName loc - in mod ++ " " ++ + in mdl ++ " " ++ span "hoogle-module" (link loc $ extractModule string) ++ packageSub package @@ -185,6 +188,12 @@ span "hoogle-class" (link loc $ extractNewtype string) ++ packageSub package + | "type" `isPrefixOf` string = + let package = extractPackageName loc + in nwt ++ " " ++ + span "hoogle-class" (link loc $ extractType string) ++ + packageSub package + | otherwise = let [name, args] = split "::" string package = extractPackageName loc @@ -201,8 +210,9 @@ extractClass = strip . replace "class" "" extractData = strip . replace "data" "" extractNewtype = strip . replace "newtype" "" + extractType = strip . replace "newtype" "" pkg = span "hoogle-head" "package" - mod = span "hoogle-head" "module" + mdl = span "hoogle-head" "module" cls = span "hoogle-head" "class" dat = span "hoogle-head" "data" nwt = span "hoogle-head" "newtype" @@ -224,37 +234,22 @@ packageAndModuleSub (Just package) (Just modname) = span "hoogle-sub" $ "(" ++ pkg ++ " " ++ span "hoogle-package" package ++ - ", " ++ mod ++ " " ++ span "hoogle-module" modname ++ ")" + ", " ++ mdl ++ " " ++ span "hoogle-module" modname ++ ")" renderDocs :: String -> String -renderDocs doc = - let groups = List.groupBy bothAreCode $ lines doc - nonull = filter (not . null . strip) - bothAreCode s1 s2 = - 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 +renderDocs doc = div' "hoogle-doc" doc extractPackageName :: String -> Maybe String -extractPackageName link = do - let pieces = split "/" link +extractPackageName lnk = do + let pieces = split "/" lnk archiveLoc <- List.elemIndex "archive" pieces latestLoc <- List.elemIndex "latest" pieces guard $ latestLoc - archiveLoc == 2 return $ pieces List.!! (latestLoc - 1) extractModuleName :: String -> Maybe String -extractModuleName link = do - let pieces = split "/" link - guard $ not $ null pieces - let html = fromJust $ lastMay pieces - mod = replace "-" "." $ takeWhile (/= '.') html - return mod +extractModuleName lnk = + replace "-" "." . takeWhile (/= '.') <$> lastMay (split "/" lnk) div' :: String -> String -> String div' = printf "
%s
" @@ -264,3 +259,19 @@ link :: String -> String -> String link = printf "%s" + +-- | very explicit cleaning of the type signature in the hoogle 5 response, +-- to remove html markup and escaped characters. +removeMarkup :: String -> String +removeMarkup s = T.unpack $ List.foldl (flip ($)) (T.pack s) replaceAll + where replacements :: [ (T.Text, T.Text) ] + replacements = [ ( "", "" ) + , ( "", "" ) + , ( "<0>", "" ) + , ( "", "" ) + , ( ">", ">" ) + , ( "<", "<" ) + , ( "", "") + , ( "", "") + ] + replaceAll = uncurry T.replace <$> replacements diff --git a/src/IHaskell/Eval/Info.hs b/src/IHaskell/Eval/Info.hs --- a/src/IHaskell/Eval/Info.hs +++ b/src/IHaskell/Eval/Info.hs @@ -4,11 +4,6 @@ module IHaskell.Eval.Info (info) 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 IHaskell.Eval.Evaluate (typeCleaner, Interpreter) diff --git a/src/IHaskell/Eval/Inspect.hs b/src/IHaskell/Eval/Inspect.hs --- a/src/IHaskell/Eval/Inspect.hs +++ b/src/IHaskell/Eval/Inspect.hs @@ -7,11 +7,6 @@ module IHaskell.Eval.Inspect (inspect) 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 qualified Prelude as P @@ -22,7 +17,6 @@ import IHaskell.Eval.Evaluate (Interpreter) import IHaskell.Display import IHaskell.Eval.Util (getType) -import IHaskell.Types -- | Characters used in Haskell operators. operatorChars :: String @@ -34,7 +28,7 @@ -- | Compute the identifier that is being queried. getIdentifier :: String -> Int -> String -getIdentifier code pos = identifier +getIdentifier code _pos = identifier where chunks = splitOn whitespace code lastChunk = P.last chunks :: String diff --git a/src/IHaskell/Eval/Lint.hs b/src/IHaskell/Eval/Lint.hs --- a/src/IHaskell/Eval/Lint.hs +++ b/src/IHaskell/Eval/Lint.hs @@ -3,33 +3,21 @@ module IHaskell.Eval.Lint (lint) where import IHaskellPrelude -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Char8 as CBS -import Prelude (head, tail, last) -import Control.Monad -import Data.List (findIndex) -import Data.Char -import Data.Monoid +import Prelude (last) import Data.Maybe (mapMaybe) import System.IO.Unsafe (unsafePerformIO) import Language.Haskell.Exts.Syntax hiding (Module) import qualified Language.Haskell.Exts.Syntax as SrcExts import Language.Haskell.Exts (parseFileContentsWithMode) -import Language.Haskell.Exts.Build (doE) import Language.Haskell.Exts hiding (Module) -import Language.Haskell.Exts.SrcLoc import Language.Haskell.HLint as HLint import Language.Haskell.HLint3 import IHaskell.Types import IHaskell.Display -import IHaskell.IPython import IHaskell.Eval.Parser hiding (line) import StringUtils (replace) @@ -65,10 +53,9 @@ -- Get hlint settings (flags, classify, hint) <- readMVar hlintSettings - let mode = hseFlags flags -- create 'suggestions' - let modules = mapMaybe (createModule mode) blocks + let modules = mapMaybe (createModule (hseFlags flags)) blocks ideas = applyHints classify hint (map (\m -> (m, [])) modules) suggestions = mapMaybe showIdea $ filter (not . ignoredIdea) ideas @@ -78,33 +65,33 @@ else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions] where autoSettings' = do - (fixities, classify, hints) <- autoSettings + (fixts, classify, hints) <- autoSettings let hidingIgnore = Classify Ignore "Unnecessary hiding" "" "" - return (fixities, hidingIgnore:classify, hints) + return (fixts, hidingIgnore:classify, hints) ignoredIdea idea = ideaSeverity idea == Ignore showIdea :: Idea -> Maybe LintSuggestion showIdea idea = case ideaTo idea of Nothing -> Nothing - Just whyNot -> + Just wn -> Just Suggest { line = srcSpanStartLine $ ideaSpan idea , found = showSuggestion $ ideaFrom idea - , whyNot = showSuggestion whyNot + , whyNot = showSuggestion wn , severity = ideaSeverity idea , suggestion = ideaHint idea } createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule -createModule mode (Located line block) = +createModule md (Located ln block) = case block of Expression expr -> unparse $ exprToModule expr Declaration decl -> unparse $ declToModule decl Statement stmt -> unparse $ stmtToModule stmt Import impt -> unparse $ imptToModule impt - Module mod -> unparse $ parseModule mod + Module mdl -> unparse $ pModule mdl _ -> Nothing where blockStr = @@ -113,8 +100,11 @@ Declaration decl -> decl Statement stmt -> stmt Import impt -> impt - Module mod -> mod + Module mdl -> mdl + -- TODO: Properly handle the other constructors + _ -> [] + unparse :: ParseResult a -> Maybe a unparse (ParseOk a) = Just a unparse _ = Nothing @@ -122,49 +112,47 @@ srcSpan :: SrcSpan srcSpan = SrcSpan { srcSpanFilename = "" - , srcSpanStartLine = line + , srcSpanStartLine = ln , srcSpanStartColumn = 0 - , srcSpanEndLine = line + length (lines blockStr) + , srcSpanEndLine = ln + length (lines blockStr) , srcSpanEndColumn = length $ last $ lines blockStr } - loc :: SrcSpanInfo - loc = SrcSpanInfo srcSpan [] + lcn :: SrcSpanInfo + lcn = SrcSpanInfo srcSpan [] moduleWithDecls :: Decl SrcSpanInfo -> ExtsModule - moduleWithDecls decl = SrcExts.Module loc Nothing [] [] [decl] + moduleWithDecls decl = SrcExts.Module lcn Nothing [] [] [decl] - parseModule :: String -> ParseResult ExtsModule - parseModule = parseFileContentsWithMode mode + pModule :: String -> ParseResult ExtsModule + pModule = parseFileContentsWithMode md declToModule :: String -> ParseResult ExtsModule - declToModule decl = moduleWithDecls <$> parseDeclWithMode mode decl + declToModule decl = moduleWithDecls <$> parseDeclWithMode md decl exprToModule :: String -> ParseResult ExtsModule - exprToModule exp = moduleWithDecls <$> SpliceDecl loc <$> parseExpWithMode mode exp + exprToModule exp = moduleWithDecls <$> SpliceDecl lcn <$> parseExpWithMode md exp stmtToModule :: String -> ParseResult ExtsModule stmtToModule stmtStr = - case parseStmtWithMode mode stmtStr of - ParseOk stmt -> ParseOk mod + case parseStmtWithMode md stmtStr of + ParseOk _ -> ParseOk $ moduleWithDecls decl ParseFailed a b -> ParseFailed a b where - mod = moduleWithDecls decl - decl :: Decl SrcSpanInfo - decl = SpliceDecl loc expr + decl = SpliceDecl lcn expr expr :: Exp SrcSpanInfo - expr = Do loc [stmt, ret] + expr = Do lcn [stmt, ret] stmt :: Stmt SrcSpanInfo - ParseOk stmt = parseStmtWithMode mode stmtStr + ParseOk stmt = parseStmtWithMode md stmtStr ret :: Stmt SrcSpanInfo - ParseOk ret = Qualifier loc <$> parseExp lintIdent + ParseOk ret = Qualifier lcn <$> parseExp lintIdent imptToModule :: String -> ParseResult ExtsModule - imptToModule = parseFileContentsWithMode mode + imptToModule = parseFileContentsWithMode md plainSuggestion :: LintSuggestion -> String plainSuggestion suggest = @@ -177,10 +165,10 @@ toHtml :: LintSuggestion -> String toHtml suggest = concat [ named $ suggestion suggest - , floating "left" $ style severityClass "Found:" ++ + , floating "left" $ styl severityClass "Found:" ++ -- Things that look like this get highlighted. styleId "highlight-code" "haskell" (found suggest) - , floating "left" $ style severityClass "Why Not:" ++ + , floating "left" $ styl severityClass "Why Not:" ++ -- Things that look like this get highlighted. styleId "highlight-code" "haskell" (whyNot suggest) ] @@ -193,8 +181,8 @@ -- Should not occur _ -> "warning" - style :: String -> String -> String - style = printf "
%s
" + styl :: String -> String -> String + styl = printf "
%s
" named :: String -> String named = printf "
%s
" diff --git a/src/IHaskell/Eval/ParseShell.hs b/src/IHaskell/Eval/ParseShell.hs --- a/src/IHaskell/Eval/ParseShell.hs +++ b/src/IHaskell/Eval/ParseShell.hs @@ -5,11 +5,6 @@ module IHaskell.Eval.ParseShell (parseShell) 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 Text.ParserCombinators.Parsec @@ -28,6 +23,7 @@ xs <- scan return $ x : xs +manyTillEnd1 :: Parser a -> Parser [a] -> Parser [a] manyTillEnd1 p end = do x <- p xs <- manyTillEnd p end @@ -36,18 +32,21 @@ unescapedChar :: Parser Char -> Parser String unescapedChar p = try $ do x <- noneOf "\\" - lookAhead p + _ <- lookAhead p return [x] +quotedString :: Parser [Char] quotedString = do - quote "expected starting quote" + _ <- quote "expected starting quote" (manyTillEnd anyChar (unescapedChar quote) <* quote) "unexpected in quoted String " +unquotedString :: Parser [Char] unquotedString = manyTillEnd1 anyChar end where end = unescapedChar space <|> (lookAhead eol >> return []) +word :: Parser [Char] word = quotedString <|> unquotedString "word" separator :: Parser String @@ -57,11 +56,11 @@ shellWords :: Parser [String] shellWords = try (eof *> return []) <|> do x <- word - rest1 <- lookAhead (many anyToken) - ss <- separator - rest2 <- lookAhead (many anyToken) + _rest1 <- lookAhead (many anyToken) + _ss <- separator + _rest2 <- lookAhead (many anyToken) xs <- shellWords return $ x : xs parseShell :: String -> Either ParseError [String] -parseShell string = parse shellWords "shell" (string ++ "\n") +parseShell str = parse shellWords "shell" (str ++ "\n") diff --git a/src/IHaskell/Eval/Parser.hs b/src/IHaskell/Eval/Parser.hs --- a/src/IHaskell/Eval/Parser.hs +++ b/src/IHaskell/Eval/Parser.hs @@ -16,11 +16,6 @@ ) where import IHaskellPrelude -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Char8 as CBS import Data.Char (toLower) import Data.List (maximumBy, inits) @@ -83,8 +78,8 @@ flags <- getSessionDynFlags let output = runParser flags parserModule codeString case output of - Parsed mod - | Just _ <- hsmodName (unLoc mod) -> return [Located 1 $ Module codeString] + Parsed mdl + | Just _ <- hsmodName (unLoc mdl) -> return [Located 1 $ Module codeString] _ -> do -- Split input into chunks based on indentation. let chunks = layoutChunks $ removeComments codeString @@ -97,12 +92,12 @@ where parseChunk :: GhcMonad m => String -> LineNumber -> m (Located CodeBlock) - parseChunk chunk line = Located line <$> handleChunk chunk line + parseChunk chunk ln = Located ln <$> handleChunk where - handleChunk chunk line - | isDirective chunk = return $ parseDirective chunk line - | isPragma chunk = return $ parsePragma chunk line - | otherwise = parseCodeChunk chunk line + handleChunk + | isDirective chunk = return $ parseDirective chunk ln + | isPragma chunk = return $ parsePragma chunk ln + | otherwise = parseCodeChunk chunk ln processChunks :: GhcMonad m => [Located CodeBlock] -> [Located String] -> m [Located CodeBlock] processChunks accum remaining = @@ -111,10 +106,10 @@ [] -> return $ reverse accum -- If we have more remaining, parse the current chunk and recurse. - Located line chunk:remaining -> do - block <- parseChunk chunk line + Located ln chunk:remain -> do + block <- parseChunk chunk ln activateExtensions $ unloc block - processChunks (block : accum) remaining + processChunks (block : accum) remain -- Test whether a given chunk is a directive. isDirective :: String -> Bool @@ -130,11 +125,11 @@ case stripPrefix "-X" flags of Just ext -> void $ setExtension ext Nothing -> return () -activateExtensions (Pragma PragmaLanguage extensions) = void $ setAll extensions +activateExtensions (Pragma PragmaLanguage exts) = void $ setAll exts where setAll :: GhcMonad m => [String] -> m (Maybe String) - setAll exts = do - errs <- mapM setExtension exts + setAll exts' = do + errs <- mapM setExtension exts' return $ msum errs activateExtensions _ = return () @@ -142,7 +137,7 @@ parseCodeChunk :: GhcMonad m => String -> LineNumber -> m CodeBlock parseCodeChunk code startLine = do flags <- getSessionDynFlags - let + let -- Try each parser in turn. rawResults = map (tryParser code) (parsers flags) @@ -164,13 +159,13 @@ failures :: [ParseOutput a] -> [(ErrMsg, LineNumber, ColumnNumber)] failures [] = [] - failures (Failure msg (Loc line col):rest) = (msg, line, col) : failures rest + failures (Failure msg (Loc ln col):rest) = (msg, ln, col) : failures rest failures (_:rest) = failures rest bestError :: [(ErrMsg, LineNumber, ColumnNumber)] -> CodeBlock - bestError errors = ParseError (Loc (line + startLine - 1) col) msg + bestError errors = ParseError (Loc (ln + startLine - 1) col) msg where - (msg, line, col) = maximumBy compareLoc errors + (msg, ln, col) = maximumBy compareLoc errors compareLoc (_, line1, col1) (_, line2, col2) = compare line1 line2 <> compare col1 col2 statementToExpression :: DynFlags -> ParseOutput CodeBlock -> ParseOutput CodeBlock @@ -189,11 +184,11 @@ _ -> False tryParser :: String -> (String -> CodeBlock, String -> ParseOutput String) -> ParseOutput CodeBlock - tryParser string (blockType, parser) = - case parser string of + tryParser string (blockType, psr) = + case psr string of Parsed res -> Parsed (blockType res) Failure err loc -> Failure err loc - otherwise -> error "tryParser failed, output was neither Parsed nor Failure" + _ -> error "tryParser failed, output was neither Parsed nor Failure" parsers :: DynFlags -> [(String -> CodeBlock, String -> ParseOutput String)] parsers flags = @@ -204,10 +199,10 @@ ] where unparser :: Parser a -> String -> ParseOutput String - unparser parser code = - case runParser flags parser code of - Parsed out -> Parsed code - Partial out strs -> Partial code strs + unparser psr cd = + case runParser flags psr cd of + Parsed _ -> Parsed cd + Partial _ strs -> Partial cd strs Failure err loc -> Failure err loc -- | Find consecutive declarations of the same function and join them into a single declaration. @@ -239,11 +234,11 @@ parsePragma :: String -- ^ Pragma string. -> Int -- ^ Line number at which the directive appears. -> CodeBlock -- ^ Pragma code block or a parse error. -parsePragma ('{':'-':'#':pragma) line = +parsePragma pragma _ln = let commaToSpace :: Char -> Char commaToSpace ',' = ' ' commaToSpace x = x - pragmas = words $ takeWhile (/= '#') $ map commaToSpace pragma + pragmas = words $ takeWhile (/= '#') $ map commaToSpace $ drop 3 pragma in case pragmas of --empty string pragmas are unsupported [] -> Pragma (PragmaUnsupported "") [] @@ -256,8 +251,8 @@ parseDirective :: String -- ^ Directive string. -> Int -- ^ Line number at which the directive appears. -> CodeBlock -- ^ Directive code block or a parse error. -parseDirective (':':'!':directive) line = Directive ShellCmd $ '!' : directive -parseDirective (':':directive) line = +parseDirective (':':'!':directive) _ln = Directive ShellCmd $ '!' : directive +parseDirective (':':directive) ln = case find rightDirective directives of Just (directiveType, _) -> Directive directiveType arg where arg = unwords restLine @@ -267,7 +262,7 @@ case words directive of [] -> "" first:_ -> first - in ParseError (Loc line 1) $ "Unknown directive: '" ++ directiveStart ++ "'." + in ParseError (Loc ln 1) $ "Unknown directive: '" ++ directiveStart ++ "'." where rightDirective (_, dirname) = case words directive of @@ -298,8 +293,8 @@ let output = runParser flags parserModule moduleSrc case output of Failure{} -> error "Module parsing failed." - Parsed mod -> - case unLoc <$> hsmodName (unLoc mod) of + Parsed mdl -> + case unLoc <$> hsmodName (unLoc mdl) of Nothing -> error "Module must have a name." Just name -> return $ split "." $ moduleNameString name - otherwise -> error "getModuleName failed, output was neither Parsed nor Failure" + _ -> error "getModuleName failed, output was neither Parsed nor Failure" diff --git a/src/IHaskell/Eval/Util.hs b/src/IHaskell/Eval/Util.hs --- a/src/IHaskell/Eval/Util.hs +++ b/src/IHaskell/Eval/Util.hs @@ -27,29 +27,25 @@ ) 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 +#if MIN_VERSION_ghc(8,6,0) +#else import qualified Data.ByteString.Char8 as CBS +#endif -- GHC imports. import DynFlags +#if MIN_VERSION_ghc(8,6,0) +#else import FastString +#endif import GHC import GhcMonad -import HsImpExp import HscTypes -import InteractiveEval -import Module -import Packages -import RdrName import NameSet import Name import PprTyThing import InstEnv (ClsInst(..)) import Unify (tcMatchTys) -import VarSet (mkVarSet) import qualified Pretty import qualified Outputable as O @@ -63,11 +59,9 @@ import CmdLineParser (warnMsg) #endif -#if MIN_VERSION_ghc(8,0,1) import GHC.LanguageExtensions type ExtensionFlag = Extension -#endif -- | A extension flag that can be set or unset. data ExtFlag = SetFlag ExtensionFlag @@ -87,15 +81,11 @@ Nothing -> Nothing where -- Check if a FlagSpec matches an extension name. - flagMatches ext fs = ext == flagSpecName fs + flagMatches ex fs = ex == flagSpecName fs -- Check if a FlagSpec matches "No". In that case, we disable the extension. - flagMatchesNo ext fs = ext == "No" ++ flagSpecName fs -#if !MIN_VERSION_ghc(7,10,0) -flagSpecName (name, _, _) = name + flagMatchesNo ex fs = ex == "No" ++ flagSpecName fs -flagSpecFlag (_, flag, _) = flag -#endif -- | Pretty-print dynamic flags (taken from 'InteractiveUI' module of `ghc-bin`) pprDynFlags :: Bool -- ^ Whether to include flags which are on by default -> DynFlags @@ -107,21 +97,14 @@ , 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) warningFlags)) + O.nest 2 (O.vcat (map (setting wopt) wFlags)) ] where -#if MIN_VERSION_ghc(8,0,0) - warningFlags = DynFlags.wWarningFlags -#else - warningFlags = DynFlags.fWarningFlags -#endif + wFlags = DynFlags.wWarningFlags -#if MIN_VERSION_ghc(7,8,0) opt = gopt -#else - opt = dopt -#endif + setting test flag | quiet = O.empty :: O.SDoc | is_on = fstr name :: O.SDoc @@ -131,28 +114,28 @@ f = flagSpecFlag flag is_on = test f dflags quiet = not show_all && test f default_dflags == is_on - -#if MIN_VERSION_ghc(8,4,0) + +#if MIN_VERSION_ghc(8,6,0) + default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags) +#elif MIN_VERSION_ghc(8,4,0) default_dflags = defaultDynFlags (settings dflags) (llvmTargets dflags) #else default_dflags = defaultDynFlags (settings dflags) #endif - + fstr, fnostr :: String -> O.SDoc fstr str = O.text "-f" O.<> O.text str - + fnostr str = O.text "-fno-" O.<> O.text str - + (ghciFlags, others) = partition (\f -> flagSpecFlag f `elem` flgs) DynFlags.fFlags - + flgs = concat [flgs1, flgs2, flgs3] - + flgs1 = [Opt_PrintExplicitForalls] -#if MIN_VERSION_ghc(7,8,0) flgs2 = [Opt_PrintExplicitKinds] -#else - flgs2 = [] -#endif + +flgs3 :: [GeneralFlag] flgs3 = [Opt_PrintBindResult, Opt_BreakOnException, Opt_BreakOnError, Opt_PrintEvldWithShow] -- | Pretty-print the base language and active options (taken from `InteractiveUI` module of @@ -184,7 +167,9 @@ quiet = not show_all && test f default_dflags == is_on default_dflags = -#if MIN_VERSION_ghc(8,4,0) +#if MIN_VERSION_ghc(8,6,0) + defaultDynFlags (settings dflags) (llvmTargets dflags, llvmPasses dflags) `lang_set` +#elif MIN_VERSION_ghc(8,4,0) defaultDynFlags (settings dflags) (llvmTargets dflags) `lang_set` #else defaultDynFlags (settings dflags) `lang_set` @@ -201,7 +186,7 @@ case extensionFlag ext of Nothing -> return $ Just $ "Could not parse extension name: " ++ ext Just flag -> do - setSessionDynFlags $ + _ <- setSessionDynFlags $ case flag of SetFlag ghcFlag -> xopt_set flags ghcFlag UnsetFlag ghcFlag -> xopt_unset flags ghcFlag @@ -216,9 +201,8 @@ (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) -- First, try to check if this flag matches any extension name. - let restorePkg x = x { packageFlags = packageFlags flags } let restoredPkgs = flags' { packageFlags = packageFlags flags } - GHC.setProgramDynFlags restoredPkgs + _ <- GHC.setProgramDynFlags restoredPkgs GHC.setInteractiveDynFlags restoredPkgs -- Create the parse errors. @@ -251,10 +235,15 @@ where string_txt :: Pretty.TextDetails -> String -> String +#if MIN_VERSION_ghc(8,6,0) + string_txt = Pretty.txtPrinter +#else string_txt (Pretty.Chr c) s = c : s string_txt (Pretty.Str s1) s2 = s1 ++ s2 string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 + string_txt (Pretty.ZStr s1) s2 = CBS.unpack (fastZStringToByteString s1) ++ s2 +#endif -- | Initialize the GHC API. Run this as the first thing in the `runGhc`. This initializes some dyn -- flags (@ExtendedDefaultRules@, @@ -271,11 +260,7 @@ originalFlags <- getSessionDynFlags let flag = flip xopt_set unflag = flip xopt_unset -#if MIN_VERSION_ghc(8,0,0) dflags = flag ExtendedDefaultRules . unflag MonomorphismRestriction $ originalFlags -#else - dflags = flag Opt_ExtendedDefaultRules . unflag Opt_MonomorphismRestriction $ originalFlags -#endif #if MIN_VERSION_ghc(8,2,0) pkgFlags = case sandboxPackages of @@ -357,15 +342,14 @@ _ -> False removeImport :: GhcMonad m => String -> m () -removeImport moduleName = do - flags <- getSessionDynFlags +removeImport modName = do ctx <- getContext - let ctx' = filter (not . (isImportOf $ mkModuleName moduleName)) ctx + let ctx' = filter (not . (isImportOf $ mkModuleName modName)) ctx setContext ctx' where isImportOf :: ModuleName -> InteractiveImport -> Bool - isImportOf name (IIModule modName) = name == modName + isImportOf name (IIModule mName) = name == mName isImportOf name (IIDecl impDecl) = name == unLoc (ideclName impDecl) -- | Evaluate a series of declarations. Return all names which were bound by these declarations. @@ -378,7 +362,7 @@ cleanUpDuplicateInstances :: GhcMonad m => m () cleanUpDuplicateInstances = modifySession $ \hscEnv -> - let + let -- Get all class instances ic = hsc_IC hscEnv (clsInsts, famInsts) = ic_instances ic @@ -387,21 +371,9 @@ in hscEnv { hsc_IC = ic { ic_instances = (clsInsts', famInsts) } } where instEq :: ClsInst -> ClsInst -> Bool -#if MIN_VERSION_ghc(8,0,0) -- Only support replacing instances on GHC 7.8 and up - instEq c1 c2 - | ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1, - ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2 - = cls == cls' && isJust (tcMatchTys tpl_tys tpl_tys') -#elif MIN_VERSION_ghc(7,8,0) - instEq c1 c2 - | ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys, is_cls = cls } <- c1, - ClsInst { is_tys = tpl_tys', is_cls = cls' } <- c2 - = let tpl_tv_set = mkVarSet tpl_tvs - in cls == cls' && isJust (tcMatchTys tpl_tv_set tpl_tys tpl_tys') -#else - instEq _ _ = False -#endif + instEq c1 c2 = + is_cls c1 == is_cls c2 && isJust (tcMatchTys (is_tys c1) (is_tys c2)) -- | Get the type of an expression and convert it to a string. @@ -430,9 +402,9 @@ -- Filter out types that have parents in the same set. GHCi also does this. let infos = catMaybes maybeInfos - allNames = mkNameSet $ map (getName . getType) infos + allNames = mkNameSet $ map (getName . getInfoType) infos hasParent info = - case tyThingParent_maybe (getType info) of + case tyThingParent_maybe (getInfoType info) of Just parent -> getName parent `elemNameSet` allNames Nothing -> False filteredOutput = filter (not . hasParent) infos @@ -442,18 +414,12 @@ where -#if MIN_VERSION_ghc(7,8,0) getInfo' = getInfo False -#else - getInfo' = getInfo -#endif #if MIN_VERSION_ghc(8,4,0) - getType (theType, _, _, _, _) = theType -#elif MIN_VERSION_ghc(7,8,0) - getType (theType, _, _, _) = theType + getInfoType (theType, _, _, _, _) = theType #else - getType (theType, _, _) = theType + getInfoType (theType, _, _, _) = theType #endif #if MIN_VERSION_ghc(8,4,0) @@ -462,16 +428,12 @@ showFixity thing fixity O.$$ O.vcat (map GHC.pprInstance classInstances) O.$$ O.vcat (map GHC.pprFamInst famInstances) -#elif MIN_VERSION_ghc(7,8,0) +#else printInfo (thing, fixity, classInstances, 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 O.$$ showFixity thing fixity O.$$ - O.vcat (map GHC.pprInstance classInstances) #endif showFixity thing fixity = if fixity == GHC.defaultFixity diff --git a/src/IHaskell/Eval/Widgets.hs b/src/IHaskell/Eval/Widgets.hs --- a/src/IHaskell/Eval/Widgets.hs +++ b/src/IHaskell/Eval/Widgets.hs @@ -14,7 +14,6 @@ import IHaskellPrelude -import Control.Concurrent.Chan (writeChan) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan import Control.Monad (foldM) @@ -25,8 +24,6 @@ import IHaskell.Display import IHaskell.Eval.Util (unfoldM) import IHaskell.IPython.Types (showMessageType) -import IHaskell.IPython.Message.UUID -import IHaskell.IPython.Message.Writer import IHaskell.Types -- All comm_open messages go here @@ -50,7 +47,7 @@ widgetSend :: IHaskellWidget a => (Widget -> Value -> WidgetMsg) -> a -> Value -> IO () -widgetSend msgType widget value = queue $ msgType (Widget widget) value +widgetSend mtype widget value = queue $ mtype (Widget widget) value -- | Send a message to open a comm widgetSendOpen :: IHaskellWidget a => a -> Value -> IO () @@ -82,7 +79,7 @@ -- | Send a `clear_output` message as a [method .= custom] message widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO () -widgetClearOutput widget wait = queue $ ClrOutput (Widget widget) wait +widgetClearOutput widget w = queue $ ClrOutput (Widget widget) w -- | Handle a single widget message. Takes necessary actions according to the message type, such as -- opening comms, storing and updating widget representation in the kernel state etc. @@ -111,8 +108,8 @@ then return state else do -- Send the comm open, with the initial state - header <- dupHeader replyHeader CommOpenMessage - send $ CommOpen header target_name target_module uuid value + hdr <- dupHeader replyHeader CommOpenMessage + send $ CommOpen hdr target_name target_module uuid value -- Send anything else the widget requires. open widget communicate @@ -130,8 +127,8 @@ -- If the widget is not present in the state, we don't close it. if present then do - header <- dupHeader replyHeader CommCloseMessage - send $ CommClose header uuid value + hdr <- dupHeader replyHeader CommCloseMessage + send $ CommClose hdr uuid value return newState else return state @@ -148,9 +145,9 @@ let dmsg = WidgetDisplay dispHeader $ unwrap disp sendMessage widget (toJSON $ CustomContent $ toJSON dmsg) - ClrOutput widget wait -> do - header <- dupHeader replyHeader ClearOutputMessage - let cmsg = WidgetClear header wait + ClrOutput widget w -> do + hdr <- dupHeader replyHeader ClearOutputMessage + let cmsg = WidgetClear hdr w sendMessage widget (toJSON $ CustomContent $ toJSON cmsg) where @@ -161,8 +158,8 @@ -- If the widget is present, we send an update message on its comm. when present $ do - header <- dupHeader replyHeader CommDataMessage - send $ CommData header uuid value + hdr <- dupHeader replyHeader CommDataMessage + send $ CommData hdr uuid value return state unwrap :: Display -> [DisplayData] @@ -174,27 +171,27 @@ instance ToJSON WidgetDisplay where toJSON (WidgetDisplay replyHeader ddata) = - let pbval = toJSON $ PublishDisplayData replyHeader ddata + let pbval = toJSON $ PublishDisplayData replyHeader ddata Nothing in toJSON $ IPythonMessage replyHeader pbval DisplayDataMessage -- Override toJSON for ClearOutput data WidgetClear = WidgetClear MessageHeader Bool instance ToJSON WidgetClear where - toJSON (WidgetClear replyHeader wait) = - let clrVal = toJSON $ ClearOutput replyHeader wait + toJSON (WidgetClear replyHeader w) = + let clrVal = toJSON $ ClearOutput replyHeader w in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage data IPythonMessage = IPythonMessage MessageHeader Value MessageType instance ToJSON IPythonMessage where - toJSON (IPythonMessage replyHeader val msgType) = + toJSON (IPythonMessage replyHeader val mtype) = object [ "header" .= replyHeader , "parent_header" .= str "" , "metadata" .= str "{}" , "content" .= val - , "msg_type" .= (toJSON . showMessageType $ msgType) + , "msg_type" .= (toJSON . showMessageType $ mtype) ] str :: String -> String @@ -206,4 +203,4 @@ -> KernelState -> [WidgetMsg] -> IO KernelState -widgetHandler sender header = foldM (handleMessage sender header) +widgetHandler sender hdr = foldM (handleMessage sender hdr) diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -14,22 +14,17 @@ import IHaskellPrelude hiding (Arg(..)) 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) -import IHaskell.Types -- Command line arguments to IHaskell. A set of arguments is annotated with the mode being invoked. data Args = Args IHaskellMode [Argument] deriving Show data Argument = ConfFile String -- ^ A file with commands to load at startup. - | OverwriteFiles -- ^ Present when output should overwrite existing files. + | OverwriteFiles -- ^ Present when output should overwrite existing files. | GhcLibDir String -- ^ Where to find the GHC libraries. | RTSFlags [String] -- ^ Options for the GHC runtime (e.g. heap-size limit -- or number of threads). @@ -70,7 +65,7 @@ -- | Given a list of command-line arguments, return the IHaskell mode and arguments to process. parseFlags :: [String] -> Either String Args parseFlags flags = - let modeIndex = findIndex (`elem` modeFlags) flags + let modeIndex = findIndex (`elem` modeFlgs) flags in case modeIndex of Nothing -> -- Treat no mode as 'console'. @@ -82,18 +77,19 @@ let (start, first:end) = splitAt idx flags in process ihaskellArgs $ first : start ++ end where - modeFlags = concatMap modeNames allModes + modeFlgs = concatMap modeNames allModes allModes :: [Mode Args] allModes = [installKernelSpec, kernel, convert] -- | Get help text for a given IHaskell ode. help :: IHaskellMode -> String -help mode = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode mode +help md = showText (Wrap 100) $ helpText [] HelpFormatAll $ chooseMode md where chooseMode InstallKernelSpec = installKernelSpec chooseMode (Kernel _) = kernel chooseMode ConvertLhs = convert + chooseMode (ShowDefault _) = error "IHaskell.Flags.help: Should never happen." ghcLibFlag :: Flag Args ghcLibFlag = flagReq ["ghclib", "l"] (store GhcLibDir) "" "Library directory for GHC." @@ -101,8 +97,8 @@ ghcRTSFlag :: Flag Args ghcRTSFlag = flagReq ["use-rtsopts"] storeRTS "\"\"" "Runtime options (multithreading etc.). See `ghc +RTS -?`." - where storeRTS allRTSFlags (Args mode prev) - = fmap (Args mode . (:prev) . RTSFlags) + where storeRTS allRTSFlags (Args md prev) + = fmap (Args md . (:prev) . RTSFlags) . parseRTS . words $ filter (/='"') allRTSFlags parseRTS ("+RTS":fs) -- Ignore if this is included (we already wrap = parseRTS fs -- the ihaskell-kernel call in +RTS -RTS anyway) @@ -115,13 +111,13 @@ kernelDebugFlag :: Flag Args kernelDebugFlag = flagNone ["debug"] addDebug "Print debugging output from the kernel." where - addDebug (Args mode prev) = Args mode (KernelDebug : prev) + addDebug (Args md prev) = Args md (KernelDebug : prev) kernelStackFlag :: Flag Args kernelStackFlag = flagNone ["stack"] addStack "Inherit environment from `stack` when it is installed" where - addStack (Args mode prev) = Args mode (KernelspecUseStack : prev) + addStack (Args md prev) = Args md (KernelspecUseStack : prev) confFlag :: Flag Args confFlag = flagReq ["conf", "c"] (store ConfFile) "" @@ -131,12 +127,14 @@ installPrefixFlag = flagReq ["prefix"] (store KernelspecInstallPrefix) "" "Installation prefix for kernelspec (see Jupyter's --prefix option)" +helpFlag :: Flag Args helpFlag = flagHelpSimple (add Help) -add flag (Args mode flags) = Args mode $ flag : flags +add :: Argument -> Args -> Args +add flag (Args md flags) = Args md $ flag : flags store :: (String -> Argument) -> String -> Args -> Either String Args -store constructor str (Args mode prev) = Right $ Args mode $ constructor str : prev +store constructor str (Args md prev) = Right $ Args md $ constructor str : prev installKernelSpec :: Mode Args installKernelSpec = @@ -168,14 +166,14 @@ , helpFlag ] - consForce (Args mode prev) = Args mode (OverwriteFiles : prev) + consForce (Args md prev) = Args md (OverwriteFiles : prev) unnamedArg = Arg (store ConvertFrom) "" False - consStyle style (Args mode prev) = Args mode (ConvertLhsStyle style : prev) + consStyle style (Args md prev) = Args md (ConvertLhsStyle style : prev) - storeFormat constructor str (Args mode prev) = + storeFormat constructor str (Args md prev) = case T.toLower (T.pack str) of - "lhs" -> Right $ Args mode $ constructor LhsMarkdown : prev - "ipynb" -> Right $ Args mode $ constructor IpynbFile : prev + "lhs" -> Right $ Args md $ constructor LhsMarkdown : prev + "ipynb" -> Right $ Args md $ constructor IpynbFile : prev _ -> Left $ "Unknown format requested: " ++ str storeLhs str previousArgs = @@ -196,13 +194,11 @@ let noMode = mode "IHaskell" defaultReport descr noArgs [helpFlag, versionFlag] defaultReport = Args (ShowDefault helpStr) [] descr = "Haskell for Interactive Computing." - helpFlag = flagHelpSimple (add Help) versionFlag = flagVersion (add Version) helpStr = showText (Wrap 100) $ helpText [] HelpFormatAll ihaskellArgs in noMode { modeGroupModes = toGroup allModes } - where - add flag (Args mode flags) = Args mode $ flag : flags +noArgs :: Arg a noArgs = flagArg unexpected "" where unexpected a = error $ "Unexpected argument: " ++ a diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -1,5 +1,4 @@ {-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} -{-# LANGUAGE CPP #-} -- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and -- @console@ commands. @@ -17,11 +16,7 @@ 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 System.Argv0 import qualified Shelly as SH import qualified System.IO as IO @@ -33,12 +28,10 @@ import Data.Text.Lazy.Builder (toLazyText) import Control.Monad (mplus) -import qualified System.IO.Strict as StrictIO import qualified Paths_ihaskell as Paths import qualified GHC.Paths import IHaskell.Types -import System.Posix.Signals import StringUtils (replace, split) @@ -67,9 +60,6 @@ kernelName :: String kernelName = "haskell" -kernelArgs :: [String] -kernelArgs = ["--kernel", kernelName] - ipythonCommand :: SH.Sh SH.FilePath ipythonCommand = do jupyterMay <- SH.which "jupyter" @@ -85,33 +75,6 @@ Nothing -> SH.errorExit "The Jupyter binary could not be located" Just ipython -> return ipython --- | 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.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. - cmd <- ipythonCommand - SH.runHandles cmd args handles doNothing - - where - 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 = SH.runHandles path args handles nothing - where - handles = [SH.InHandle SH.Inherit, SH.OutHandle SH.CreatePipe, SH.ErrorHandle SH.CreatePipe] - nothing _ _ _ = return () - fp :: SH.FilePath -> FilePath fp = T.unpack . SH.toTextIgnore @@ -126,17 +89,14 @@ ihaskellDir :: SH.Sh FilePath ihaskellDir = do home <- maybe (error "$HOME not defined.") SH.fromText <$> SH.get_env "HOME" - fp <$> ensure (return (home SH. ".ihaskell")) - -notebookDir :: SH.Sh SH.FilePath -notebookDir = ensure $ (SH. "notebooks") <$> ihaskellDir + fp <$> ensure (return (home SH. (".ihaskell" :: SH.FilePath))) getIHaskellDir :: IO String getIHaskellDir = SH.shelly ihaskellDir defaultConfFile :: IO (Maybe String) defaultConfFile = fmap (fmap fp) . SH.shelly $ do - filename <- (SH. "rc.hs") <$> ihaskellDir + filename <- (SH. ("rc.hs" :: SH.FilePath)) <$> ihaskellDir exists <- SH.test_f filename return $ if exists then Just filename @@ -156,17 +116,17 @@ Nothing -> badIPython "No Jupyter / IPython detected -- install Jupyter 3.0+ before using IHaskell." Just path -> do - stdout <- SH.silently (SH.run path ["--version"]) - stderr <- SH.lastStderr + sout <- SH.silently (SH.run path ["--version"]) + serr <- SH.lastStderr let majorVersion = join . fmap listToMaybe . parseVersion . T.unpack - case mplus (majorVersion stderr) (majorVersion stdout) of + case mplus (majorVersion serr) (majorVersion sout) of Nothing -> badIPython $ T.concat [ "Detected Jupyter, but could not parse version number." , "\n" , "(stdout = " - , stdout + , sout , ", stderr = " - , stderr + , serr , ")" ] @@ -183,7 +143,7 @@ -- | Install an IHaskell kernelspec into the right location. The right location is determined by -- using `ipython kernelspec install --user`. installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh () -installKernelspec replace opts = void $ do +installKernelspec repl opts = void $ do ihaskellPath <- getIHaskellPath confFile <- liftIO $ kernelSpecConfFile opts @@ -196,7 +156,7 @@ ++ ["--ghclib", kernelSpecGhcLibdir opts] ++ (case kernelSpecRTSOptions opts of [] -> [] - rtsOpts -> "+RTS" : kernelSpecRTSOptions opts ++ ["-RTS"]) + _ -> "+RTS" : kernelSpecRTSOptions opts ++ ["-RTS"]) ++ ["--stack" | kernelSpecUseStack opts] let kernelSpec = KernelSpec @@ -209,7 +169,7 @@ -- shell out to IPython to install this kernelspec directory. SH.withTmpDir $ \tmp -> do let kernelDir = tmp SH. kernelName - let filename = kernelDir SH. "kernel.json" + let filename = kernelDir SH. ("kernel.json" :: SH.FilePath) SH.mkdir_p kernelDir SH.writefile filename $ LT.toStrict $ toLazyText $ encodeToTextBuilder $ toJSON kernelSpec @@ -220,43 +180,24 @@ ipython <- locateIPython - let replaceFlag = ["--replace" | replace] + let replaceFlag = ["--replace" | repl] installPrefixFlag = maybe ["--user"] (\prefix -> ["--prefix", T.pack prefix]) (kernelSpecInstallPrefix opts) cmd = concat [["kernelspec", "install"], installPrefixFlag, [SH.toTextIgnore kernelDir], replaceFlag] SH.silently $ SH.run ipython cmd -kernelSpecCreated :: SH.Sh Bool -kernelSpecCreated = do - ipython <- locateIPython - 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 = 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.Sh SH.FilePath -path exe = do - path <- SH.which $ SH.fromText exe - case path of - Nothing -> do - 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 readMay $ split "." versionStr - parsed = all isJust versions - in if parsed - then Just $ map fromJust versions + in if all isJust versions + then Just $ catMaybes versions else Nothing -- | Get the absolute path to this IHaskell executable. @@ -268,7 +209,7 @@ -- If we have an absolute path, that's the IHaskell we're interested in. if FP.isAbsolute f then return f - else + 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 FP.takeFileName f == f @@ -278,16 +219,6 @@ Nothing -> error "ihaskell not on $PATH and not referenced relative to directory." 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 = SH.shelly $ do myPath <- getIHaskellPath diff --git a/src/IHaskell/IPython/Stdin.hs b/src/IHaskell/IPython/Stdin.hs --- a/src/IHaskell/IPython/Stdin.hs +++ b/src/IHaskell/IPython/Stdin.hs @@ -26,21 +26,14 @@ 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.FilePath (()) import System.Posix.IO import System.IO.Unsafe -import qualified Data.Map as Map import IHaskell.IPython.Types import IHaskell.IPython.ZeroMQ @@ -55,7 +48,9 @@ fixStdin :: String -> IO () fixStdin dir = do -- Initialize the stdin interface. - profile <- fromJust . readMay <$> readFile (dir ++ "/.kernel-profile") + let fpath = dir ".kernel-profile" + profile <- fromMaybe (error $ "fixStdin: Failed reading " ++ fpath) + . readMay <$> readFile fpath interface <- serveStdin profile putMVar stdinInterface interface void $ forkIO $ stdinOnce dir @@ -79,8 +74,8 @@ loop stdinInput oldStdin newStdin = do let FileHandle _ mvar = stdin threadDelay $ 150 * 1000 - empty <- isEmptyMVar mvar - if not empty + e <- isEmptyMVar mvar + if not e then loop stdinInput oldStdin newStdin else do line <- getInputLine dir @@ -94,17 +89,12 @@ -- Send a request for input. uuid <- UUID.random - parentHeader <- fromJust . readMay <$> readFile (dir ++ "/.last-req-header") - let header = MessageHeader - { username = username parentHeader - , identifiers = identifiers parentHeader - , parentHeader = Just parentHeader - , messageId = uuid - , sessionId = sessionId parentHeader - , metadata = Map.fromList [] - , msgType = InputRequestMessage - } - let msg = RequestInput header "" + let fpath = dir ".last-req-header" + parentHdr <- fromMaybe (error $ "getInputLine: Failed reading " ++ fpath) + . readMay <$> readFile fpath + let hdr = MessageHeader (mhIdentifiers parentHdr) (Just parentHdr) mempty + uuid (mhSessionId parentHdr) (mhUsername parentHdr) InputRequestMessage + let msg = RequestInput hdr "" writeChan req msg -- Get the reply. @@ -112,8 +102,8 @@ return value recordParentHeader :: String -> MessageHeader -> IO () -recordParentHeader dir header = - writeFile (dir ++ "/.last-req-header") $ show header +recordParentHeader dir hdr = + writeFile (dir ++ "/.last-req-header") $ show hdr recordKernelProfile :: String -> Profile -> IO () recordKernelProfile dir profile = diff --git a/src/IHaskell/Publish.hs b/src/IHaskell/Publish.hs --- a/src/IHaskell/Publish.hs +++ b/src/IHaskell/Publish.hs @@ -1,10 +1,12 @@ {-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} -module IHaskell.Publish (publishResult) where +module IHaskell.Publish + ( publishResult + ) where import IHaskellPrelude import qualified Data.Text as T -import qualified Data.Text.Encoding as E +import qualified Data.Time as Time import IHaskell.Display import IHaskell.Types @@ -24,23 +26,27 @@ -> MVar [DisplayData] -- ^ A MVar to use for storing pager output -> Bool -- ^ Whether to use the pager -> EvaluationResult -- ^ The evaluation result + -> ErrorOccurred -- ^ Whether evaluation completed successfully -> IO () -publishResult send replyHeader displayed updateNeeded pagerOutput usePager result = do +publishResult send replyHeader displayed updateNeeded poutput upager result success = do let final = case result of IntermediateResult{} -> False FinalResult{} -> True - outs = outputs result + outs = evaluationOutputs result + -- Get time to send to output for unique labels. + uniqueLabel <- getUniqueLabel + -- If necessary, clear all previous output and redraw. clear <- readMVar updateNeeded when clear $ do clearOutput disps <- readMVar displayed - mapM_ sendOutput $ reverse disps + mapM_ (sendOutput uniqueLabel) $ reverse disps -- Draw this message. - sendOutput outs + sendOutput uniqueLabel 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. @@ -49,30 +55,45 @@ modifyMVar_ displayed (return . (outs :)) -- If this has some pager output, store it for later. - let pager = pagerOut result - unless (null pager) $ - if usePager - then modifyMVar_ pagerOutput (return . (++ pager)) - else sendOutput $ Display pager + case result of + IntermediateResult _ -> pure () + FinalResult _ pager _ -> + unless (null pager) $ + if upager + then modifyMVar_ poutput (return . (++ pager)) + else sendOutput uniqueLabel $ Display pager where clearOutput = do - header <- dupHeader replyHeader ClearOutputMessage - send $ ClearOutput header True + hdr <- dupHeader replyHeader ClearOutputMessage + send $ ClearOutput hdr True - sendOutput (ManyDisplay manyOuts) = mapM_ sendOutput manyOuts - sendOutput (Display outs) = do - header <- dupHeader replyHeader DisplayDataMessage - send $ PublishDisplayData header $ map (convertSvgToHtml . prependCss) outs + sendOutput uniqueLabel (ManyDisplay manyOuts) = + mapM_ (sendOutput uniqueLabel) manyOuts + sendOutput uniqueLabel (Display outs) = case success of + Success -> do + hdr <- dupHeader replyHeader DisplayDataMessage + send $ PublishDisplayData hdr (map (makeUnique uniqueLabel . prependCss) outs) Nothing + Failure -> do + hdr <- dupHeader replyHeader ExecuteErrorMessage + send $ ExecuteError hdr [T.pack (extractPlain outs)] "" "" - convertSvgToHtml (DisplayData MimeSvg svg) = html $ makeSvgImg $ base64 $ E.encodeUtf8 svg - convertSvgToHtml x = x + prependCss (DisplayData MimeHtml h) = + DisplayData MimeHtml $ mconcat ["", h] + prependCss x = x - makeSvgImg :: Base64 -> String - makeSvgImg base64data = T.unpack $ " - base64data <> - "\"/>" + makeUnique l (DisplayData MimeSvg s) = + DisplayData MimeSvg + . T.replace "glyph" ("glyph-" <> l) + . T.replace "\"clip" ("\"clip-" <> l) + . T.replace "#clip" ("#clip-" <> l) + . T.replace "\"image" ("\"image-" <> l) + . T.replace "#image" ("#image-" <> l) + . T.replace "linearGradient id=\"linear" ("linearGradient id=\"linear-" <> l) + . T.replace "#linear" ("#linear-" <> l) + $ s + makeUnique _ x = x - prependCss (DisplayData MimeHtml html) = - DisplayData MimeHtml $ mconcat ["", html] - prependCss x = x + getUniqueLabel = + fmap (\(Time.UTCTime d s) -> T.pack (show d) <> T.pack (show s)) + Time.getCurrentTime diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -12,13 +12,15 @@ MessageType(..), dupHeader, Username, - Metadata(..), + Metadata, replyType, ExecutionState(..), StreamType(..), MimeType(..), DisplayData(..), + ErrorOccurred(..), EvaluationResult(..), + evaluationOutputs, ExecuteReplyStatus(..), KernelState(..), LintStatus(..), @@ -39,17 +41,8 @@ import IHaskellPrelude -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as CBS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT - -import Data.Aeson (Value, (.=), object) -import Data.Aeson.Types (emptyObject) -import qualified Data.ByteString.Char8 as Char +import Data.Aeson (ToJSON (..), Value, (.=), object) import Data.Function (on) -import Data.Semigroup import Data.Serialize import GHC.Generics @@ -100,6 +93,28 @@ -> IO () close _ _ = return () +-- | these instances cause the image, html etc. which look like: +-- +-- > Display +-- > [Display] +-- > IO [Display] +-- > IO (IO Display) +-- +-- be run the IO and get rendered (if the frontend allows it) in the pretty form. +instance IHaskellDisplay a => IHaskellDisplay (IO a) where + display = (display =<<) + +instance IHaskellDisplay Display where + display = return + +instance IHaskellDisplay DisplayData where + display disp = return $ Display [disp] + +instance IHaskellDisplay a => IHaskellDisplay [a] where + display disps = do + displays <- mapM display disps + return $ ManyDisplay displays + data Widget = forall a. IHaskellWidget a => Widget a deriving Typeable @@ -157,7 +172,7 @@ defaultKernelState = KernelState { getExecutionCounter = 1 , getLintStatus = LintOn - , useSvg = False + , useSvg = True , useShowErrors = False , useShowTypes = False , usePager = True @@ -230,29 +245,39 @@ | DisplayWidget instance ToJSON WidgetMethod where - toJSON DisplayWidget = object ["method" .= "display"] - toJSON (UpdateState v) = object ["method" .= "update", "state" .= v] - toJSON (CustomContent v) = object ["method" .= "custom", "content" .= v] + toJSON DisplayWidget = object ["method" .= ("display" :: Text)] + toJSON (UpdateState v) = object ["method" .= ("update" :: Text), "state" .= v] + toJSON (CustomContent v) = object ["method" .= ("custom" :: Text), "content" .= v] -- | Output of evaluation. -data EvaluationResult = - -- | An intermediate result which communicates what has been printed thus - -- far. - IntermediateResult - { outputs :: Display -- ^ Display outputs. - } - | - FinalResult - { outputs :: Display -- ^ Display outputs. - , pagerOut :: [DisplayData] -- ^ Mimebundles to display in the IPython - -- pager. - , commMsgs :: [WidgetMsg] -- ^ Comm operations - } +-- +-- A result can either be intermediate or final. +-- Final result has Mimebundles ('DisplayData') and Comm operations +-- ('WidgetMsg') on top of Display outputs. +data EvaluationResult + -- | An intermediate result which communicates what has been printed thus far. + = IntermediateResult + !Display + | FinalResult + !Display + ![DisplayData] + ![WidgetMsg] deriving Show + +evaluationOutputs :: EvaluationResult -> Display +evaluationOutputs er = + case er of + IntermediateResult outputs -> outputs + FinalResult outputs _ _ -> outputs + -- | Duplicate a message header, giving it a new UUID and message type. dupHeader :: MessageHeader -> MessageType -> IO MessageHeader -dupHeader header messageType = do +dupHeader hdr messageType = do uuid <- liftIO random + return hdr { mhMessageId = uuid, mhMsgType = messageType } - return header { messageId = uuid, msgType = messageType } +-- | Whether or not an error occurred. +data ErrorOccurred = Success + | Failure + deriving (Show, Eq) diff --git a/src/IHaskellPrelude.hs b/src/IHaskellPrelude.hs --- a/src/IHaskellPrelude.hs +++ b/src/IHaskellPrelude.hs @@ -8,12 +8,10 @@ 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, @@ -54,8 +52,8 @@ Data.IORef.modifyIORef', Data.IORef.newIORef, - + -- Miscellaneous names Data.Map.Map, GHC.IO.FilePath, @@ -80,20 +78,14 @@ import GHC.Num as X import GHC.Real as X import GHC.Err as X hiding (absentErr) -#if MIN_VERSION_ghc(8,0,0) import GHC.Base as X hiding (Any, mapM, foldr, sequence, many, (<|>), Module(..)) -#elif 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, + unionBy, intersectBy, group, groupBy, insertBy, maximumBy, minimumBy, genericLength, genericDrop, genericTake, genericSplitAt, genericIndex, genericReplicate, inits, tails) @@ -121,13 +113,27 @@ 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) +headMay :: [a] -> Maybe a +headMay = wrapEmpty head + +tailMay :: [a] -> Maybe [a] +tailMay = wrapEmpty tail + +lastMay :: [a] -> Maybe a +lastMay = wrapEmpty last + +initMay :: [a] -> Maybe [a] +initMay = wrapEmpty init + +maximumMay :: Ord a => [a] -> Maybe a +maximumMay = wrapEmpty maximum + +minimumMay :: Ord a => [a] -> Maybe a +minimumMay = wrapEmpty minimum + +wrapEmpty :: ([a] -> b) -> [a] -> Maybe b +wrapEmpty _ [] = Nothing +wrapEmpty f xs = Just (f xs) maximumByMay :: (a -> a -> Ordering) -> [a] -> Maybe a maximumByMay _ [] = Nothing diff --git a/src/StringUtils.hs b/src/StringUtils.hs --- a/src/StringUtils.hs +++ b/src/StringUtils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} module StringUtils ( strip, lstrip, diff --git a/src/tests/Hspec.hs b/src/tests/Hspec.hs --- a/src/tests/Hspec.hs +++ b/src/tests/Hspec.hs @@ -7,10 +7,12 @@ import IHaskell.Test.Completion (testCompletions) import IHaskell.Test.Parser (testParser) import IHaskell.Test.Eval (testEval) +import IHaskell.Test.Hoogle (testHoogle) main :: IO () -main = +main = hspec $ do testParser testEval testCompletions + testHoogle diff --git a/src/tests/IHaskell/Test/Completion.hs b/src/tests/IHaskell/Test/Completion.hs --- a/src/tests/IHaskell/Test/Completion.hs +++ b/src/tests/IHaskell/Test/Completion.hs @@ -1,5 +1,9 @@ {-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} {-# LANGUAGE CPP #-} + +-- Shelly's types are kinda borked. +{-# OPTIONS_GHC -Wno-type-defaults #-} + module IHaskell.Test.Completion (testCompletions) where import Prelude @@ -23,12 +27,8 @@ completionTarget) import IHaskell.Test.Util (replace, shouldBeAmong, ghc) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - -- | @readCompletePrompt "xs*ys"@ return @(xs, i)@ where i is the location of --- @'*'@ in the input string. +-- @'*'@ in the input string. readCompletePrompt :: String -> (String, Int) readCompletePrompt string = case elemIndex '*' string of @@ -48,23 +48,20 @@ shouldHaveCompletionsInDirectory :: String -> [String] -> IO () shouldHaveCompletionsInDirectory string expected = do - (matched, completions) <- completionEventInDirectory string - let existsInCompletion = (`elem` completions) - unmatched = filter (not . existsInCompletion) expected + (_, completions) <- completionEventInDirectory string expected `shouldBeAmong` completions +completionHas :: String -> [String] -> IO () completionHas string expected = do - (matched, completions) <- ghc $ do + (_, completions) <- ghc $ do initCompleter completionEvent string - let existsInCompletion = (`elem` completions) - unmatched = filter (not . existsInCompletion) expected expected `shouldBeAmong` completions initCompleter :: Interpreter () initCompleter = do flags <- getSessionDynFlags - setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } + _ <- setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } -- Import modules. imports <- mapM parseImportDecl @@ -168,9 +165,8 @@ it "correctly interprets ~ as the environment HOME variable" $ do let shouldHaveCompletions :: String -> [String] -> IO () shouldHaveCompletions string expected = do - (matched, completions) <- withHsHome $ completionEvent string - let existsInCompletion = (`elem` completions) - unmatched = filter (not . existsInCompletion) expected + (_, completions) <- withHsHome $ completionEvent string + expected `shouldBeAmong` completions ":! cd ~/*" `shouldHaveCompletions` ["~/dir/"] ":! ~/*" `shouldHaveCompletions` ["~/dir/"] @@ -182,8 +178,6 @@ matchText <- withHsHome $ fst <$> uncurry complete (readCompletePrompt string) matchText `shouldBe` expected - setHomeEvent path = liftIO $ setEnv "HOME" (T.unpack $ toTextIgnore path) - it "generates the correct matchingText on `:! cd ~/*` " $ ":! cd ~/*" `shouldHaveMatchingText` ("~/" :: String) @@ -197,7 +191,7 @@ -> [Shelly.FilePath] -- ^ files relative to temporary directory -> (Shelly.FilePath -> Interpreter a) -> IO a --- | Run an Interpreter action, but first make a temporary directory +-- | Run an Interpreter action, but first make a temporary directory -- with some files and folder and cd to it. inDirectory dirs files action = shelly $ withTmpDir $ \dirPath -> do cd dirPath @@ -207,11 +201,11 @@ where cdEvent path = liftIO $ setCurrentDirectory path wrap :: String -> Interpreter a -> Interpreter a - wrap path action = do + wrap path actn = do initCompleter pwd <- IHaskell.Eval.Evaluate.liftIO getCurrentDirectory cdEvent path -- change to the temporary directory - out <- action -- run action + out <- actn -- run action cdEvent pwd -- change back to the original directory return out @@ -223,4 +217,5 @@ , p "dir" p "file2.lhs" ] where + p :: T.Text -> T.Text p = id diff --git a/src/tests/IHaskell/Test/Eval.hs b/src/tests/IHaskell/Test/Eval.hs --- a/src/tests/IHaskell/Test/Eval.hs +++ b/src/tests/IHaskell/Test/Eval.hs @@ -24,34 +24,34 @@ eval string = do outputAccum <- newIORef [] pagerAccum <- newIORef [] - let publish evalResult = + let publish evalResult _ = case evalResult of IntermediateResult{} -> return () - FinalResult outs page [] -> do + FinalResult outs page _ -> do modifyIORef outputAccum (outs :) modifyIORef pagerAccum (page :) noWidgetHandling s _ = return s getTemporaryDirectory >>= setCurrentDirectory let state = defaultKernelState { getLintStatus = LintOff } - interpret GHC.Paths.libdir False $ const $ - IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling + _ <- interpret GHC.Paths.libdir False $ const $ + IHaskell.Eval.Evaluate.evaluate state string publish noWidgetHandling out <- readIORef outputAccum - pagerOut <- readIORef pagerAccum - return (reverse out, unlines . map extractPlain . reverse $ pagerOut) + pagerout <- readIORef pagerAccum + return (reverse out, unlines . map extractPlain . reverse $ pagerout) becomes :: String -> [String] -> IO () becomes string expected = evaluationComparing comparison string where comparison :: ([Display], String) -> IO () - comparison (results, pageOut) = do + comparison (results, _pageOut) = do when (length results /= length expected) $ expectationFailure $ "Expected result to have " ++ show (length expected) ++ " results. Got " ++ show results - forM_ (zip results expected) $ \(ManyDisplay [Display result], expected) -> case extractPlain result of - "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expected - str -> str `shouldBe` expected + forM_ (zip results expected) $ \(ManyDisplay [Display result], expect) -> case extractPlain result of + "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expect + str -> str `shouldBe` expect evaluationComparing :: (([Display], String) -> IO b) -> String -> IO b evaluationComparing comparison string = do @@ -66,37 +66,30 @@ pages :: String -> [String] -> IO () pages string expected = evaluationComparing comparison string where - comparison (results, pageOut) = + comparison (_results, pageOut) = strip (stripHtml pageOut) `shouldBe` strip (fixQuotes $ unlines expected) -- A very, very hacky method for removing HTML stripHtml str = go str where - go ('<':str) = - case stripPrefix "script" str of + go ('<':xs) = + case stripPrefix "script" xs of Nothing -> go' str - Just str -> dropScriptTag str + Just s -> dropScriptTag s go (x:xs) = x : go xs go [] = [] - go' ('>':str) = go str - go' (x:xs) = go' xs + go' ('>':xs) = go xs + go' (_:xs) = go' xs go' [] = error $ "Unending bracket html tag in string " ++ str - dropScriptTag str = - case stripPrefix "" str of - Just str -> go str - Nothing -> dropScriptTag $ tail str + dropScriptTag str1 = + case stripPrefix "" str1 of + Just s -> go s + Nothing -> dropScriptTag $ tail str fixQuotes :: String -> String -#if MIN_VERSION_ghc(7, 8, 0) fixQuotes = id -#else - fixQuotes = map $ \char -> case char of - '\8216' -> '`' - '\8217' -> '\'' - c -> c -#endif testEval :: Spec @@ -163,6 +156,9 @@ it "prints Unicode characters correctly" $ do "putStrLn \"Héllö, Üñiço∂e!\"" `becomes` ["Héllö, Üñiço∂e!"] "putStrLn \"Привет!\"" `becomes` ["Привет!"] + + it "prints multiline output correctly" $ do + ":! printf \"hello\\nworld\"" `becomes` ["hello\nworld"] it "evaluates directives" $ do #if MIN_VERSION_ghc(8,2,0) diff --git a/src/tests/IHaskell/Test/Hoogle.hs b/src/tests/IHaskell/Test/Hoogle.hs new file mode 100644 --- /dev/null +++ b/src/tests/IHaskell/Test/Hoogle.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE QuasiQuotes #-} + +module IHaskell.Test.Hoogle ( testHoogle ) where + +import Test.Hspec +import Text.RawString.QQ + +import IHaskell.Eval.Hoogle +-- import Data.Text (unpack) +-- import qualified Data.Text.IO as T +preludeFmapJson :: String +preludeFmapJson = [r| +[ + { + "url": "https://hackage.haskell.org/package/base/docs/Prelude.html#v:fmap", + "module": { + "url": "https://hackage.haskell.org/package/base/docs/Prelude.html", + "name": "Prelude" + }, + "package": { + "url": "https://hackage.haskell.org/package/base", + "name": "base" + }, + "item": "<0>fmap :: Functor f => (a -> b) -> f a -> f b", + "type": "", + "docs": "" + } +]|] + +moduleJson :: String +moduleJson = [r| +[ + { + "url": "https://hackage.haskell.org/package/universum/docs/Universum-Functor-Fmap.html", + "module": {}, + "package": { + "url": "https://hackage.haskell.org/package/universum", + "name": "universum" + }, + "item": "module Universum.Functor.<0>Fmap", + "type": "module", + "docs": "This module contains useful functions to work with Functor type\nclass.\n" + } +]|] + +testHoogle :: Spec +testHoogle = describe "Hoogle Search" $ do + describe "fmap search result" $ do + let results = parseResponse preludeFmapJson :: [HoogleResult] + it "should find 1 results" $ do + length results `shouldBe` 1 + let (SearchResult (HoogleResponse loc signature _docUrl)) = head results + it "should not contain html markup" $ do + loc `shouldBe` "https://hackage.haskell.org/package/base/docs/Prelude.html#v:fmap" + signature `shouldBe` "fmap :: Functor f => (a -> b) -> f a -> f b" + describe "module result" $ do + let results = parseResponse moduleJson :: [HoogleResult] + let (SearchResult (HoogleResponse _loc signature _docUrl)) = head results + it "should not contain html markup" $ do + signature `shouldBe` "module Universum.Functor.Fmap" + it "should be renderable" $ do + (render Plain $ head results) `shouldStartWith` "module Universum.Functor.Fmap" + (render HTML $ head results) `shouldStartWith` "module" diff --git a/src/tests/IHaskell/Test/Parser.hs b/src/tests/IHaskell/Test/Parser.hs --- a/src/tests/IHaskell/Test/Parser.hs +++ b/src/tests/IHaskell/Test/Parser.hs @@ -1,25 +1,18 @@ {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE CPP #-} -module IHaskell.Test.Parser (testParser) where +module IHaskell.Test.Parser (testParser) where import Prelude import Data.String.Here (hereLit) import Test.Hspec -import Test.Hspec.Contrib.HUnit -import Test.HUnit (assertBool, assertFailure) +import Test.HUnit (assertFailure) import IHaskell.Test.Util (ghc, strip) import IHaskell.Eval.Parser (parseString, getModuleName, unloc, layoutChunks, Located(..), CodeBlock(..), DirectiveType(..), StringLoc(..), PragmaType(..)) import IHaskell.Eval.ParseShell (parseShell) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif - - parses :: String -> IO [CodeBlock] parses str = map unloc <$> ghc (parseString str) @@ -234,10 +227,4 @@ |]) >>= (`shouldBe` [Located 2 (Expression "first"), Located 4 (Expression "second")]) where dataKindsError = ParseError (Loc 1 10) msg -#if MIN_VERSION_ghc(7, 10, 0) msg = "Cannot parse data constructor in a data/newtype declaration: 3" -#elif MIN_VERSION_ghc(7, 8, 0) - msg = "Illegal literal in type (use DataKinds to enable): 3" -#else - msg = "Illegal literal in type (use -XDataKinds to enable): 3" -#endif