{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}
module IHaskell.IPython (
replaceIPythonKernelspec,
defaultConfFile,
getIHaskellDir,
getSandboxPackageConf,
subHome,
KernelSpecOptions(..),
defaultKernelSpecOptions,
installLabextension,
) where
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
import qualified System.FilePath as FP
import System.Directory
import System.Environment (getExecutablePath)
import System.Exit (exitFailure)
import Data.Aeson (toJSON)
import Data.Aeson.Text (encodeToTextBuilder)
import Data.Text.Lazy.Builder (toLazyText)
import qualified Paths_ihaskell as Paths
import qualified GHC.Paths
import IHaskell.Types
import StringUtils (replace, split)
data KernelSpecOptions =
KernelSpecOptions
{ KernelSpecOptions -> FilePath
kernelSpecGhcLibdir :: String
, KernelSpecOptions -> [FilePath]
kernelSpecRTSOptions :: [String]
, KernelSpecOptions -> Bool
kernelSpecDebug :: Bool
, KernelSpecOptions -> FilePath
kernelSpecCodeMirror :: String
, KernelSpecOptions -> Maybe FilePath
kernelSpecHtmlCodeWrapperClass :: Maybe String
, KernelSpecOptions -> FilePath
kernelSpecHtmlCodeTokenPrefix :: String
, KernelSpecOptions -> IO (Maybe FilePath)
kernelSpecConfFile :: IO (Maybe String)
, KernelSpecOptions -> Maybe FilePath
kernelSpecInstallPrefix :: Maybe String
, KernelSpecOptions -> Bool
kernelSpecUseStack :: Bool
, KernelSpecOptions -> Maybe FilePath
kernelSpecEnvFile :: Maybe FilePath
, KernelSpecOptions -> FilePath
kernelSpecKernelName :: String
, KernelSpecOptions -> FilePath
kernelSpecDisplayName :: String
}
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions
{ kernelSpecGhcLibdir :: FilePath
kernelSpecGhcLibdir = FilePath
GHC.Paths.libdir
, kernelSpecRTSOptions :: [FilePath]
kernelSpecRTSOptions = [FilePath
"-M3g", FilePath
"-N2"]
, kernelSpecDebug :: Bool
kernelSpecDebug = Bool
False
, kernelSpecCodeMirror :: FilePath
kernelSpecCodeMirror = FilePath
"ihaskell"
, kernelSpecHtmlCodeWrapperClass :: Maybe FilePath
kernelSpecHtmlCodeWrapperClass = forall a. a -> Maybe a
Just FilePath
"CodeMirror cm-s-jupyter cm-s-ipython"
, kernelSpecHtmlCodeTokenPrefix :: FilePath
kernelSpecHtmlCodeTokenPrefix = FilePath
"cm-"
, kernelSpecConfFile :: IO (Maybe FilePath)
kernelSpecConfFile = IO (Maybe FilePath)
defaultConfFile
, kernelSpecInstallPrefix :: Maybe FilePath
kernelSpecInstallPrefix = forall a. Maybe a
Nothing
, kernelSpecUseStack :: Bool
kernelSpecUseStack = Bool
False
, kernelSpecEnvFile :: Maybe FilePath
kernelSpecEnvFile = forall a. Maybe a
Nothing
, kernelSpecKernelName :: FilePath
kernelSpecKernelName = FilePath
"haskell"
, kernelSpecDisplayName :: FilePath
kernelSpecDisplayName = FilePath
"Haskell"
}
ipythonCommand :: SH.Sh SH.FilePath
ipythonCommand :: Sh FilePath
ipythonCommand = do
Maybe FilePath
jupyterMay <- FilePath -> Sh (Maybe FilePath)
SH.which FilePath
"jupyter"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case Maybe FilePath
jupyterMay of
Maybe FilePath
Nothing -> FilePath
"ipython"
Just FilePath
_ -> FilePath
"jupyter"
locateIPython :: SH.Sh SH.FilePath
locateIPython :: Sh FilePath
locateIPython = do
Maybe FilePath
mbinary <- FilePath -> Sh (Maybe FilePath)
SH.which FilePath
"jupyter"
case Maybe FilePath
mbinary of
Maybe FilePath
Nothing -> forall a. Text -> Sh a
SH.errorExit Text
"The Jupyter binary could not be located"
Just FilePath
ipython -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
ipython
fp :: SH.FilePath -> FilePath
fp :: FilePath -> FilePath
fp = Text -> FilePath
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
SH.toTextIgnore
ensure :: SH.Sh SH.FilePath -> SH.Sh SH.FilePath
ensure :: Sh FilePath -> Sh FilePath
ensure Sh FilePath
getDir = do
FilePath
dir <- Sh FilePath
getDir
FilePath -> Sh ()
SH.mkdir_p FilePath
dir
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir
ihaskellDir :: SH.Sh FilePath
ihaskellDir :: Sh FilePath
ihaskellDir = do
FilePath
home <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => FilePath -> a
error FilePath
"$HOME not defined.") Text -> FilePath
SH.fromText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Sh (Maybe Text)
SH.get_env Text
"HOME"
FilePath -> FilePath
fp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sh FilePath -> Sh FilePath
ensure (forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
home forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
".ihaskell" :: SH.FilePath)))
getIHaskellDir :: IO String
getIHaskellDir :: IO FilePath
getIHaskellDir = forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly Sh FilePath
ihaskellDir
defaultConfFile :: IO (Maybe String)
defaultConfFile :: IO (Maybe FilePath)
defaultConfFile = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> FilePath
fp) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly forall a b. (a -> b) -> a -> b
$ do
FilePath
filename <- (forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"rc.hs" :: SH.FilePath)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sh FilePath
ihaskellDir
Bool
exists <- FilePath -> Sh Bool
SH.test_f FilePath
filename
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
exists
then forall a. a -> Maybe a
Just FilePath
filename
else forall a. Maybe a
Nothing
replaceIPythonKernelspec :: KernelSpecOptions -> IO ()
replaceIPythonKernelspec :: KernelSpecOptions -> IO ()
replaceIPythonKernelspec KernelSpecOptions
kernelSpecOpts = forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly forall a b. (a -> b) -> a -> b
$ do
Sh ()
verifyIPythonVersion
Bool -> KernelSpecOptions -> Sh ()
installKernelspec Bool
True KernelSpecOptions
kernelSpecOpts
verifyIPythonVersion :: SH.Sh ()
verifyIPythonVersion :: Sh ()
verifyIPythonVersion = do
FilePath
cmd <- Sh FilePath
ipythonCommand
Maybe FilePath
pathMay <- FilePath -> Sh (Maybe FilePath)
SH.which FilePath
cmd
case Maybe FilePath
pathMay of
Maybe FilePath
Nothing -> Text -> Sh ()
badIPython
Text
"No Jupyter / IPython detected -- install Jupyter 3.0+ before using IHaskell."
Just FilePath
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
where
badIPython :: Text -> SH.Sh ()
badIPython :: Text -> Sh ()
badIPython Text
message = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Handle -> FilePath -> IO ()
IO.hPutStrLn Handle
IO.stderr (Text -> FilePath
T.unpack Text
message)
forall a. IO a
exitFailure
installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh ()
installKernelspec :: Bool -> KernelSpecOptions -> Sh ()
installKernelspec Bool
repl KernelSpecOptions
opts = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ do
FilePath
ihaskellPath <- Sh FilePath
getIHaskellPath
Maybe FilePath
confFile <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ KernelSpecOptions -> IO (Maybe FilePath)
kernelSpecConfFile KernelSpecOptions
opts
let kernelName :: FilePath
kernelName = KernelSpecOptions -> FilePath
kernelSpecKernelName KernelSpecOptions
opts
let kernelFlags :: [String]
kernelFlags :: [FilePath]
kernelFlags =
[FilePath
"--debug" | KernelSpecOptions -> Bool
kernelSpecDebug KernelSpecOptions
opts] forall a. [a] -> [a] -> [a]
++
(case Maybe FilePath
confFile of
Maybe FilePath
Nothing -> []
Just FilePath
file -> [FilePath
"--conf", FilePath
file])
forall a. [a] -> [a] -> [a]
++ [FilePath
"--ghclib", KernelSpecOptions -> FilePath
kernelSpecGhcLibdir KernelSpecOptions
opts]
forall a. [a] -> [a] -> [a]
++ (case KernelSpecOptions -> [FilePath]
kernelSpecRTSOptions KernelSpecOptions
opts of
[] -> []
[FilePath]
_ -> FilePath
"+RTS" forall a. a -> [a] -> [a]
: KernelSpecOptions -> [FilePath]
kernelSpecRTSOptions KernelSpecOptions
opts forall a. [a] -> [a] -> [a]
++ [FilePath
"-RTS"])
forall a. [a] -> [a] -> [a]
++ [FilePath
"--stack" | KernelSpecOptions -> Bool
kernelSpecUseStack KernelSpecOptions
opts]
let kernelSpec :: KernelSpec
kernelSpec = KernelSpec
{ kernelDisplayName :: FilePath
kernelDisplayName = KernelSpecOptions -> FilePath
kernelSpecDisplayName KernelSpecOptions
opts
, kernelLanguage :: FilePath
kernelLanguage = FilePath
kernelName
, kernelCommand :: [FilePath]
kernelCommand = [FilePath
ihaskellPath, FilePath
"kernel", FilePath
"{connection_file}"] forall a. [a] -> [a] -> [a]
++ [FilePath]
kernelFlags
}
forall a. (FilePath -> Sh a) -> Sh a
SH.withTmpDir forall a b. (a -> b) -> a -> b
$ \FilePath
tmp -> do
let kernelDir :: FilePath
kernelDir = FilePath
tmp forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> FilePath
kernelName
let filename :: FilePath
filename = FilePath
kernelDir forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"kernel.json" :: SH.FilePath)
FilePath -> Sh ()
SH.mkdir_p FilePath
kernelDir
FilePath -> Text -> Sh ()
SH.writefile FilePath
filename forall a b. (a -> b) -> a -> b
$ Text -> Text
LT.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Builder
encodeToTextBuilder forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON KernelSpec
kernelSpec
let files :: [FilePath]
files = [FilePath
"kernel.js", FilePath
"logo-64x64.svg"]
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
files forall a b. (a -> b) -> a -> b
$ \FilePath
file -> do
FilePath
src <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
Paths.getDataFileName forall a b. (a -> b) -> a -> b
$ FilePath
"html/" forall a. [a] -> [a] -> [a]
++ FilePath
file
FilePath -> FilePath -> Sh ()
SH.cp (Text -> FilePath
SH.fromText forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
src) (FilePath
tmp forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> FilePath
kernelName forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> FilePath
file)
FilePath
ipython <- Sh FilePath
locateIPython
let replaceFlag :: [Text]
replaceFlag = [Text
"--replace" | Bool
repl]
installPrefixFlag :: [Text]
installPrefixFlag = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Text
"--user"] (\FilePath
prefix -> [Text
"--prefix", FilePath -> Text
T.pack FilePath
prefix]) (KernelSpecOptions -> Maybe FilePath
kernelSpecInstallPrefix KernelSpecOptions
opts)
cmd :: [Text]
cmd = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Text
"kernelspec", Text
"install"], [Text]
installPrefixFlag, [FilePath -> Text
SH.toTextIgnore FilePath
kernelDir], [Text]
replaceFlag]
let transformOutput :: Sh a -> Sh a
transformOutput = if KernelSpecOptions -> Bool
kernelSpecDebug KernelSpecOptions
opts then forall a. a -> a
id else forall a. Sh a -> Sh a
SH.silently
forall a. Sh a -> Sh a
transformOutput forall a b. (a -> b) -> a -> b
$ FilePath -> [Text] -> Sh Text
SH.run FilePath
ipython [Text]
cmd
installLabextension :: Bool -> IO ()
installLabextension :: Bool -> IO ()
installLabextension Bool
debug = forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly forall a b. (a -> b) -> a -> b
$ do
FilePath
ihaskellDataDir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO FilePath
Paths.getDataDir
let labextensionDataDir :: FilePath
labextensionDataDir = FilePath
ihaskellDataDir
forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"jupyterlab-ihaskell" :: SH.FilePath)
forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"labextension" :: SH.FilePath)
FilePath
jupyter <- Sh FilePath
locateIPython
FilePath
jupyterDataDir <- forall a. Sh a -> Sh a
SH.silently forall a b. (a -> b) -> a -> b
$ Text -> FilePath
SH.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [Text] -> Sh Text
SH.run FilePath
jupyter [Text
"--data-dir"]
let jupyterlabIHaskellDir :: FilePath
jupyterlabIHaskellDir = FilePath
jupyterDataDir
forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"labextensions" :: SH.FilePath)
forall filepath1 filepath2.
(ToFilePath filepath1, ToFilePath filepath2) =>
filepath1 -> filepath2 -> FilePath
SH.</> (FilePath
"jupyterlab-ihaskell" :: SH.FilePath)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (forall (m :: * -> *). MonadIO m => FilePath -> m ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Installing kernel in folder: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show FilePath
jupyterlabIHaskellDir)
FilePath -> Sh ()
SH.rm_rf FilePath
jupyterlabIHaskellDir
FilePath -> Sh ()
SH.mkdir_p FilePath
jupyterlabIHaskellDir
[FilePath]
extensionContents <- FilePath -> Sh [FilePath]
SH.ls FilePath
labextensionDataDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [FilePath]
extensionContents forall a b. (a -> b) -> a -> b
$ \FilePath
entry ->
FilePath -> FilePath -> Sh ()
SH.cp_r FilePath
entry FilePath
jupyterlabIHaskellDir
subHome :: String -> IO String
subHome :: FilePath -> IO FilePath
subHome FilePath
path = forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly forall a b. (a -> b) -> a -> b
$ do
FilePath
home <- Text -> FilePath
T.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> Maybe a -> a
fromMaybe Text
"~" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Sh (Maybe Text)
SH.get_env Text
"HOME"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
replace FilePath
"~" FilePath
home FilePath
path
getIHaskellPath :: SH.Sh FilePath
getIHaskellPath :: Sh FilePath
getIHaskellPath = do
FilePath
f <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath
if FilePath -> Bool
FP.isAbsolute FilePath
f
then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
else
if FilePath -> FilePath
FP.takeFileName FilePath
f forall a. Eq a => a -> a -> Bool
== FilePath
f
then do
Maybe FilePath
ihaskellPath <- FilePath -> Sh (Maybe FilePath)
SH.which FilePath
"ihaskell"
case Maybe FilePath
ihaskellPath of
Maybe FilePath
Nothing -> forall a. HasCallStack => FilePath -> a
error FilePath
"ihaskell not on $PATH and not referenced relative to directory."
Just FilePath
path -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> FilePath
T.unpack forall a b. (a -> b) -> a -> b
$ FilePath -> Text
SH.toTextIgnore FilePath
path
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
makeAbsolute FilePath
f
getSandboxPackageConf :: IO (Maybe String)
getSandboxPackageConf :: IO (Maybe FilePath)
getSandboxPackageConf = forall (m :: * -> *) a. MonadIO m => Sh a -> m a
SH.shelly forall a b. (a -> b) -> a -> b
$ do
FilePath
myPath <- Sh FilePath
getIHaskellPath
let sandboxName :: FilePath
sandboxName = FilePath
".cabal-sandbox"
if Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FilePath
sandboxName forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` FilePath
myPath
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
else do
let pieces :: [FilePath]
pieces = FilePath -> FilePath -> [FilePath]
split FilePath
"/" FilePath
myPath
sandboxDir :: FilePath
sandboxDir = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= FilePath
sandboxName) [FilePath]
pieces forall a. [a] -> [a] -> [a]
++ [FilePath
sandboxName]
[FilePath]
subdirs <- forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
fp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Sh [FilePath]
SH.ls (Text -> FilePath
SH.fromText forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
sandboxDir)
let confdirs :: [FilePath]
confdirs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf (FilePath
"packages.conf.d" :: String)) [FilePath]
subdirs
case [FilePath]
confdirs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
FilePath
dir:[FilePath]
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
dir