diff --git a/ihaskell.cabal b/ihaskell.cabal --- a/ihaskell.cabal +++ b/ihaskell.cabal @@ -7,7 +7,7 @@ -- PVP summary: +--+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.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, diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/src/IHaskell/CSS.hs b/src/IHaskell/CSS.hs --- a/src/IHaskell/CSS.hs +++ b/src/IHaskell/CSS.hs @@ -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);" diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -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 ["", T.pack s] + Nothing -> T.pack s -- | Generate an SVG display. svg :: T.Text -> DisplayData 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 @@ -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 - [ "
" - , "" - ] - 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 = "
Unshowable:%s%s
" 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 "%s" 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 "%s" diff --git a/src/IHaskell/Eval/Evaluate/HTML.hs b/src/IHaskell/Eval/Evaluate/HTML.hs new file mode 100644 --- /dev/null +++ b/src/IHaskell/Eval/Evaluate/HTML.hs @@ -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 ("
T.intercalate " " classNames <> "\">" <> spans <> "
") + + classNames = "code" : catMaybes [wrapClass] + + spans :: Text + spans = T.intercalate "\n" (fmap renderLine (getLines tokensAndTexts)) + + renderLine xs = mconcat [" classPrefix <> tokenToClassName token <> "\">" <> escapeHtml text <> "" + | (token, text) <- xs] + + tokensAndTexts = fromMaybe [] (tokenizeHaskell (T.pack str1)) + + escapeHtml text = text + & T.replace "\n" "
" + + 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" 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 @@ -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 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 @@ -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 ++ diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -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) "" "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 "" update filename (Args _ flags) = Right $ Args (Kernel $ Just filename) flags diff --git a/src/IHaskell/IPython.hs b/src/IHaskell/IPython.hs --- a/src/IHaskell/IPython.hs +++ b/src/IHaskell/IPython.hs @@ -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 diff --git a/src/IHaskell/Publish.hs b/src/IHaskell/Publish.hs --- a/src/IHaskell/Publish.hs +++ b/src/IHaskell/Publish.hs @@ -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 ["", h] - prependCss x = x makeUnique l (DisplayData MimeSvg s) = DisplayData MimeSvg diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -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`. 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 @@ -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 "" 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 "
type String :: *
\ntype String = [Char]
\t-- Defined in \8216GHC.Base\8217
" + ]] + ] +#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 "
type String = [Char] \t-- Defined in \8216GHC.Base\8217
" + ]] + ] +#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 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 @@ -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