ihaskell 0.10.4.0 → 0.11.0.0
raw patch · 14 files changed
+312/−157 lines, 14 filesdep +ghc-syntax-highlighterdep −heredep ~aesondep ~basedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-syntax-highlighter
Dependencies removed: here
Dependency ranges changed: aeson, base, ghc, ipython-kernel
API changes (from Hackage documentation)
+ IHaskell.Display: html' :: Maybe Text -> String -> DisplayData
+ IHaskell.Eval.Evaluate.HTML: htmlify :: Maybe Text -> Text -> String -> DisplayData
+ IHaskell.Flags: HtmlCodeTokenPrefix :: String -> Argument
+ IHaskell.Flags: HtmlCodeWrapperClass :: String -> Argument
+ IHaskell.IPython: [kernelSpecHtmlCodeTokenPrefix] :: KernelSpecOptions -> String
+ IHaskell.IPython: [kernelSpecHtmlCodeWrapperClass] :: KernelSpecOptions -> Maybe String
+ IHaskell.Types: [htmlCodeTokenPrefix] :: KernelState -> String
+ IHaskell.Types: [htmlCodeWrapperClass] :: KernelState -> Maybe String
+ IHaskell.Types: instance GHC.Classes.Eq IHaskell.Types.Display
- IHaskell.CSS: ihaskellCSS :: String
+ IHaskell.CSS: ihaskellCSS :: Text
- IHaskell.IPython: KernelSpecOptions :: String -> [String] -> Bool -> String -> IO (Maybe String) -> Maybe String -> Bool -> Maybe FilePath -> String -> String -> KernelSpecOptions
+ IHaskell.IPython: KernelSpecOptions :: String -> [String] -> Bool -> String -> Maybe String -> String -> IO (Maybe String) -> Maybe String -> Bool -> Maybe FilePath -> String -> String -> KernelSpecOptions
- IHaskell.Types: KernelState :: Int -> LintStatus -> Bool -> Bool -> Bool -> Bool -> Map UUID Widget -> Bool -> Bool -> KernelState
+ IHaskell.Types: KernelState :: Int -> LintStatus -> Bool -> Bool -> Bool -> Bool -> Map UUID Widget -> Bool -> Bool -> Maybe String -> String -> KernelState
Files
- ihaskell.cabal +36/−34
- main/Main.hs +14/−6
- src/IHaskell/CSS.hs +34/−7
- src/IHaskell/Display.hs +9/−2
- src/IHaskell/Eval/Evaluate.hs +23/−22
- src/IHaskell/Eval/Evaluate/HTML.hs +53/−0
- src/IHaskell/Eval/Lint.hs +6/−3
- src/IHaskell/Eval/Util.hs +25/−2
- src/IHaskell/Flags.hs +31/−13
- src/IHaskell/IPython.hs +13/−9
- src/IHaskell/Publish.hs +1/−6
- src/IHaskell/Types.hs +5/−1
- src/tests/IHaskell/Test/Eval.hs +57/−47
- src/tests/IHaskell/Test/Parser.hs +5/−5
ihaskell.cabal view
@@ -7,7 +7,7 @@ -- PVP summary: +--+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.10.4.0+version: 0.11.0.0 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the Jupyter project.@@ -61,40 +61,42 @@ if impl (ghc >= 8.4) ghc-options: -Wpartial-fields+ build-depends: ghc-syntax-highlighter+ exposed-modules: IHaskell.Eval.Evaluate.HTML build-depends:- base >=4.9 && <4.19,- binary ,- containers ,- directory ,- bytestring ,- exceptions ,- filepath ,- ghc >=8.0 && <9.7,- ghc-boot ,- haskeline ,- parsec ,- process ,- random ,- stm ,- text ,- time ,- transformers ,- unix ,- aeson >=1.0,- base64-bytestring >=1.0,- cmdargs >=0.10,- ghc-parser >=0.2.1,- ghc-paths >=0.1,- http-client >=0.4,- http-client-tls >=0.2,- shelly >=1.5,- split >=0.2,- strict >=0.3,- unordered-containers -any,- utf8-string -any,- vector -any,- ipython-kernel >=0.10.2.0+ base >=4.9 && <5,+ binary ,+ containers ,+ directory ,+ bytestring ,+ exceptions ,+ filepath ,+ ghc >=8.0 && <9.9,+ ghc-boot ,+ haskeline ,+ parsec ,+ process ,+ random ,+ stm ,+ text ,+ time ,+ transformers ,+ unix ,+ aeson >=1.0,+ base64-bytestring >=1.0,+ cmdargs >=0.10,+ ghc-parser >=0.2.1,+ ghc-paths >=0.1,+ http-client >=0.4,+ http-client-tls >=0.2,+ shelly >=1.5,+ split >=0.2,+ strict >=0.3,+ unordered-containers -any,+ utf8-string -any,+ vector -any,+ ipython-kernel >=0.11.0.0 exposed-modules: IHaskell.Display IHaskell.Convert@@ -179,6 +181,7 @@ IHaskell.Test.Hoogle default-language: Haskell2010 build-depends:+ aeson, base, ghc, ghc-paths,@@ -186,7 +189,6 @@ directory, text, ihaskell,- here, hspec, hspec-contrib, HUnit,
main/Main.hs view
@@ -5,9 +5,9 @@ -- Chans to communicate with the ZeroMQ sockets. module Main (main) where -import IHaskellPrelude-import qualified Data.Text as T import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import IHaskellPrelude -- Standard library imports. import Control.Concurrent.Chan@@ -97,6 +97,10 @@ kernelSpecOpts { kernelSpecDebug = True } addFlag kernelSpecOpts (CodeMirror codemirror) = kernelSpecOpts { kernelSpecCodeMirror = codemirror }+ addFlag kernelSpecOpts (HtmlCodeWrapperClass clazz) =+ kernelSpecOpts { kernelSpecHtmlCodeWrapperClass = Just clazz }+ addFlag kernelSpecOpts (HtmlCodeTokenPrefix prefix) =+ kernelSpecOpts { kernelSpecHtmlCodeTokenPrefix = prefix } addFlag kernelSpecOpts (GhcLibDir libdir) = kernelSpecOpts { kernelSpecGhcLibdir = libdir } addFlag kernelSpecOpts (KernelName name) =@@ -151,7 +155,7 @@ interface <- serveProfile profile debug -- Create initial state in the directory the kernel *should* be in.- state <- initialKernelState+ state <- initialKernelState kOpts modifyMVar_ state $ \kernelState -> return $ kernelState { kernelDebug = debug } @@ -169,7 +173,7 @@ noWidget s _ = return s evaluator line = void $ do -- Create a new state each time.- stateVar <- liftIO initialKernelState+ stateVar <- liftIO $ initialKernelState kOpts st <- liftIO $ takeMVar stateVar evaluate st line noPublish noWidget @@ -229,8 +233,12 @@ (key, _:val) -> setEnv key val -- Initial kernel state.-initialKernelState :: IO (MVar KernelState)-initialKernelState = newMVar defaultKernelState+initialKernelState :: KernelSpecOptions -> IO (MVar KernelState)+initialKernelState kOpts = newMVar (+ defaultKernelState {+ htmlCodeWrapperClass = kernelSpecHtmlCodeWrapperClass kOpts+ , htmlCodeTokenPrefix = kernelSpecHtmlCodeTokenPrefix kOpts+ }) -- | Create a new message header, given a parent message header. createReplyHeader :: MessageHeader -> Interpreter MessageHeader
src/IHaskell/CSS.hs view
@@ -1,12 +1,24 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+ module IHaskell.CSS (ihaskellCSS) where -import IHaskellPrelude+import Data.Text as T -ihaskellCSS :: String+ihaskellCSS :: Text ihaskellCSS =- unlines+ T.unlines [+ hoogleCSS+ , basicCSS+ , highlightCSS+ , hlintCSS+ ]++hoogleCSS :: Text+hoogleCSS =+ T.unlines+ [ -- Custom IHaskell CSS "/* Styles used for the Hoogle display in the pager */" , ".hoogle-doc {"@@ -43,7 +55,13 @@ , ".hoogle-class {" , "font-weight: bold;" , "}"- ,+ ]+++basicCSS :: Text+basicCSS =+ T.unlines+ [ -- Styles used for basic displays ".get-type {" , "color: green;"@@ -76,14 +94,23 @@ , ".err-msg.in.collapse {" , "padding-top: 0.7em;" , "}"- ,+ ]++highlightCSS :: Text+highlightCSS =+ T.unlines+ [ -- Code that will get highlighted before it is highlighted ".highlight-code {" , "white-space: pre;" , "font-family: monospace;" , "}"- ,- -- Hlint styles+ ]++hlintCSS :: Text+hlintCSS =+ T.unlines+ [ ".suggestion-warning { " , "font-weight: bold;" , "color: rgb(200, 130, 0);"
src/IHaskell/Display.hs view
@@ -25,6 +25,7 @@ -- * Constructors for displays plain, html,+ html', bmp, png, jpg,@@ -68,8 +69,8 @@ import qualified Data.Text.Encoding as E -import IHaskell.Types import IHaskell.Eval.Util (unfoldM)+import IHaskell.Types import StringUtils (rstrip) type Base64 = Text@@ -84,7 +85,13 @@ -- | Generate an HTML display. html :: String -> DisplayData-html = DisplayData MimeHtml . T.pack+html = html' Nothing++-- | Generate an HTML display with optional styles.+html' :: Maybe Text -> String -> DisplayData+html' maybeStyles s = DisplayData MimeHtml $ case maybeStyles of+ Just css -> mconcat ["<style>", css, "</style>", T.pack s]+ Nothing -> T.pack s -- | Generate an SVG display. svg :: T.Text -> DisplayData
src/IHaskell/Eval/Evaluate.hs view
@@ -92,6 +92,7 @@ import qualified GHC.Paths import GHC hiding (Stmt, TypeSig) +import IHaskell.CSS (ihaskellCSS) import IHaskell.Types import IHaskell.IPython import IHaskell.Eval.Parser@@ -105,6 +106,11 @@ import IHaskell.Eval.Lint #endif +#if MIN_VERSION_ghc(8,4,0)+import qualified Data.Text as Text+import IHaskell.Eval.Evaluate.HTML (htmlify)+#endif+ #if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString #elif MIN_VERSION_ghc(8,2,0)@@ -364,7 +370,7 @@ displayImports = map toImportStmt displayPkgs - void $ setSessionDynFlags $ dflgs { packageFlags = hiddenFlags ++ packageFlags dflgs }+ void $ setSessionDynFlags $ dflgs { packageFlags = packageFlags dflgs ++ hiddenFlags } #if MIN_VERSION_ghc(9,6,0) -- Import implicit prelude.@@ -930,23 +936,19 @@ -- Get all the info for all the names we're given. strings <- unlines <$> getDescription str - -- Make pager work without html by porting to newer architecture- let htmlify str1 =- html $- concat- [ "<div style='background: rgb(247, 247, 247);'><form><textarea id='code'>"- , str1- , "</textarea></form></div>"- , "<script>CodeMirror.fromTextArea(document.getElementById('code'),"- , " {mode: 'haskell', readOnly: 'nocursor'});</script>"- ]- return EvalOut { evalStatus = Success- , evalResult = mempty+ , evalResult = Display [+ plain strings+#if MIN_VERSION_ghc(8,4,0)+ , htmlify (Text.pack <$> htmlCodeWrapperClass state)+ (Text.pack $ htmlCodeTokenPrefix state)+ strings+#endif+ ] , evalState = state- , evalPager = [plain strings, htmlify strings]+ , evalPager = [] , evalMsgs = [] } @@ -1122,8 +1124,7 @@ txt = extractPlain disps postprocess (DisplayData MimeHtml _) =- html $ printf fmt unshowableType- (formatErrorWithClass "err-msg collapse" txt) script+ html' (Just ihaskellCSS) $ printf fmt unshowableType (formatErrorWithClass "err-msg collapse" txt) script where fmt = "<div class='collapse-group'><span class='btn btn-default' href='#' id='unshowable'>Unshowable:<span class='show-type'>%s</span></span>%s</div><script>%s</script>" script = unlines@@ -1167,7 +1168,7 @@ #endif return $ name ++ " :: " ++ theType - return $ Display [html $ unlines $ map formatGetType types]+ return $ Display [html' (Just ihaskellCSS) $ unlines $ map formatGetType types] evalCommand _ (TypeSignature sig) state = wrapExecution state $ -- We purposefully treat this as a "success" because that way execution continues. Empty type@@ -1199,7 +1200,7 @@ , evalResult = mempty , evalState = state , evalPager = [ plain $ unlines $ map (Hoogle.render Hoogle.Plain) results- , html $ unlines $ map (Hoogle.render Hoogle.HTML) results+ , html' (Just ihaskellCSS) $ unlines $ map (Hoogle.render Hoogle.HTML) results ] , evalMsgs = [] }@@ -1560,10 +1561,10 @@ return $ case extractPlain oput of- "" -> Display [html htmled]+ "" -> Display [html' (Just ihaskellCSS) htmled] -- Return plain and html versions. Previously there was only a plain version.- txt -> Display [plain $ joined ++ "\n" ++ txt, html $ htmled ++ mono txt]+ txt -> Display [plain $ joined ++ "\n" ++ txt, html' (Just ihaskellCSS) $ htmled ++ mono txt] ExecComplete (Left exception) _ -> throw exception ExecBreak{} -> error "Should not break."@@ -1616,10 +1617,10 @@ formatGetType = printf "<span class='get-type'>%s</span>" formatType :: String -> Display-formatType typeStr = Display [plain typeStr, html $ formatGetType typeStr]+formatType typeStr = Display [plain typeStr, html' (Just ihaskellCSS) $ formatGetType typeStr] displayError :: ErrMsg -> Display-displayError msg = Display [plain . typeCleaner $ msg, html $ formatError msg]+displayError msg = Display [plain . typeCleaner $ msg, html' (Just ihaskellCSS) $ formatError msg] mono :: String -> String mono = printf "<span class='mono'>%s</span>"
+ src/IHaskell/Eval/Evaluate/HTML.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}++module IHaskell.Eval.Evaluate.HTML (htmlify) where++import Data.Function ((&))+import qualified Data.List as L+import Data.Maybe+import Data.Text as T hiding (concat)+import GHC.SyntaxHighlighter (tokenizeHaskell)+import qualified GHC.SyntaxHighlighter as SH+import IHaskell.Display (html')+import IHaskell.IPython.Types (DisplayData)+++htmlify :: Maybe Text -> Text -> String -> DisplayData+htmlify wrapClass classPrefix str1 = html' Nothing outerDiv+ where+ outerDiv = T.unpack ("<div class=\"" <> T.intercalate " " classNames <> "\">" <> spans <> "</div>")++ classNames = "code" : catMaybes [wrapClass]++ spans :: Text+ spans = T.intercalate "\n" (fmap renderLine (getLines tokensAndTexts))++ renderLine xs = mconcat ["<span class=\"" <> classPrefix <> tokenToClassName token <> "\">" <> escapeHtml text <> "</span>"+ | (token, text) <- xs]++ tokensAndTexts = fromMaybe [] (tokenizeHaskell (T.pack str1))++ escapeHtml text = text+ & T.replace "\n" "<br />"++ getLines :: [(SH.Token, Text)] -> [[(SH.Token, Text)]]+ getLines [] = []+ getLines xs = (curLine <> [spaceBoundary]) : getLines (L.tail rest)+ where (curLine, rest) = L.span (/= spaceBoundary) xs++ spaceBoundary = (SH.SpaceTok, "\n")++tokenToClassName :: SH.Token -> Text+tokenToClassName SH.KeywordTok = "keyword"+tokenToClassName SH.PragmaTok = "meta"+tokenToClassName SH.SymbolTok = "atom"+tokenToClassName SH.VariableTok = "variable"+tokenToClassName SH.ConstructorTok = "variable-2"+tokenToClassName SH.OperatorTok = "operator"+tokenToClassName SH.CharTok = "char"+tokenToClassName SH.StringTok = "string"+tokenToClassName SH.IntegerTok = "number"+tokenToClassName SH.RationalTok = "number"+tokenToClassName SH.CommentTok = "comment"+tokenToClassName SH.SpaceTok = "space"+tokenToClassName SH.OtherTok = "builtin"
src/IHaskell/Eval/Lint.hs view
@@ -19,7 +19,7 @@ import Language.Haskell.HLint3 #endif -import IHaskell.Types+import IHaskell.CSS (ihaskellCSS) import IHaskell.Display import IHaskell.Eval.Parser hiding (line) import StringUtils (replace)@@ -78,7 +78,10 @@ return $ Display $ if null suggestions then []- else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]+ else [+ plain $ concatMap plainSuggestion suggestions+ , html' (Just ihaskellCSS) (htmlSuggestions suggestions)+ ] where autoSettings' = do (fixts, classify, hints) <- autoSettings@@ -111,7 +114,7 @@ return $ Display $ if null suggestions then []- else [plain $ concatMap plainSuggestion suggestions, html $ htmlSuggestions suggestions]+ else [plain $ concatMap plainSuggestion suggestions, html' (Just ihaskellCSS) $ htmlSuggestions suggestions] where autoSettings' = do (fixts, classify, hints) <- autoSettings
src/IHaskell/Eval/Util.hs view
@@ -34,9 +34,10 @@ #endif -- GHC imports.-#if MIN_VERSION_ghc(9,4,0)+#if MIN_VERSION_ghc(9,8,0) import GHC.Core.InstEnv (is_cls, is_tys, mkInstEnv, instEnvElts) import GHC.Core.Unify+import GHC.Data.Bag import GHC.Types.TyThing.Ppr import GHC.Driver.CmdLine import GHC.Driver.Monad (modifySession)@@ -45,13 +46,33 @@ import GHC.Driver.Env.Types import GHC.Platform.Ways import GHC.Runtime.Context+import GHC.Types.Error import GHC.Types.Name (pprInfixName) import GHC.Types.Name.Set import GHC.Types.TyThing import qualified GHC.Driver.Session as DynFlags+import qualified GHC.Utils.Error as E import qualified GHC.Utils.Outputable as O import qualified GHC.Utils.Ppr as Pretty import GHC.Runtime.Loader+#elif MIN_VERSION_ghc(9,4,0)+import GHC.Core.InstEnv (is_cls, is_tys, mkInstEnv, instEnvElts)+import GHC.Core.Unify+import GHC.Types.TyThing.Ppr+import GHC.Driver.CmdLine+import GHC.Driver.Monad (modifySession)+import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Driver.Env.Types+import GHC.Platform.Ways+import GHC.Runtime.Context+import GHC.Types.Name (pprInfixName)+import GHC.Types.Name.Set+import GHC.Types.TyThing+import qualified GHC.Driver.Session as DynFlags+import qualified GHC.Utils.Outputable as O+import qualified GHC.Utils.Ppr as Pretty+import GHC.Runtime.Loader #elif MIN_VERSION_ghc(9,2,0) import GHC.Core.InstEnv (is_cls, is_tys) import GHC.Core.Unify@@ -316,7 +337,9 @@ -- Create the parse errors. let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized-#if MIN_VERSION_ghc(8,4,0)+#if MIN_VERSION_ghc(9,8,0)+ allWarns = map (show . flip O.runSDoc O.defaultSDocContext . E.formatBulleted . diagnosticMessage defaultOpts . errMsgDiagnostic) (bagToList $ getWarningMessages warnings) +++#elif MIN_VERSION_ghc(8,4,0) allWarns = map (unLoc . warnMsg) warnings ++ #else allWarns = map unLoc warnings ++
src/IHaskell/Flags.hs view
@@ -12,8 +12,8 @@ help, ) where -import IHaskellPrelude hiding (Arg(..)) import qualified Data.Text as T+import IHaskellPrelude hiding (Arg(..)) import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Text@@ -23,17 +23,19 @@ 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.- | GhcLibDir String -- ^ Where to find the GHC libraries.- | RTSFlags [String] -- ^ Options for the GHC runtime (e.g. heap-size limit- -- or number of threads).- | KernelDebug -- ^ Spew debugging output from the kernel.- | KernelName String -- ^ The IPython kernel directory name.- | DisplayName String -- ^ The IPython display name.- | Help -- ^ Display help text.- | Version -- ^ Display version text.- | CodeMirror String -- ^ change codemirror mode (default=ihaskell)+data Argument = ConfFile String -- ^ A file with commands to load at startup.+ | 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).+ | KernelDebug -- ^ Spew debugging output from the kernel.+ | KernelName String -- ^ The IPython kernel directory name.+ | DisplayName String -- ^ The IPython display name.+ | Help -- ^ Display help text.+ | Version -- ^ Display version text.+ | CodeMirror String -- ^ change codemirror mode (default=ihaskell)+ | HtmlCodeWrapperClass String -- ^ set the wrapper class for HTML output+ | HtmlCodeTokenPrefix String -- ^ set a prefix on each token of HTML output | ConvertFrom String | ConvertTo String | ConvertFromFormat NotebookFormat@@ -137,6 +139,14 @@ kernelCodeMirrorFlag = flagReq ["codemirror"] (store CodeMirror) "<codemirror>" "Specify codemirror mode that is used for syntax highlighting (default: ihaskell)." +kernelHtmlCodeWrapperClassFlag :: Flag Args+kernelHtmlCodeWrapperClassFlag = flagReq ["html-code-wrapper-class"] (store HtmlCodeWrapperClass) "CodeMirror cm-s-jupyter cm-s-ipython"+ "Specify class name for wrapper div around HTML output (default: 'CodeMirror cm-s-jupyter cm-s-ipython')"++kernelHtmlCodeTokenPrefixFlag :: Flag Args+kernelHtmlCodeTokenPrefixFlag = flagReq ["html-code-token-prefix"] (store HtmlCodeTokenPrefix) "cm-"+ "Specify class name prefix for each token in HTML output (default: cm-)"+ kernelStackFlag :: Flag Args kernelStackFlag = flagNone ["stack"] addStack "Inherit environment from `stack` when it is installed"@@ -175,7 +185,15 @@ kernel :: Mode Args kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg- [ghcLibFlag, kernelDebugFlag, confFlag, kernelStackFlag, kernelEnvFileFlag, kernelCodeMirrorFlag]+ [ghcLibFlag+ , kernelDebugFlag+ , confFlag+ , kernelStackFlag+ , kernelEnvFileFlag+ , kernelCodeMirrorFlag+ , kernelHtmlCodeWrapperClassFlag+ , kernelHtmlCodeTokenPrefixFlag+ ] where kernelArg = flagArg update "<json-kernel-file>" update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags
src/IHaskell/IPython.hs view
@@ -13,9 +13,9 @@ installLabextension, ) where -import IHaskellPrelude import qualified Data.Text as T import qualified Data.Text.Lazy as LT+import IHaskellPrelude import qualified Shelly as SH import qualified System.IO as IO@@ -36,16 +36,18 @@ data KernelSpecOptions = KernelSpecOptions- { kernelSpecGhcLibdir :: String -- ^ GHC libdir.- , kernelSpecRTSOptions :: [String] -- ^ Runtime options to use.- , kernelSpecDebug :: Bool -- ^ Spew debugging output?- , kernelSpecCodeMirror :: String -- ^ CodeMirror mode- , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.+ { kernelSpecGhcLibdir :: String -- ^ GHC libdir.+ , kernelSpecRTSOptions :: [String] -- ^ Runtime options to use.+ , kernelSpecDebug :: Bool -- ^ Spew debugging output?+ , kernelSpecCodeMirror :: String -- ^ CodeMirror mode+ , kernelSpecHtmlCodeWrapperClass :: Maybe String -- ^ HTML output: class name for wrapper div+ , kernelSpecHtmlCodeTokenPrefix :: String -- ^ HTML output: class name prefix for token spans+ , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file. , kernelSpecInstallPrefix :: Maybe String- , kernelSpecUseStack :: Bool -- ^ Whether to use @stack@ environments.+ , kernelSpecUseStack :: Bool -- ^ Whether to use @stack@ environments. , kernelSpecEnvFile :: Maybe FilePath- , kernelSpecKernelName :: String -- ^ The IPython kernel name- , kernelSpecDisplayName :: String -- ^ The IPython kernel display name+ , kernelSpecKernelName :: String -- ^ The IPython kernel name+ , kernelSpecDisplayName :: String -- ^ The IPython kernel display name } defaultKernelSpecOptions :: KernelSpecOptions@@ -55,6 +57,8 @@ -- multithreading on two processors. , kernelSpecDebug = False , kernelSpecCodeMirror = "ihaskell"+ , kernelSpecHtmlCodeWrapperClass = Just "CodeMirror cm-s-jupyter cm-s-ipython"+ , kernelSpecHtmlCodeTokenPrefix = "cm-" , kernelSpecConfFile = defaultConfFile , kernelSpecInstallPrefix = Nothing , kernelSpecUseStack = False
src/IHaskell/Publish.hs view
@@ -10,7 +10,6 @@ import IHaskell.Display import IHaskell.Types-import IHaskell.CSS (ihaskellCSS) -- | Publish evaluation results, ignore any CommMsgs. This function can be used to create a function -- of type (EvaluationResult -> IO ()), which can be used to publish results to the frontend. The@@ -73,14 +72,10 @@ sendOutput uniqueLabel (Display outs) = case success of Success -> do hdr <- dupHeader replyHeader DisplayDataMessage- send $ PublishDisplayData hdr (map (makeUnique uniqueLabel . prependCss) outs) Nothing+ send $ PublishDisplayData hdr (map (makeUnique uniqueLabel) outs) Nothing Failure -> do hdr <- dupHeader replyHeader ExecuteErrorMessage send $ ExecuteError hdr [T.pack (extractPlain outs)] "" ""-- prependCss (DisplayData MimeHtml h) =- DisplayData MimeHtml $ mconcat ["<style>", T.pack ihaskellCSS, "</style>", h]- prependCss x = x makeUnique l (DisplayData MimeSvg s) = DisplayData MimeSvg
src/IHaskell/Types.hs view
@@ -159,7 +159,7 @@ -- expression. data Display = Display [DisplayData] | ManyDisplay [Display]- deriving (Show, Typeable, Generic)+ deriving (Show, Eq, Typeable, Generic) instance ToJSON Display where toJSON (Display d) = object (map displayDataToJson d)@@ -189,6 +189,8 @@ , openComms :: Map UUID Widget , kernelDebug :: Bool , supportLibrariesAvailable :: Bool+ , htmlCodeWrapperClass :: Maybe String -- ^ HTML output: class name for wrapper div+ , htmlCodeTokenPrefix :: String -- ^ HTML output: class name prefix for token spans } deriving Show @@ -203,6 +205,8 @@ , openComms = mempty , kernelDebug = False , supportLibrariesAvailable = True+ , htmlCodeWrapperClass = Just "CodeMirror cm-s-jupyter cm-s-ipython"+ , htmlCodeTokenPrefix = "cm-" } -- | Kernel options to be set via `:set` and `:option`.
src/tests/IHaskell/Test/Eval.hs view
@@ -1,24 +1,26 @@-{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+ module IHaskell.Test.Eval (testEval) where import Prelude -import Data.List (stripPrefix) import Control.Monad (when, forM_)+import Data.Aeson (encode) import Data.IORef (newIORef, modifyIORef, readIORef) import System.Directory (getTemporaryDirectory, setCurrentDirectory) -import Data.String.Here (hereLit)+import Text.RawString.QQ (r) import qualified GHC.Paths import Test.Hspec -import IHaskell.Test.Util (strip) import IHaskell.Eval.Evaluate (interpret, evaluate)-import IHaskell.Types (EvaluationResult(..), defaultKernelState, KernelState(..),- LintStatus(..), Display(..), extractPlain)+import IHaskell.Test.Util (strip)+import IHaskell.Types (Display(..), DisplayData(..), EvaluationResult(..), KernelState(..),+ LintStatus(..), MimeType(..), defaultKernelState, extractPlain) eval :: String -> IO ([Display], String) eval string = do@@ -40,6 +42,13 @@ pagerout <- readIORef pagerAccum return (reverse out, unlines . map extractPlain . reverse $ pagerout) +displayDatasBecome :: String -> [Display] -> IO ()+displayDatasBecome command desired = do+ (displays, _output) <- eval command+ when (displays /= desired) $+ expectationFailure $ "Expected display datas to be " ++ show (encode desired)+ ++ ". Got " ++ show (encode displays)+ becomes :: String -> [String] -> IO () becomes string expected = evaluationComparing comparison string where@@ -47,7 +56,7 @@ comparison (results, _pageOut) = do when (length results /= length expected) $ expectationFailure $ "Expected result to have " ++ show (length expected)- ++ " results. Got " ++ show results+ ++ " results. Got " ++ show (encode results) forM_ (zip results expected) $ \(ManyDisplay [Display result], expect) -> case extractPlain result of "" -> expectationFailure $ "No plain-text output in " ++ show result ++ "\nExpected: " ++ expect@@ -63,40 +72,13 @@ newString = unlines $ map (drop minIndent) stringLines eval newString >>= comparison -pages :: String -> [String] -> IO ()-pages string expected = evaluationComparing comparison string- where- 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 ('<':xs) =- case stripPrefix "script" xs of- Nothing -> go' str- Just s -> dropScriptTag s- go (x:xs) = x : go xs- go [] = []-- go' ('>':xs) = go xs- go' (_:xs) = go' xs- go' [] = error $ "Unending bracket html tag in string " ++ str-- dropScriptTag str1 =- case stripPrefix "</script>" str1 of- Just s -> go s- Nothing -> dropScriptTag $ tail str-- fixQuotes :: String -> String- fixQuotes = id-- testEval :: Spec testEval = describe "Code Evaluation" $ do it "gets rid of the test failure with Nix" $ let+ throwAway :: String -> [String] -> IO () throwAway string _ = evaluationComparing (const $ shouldBe True True) string in throwAway "True" ["True"]@@ -105,25 +87,27 @@ "3" `becomes` ["3"] "3+5" `becomes` ["8"] "print 3" `becomes` ["3"]- [hereLit|+ [r| let x = 11 z = 10 in x+z |] `becomes` ["21"] - it "evaluates flags" $ do+ it "evaluates :set -package" $ do ":set -package hello" `becomes` ["Warning: -package not supported yet"]- ":set -XNoImplicitPrelude" `becomes` [] + -- it "evaluates :set -XNoImplicitPrelude" $ do+ -- ":set -XNoImplicitPrelude" `becomes` []+ it "evaluates multiline expressions" $ do- [hereLit|+ [r| import Control.Monad forM_ [1, 2, 3] $ \x -> print x |] `becomes` ["1\n2\n3"] it "evaluates function declarations silently" $ do- [hereLit|+ [r| fun :: [Int] -> Int fun [] = 3 fun (x:xs) = 10@@ -131,7 +115,7 @@ |] `becomes` ["10"] it "evaluates data declarations" $ do- [hereLit|+ [r| data X = Y Int | Z String deriving (Show, Eq)@@ -140,7 +124,7 @@ |] `becomes` ["[Y 3,Z \"No\"]", "False"] it "evaluates do blocks in expressions" $ do- [hereLit|+ [r| show (show (do Just 10 Nothing@@ -160,7 +144,7 @@ it "prints multiline output correctly" $ do ":! printf \"hello\\nworld\"" `becomes` ["hello\nworld"] - it "evaluates directives" $ do+ it "evaluates :typ directive" $ do #if MIN_VERSION_ghc(9,2,0) -- It's `a` instead of `p` ":typ 3" `becomes` ["3 :: forall {a}. Num a => a"]@@ -173,21 +157,47 @@ #else ":typ 3" `becomes` ["3 :: forall t. Num t => t"] #endif++ it "evaluates :k directive" $ do ":k Maybe" `becomes` ["Maybe :: * -> *"]++ it "evaluates :in directive" $ do #if MIN_VERSION_ghc(8,10,0)- ":in String" `pages` ["type String :: *\ntype String = [Char]\n \t-- Defined in \8216GHC.Base\8217"]+ displayDatasBecome ":in String" [+ ManyDisplay [Display [+ DisplayData PlainText "type String :: *\ntype String = [Char]\n \t-- Defined in \8216GHC.Base\8217"+ , DisplayData MimeHtml "<div class=\"code CodeMirror cm-s-jupyter cm-s-ipython\"><span class=\"cm-keyword\">type</span><span class=\"cm-space\"> </span><span class=\"cm-variable-2\">String</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">::</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">*</span><span class=\"cm-space\"><br /></span>\n<span class=\"cm-keyword\">type</span><span class=\"cm-space\"> </span><span class=\"cm-variable-2\">String</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">=</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">[</span><span class=\"cm-variable-2\">Char</span><span class=\"cm-atom\">]</span><span class=\"cm-space\"><br /> \t</span><span class=\"cm-comment\">-- Defined in \8216GHC.Base\8217</span><span class=\"cm-space\"><br /></span></div>"+ ]]+ ]+#elif MIN_VERSION_ghc(8,4,0)+ displayDatasBecome ":in String" [+ ManyDisplay [Display [+ DisplayData PlainText "type String = [Char] \t-- Defined in \8216GHC.Base\8217"+ , DisplayData MimeHtml "<div class=\"code CodeMirror cm-s-jupyter cm-s-ipython\"><span class=\"cm-keyword\">type</span><span class=\"cm-space\"> </span><span class=\"cm-variable-2\">String</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">=</span><span class=\"cm-space\"> </span><span class=\"cm-atom\">[</span><span class=\"cm-variable-2\">Char</span><span class=\"cm-atom\">]</span><span class=\"cm-space\"> \t</span><span class=\"cm-comment\">-- Defined in \8216GHC.Base\8217</span><span class=\"cm-space\"><br /></span></div>"+ ]]+ ]+#elif MIN_VERSION_ghc(8,2,0)+ displayDatasBecome ":in String" [+ ManyDisplay [Display [+ DisplayData PlainText "type String = [Char] \t-- Defined in \8216GHC.Base\8217"+ ]]+ ] #else- ":in String" `pages` ["type String = [Char] \t-- Defined in \8216GHC.Base\8217"]+ displayDatasBecome ":in String" [+ ManyDisplay [Display [+ DisplayData PlainText "type String = [Char] \t-- Defined in \8216GHC.Base\8217"+ ]]+ ] #endif it "captures stderr" $ do- [hereLit|+ [r| import Debug.Trace trace "test" 5 |] `becomes` ["test\n5"] it "immediately applies language extensions" $ do- [hereLit|+ [r| {-# LANGUAGE RankNTypes #-} identity :: forall a. a -> a
src/tests/IHaskell/Test/Parser.hs view
@@ -4,7 +4,7 @@ import Prelude -import Data.String.Here (hereLit)+import Text.RawString.QQ (r) import Test.Hspec import Test.HUnit (assertFailure)@@ -47,7 +47,7 @@ map unloc (layoutChunks "a\n\nstring") `shouldBe` ["a", "string"] it "parses multiple exprs" $ do- let text = [hereLit|+ let text = [r| first second@@ -201,7 +201,7 @@ parses "import X\nprint 3" `like` [Import "import X", Expression "print 3"] parses "import X\n\nprint 3" `like` [Import "import X", Expression "print 3"] it "ignores blank lines properly" $- [hereLit|+ [r| test arg = hello where x = y@@ -213,7 +213,7 @@ ("img ! src \"" ++ longString ++ "\" ! width \"500\"") `is` Expression it "parses do blocks in expression" $ do- [hereLit|+ [r| show (show (do Just 10 Nothing@@ -221,7 +221,7 @@ |] `is` Expression it "correctly locates parsed items" $ do ghc (parseString- [hereLit|+ [r| first second