{-# LANGUAGE TypeApplications #-}

module Language.PureScript.Interactive.IO (findNodeProcess, readNodeProcessWithExitCode, getHistoryFilename) where

import Prelude

import Control.Monad (msum, void)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import Data.Functor ((<&>))
import Data.List (isInfixOf)
import System.Directory (XdgDirectory (..), createDirectoryIfMissing,
                         getAppUserDataDirectory, getXdgDirectory,
                         findExecutable, doesFileExist)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import System.FilePath (takeDirectory, (</>))
import System.Process (readProcessWithExitCode)
import Text.Parsec ((<?>), many1, parse, sepBy)
import Text.Parsec.Char (char, digit)
import Protolude (note)

mkdirp :: FilePath -> IO ()
mkdirp :: String -> IO ()
mkdirp = Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeDirectory

-- File helpers

onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
onFirstFileMatching :: forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> [b] -> m (Maybe a)
onFirstFileMatching b -> m (Maybe a)
f [b]
pathVariants = forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> m (Maybe a)
f) [b]
pathVariants

-- |
-- Locates the node executable.
-- Checks for either @nodejs@ or @node@.
--
findNodeProcess :: IO (Either String String)
findNodeProcess :: IO (Either String String)
findNodeProcess = forall (m :: * -> *) b a.
Monad m =>
(b -> m (Maybe a)) -> [b] -> m (Maybe a)
onFirstFileMatching String -> IO (Maybe String)
findExecutable [String
"nodejs", String
"node"] forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
  forall e (m :: * -> *) a. MonadError e m => e -> Maybe a -> m a
note String
"Could not find Node.js. Do you have Node.js installed and available in your PATH?"

findNodeVersion :: String -> IO (Maybe String)
findNodeVersion :: String -> IO (Maybe String)
findNodeVersion String
node = do
  (ExitCode, String, String)
result <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
node [String
"--version"] String
""
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (ExitCode, String, String)
result of
    (ExitCode
ExitSuccess, String
version, String
_) -> forall a. a -> Maybe a
Just String
version
    (ExitFailure Int
_, String
_, String
_) -> forall a. Maybe a
Nothing

readNodeProcessWithExitCode :: Maybe FilePath -> [String] -> String -> IO (Either String (ExitCode, String, String))
readNodeProcessWithExitCode :: Maybe String
-> [String]
-> String
-> IO (Either String (ExitCode, String, String))
readNodeProcessWithExitCode Maybe String
nodePath [String]
nodeArgs String
stdin = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  String
process <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT IO (Either String String)
findNodeProcess) forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
nodePath
  (Int
major, Int
_, Int
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> IO (Maybe String)
findNodeVersion String
process) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe String
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"Could not find Node.js version."
    Just String
version -> do
      let semver :: ParsecT String u Identity (Int, Int, Int)
semver = do
            forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'v'
            Int
major : Int
minor : Int
patch : [Int]
_ <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Read a => String -> a
read @Int) (forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit) forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.')
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
major, Int
minor, Int
patch)
      case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (forall {u}. ParsecT String u Identity (Int, Int, Int)
semver forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Could not parse Node.js version.") String
"" String
version of
        Left ParseError
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ParseError
err
        Right (Int
major, Int
minor, Int
patch)
          | Int
major forall a. Ord a => a -> a -> Bool
< Int
12 -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"Unsupported Node.js version " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
major forall a. Semigroup a => a -> a -> a
<> String
". Required Node.js version >=12."
          | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
major, Int
minor, Int
patch)
  let nodeArgs' :: [String]
nodeArgs' = if Int
major forall a. Ord a => a -> a -> Bool
< Int
13 then String
"--experimental-modules" forall a. a -> [a] -> [a]
: [String]
nodeArgs else [String]
nodeArgs
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
process [String]
nodeArgs' String
stdin) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    (ExitCode
ExitSuccess, String
out, String
err) ->
      (ExitCode
ExitSuccess, String
out, String -> String
censorExperimentalWarnings String
err)
    (ExitFailure Int
code, String
out, String
err) ->
      (Int -> ExitCode
ExitFailure Int
code, String
out, String
err)

censorExperimentalWarnings :: String -> String
censorExperimentalWarnings :: String -> String
censorExperimentalWarnings =
  [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"ExperimentalWarning" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines

-- |
-- Grabs the filename where the history is stored.
--
getHistoryFilename :: IO FilePath
getHistoryFilename :: IO String
getHistoryFilename = do
  String
appuserdata <- String -> IO String
getAppUserDataDirectory String
"purescript"
  Bool
olddirbool <- String -> IO Bool
doesFileExist (String
appuserdata String -> String -> String
</> String
"psci_history")
  if Bool
olddirbool
      then forall (m :: * -> *) a. Monad m => a -> m a
return (String
appuserdata String -> String -> String
</> String
"psci_history")
      else do
        String
datadir <- XdgDirectory -> String -> IO String
getXdgDirectory XdgDirectory
XdgData String
"purescript"
        let filename :: String
filename = String
datadir String -> String -> String
</> String
"psci_history"
        String -> IO ()
mkdirp String
filename
        forall (m :: * -> *) a. Monad m => a -> m a
return String
filename