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.2.1 +version: 0.10.2.2 -- A short (one-line) description of the package. synopsis: A Haskell backend kernel for the IPython project. @@ -45,7 +45,15 @@ data-files: html/kernel.js html/logo-64x64.svg + jupyterlab-ihaskell/labextension/package.json + jupyterlab-ihaskell/labextension/static/*.js + jupyterlab-ihaskell/labextension/static/*.json +flag use-hlint + description: Include HLint support + default: True + manual: True + library hs-source-dirs: src default-language: Haskell2010 @@ -55,44 +63,38 @@ ghc-options: -Wpartial-fields build-depends: + base >=4.9 && <4.17, + binary , + containers , + directory , + bytestring , + exceptions , + filepath , + ghc >=8.0 && <9.3, + ghc-boot , + haskeline , + parsec , + process , + random , + stm , + text , + time , + transformers , + unix , aeson >=1.0, - base >=4.9, base64-bytestring >=1.0, - bytestring >=0.10, - cereal >=0.3, cmdargs >=0.10, - containers >=0.5, - directory -any, - exceptions -any, - filepath -any, - ghc >=8.0, ghc-parser >=0.2.1, ghc-paths >=0.1, - haskeline -any, - hlint >=1.9, - http-client >= 0.4, - http-client-tls >= 0.2, - mtl >=2.1, - parsec -any, - process >=1.1, - random >=1.0, + http-client >=0.4, + http-client-tls >=0.2, shelly >=1.5, - split >= 0.2, - stm -any, + split >=0.2, strict >=0.3, - text >=0.11, - time >= 1.6, - transformers -any, - unix >= 2.6, unordered-containers -any, utf8-string -any, vector -any, - ipython-kernel >=0.10.2.0, - ghc-boot >=8.0 && <9.1 - - if impl (ghc < 8.10) - build-depends: - haskell-src-exts >=1.18 + ipython-kernel >=0.10.2.0 exposed-modules: IHaskell.Display IHaskell.Convert @@ -103,7 +105,6 @@ IHaskell.Eval.Inspect IHaskell.Eval.Evaluate IHaskell.Eval.Info - IHaskell.Eval.Lint IHaskell.Eval.Parser IHaskell.Eval.Hoogle IHaskell.Eval.ParseShell @@ -121,13 +122,21 @@ other-modules: StringUtils + if flag(use-hlint) + exposed-modules: IHaskell.Eval.Lint + build-depends: hlint >=1.9 + cpp-options: -DUSE_HLINT + + if flag(use-hlint) && impl (ghc < 8.10) + build-depends: haskell-src-exts >=1.18 + executable ihaskell -- .hs or .lhs file containing the Main module. main-is: Main.hs hs-source-dirs: main other-modules: Paths_ihaskell - ghc-options: -threaded -rtsopts -Wall -dynamic + ghc-options: -threaded -rtsopts -Wall if os(darwin) ghc-options: -optP-Wno-nonportable-include-path @@ -138,21 +147,20 @@ -- Other library packages from which modules are imported. default-language: Haskell2010 build-depends: - ihaskell -any, - base >=4.9 && < 4.16, - text >=0.11, - transformers -any, - ghc >=8.0 && < 9.1, - 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.10, - unordered-containers -any + base , + bytestring , + containers , + directory , + text , + transformers , + ghc , + process , + unix , + aeson , + ihaskell , + ipython-kernel , + strict , + unordered-containers Test-Suite hspec Type: exitcode-stdio-1.0 @@ -172,16 +180,16 @@ default-language: Haskell2010 build-depends: base, - ihaskell, - here, - hspec, - hspec-contrib, - HUnit, ghc, ghc-paths, transformers, directory, text, + ihaskell, + here, + hspec, + hspec-contrib, + HUnit, shelly, raw-strings-qq, setenv diff --git a/jupyterlab-ihaskell/labextension/package.json b/jupyterlab-ihaskell/labextension/package.json new file mode 100644 --- /dev/null +++ b/jupyterlab-ihaskell/labextension/package.json @@ -0,0 +1,54 @@ +{ + "name": "jupyterlab-ihaskell", + "version": "0.0.14", + "description": "adds ihaskell syntax highlighting to jupyterlab", + "keywords": [ + "jupyter", + "jupyterlab", + "ihaskell", + "jupyterlab-extension" + ], + "homepage": "https://github.com/gibiansky/IHaskell/", + "bugs": { + "url": "https://github.com/gibiansky/IHaskell/issues" + }, + "license": "BSD-3-Clause", + "author": "MMesch", + "files": [ + "lib/**/*.{d.ts,js,js.map,json}" + ], + "main": "lib/index.js", + "types": "lib/index.d.ts", + "repository": { + "type": "git", + "url": "git@github.com:gibiansky/IHaskell.git" + }, + "scripts": { + "build": "tsc", + "clean": "rimraf lib", + "watch": "tsc -w" + }, + "dependencies": { + "@jupyterlab/application": ">=3.0.0", + "@jupyterlab/codemirror": ">=3.0.0", + "@jupyterlab/apputils": ">=3.0.0", + "@jupyterlab/docregistry": ">=3.0.0", + "@jupyterlab/notebook": ">=3.0.0", + "@jupyterlab/services": ">=6.0.0" + }, + "devDependencies": { + "rimraf": "^3.0.0", + "typescript": "~3.7.3", + "@types/codemirror": ">=0.0.0", + "@jupyterlab/builder": ">=3.0.0" + }, + "jupyterlab": { + "extension": true, + "outputDir": "labextension", + "webpackConfig": "./webpack.config.js", + "_build": { + "load": "static/remoteEntry-ddc4c9d791a676e50bb9.js", + "extension": "./extension" + } + } +} diff --git a/jupyterlab-ihaskell/labextension/static/568-1b6fb876268b3f3be3f4.js b/jupyterlab-ihaskell/labextension/static/568-1b6fb876268b3f3be3f4.js new file mode 100644 --- /dev/null +++ b/jupyterlab-ihaskell/labextension/static/568-1b6fb876268b3f3be3f4.js @@ -0,0 +1,1 @@ +"use strict";(self.webpackChunkjupyterlab_ihaskell=self.webpackChunkjupyterlab_ihaskell||[]).push([[568],{291:function(e,t,l){var i=this&&this.__awaiter||function(e,t,l,i){return new(l||(l=Promise))((function(n,o){function r(e){try{s(i.next(e))}catch(e){o(e)}}function a(e){try{s(i.throw(e))}catch(e){o(e)}}function s(e){var t;e.done?n(e.value):(t=e.value,t instanceof l?t:new l((function(e){e(t)}))).then(r,a)}s((i=i.apply(e,t||[])).next())}))};Object.defineProperty(t,"__esModule",{value:!0});const n=l(36);t.defineIHaskellMode=function({CodeMirror:e}){return i(this,void 0,void 0,(function*(){yield n.Mode.ensure("haskell"),yield n.Mode.ensure("r"),e.defineMode("ihaskell",(t=>{let l=e.getMode(t,"haskell");return e.multiplexingMode(l,{open:/:(?=!)/,close:/^(?!!)/,mode:e.getMode(t,"text/plain"),delimStyle:"delimit"},{open:/\[r\||\[rprint\||\[rgraph\|/,close:/\|\]/,mode:e.getMode(t,"text/x-rsrc"),delimStyle:"delimit"})})),e.defineMIME("text/x-ihaskell","ihaskell"),e.modeInfo.push({ext:["hs"],mime:"text/x-ihaskell",mode:"ihaskell",name:"ihaskell"})}))}},568:(e,t,l)=>{Object.defineProperty(t,"__esModule",{value:!0});const i=l(36),n=l(291),o={id:"ihaskell",autoStart:!0,requires:[i.ICodeMirror],activate:(e,t)=>{n.defineIHaskellMode(t).catch(console.warn)}};t.default=o}}]); diff --git a/jupyterlab-ihaskell/labextension/static/remoteEntry-ddc4c9d791a676e50bb9.js b/jupyterlab-ihaskell/labextension/static/remoteEntry-ddc4c9d791a676e50bb9.js new file mode 100644 --- /dev/null +++ b/jupyterlab-ihaskell/labextension/static/remoteEntry-ddc4c9d791a676e50bb9.js @@ -0,0 +1,1 @@ +var _JUPYTERLAB;(()=>{"use strict";var e,r,t,n,o,a,i,l,u,s,f,p,h,c,d,v={494:(e,r,t)=>{var n={"./index":()=>t.e(568).then((()=>()=>t(568))),"./extension":()=>t.e(568).then((()=>()=>t(568)))},o=(e,r)=>(t.R=r,r=t.o(n,e)?n[e]():Promise.resolve().then((()=>{throw new Error('Module "'+e+'" does not exist in container.')})),t.R=void 0,r),a=(e,r)=>{if(t.S){var n=t.S.default,o="default";if(n&&n!==e)throw new Error("Container initialization failed as it has already been initialized with a different share scope");return t.S[o]=e,t.I(o,r)}};t.d(r,{get:()=>o,init:()=>a})}},b={};function g(e){var r=b[e];if(void 0!==r)return r.exports;var t=b[e]={exports:{}};return v[e].call(t.exports,t,t.exports,g),t.exports}g.m=v,g.c=b,g.d=(e,r)=>{for(var t in r)g.o(r,t)&&!g.o(e,t)&&Object.defineProperty(e,t,{enumerable:!0,get:r[t]})},g.f={},g.e=e=>Promise.all(Object.keys(g.f).reduce(((r,t)=>(g.f[t](e,r),r)),[])),g.u=e=>e+"-1b6fb876268b3f3be3f4.js",g.g=function(){if("object"==typeof globalThis)return globalThis;try{return this||new Function("return this")()}catch(e){if("object"==typeof window)return window}}(),g.o=(e,r)=>Object.prototype.hasOwnProperty.call(e,r),e={},r="jupyterlab-ihaskell:",g.l=(t,n,o,a)=>{if(e[t])e[t].push(n);else{var i,l;if(void 0!==o)for(var u=document.getElementsByTagName("script"),s=0;s{i.onerror=i.onload=null,clearTimeout(h);var o=e[t];if(delete e[t],i.parentNode&&i.parentNode.removeChild(i),o&&o.forEach((e=>e(n))),r)return r(n)},h=setTimeout(p.bind(null,void 0,{type:"timeout",target:i}),12e4);i.onerror=p.bind(null,i.onerror),i.onload=p.bind(null,i.onload),l&&document.head.appendChild(i)}},(()=>{g.S={};var e={},r={};g.I=(t,n)=>{n||(n=[]);var o=r[t];if(o||(o=r[t]={}),!(n.indexOf(o)>=0)){if(n.push(o),e[t])return e[t];g.o(g.S,t)||(g.S[t]={});var a=g.S[t],i="jupyterlab-ihaskell",l=[];switch(t){case"default":((e,r,t,n)=>{var o=a[e]=a[e]||{},l=o[r];(!l||!l.loaded&&(1!=!l.eager?n:i>l.from))&&(o[r]={get:()=>g.e(568).then((()=>()=>g(568))),from:i,eager:!1})})("jupyterlab-ihaskell","0.0.14")}return e[t]=l.length?Promise.all(l).then((()=>e[t]=1)):1}}})(),(()=>{var e;g.g.importScripts&&(e=g.g.location+"");var r=g.g.document;if(!e&&r&&(r.currentScript&&(e=r.currentScript.src),!e)){var t=r.getElementsByTagName("script");t.length&&(e=t[t.length-1].src)}if(!e)throw new Error("Automatic publicPath is not supported in this browser");e=e.replace(/#.*$/,"").replace(/\?.*$/,"").replace(/\/[^\/]+$/,"/"),g.p=e})(),t=e=>{var r=e=>e.split(".").map((e=>+e==e?+e:e)),t=/^([^-+]+)?(?:-([^+]+))?(?:\+(.+))?$/.exec(e),n=t[1]?r(t[1]):[];return t[2]&&(n.length++,n.push.apply(n,r(t[2]))),t[3]&&(n.push([]),n.push.apply(n,r(t[3]))),n},n=(e,r)=>{e=t(e),r=t(r);for(var n=0;;){if(n>=e.length)return n=r.length)return"u"==a;var i=r[n],l=(typeof i)[0];if(a!=l)return"o"==a&&"n"==l||"s"==l||"u"==a;if("o"!=a&&"u"!=a&&o!=i)return o{var r=e[0],t="";if(1===e.length)return"*";if(r+.5){t+=0==r?">=":-1==r?"<":1==r?"^":2==r?"~":r>0?"=":"!=";for(var n=1,a=1;a0?".":"")+(n=2,l);return t}var i=[];for(a=1;a{if(0 in e){r=t(r);var n=e[0],o=n<0;o&&(n=-n-1);for(var i=0,l=1,u=!0;;l++,i++){var s,f,p=l=r.length||"o"==(f=(typeof(s=r[i]))[0]))return!u||("u"==p?l>n&&!o:""==p!=o);if("u"==f){if(!u||"u"!=p)return!1}else if(u)if(p==f)if(l<=n){if(s!=e[l])return!1}else{if(o?s>e[l]:s{var t=g.S[e];if(!t||!g.o(t,r))throw new Error("Shared module "+r+" doesn't exist in shared scope "+e);return t},l=(e,r)=>{var t=e[r];return Object.keys(t).reduce(((e,r)=>!e||!t[e].loaded&&n(e,r)?r:e),0)},u=(e,r,t)=>"Unsatisfied version "+r+" of shared singleton module "+e+" (required "+o(t)+")",s=(e,r,t,n)=>{var o=l(e,t);return a(n,o)||"undefined"!=typeof console&&console.warn&&console.warn(u(t,o,n)),f(e[t][o])},f=e=>(e.loaded=1,e.get()),p=(e=>function(r,t,n,o){var a=g.I(r);return a&&a.then?a.then(e.bind(e,r,g.S[r],t,n,o)):e(r,g.S[r],t,n)})(((e,r,t,n)=>(i(e,t),s(r,0,t,n)))),h={},c={36:()=>p("default","@jupyterlab/codemirror",[1,3,0,7])},d={568:[36]},g.f.consumes=(e,r)=>{g.o(d,e)&&d[e].forEach((e=>{if(g.o(h,e))return r.push(h[e]);var t=r=>{h[e]=0,g.m[e]=t=>{delete g.c[e],t.exports=r()}},n=r=>{delete h[e],g.m[e]=t=>{throw delete g.c[e],r}};try{var o=c[e]();o.then?r.push(h[e]=o.then(t).catch(n)):t(o)}catch(e){n(e)}}))},(()=>{var e={589:0};g.f.j=(r,t)=>{var n=g.o(e,r)?e[r]:void 0;if(0!==n)if(n)t.push(n[2]);else{var o=new Promise(((t,o)=>n=e[r]=[t,o]));t.push(n[2]=o);var a=g.p+g.u(r),i=new Error;g.l(a,(t=>{if(g.o(e,r)&&(0!==(n=e[r])&&(e[r]=void 0),n)){var o=t&&("load"===t.type?"missing":t.type),a=t&&t.target&&t.target.src;i.message="Loading chunk "+r+" failed.\n("+o+": "+a+")",i.name="ChunkLoadError",i.type=o,i.request=a,n[1](i)}}),"chunk-"+r,r)}};var r=(r,t)=>{var n,o,[a,i,l]=t,u=0;if(a.some((r=>0!==e[r]))){for(n in i)g.o(i,n)&&(g.m[n]=i[n]);l&&l(g)}for(r&&r(t);u getArgs @@ -56,6 +62,7 @@ ihaskell (Args InstallKernelSpec args) = showingHelp InstallKernelSpec args $ do let kernelSpecOpts = parseKernelArgs args replaceIPythonKernelspec kernelSpecOpts + installLabextension (kernelSpecDebug kernelSpecOpts) ihaskell (Args (Kernel (Just filename)) args) = do let kernelSpecOpts = parseKernelArgs args runKernel kernelSpecOpts filename @@ -98,6 +105,8 @@ kernelSpecOpts { kernelSpecInstallPrefix = Just prefix } addFlag kernelSpecOpts KernelspecUseStack = kernelSpecOpts { kernelSpecUseStack = True } + addFlag kernelSpecOpts (KernelspecEnvFile fp) = + kernelSpecOpts { kernelSpecEnvFile = Just fp } addFlag _kernelSpecOpts flag = error $ "Unknown flag" ++ show flag -- | Run the IHaskell language kernel. @@ -127,14 +136,13 @@ -- If we're in a stack directory, use `stack` to set the environment -- We can't do this with base <= 4.6 because setEnv doesn't exist. - when stack $ do - stackEnv <- lines <$> readProcess "stack" ["exec", "env"] "" - forM_ stackEnv $ \line -> - let (var, val) = break (== '=') line - in case tailMay val of - Nothing -> return () - Just val' -> setEnv var val' + when stack $ + readProcess "stack" ["exec", "env"] "" >>= parseAndSetEnv + case kernelSpecEnvFile kOpts of + Nothing -> return () + Just envFile -> readFile envFile >>= parseAndSetEnv + -- Serve on all sockets and ports defined in the profile. interface <- serveProfile profile debug @@ -210,6 +218,12 @@ isCommMessage req = mhMsgType (header req) `elem` [CommDataMessage, CommCloseMessage] + parseAndSetEnv envLines = + forM_ (lines envLines) $ \line -> do + case break (== '=') line of + (_, []) -> return () + (key, _:val) -> setEnv key val + -- Initial kernel state. initialKernelState :: IO (MVar KernelState) initialKernelState = newMVar defaultKernelState @@ -332,7 +346,11 @@ let start = pos - length matchedText end = pos +#if MIN_VERSION_aeson(2,0,0) + reply = CompleteReply replyHeader (map T.pack completions) start end (Metadata KeyMap.empty) True +#else reply = CompleteReply replyHeader (map T.pack completions) start end (Metadata HashMap.empty) True +#endif return (state, reply) replyTo _ _ req@InspectRequest{} replyHeader state = do @@ -379,7 +397,11 @@ commMap = openComms state uuidTargetPairs = map (second targetName) $ Map.toList commMap +#if MIN_VERSION_aeson(2,0,0) + pairProcessor (x, y) = (Key.fromText $ T.pack (UUID.uuidToString x)) .= object ["target_name" .= T.pack y] +#else pairProcessor (x, y) = T.pack (UUID.uuidToString x) .= object ["target_name" .= T.pack y] +#endif currentComms = object $ map pairProcessor $ (incomingUuid, "comm") : uuidTargetPairs diff --git a/src/IHaskell/Convert.hs b/src/IHaskell/Convert.hs --- a/src/IHaskell/Convert.hs +++ b/src/IHaskell/Convert.hs @@ -5,13 +5,12 @@ import IHaskellPrelude -import Control.Monad.Identity (Identity(Identity), unless, when) +import Data.Functor.Identity (Identity(Identity)) import IHaskell.Convert.Args (ConvertSpec(..), fromJustConvertSpec, toConvertSpec) import IHaskell.Convert.IpynbToLhs (ipynbToLhs) import IHaskell.Convert.LhsToIpynb (lhsToIpynb) import IHaskell.Flags (Argument) import System.Directory (doesFileExist) -import Text.Printf (printf) -- | used by @IHaskell convert@ convert :: [Argument] -> IO () 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 @@ -6,14 +6,10 @@ import IHaskellPrelude import qualified Data.Text.Lazy as LT -import Control.Applicative ((<$>)) -import Control.Monad.Identity (Identity(Identity)) +import Data.Functor.Identity (Identity(Identity)) import Data.Char (toLower) -import Data.List (partition) -import Data.Maybe (fromMaybe) import IHaskell.Flags (Argument(..), LhsStyle, lhsStyleBird, NotebookFormat(..)) import System.FilePath ((<.>), dropExtension, takeExtension) -import Text.Printf (printf) -- | ConvertSpec is the accumulator for command line arguments data ConvertSpec f = diff --git a/src/IHaskell/Convert/IpynbToLhs.hs b/src/IHaskell/Convert/IpynbToLhs.hs --- a/src/IHaskell/Convert/IpynbToLhs.hs +++ b/src/IHaskell/Convert/IpynbToLhs.hs @@ -1,5 +1,6 @@ {-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module IHaskell.Convert.IpynbToLhs (ipynbToLhs) where @@ -9,12 +10,17 @@ import Data.Aeson (decode, Object, Value(Array, Object, String)) import Data.Vector (Vector) -import Data.HashMap.Strict (lookup) import qualified Data.Text.Lazy.IO as LTIO import qualified Data.Vector as V (map, mapM, toList) import IHaskell.Flags (LhsStyle(..)) + +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.KeyMap (lookup) +#else +import Data.HashMap.Strict (lookup) +#endif ipynbToLhs :: LhsStyle LText -> FilePath -- ^ the filename of an ipython notebook 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 @@ -15,6 +15,12 @@ import IHaskell.Flags (LhsStyle(LhsStyle)) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.Aeson.Key as Key +#else +#endif + lhsToIpynb :: LhsStyle LText -> FilePath -> FilePath -> IO () lhsToIpynb sty from to = do classed <- classifyLines sty . LT.lines . LT.pack <$> readFile from @@ -82,7 +88,11 @@ -- | ihaskell needs this boilerplate at the upper level to interpret the json describing cells and -- output correctly. +#if MIN_VERSION_aeson(2,0,0) +boilerplate :: [(Key.Key, Value)] +#else boilerplate :: [(T.Text, Value)] +#endif boilerplate = ["metadata" .= object [kernelspec, lang], "nbformat" .= Number 4, "nbformat_minor" .= Number 0] where diff --git a/src/IHaskell/Display.hs b/src/IHaskell/Display.hs --- a/src/IHaskell/Display.hs +++ b/src/IHaskell/Display.hs @@ -37,6 +37,7 @@ vega, vegalite, vdom, + widgetdisplay, custom, many, @@ -59,8 +60,9 @@ import IHaskellPrelude import qualified Data.Text as T import qualified Data.ByteString.Char8 as CBS +import qualified Data.ByteString.Lazy as LBS -import Data.Serialize as Serialize +import Data.Binary as Binary import qualified Data.ByteString.Base64 as Base64 import System.Directory (getTemporaryDirectory, setCurrentDirectory) @@ -150,6 +152,10 @@ jpg :: Width -> Height -> Base64 -> DisplayData jpg width height = DisplayData (MimeJpg width height) +-- | Generate a Widget display given the uuid and the view version +widgetdisplay :: String -> DisplayData +widgetdisplay = DisplayData MimeWidget .T.pack + -- | Convert from a string into base 64 encoded data. encode64 :: String -> Base64 encode64 str = base64 $ CBS.pack str @@ -159,8 +165,8 @@ base64 = E.decodeUtf8 . Base64.encode -- | For internal use within IHaskell. Serialize displays to a ByteString. -serializeDisplay :: Display -> ByteString -serializeDisplay = Serialize.encode +serializeDisplay :: Display -> LBS.ByteString +serializeDisplay = Binary.encode -- | Items written to this chan will be included in the output sent to the frontend (ultimately the -- browser), the next time IHaskell has an item to display. @@ -170,9 +176,9 @@ -- | Take everything that was put into the 'displayChan' at that point out, and make a 'Display' out -- of it. -displayFromChanEncoded :: IO ByteString +displayFromChanEncoded :: IO LBS.ByteString displayFromChanEncoded = - Serialize.encode <$> Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) + Binary.encode <$> Just . many <$> unfoldM (atomically $ tryReadTChan displayChan) -- | Write to the display channel. The contents will be displayed in the notebook once the current -- execution call ends. 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 @@ -14,19 +14,24 @@ import IHaskellPrelude -import Control.Applicative ((<$>)) import Data.Char -import Data.List (nub, init, last, elemIndex, concatMap) +import Data.List (init, last, elemIndex) import qualified Data.List.Split as Split import qualified Data.List.Split.Internals as Split import System.Environment (getEnv) import GHC -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) import GHC.Unit.Database import GHC.Unit.State +import GHC.Driver.Ppr import GHC.Driver.Session import GHC.Driver.Monad as GhcMonad +#elif MIN_VERSION_ghc(9,0,0) +import GHC.Unit.Database +import GHC.Unit.State +import GHC.Driver.Session +import GHC.Driver.Monad as GhcMonad import GHC.Utils.Outputable (showPpr) #else import GHC.PackageDb @@ -81,8 +86,12 @@ let isQualified = ('.' `elem`) unqualNames = nub $ filter (not . isQualified) rdrNames qualNames = nub $ scopeNames ++ filter isQualified rdrNames - -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + (db, _, _, _) <- liftIO $ initUnits logger flags Nothing + let getNames = map (moduleNameString . exposedName) . unitExposedModules + moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db +#elif MIN_VERSION_ghc(9,0,0) let Just db = unitDatabases flags getNames = map (moduleNameString . exposedName) . unitExposedModules moduleNames = nub $ concatMap getNames $ concatMap unitDatabaseUnits db 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 @@ -23,24 +23,36 @@ import Control.Concurrent (forkIO, threadDelay) import Data.Foldable (foldMap) import Prelude (head, tail, last, init) -import Data.List (nubBy) import qualified Data.Set as Set import Data.Char as Char import Data.Dynamic -import qualified Data.Serialize as Serialize +import qualified Data.Binary as Binary import System.Directory import System.Posix.IO (fdToHandle) import System.IO (hGetChar, hSetEncoding, utf8) import System.Random (getStdGen, randomRs) import System.Process import System.Exit -import Data.Maybe (mapMaybe) import System.Environment (getEnv) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) import qualified GHC.Runtime.Debugger as Debugger import GHC.Runtime.Eval import GHC.Driver.Session +import GHC.Unit.State +import Control.Monad.Catch as MC +import GHC.Utils.Outputable hiding ((<>)) +import GHC.Data.Bag +import GHC.Driver.Backend +import GHC.Driver.Ppr +import GHC.Runtime.Context +import GHC.Types.SourceError +import GHC.Unit.Types (UnitId) +import qualified GHC.Utils.Error as ErrUtils +#elif MIN_VERSION_ghc(9,0,0) +import qualified GHC.Runtime.Debugger as Debugger +import GHC.Runtime.Eval +import GHC.Driver.Session import GHC.Driver.Types import GHC.Unit.State import Control.Monad.Catch as MC @@ -54,7 +66,6 @@ import DynFlags import HscTypes import InteractiveEval -import Exception (gtry) import Exception hiding (evaluate) import GhcMonad (liftIO) import Outputable hiding ((<>)) @@ -68,13 +79,16 @@ import IHaskell.Types import IHaskell.IPython import IHaskell.Eval.Parser -import IHaskell.Eval.Lint import IHaskell.Display import qualified IHaskell.Eval.Hoogle as Hoogle import IHaskell.Eval.Util import IHaskell.BrokenPackages import StringUtils (replace, split, strip, rstrip) +#ifdef USE_HLINT +import IHaskell.Eval.Lint +#endif + #if MIN_VERSION_ghc(9,0,0) import GHC.Data.FastString #elif MIN_VERSION_ghc(8,2,0) @@ -84,6 +98,11 @@ import Data.Version (versionBranch) #endif +#if MIN_VERSION_ghc(9,2,0) +showSDocUnqual :: DynFlags -> SDoc -> String +showSDocUnqual = showSDoc +#endif + #if MIN_VERSION_ghc(9,0,0) gcatch :: Ghc a -> (SomeException -> Ghc a) -> Ghc a gcatch = MC.catch @@ -189,29 +208,43 @@ -- Run the rest of the interpreter action hasSupportLibraries -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +packageIdString' :: Logger -> DynFlags -> UnitInfo -> IO String +packageIdString' logger dflags pkg_cfg = do + (_, unitState, _, _) <- initUnits logger dflags Nothing + case (lookupUnit unitState $ mkUnit pkg_cfg) of + Nothing -> pure "(unknown)" + Just cfg -> let + PackageName name = unitPackageName cfg + in pure $ unpackFS name +#elif MIN_VERSION_ghc(9,0,0) packageIdString' :: DynFlags -> UnitInfo -> String -#else -packageIdString' :: DynFlags -> PackageConfig -> String -#endif packageIdString' dflags pkg_cfg = -#if MIN_VERSION_ghc(9,0,0) case (lookupUnit (unitState dflags) $ mkUnit pkg_cfg) of Nothing -> "(unknown)" Just cfg -> let PackageName name = unitPackageName cfg in unpackFS name #elif MIN_VERSION_ghc(8,2,0) +packageIdString' :: DynFlags -> PackageConfig -> String +packageIdString' dflags pkg_cfg = case (lookupPackage dflags $ packageConfigId pkg_cfg) of Nothing -> "(unknown)" Just cfg -> let PackageName name = packageName cfg in unpackFS name #else +packageIdString' :: DynFlags -> PackageConfig -> String +packageIdString' dflags pkg_cfg = fromMaybe "(unknown)" (unitIdPackageIdString dflags $ packageConfigId pkg_cfg) #endif -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +getPackageConfigs :: Logger -> DynFlags -> IO [GenUnitInfo UnitId] +getPackageConfigs logger dflags = do + (pkgDb, _, _, _) <- initUnits logger dflags Nothing + pure $ foldMap unitDatabaseUnits pkgDb +#elif MIN_VERSION_ghc(9,0,0) getPackageConfigs :: DynFlags -> [GenUnitInfo UnitId] getPackageConfigs dflags = foldMap unitDatabaseUnits pkgDb @@ -233,16 +266,28 @@ -- version of the ihaskell library. Also verify that the packages we load are not broken. dflags <- getSessionDynFlags broken <- liftIO getBrokenPackages -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + let dflgs = dflags +#elif MIN_VERSION_ghc(9,0,0) dflgs <- liftIO $ initUnits dflags #else (dflgs, _) <- liftIO $ initPackages dflags #endif + +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + db <- liftIO $ getPackageConfigs logger dflgs + packageNames <- liftIO $ mapM (packageIdString' logger dflgs) db + let hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames) + hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages + initStr = "ihaskell-" +#else let db = getPackageConfigs dflgs packageNames = map (packageIdString' dflgs) db hiddenPackages = Set.intersection hiddenPackageNames (Set.fromList packageNames) hiddenFlags = fmap HidePackage $ Set.toList hiddenPackages initStr = "ihaskell-" +#endif #if MIN_VERSION_ghc(8,2,0) -- Name of the ihaskell package, i.e. "ihaskell" @@ -351,10 +396,13 @@ updated <- case errs of -- Only run things if there are no parse errors. [] -> do + +#ifdef USE_HLINT when (getLintStatus kernelState /= LintOff) $ liftIO $ do lintSuggestions <- lint code cmds unless (noResults lintSuggestions) $ output (FinalResult lintSuggestions [] []) Success +#endif runUntilFailure kernelState (map unloc cmds ++ [storeItCommand execCount]) -- Print all parse errors. @@ -385,9 +433,9 @@ Left err -> error $ "Deserialization error (Evaluate.hs): " ++ err Right displaysIO -> do result <- liftIO displaysIO - case Serialize.decode result of - Left err -> error $ "Deserialization error (Evaluate.hs): " ++ err - Right res -> return res + case Binary.decodeOrFail result of + Left (_, _, err) -> error $ "Deserialization error (Evaluate.hs): " ++ err + Right (_, _, res) -> return res else return Nothing let result = case dispsMay of @@ -458,9 +506,13 @@ let commMessages = evalmsgs ++ messages widgetHandler state commMessages - +#if MIN_VERSION_ghc(9,2,0) +getErrMsgDoc :: ErrUtils.WarnMsg -> SDoc +getErrMsgDoc = ErrUtils.pprLocMsgEnvelope +#else getErrMsgDoc :: ErrUtils.ErrMsg -> SDoc getErrMsgDoc = ErrUtils.pprLocErrMsg +#endif safely :: KernelState -> Interpreter EvalOut -> Interpreter EvalOut safely state = ghandle handler . ghandle sourceErrorHandler @@ -677,6 +729,15 @@ let typeStr = showSDocUnqual flags $ ppr kind return $ formatType $ expr ++ " :: " ++ typeStr +evalCommand _ (Directive GetKindBang expr) state = wrapExecution state $ do + write state $ "Kind!: " ++ expr + (typ, kind) <- GHC.typeKind True expr + flags <- getSessionDynFlags + let kindStr = text expr <+> dcolon <+> ppr kind + let typeStr = equals <+> ppr typ + let finalStr = showSDocUnqual flags $ vcat [kindStr, typeStr] + return $ formatType finalStr + evalCommand _ (Directive LoadFile names) state = wrapExecution state $ do write state $ "Load: " ++ names @@ -689,6 +750,8 @@ doLoadModule filename modName return (ManyDisplay displays) +evalCommand _ (Directive Reload _) state = wrapExecution state doReload + evalCommand publish (Directive ShellCmd cmd) state = wrapExecution state $ -- Assume the first character of 'cmd' is '!'. case words $ drop 1 cmd of @@ -845,9 +908,16 @@ #else let action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' contents (showSDoc flags msg :) #endif +#if MIN_VERSION_ghc(9,2,0) + pushLogHookM (const action) +#else let flags' = flags { log_action = action } _ <- setSessionDynFlags flags' +#endif Debugger.pprintClosureCommand False False binding +#if MIN_VERSION_ghc(9,2,0) + popLogHookM +#endif _ <- setSessionDynFlags flags sprint <- liftIO $ readIORef contents return $ formatType (unlines sprint) @@ -971,9 +1041,9 @@ Nothing -> error "Expecting lazy Bytestring" Just bytestringIO -> do bytestring <- liftIO bytestringIO - case Serialize.decode bytestring of - Left err -> error err - Right disp -> + case Binary.decodeOrFail bytestring of + Left (_, _, err) -> error err + Right (_, _, disp) -> return $ if useSvg state then disp :: Display @@ -1083,13 +1153,21 @@ -- Compile loaded modules. flags <- getSessionDynFlags errRef <- liftIO $ newIORef [] +#if MIN_VERSION_ghc(9,0,0) + let logAction = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) +#else + let logAction = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) +#endif +#if MIN_VERSION_ghc(9,2,0) + pushLogHookM (const logAction) +#endif _ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo flags - { hscTarget = objTarget flags -#if MIN_VERSION_ghc(9,0,0) - , log_action = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) +#if MIN_VERSION_ghc(9,2,0) + { backend = objTarget flags #else - , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) + { hscTarget = objTarget flags + , log_action = logAction #endif } @@ -1117,6 +1195,9 @@ -- Switch back to interpreted mode. _ <- setSessionDynFlags flags +#if MIN_VERSION_ghc(9,2,0) + popLogHookM +#endif case result of Succeeded -> return mempty @@ -1134,7 +1215,11 @@ -- Switch to interpreted mode! flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags flags { backend = Interpreter } +#else _ <- setSessionDynFlags flags { hscTarget = HscInterpreted } +#endif -- Return to old context, make sure we have `it`. setContext imported @@ -1142,10 +1227,82 @@ return $ displayError $ "Failed to load module " ++ modName ++ ": " ++ show exception +doReload :: Ghc Display +doReload = do + -- Remember which modules we've loaded before. + importedModules <- getContext + + flip gcatch (unload importedModules) $ do + -- Compile loaded modules. + flags <- getSessionDynFlags + errRef <- liftIO $ newIORef [] + _ <- setSessionDynFlags $ flip gopt_set Opt_BuildDynamicToo + flags +#if MIN_VERSION_ghc(9,2,0) + { backend = objTarget flags +#elif MIN_VERSION_ghc(9,0,0) + { hscTarget = objTarget flags + , log_action = \_dflags _warn _sev _srcspan msg -> modifyIORef' errRef (showSDoc flags msg :) +#else + { hscTarget = objTarget flags + , log_action = \_dflags _sev _srcspan _ppr _style msg -> modifyIORef' errRef (showSDoc flags msg :) +#endif + } + + -- Store the old targets in case of failure. + oldTargets <- getTargets + result <- load LoadAllTargets + + -- Reset the context, since loading things screws it up. + initializeItVariable + + -- Reset targets if we failed. + case result of + Failed -> setTargets oldTargets + Succeeded{} -> return () + + -- Add imports + setContext importedModules + + -- Switch back to interpreted mode. + _ <- setSessionDynFlags flags + + case result of + Succeeded -> return mempty + Failed -> do + errorStrs <- unlines <$> reverse <$> liftIO (readIORef errRef) + return $ displayError $ "Failed to reload.\n" ++ errorStrs + + where + unload :: [InteractiveImport] -> SomeException -> Ghc Display + unload imported exception = do + print $ show exception + -- Explicitly clear targets + setTargets [] + _ <- load LoadAllTargets + + -- Switch to interpreted mode! + flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags flags { backend = Interpreter } +#else + _ <- setSessionDynFlags flags { hscTarget = HscInterpreted } +#endif + + -- Return to old context, make sure we have `it`. + setContext imported + initializeItVariable + + return $ displayError $ "Failed to reload." + +#if MIN_VERSION_ghc(9,2,0) +objTarget :: DynFlags -> Backend +objTarget = platformDefaultBackend . targetPlatform +#elif MIN_VERSION_ghc(8,10,0) objTarget :: DynFlags -> HscTarget -#if MIN_VERSION_ghc(8,10,0) objTarget = defaultObjectTarget #else +objTarget :: DynFlags -> HscTarget objTarget flags = defaultObjectTarget $ targetPlatform flags #endif 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 @@ -14,7 +14,6 @@ import qualified Data.ByteString.Char8 as CBS import qualified Data.ByteString.Lazy as LBS -import Data.Either (either) import IHaskellPrelude import Data.Aeson 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 @@ -8,7 +8,10 @@ import IHaskell.Eval.Evaluate (typeCleaner, Interpreter) import GHC -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) +import GHC.Driver.Ppr +import Control.Monad.Catch (handle) +#elif MIN_VERSION_ghc(9,0,0) import GHC.Utils.Outputable import Control.Monad.Catch (handle) #else 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 @@ -83,7 +83,8 @@ autoSettings' = do (fixts, classify, hints) <- autoSettings let hidingIgnore = Classify Ignore "Unnecessary hiding" "" "" - return (fixts, hidingIgnore:classify, hints) + let pragmaIgnore = Classify Ignore "Unused LANGUAGE pragma" "" "" + return (fixts, pragmaIgnore:hidingIgnore:classify, hints) ignoredIdea idea = ideaSeverity idea == Ignore #else @@ -115,7 +116,8 @@ autoSettings' = do (fixts, classify, hints) <- autoSettings let hidingIgnore = Classify Ignore "Unnecessary hiding" "" "" - return (fixts, hidingIgnore:classify, hints) + let pragmaIgnore = Classify Ignore "Unused LANGUAGE pragma" "" "" + return (fixts, pragmaIgnore:hidingIgnore:classify, hints) ignoredIdea idea = ideaSeverity idea == Ignore createModule :: ParseMode -> Located CodeBlock -> Maybe ExtsModule 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 @@ -20,7 +20,6 @@ import Data.Char (toLower) import Data.List (maximumBy, inits) import Prelude (head, tail) -import Control.Monad (msum) #if MIN_VERSION_ghc(8,4,0) import GHC hiding (Located, Parsed) @@ -62,8 +61,10 @@ | SearchHoogle -- ^ Search for something via Hoogle. | GetDoc -- ^ Get documentation for an identifier via Hoogle. | GetKind -- ^ Get the kind of a type via ':kind'. + | GetKindBang -- ^ Get the kind and normalised type via ':kind!'. | LoadModule -- ^ Load and unload modules via ':module'. | SPrint -- ^ Print without evaluating via ':sprint'. + | Reload -- ^ Reload. deriving (Show, Eq) -- | Pragma types. Only LANGUAGE pragmas are currently supported. Other pragma types are kept around @@ -277,6 +278,7 @@ [ (LoadModule, "module") , (GetType, "type") , (GetKind, "kind") + , (GetKindBang, "kind!") , (GetInfo, "info") , (SearchHoogle, "hoogle") , (GetDoc, "documentation") @@ -286,6 +288,7 @@ , (SetExtension, "extension") , (GetHelp, "?") , (GetHelp, "help") + , (Reload, "reload") , (SPrint, "sprint") ] parseDirective _ _ = error "Directive must start with colon!" 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 @@ -33,9 +33,26 @@ #endif -- GHC imports. -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) import GHC.Core.InstEnv (is_cls, is_tys) 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.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,0,0) +import GHC.Core.InstEnv (is_cls, is_tys) +import GHC.Core.Unify import GHC.Core.Ppr.TyThing import GHC.Driver.CmdLine import GHC.Driver.Monad (modifySession) @@ -46,6 +63,7 @@ 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 #else import DynFlags import GhcMonad @@ -57,17 +75,16 @@ import Unify (tcMatchTys) import qualified Pretty import qualified Outputable as O +#if MIN_VERSION_ghc(8,6,0) +import DynamicLoading #endif +#endif #if MIN_VERSION_ghc(8,6,0) #else import FastString #endif import GHC -import Control.Monad (void) -import Data.Function (on) -import Data.List (nubBy) - import StringUtils (replace) #if MIN_VERSION_ghc(9,0,0) @@ -218,13 +235,29 @@ setFlags ext = do -- Try to parse flags. flags <- getSessionDynFlags - (flags', unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) +#if MIN_VERSION_ghc(9,2,0) + logger <- getLogger + (flags0, unrecognized, warnings) <- parseDynamicFlags logger flags (map noLoc ext) +#else + (flags0, unrecognized, warnings) <- parseDynamicFlags flags (map noLoc ext) +#endif - -- First, try to check if this flag matches any extension name. - let restoredPkgs = flags' { packageFlags = packageFlags flags } - _ <- GHC.setProgramDynFlags restoredPkgs - GHC.setInteractiveDynFlags restoredPkgs + -- We can't update packages here + let flags1 = flags0 { packageFlags = packageFlags flags } +#if MIN_VERSION_ghc(9,2,0) + -- Loading plugins explicitly is no longer required in 9.2 + let flags2 = flags1 +#elif MIN_VERSION_ghc(8,6,0) + -- Plugins were introduced in 8.6 + hsc_env <- GHC.getSession + flags2 <- liftIO (initializePlugins hsc_env flags1) +#else + let flags2 = flags1 +#endif + _ <- GHC.setProgramDynFlags flags2 + GHC.setInteractiveDynFlags flags2 + -- Create the parse errors. let noParseErrs = map (("Could not parse: " ++) . unLoc) unrecognized #if MIN_VERSION_ghc(8,4,0) @@ -232,7 +265,7 @@ #else allWarns = map unLoc warnings ++ #endif - ["-package not supported yet" | packageFlags flags /= packageFlags flags'] + ["-package not supported yet" | packageFlags flags /= packageFlags flags0] warnErrs = map ("Warning: " ++) allWarns return $ noParseErrs ++ warnErrs @@ -252,8 +285,13 @@ let style = O.mkUserStyle unqual O.AllTheWay #endif let cols = pprCols flags +#if MIN_VERSION_ghc(9,2,0) + d = O.runSDoc sdoc (initSDocContext flags style) + return $ Pretty.fullRender (Pretty.PageMode False) cols 1.5 string_txt "" d +#else d = O.runSDoc sdoc (O.initSDocContext flags style) return $ Pretty.fullRender Pretty.PageMode cols 1.5 string_txt "" d +#endif where string_txt :: Pretty.TextDetails -> String -> String @@ -279,7 +317,18 @@ initGhci :: GhcMonad m => Maybe String -> m () initGhci sandboxPackages = do -- Initialize dyn flags. Start with -XExtendedDefaultRules and -XNoMonomorphismRestriction. +#if MIN_VERSION_ghc(9,2,0) + -- We start handling GHC environment files + originalFlagsNoPackageEnv <- getSessionDynFlags + logger <- getLogger + originalFlags <- liftIO $ interpretPackageEnv logger originalFlagsNoPackageEnv +#elif MIN_VERSION_ghc(9,0,0) + -- We start handling GHC environment files + originalFlagsNoPackageEnv <- getSessionDynFlags + originalFlags <- liftIO $ interpretPackageEnv originalFlagsNoPackageEnv +#else originalFlags <- getSessionDynFlags +#endif let flag = flip xopt_set unflag = flip xopt_unset dflags = flag ExtendedDefaultRules . unflag MonomorphismRestriction $ originalFlags @@ -296,7 +345,11 @@ in packageDBFlags originalFlags ++ [pkg] void $ setSessionDynFlags $ dflags +#if MIN_VERSION_ghc(9,2,0) + { backend = Interpreter +#else { hscTarget = HscInterpreted +#endif , ghcLink = LinkInMemory , pprCols = 300 , packageDBFlags = pkgFlags @@ -388,7 +441,11 @@ names <- runDecls decl cleanUpDuplicateInstances flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + return $ map (replace ":Interactive." "" . showPpr flags) names +#else return $ map (replace ":Interactive." "" . O.showPpr flags) names +#endif cleanUpDuplicateInstances :: GhcMonad m => m () cleanUpDuplicateInstances = modifySession $ \hscEnv -> @@ -415,7 +472,11 @@ result <- exprType expr #endif flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + let typeStr = showSDoc flags $ O.ppr result +#else let typeStr = O.showSDocUnqual flags $ O.ppr result +#endif return typeStr -- | This is unfoldM from monad-loops. It repeatedly runs an IO action until it return Nothing, and 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 @@ -1,4 +1,4 @@ -{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-} +{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules, CPP #-} module IHaskell.Eval.Widgets ( widgetSendOpen, widgetSendView, @@ -16,9 +16,12 @@ import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan -import Control.Monad (foldM) import Data.Aeson +import Data.ByteString.Base64 as B64 (decodeLenient) import qualified Data.Map as Map +import Data.Text.Encoding (encodeUtf8) + +import Data.Foldable (foldl) import System.IO.Unsafe (unsafePerformIO) import IHaskell.Display @@ -26,6 +29,13 @@ import IHaskell.IPython.Types (showMessageType) import IHaskell.Types +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KM (lookup,insert,delete) +import qualified Data.Aeson.Key as Key +#else +import qualified Data.HashMap.Strict as HM (lookup,insert,delete) +#endif + -- All comm_open messages go here widgetMessages :: TChan WidgetMsg {-# NOINLINE widgetMessages #-} @@ -77,9 +87,9 @@ widgetPublishDisplay :: (IHaskellWidget a, IHaskellDisplay b) => a -> b -> IO () widgetPublishDisplay widget disp = display disp >>= queue . DispMsg (Widget widget) --- | Send a `clear_output` message as a [method .= custom] message -widgetClearOutput :: IHaskellWidget a => a -> Bool -> IO () -widgetClearOutput widget w = queue $ ClrOutput (Widget widget) w +-- | Send a `clear_output` message +widgetClearOutput :: Bool -> IO () +widgetClearOutput w = queue $ ClrOutput 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. @@ -99,8 +109,12 @@ newComms = Map.insert uuid widget oldComms newState = state { openComms = newComms } + (newvalue,buffers,bp) = processBPs value $ getBufferPaths widget + applyBuffers x = x {mhBuffers = buffers} + content = object [ "state" .= newvalue, "buffer_paths" .= bp ] + communicate val = do - head <- dupHeader replyHeader CommDataMessage + head <- applyBuffers <$> dupHeader replyHeader CommDataMessage send $ CommData head uuid val -- If the widget is present, don't open it again. @@ -108,8 +122,9 @@ then return state else do -- Send the comm open, with the initial state - hdr <- dupHeader replyHeader CommOpenMessage - send $ CommOpen hdr target_name target_module uuid value + hdr <- applyBuffers <$> dupHeader replyHeader CommOpenMessage + let hdrV = setVersion hdr "2.0.0" -- Widget Messaging Protocol Version + send $ CommOpen hdrV target_name target_module uuid content -- Send anything else the widget requires. open widget communicate @@ -134,7 +149,9 @@ View widget -> sendMessage widget (toJSON DisplayWidget) - Update widget value -> sendMessage widget (toJSON $ UpdateState value) + Update widget value -> do + let (newvalue,buffers,bp) = processBPs value $ getBufferPaths widget + sendMessageHdr widget (toJSON $ UpdateState newvalue bp) (\h->h {mhBuffers=buffers}) Custom widget value -> sendMessage widget (toJSON $ CustomContent value) @@ -145,20 +162,21 @@ let dmsg = WidgetDisplay dispHeader $ unwrap disp sendMessage widget (toJSON $ CustomContent $ toJSON dmsg) - ClrOutput widget w -> do + ClrOutput w -> do hdr <- dupHeader replyHeader ClearOutputMessage - let cmsg = WidgetClear hdr w - sendMessage widget (toJSON $ CustomContent $ toJSON cmsg) + send $ ClearOutput hdr w + return state where oldComms = openComms state - sendMessage widget value = do + sendMessage widget value = sendMessageHdr widget value id + sendMessageHdr widget value hdrf = do let uuid = getCommUUID widget present = isJust $ Map.lookup uuid oldComms -- If the widget is present, we send an update message on its comm. when present $ do - hdr <- dupHeader replyHeader CommDataMessage + hdr <- hdrf <$> dupHeader replyHeader CommDataMessage send $ CommData hdr uuid value return state @@ -166,6 +184,49 @@ unwrap (ManyDisplay ds) = concatMap unwrap ds unwrap (Display ddatas) = ddatas + -- Removes the values that are buffers and puts them in the third value of the tuple + -- The returned bufferpaths are the bufferpaths used + processBPs :: Value -> [BufferPath] -> (Value, [ByteString], [BufferPath]) + -- Searching if the BufferPath key is in the Object is O(log n) or O(1) depending on implementation + -- For this reason we fold on the bufferpaths + processBPs val = foldl f (val,[],[]) + where +#if MIN_VERSION_aeson(2,0,0) + nestedLookupRemove :: BufferPath -> Value -> (Value, Maybe Value) + nestedLookupRemove [] v = (v,Just v) + nestedLookupRemove [b] v = + case v of + Object o -> (Object $ KM.delete (Key.fromText b) o, KM.lookup (Key.fromText b) o) + _ -> (v, Nothing) + nestedLookupRemove (b:bp) v = + case v of + Object o -> maybe (v,Nothing) (upd . nestedLookupRemove bp) (KM.lookup (Key.fromText b) o) + _ -> (v,Nothing) + where upd :: (Value, Maybe Value) -> (Value, Maybe Value) + upd (Object v', Just (Object u)) = (Object $ KM.insert (Key.fromText b) (Object u) v', Just $ Object u) + upd r = r +#else + nestedLookupRemove :: BufferPath -> Value -> (Value, Maybe Value) + nestedLookupRemove [] v = (v,Just v) + nestedLookupRemove [b] v = + case v of + Object o -> (Object $ HM.delete b o, HM.lookup b o) + _ -> (v, Nothing) + nestedLookupRemove (b:bp) v = + case v of + Object o -> maybe (v,Nothing) (upd . nestedLookupRemove bp) (HM.lookup b o) + _ -> (v,Nothing) + where upd :: (Value, Maybe Value) -> (Value, Maybe Value) + upd (Object v', Just (Object u)) = (Object $ HM.insert b (Object u) v', Just $ Object u) + upd r = r +#endif + + f :: (Value, [ByteString], [BufferPath]) -> BufferPath -> (Value, [ByteString], [BufferPath]) + f r@(v,bs,bps) bp = + case nestedLookupRemove bp v of + (newv, Just (String b)) -> (newv, B64.decodeLenient (encodeUtf8 b) : bs, bp:bps) + _ -> r + -- Override toJSON for PublishDisplayData for sending Display messages through [method .= custom] data WidgetDisplay = WidgetDisplay MessageHeader [DisplayData] @@ -174,14 +235,6 @@ 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 w) = - let clrVal = toJSON $ ClearOutput replyHeader w - in toJSON $ IPythonMessage replyHeader clrVal ClearOutputMessage - data IPythonMessage = IPythonMessage MessageHeader Value MessageType instance ToJSON IPythonMessage where @@ -189,7 +242,7 @@ object [ "header" .= replyHeader , "parent_header" .= str "" - , "metadata" .= str "{}" + , "metadata" .= object [] , "content" .= val , "msg_type" .= (toJSON . showMessageType $ mtype) ] diff --git a/src/IHaskell/Flags.hs b/src/IHaskell/Flags.hs --- a/src/IHaskell/Flags.hs +++ b/src/IHaskell/Flags.hs @@ -39,6 +39,7 @@ | ConvertLhsStyle (LhsStyle String) | KernelspecInstallPrefix String | KernelspecUseStack + | KernelspecEnvFile FilePath deriving (Eq, Show) data LhsStyle string = @@ -124,6 +125,14 @@ where addStack (Args md prev) = Args md (KernelspecUseStack : prev) +kernelEnvFileFlag :: Flag Args +kernelEnvFileFlag = + flagReq + ["env-file"] + (store KernelspecEnvFile) + "" + "Load environment from this file when kernel is installed" + confFlag :: Flag Args confFlag = flagReq ["conf", "c"] (store ConfFile) "" "File with commands to execute at start; replaces ~/.ihaskell/rc.hs." @@ -144,11 +153,11 @@ installKernelSpec :: Mode Args installKernelSpec = mode "install" (Args InstallKernelSpec []) "Install the Jupyter kernelspec." noArgs - [ghcLibFlag, ghcRTSFlag, kernelDebugFlag, confFlag, installPrefixFlag, helpFlag, kernelStackFlag] + [ghcLibFlag, ghcRTSFlag, kernelDebugFlag, confFlag, installPrefixFlag, helpFlag, kernelStackFlag, kernelEnvFileFlag] kernel :: Mode Args kernel = mode "kernel" (Args (Kernel Nothing) []) "Invoke the IHaskell kernel." kernelArg - [ghcLibFlag, kernelDebugFlag, confFlag, kernelStackFlag, kernelCodeMirrorFlag] + [ghcLibFlag, kernelDebugFlag, confFlag, kernelStackFlag, kernelEnvFileFlag, kernelCodeMirrorFlag] 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 @@ -11,6 +11,7 @@ kernelName, KernelSpecOptions(..), defaultKernelSpecOptions, + installLabextension, ) where import IHaskellPrelude @@ -43,6 +44,7 @@ , kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file. , kernelSpecInstallPrefix :: Maybe String , kernelSpecUseStack :: Bool -- ^ Whether to use @stack@ environments. + , kernelSpecEnvFile :: Maybe FilePath } defaultKernelSpecOptions :: KernelSpecOptions @@ -55,6 +57,7 @@ , kernelSpecConfFile = defaultConfFile , kernelSpecInstallPrefix = Nothing , kernelSpecUseStack = False + , kernelSpecEnvFile = Nothing } -- | The IPython kernel name. @@ -168,7 +171,33 @@ 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 + let transformOutput = if kernelSpecDebug opts then id else SH.silently + transformOutput $ SH.run ipython cmd + +installLabextension :: Bool -> IO () +installLabextension debug = SH.shelly $ do + -- Find the prebuilt extension directory + ihaskellDataDir <- liftIO $ Paths.getDataDir + let labextensionDataDir = ihaskellDataDir + SH. ("jupyterlab-ihaskell" :: SH.FilePath) + SH. ("labextension" :: SH.FilePath) + + -- Find the $(jupyter --data-dir)/labextensions/jupyterlab-ihaskell directory + jupyter <- locateIPython + jupyterDataDir <- SH.silently $ SH.fromText . T.strip <$> SH.run jupyter ["--data-dir"] + let jupyterlabIHaskellDir = jupyterDataDir + SH. ("labextensions" :: SH.FilePath) + SH. ("jupyterlab-ihaskell" :: SH.FilePath) + + when debug (putStrLn $ "Installing kernel in folder: " ++ show jupyterlabIHaskellDir) + -- Remove the extension directory with extreme prejudice if it already exists + SH.rm_rf jupyterlabIHaskellDir + -- Create an empty 'jupyterlab-ihaskell' directory to install our extension in + SH.mkdir_p jupyterlabIHaskellDir + -- Copy the prebuilt extension files over + extensionContents <- SH.ls labextensionDataDir + forM_ extensionContents $ \entry -> + SH.cp_r entry jupyterlabIHaskellDir -- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing. subHome :: String -> IO String diff --git a/src/IHaskell/Types.hs b/src/IHaskell/Types.hs --- a/src/IHaskell/Types.hs +++ b/src/IHaskell/Types.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} -- | Description : All message type definitions. module IHaskell.Types ( @@ -11,8 +12,10 @@ MessageHeader(..), MessageType(..), dupHeader, + setVersion, Username, Metadata, + BufferPath, replyType, ExecutionState(..), StreamType(..), @@ -41,13 +44,20 @@ import IHaskellPrelude -import Data.Aeson (ToJSON (..), Value, (.=), object) +import Data.Aeson (ToJSON (..), Value, (.=), object, Value(String)) import Data.Function (on) -import Data.Serialize +import Data.Text (pack) +import Data.Binary import GHC.Generics import IHaskell.IPython.Kernel +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as KeyMap +#else +import qualified Data.HashMap.Strict as HashMap +#endif + -- | A class for displayable Haskell types. -- -- IHaskell's displaying of results behaves as if these two overlapping/undecidable instances also @@ -58,6 +68,11 @@ class IHaskellDisplay a where display :: a -> IO Display +type BufferPath = [Text] + +emptyBPs :: [BufferPath] +emptyBPs = [] + -- | Display as an interactive widget. class IHaskellDisplay a => IHaskellWidget a where -- | Target name for this widget. The actual input parameter should be ignored. By default evaluate @@ -69,6 +84,10 @@ targetModule :: a -> String targetModule _ = "" + -- | Buffer paths for this widget. Evaluates to an empty array by default. + getBufferPaths :: a -> [BufferPath] + getBufferPaths _ = emptyBPs + -- | Get the uuid for comm associated with this widget. The widget is responsible for storing the -- UUID during initialization. getCommUUID :: a -> UUID @@ -124,6 +143,7 @@ instance IHaskellWidget Widget where targetName (Widget widget) = targetName widget targetModule (Widget widget) = targetModule widget + getBufferPaths (Widget widget) = getBufferPaths widget getCommUUID (Widget widget) = getCommUUID widget open (Widget widget) = open widget comm (Widget widget) = comm widget @@ -141,8 +161,12 @@ | ManyDisplay [Display] deriving (Show, Typeable, Generic) -instance Serialize Display +instance ToJSON Display where + toJSON (Display d) = object (map displayDataToJson d) + toJSON (ManyDisplay d) = toJSON d +instance Binary Display + instance Semigroup Display where ManyDisplay a <> ManyDisplay b = ManyDisplay (a ++ b) ManyDisplay a <> b = ManyDisplay (a ++ [b]) @@ -236,17 +260,17 @@ DispMsg Widget Display | -- ^ A 'display_data' message, sent as a [method .= custom] comm_msg - ClrOutput Widget Bool - -- ^ A 'clear_output' message, sent as a [method .= custom] comm_msg + ClrOutput Bool + -- ^ A 'clear_output' message, sent as a clear_output message deriving (Show, Typeable) -data WidgetMethod = UpdateState Value +data WidgetMethod = UpdateState Value [BufferPath] | CustomContent Value | DisplayWidget instance ToJSON WidgetMethod where toJSON DisplayWidget = object ["method" .= ("display" :: Text)] - toJSON (UpdateState v) = object ["method" .= ("update" :: Text), "state" .= v] + toJSON (UpdateState v bp) = object ["method" .= ("update" :: Text), "state" .= v, "buffer_paths" .= bp] toJSON (CustomContent v) = object ["method" .= ("custom" :: Text), "content" .= v] -- | Output of evaluation. @@ -276,6 +300,20 @@ dupHeader hdr messageType = do uuid <- liftIO random return hdr { mhMessageId = uuid, mhMsgType = messageType } + +-- | Modifies a header and appends the version of the Widget Messaging Protocol as metadata +setVersion :: MessageHeader -- ^ The header to modify + -> String -- ^ The version to set + -> MessageHeader -- ^ The modified header + +-- We use the 'fromList' function from "Data.HashMap.Strict" (or +-- "Data.Aeson.KeyMap") instead of the 'object' function from "Data.Aeson" +-- because 'object' returns a 'Value', but metadata needs an 'Object'. +#if MIN_VERSION_aeson(2,0,0) +setVersion hdr v = hdr { mhMetadata = Metadata (KeyMap.fromList [("version", String $ pack v)]) } +#else +setVersion hdr v = hdr { mhMetadata = Metadata (HashMap.fromList [("version", String $ pack v)]) } +#endif -- | Whether or not an error occurred. data ErrorOccurred = Success 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 @@ -14,8 +14,13 @@ import System.Environment (setEnv) import System.Directory (setCurrentDirectory, getCurrentDirectory) +#if MIN_VERSION_ghc(9,2,0) import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, + parseImportDecl, Backend(..), InteractiveImport(..)) +#else +import GHC (getSessionDynFlags, setSessionDynFlags, DynFlags(..), GhcLink(..), setContext, parseImportDecl, HscTarget(..), InteractiveImport(..)) +#endif import Test.Hspec @@ -61,7 +66,11 @@ initCompleter :: Interpreter () initCompleter = do flags <- getSessionDynFlags +#if MIN_VERSION_ghc(9,2,0) + _ <- setSessionDynFlags $ flags { backend = Interpreter, ghcLink = LinkInMemory } +#else _ <- setSessionDynFlags $ flags { hscTarget = HscInterpreted, ghcLink = LinkInMemory } +#endif -- Import modules. imports <- mapM parseImportDecl 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 @@ -161,7 +161,10 @@ ":! printf \"hello\\nworld\"" `becomes` ["hello\nworld"] it "evaluates directives" $ do -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,2,0) + -- It's `a` instead of `p` + ":typ 3" `becomes` ["3 :: forall {a}. Num a => a"] +#elif MIN_VERSION_ghc(9,0,0) -- brackets around the type variable ":typ 3" `becomes` ["3 :: forall {p}. Num p => p"] #elif MIN_VERSION_ghc(8,2,0) 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 @@ -232,7 +232,9 @@ #else dataKindsError = ParseError (Loc 1 10) msg #endif -#if MIN_VERSION_ghc(8,8,0) +#if MIN_VERSION_ghc(9,2,0) + msg = "Cannot parse data constructor in a data/newtype declaration: 3" +#elif MIN_VERSION_ghc(8,8,0) msg = "Cannot parse data constructor in a data/newtype declaration:\n 3" #else msg = "Cannot parse data constructor in a data/newtype declaration: 3"