{-# language NoImplicitPrelude, DoAndIfThenElse, OverloadedStrings, ExtendedDefaultRules #-}

-- | Description : Shell scripting wrapper using @Shelly@ for the @notebook@, and
--                 @console@ commands.
module IHaskell.IPython (
    replaceIPythonKernelspec,
    defaultConfFile,
    getIHaskellDir,
    getSandboxPackageConf,
    subHome,
    kernelName,
    KernelSpecOptions(..),
    defaultKernelSpecOptions,
    installLabextension,
    ) where

import           IHaskellPrelude
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT

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           -- ^ GHC libdir.
         , KernelSpecOptions -> [FilePath]
kernelSpecRTSOptions :: [String]        -- ^ Runtime options to use.
         , KernelSpecOptions -> Bool
kernelSpecDebug :: Bool                 -- ^ Spew debugging output?
         , KernelSpecOptions -> FilePath
kernelSpecCodeMirror :: String          -- ^ CodeMirror mode
         , KernelSpecOptions -> IO (Maybe FilePath)
kernelSpecConfFile :: IO (Maybe String) -- ^ Filename of profile JSON file.
         , KernelSpecOptions -> Maybe FilePath
kernelSpecInstallPrefix :: Maybe String
         , KernelSpecOptions -> Bool
kernelSpecUseStack :: Bool              -- ^ Whether to use @stack@ environments.
         , KernelSpecOptions -> Maybe FilePath
kernelSpecEnvFile :: Maybe FilePath
         }

defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions :: KernelSpecOptions
defaultKernelSpecOptions = KernelSpecOptions
  { kernelSpecGhcLibdir :: FilePath
kernelSpecGhcLibdir = FilePath
GHC.Paths.libdir
  , kernelSpecRTSOptions :: [FilePath]
kernelSpecRTSOptions = [FilePath
"-M3g", FilePath
"-N2"]  -- Memory cap 3 GiB,
                                            -- multithreading on two processors.
  , kernelSpecDebug :: Bool
kernelSpecDebug = Bool
False
  , kernelSpecCodeMirror :: FilePath
kernelSpecCodeMirror = FilePath
"ihaskell"
  , 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
  }

-- | The IPython kernel name.
kernelName :: String
kernelName :: FilePath
kernelName = 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

-- | Create the directory and return it.
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

-- | Return the data directory for IHaskell.
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

-- | Verify that a proper version of IPython is installed and accessible.
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

-- | Install an IHaskell kernelspec into the right location. The right location is determined by
-- using `ipython kernelspec install --user`.
installKernelspec :: Bool -> KernelSpecOptions -> SH.Sh ()
installKernelspec :: 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 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 = FilePath
"Haskell"
        , kernelLanguage :: FilePath
kernelLanguage = FilePath
kernelName
        , kernelCommand :: [FilePath]
kernelCommand = [FilePath
ihaskellPath, FilePath
"kernel", FilePath
"{connection_file}"] forall a. [a] -> [a] -> [a]
++ [FilePath]
kernelFlags
        }

  -- Create a temporary directory. Use this temporary directory to make a kernelspec directory; then,
  -- shell out to IPython to install this kernelspec directory.
  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
  -- Find the prebuilt extension directory
  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)

  -- Find the $(jupyter --data-dir)/labextensions/jupyterlab-ihaskell directory
  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)
  -- Remove the extension directory with extreme prejudice if it already exists
  FilePath -> Sh ()
SH.rm_rf FilePath
jupyterlabIHaskellDir
  -- Create an empty 'jupyterlab-ihaskell' directory to install our extension in
  FilePath -> Sh ()
SH.mkdir_p FilePath
jupyterlabIHaskellDir
  -- Copy the prebuilt extension files over
  [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

-- | Replace "~" with $HOME if $HOME is defined. Otherwise, do nothing.
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

-- | Get the absolute path to this IHaskell executable.
getIHaskellPath :: SH.Sh FilePath
getIHaskellPath :: Sh FilePath
getIHaskellPath = do
  --  Get the absolute filepath to the argument.
  FilePath
f <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getExecutablePath

  -- If we have an absolute path, that's the IHaskell we're interested in.
  if FilePath -> Bool
FP.isAbsolute FilePath
f
    then forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
f
    else
    -- Check whether this is a relative path, or just 'IHaskell' with $PATH resolution done by
    -- the shell. If it's just 'IHaskell', use the $PATH variable to find where IHaskell lives.
    if 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