-- | Functions for running generated modules
--
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
module Language.Haskell.RunHaskellModule
    ( RunOptions(..)
    , compileHaskellModule
    , compileHaskellModule'
    , runHaskellModule
    , runHaskellModule'
    ) where


import           Control.Exception
import           Control.Monad
import           Data.Char
import           Data.Default
import           Data.Semigroup((<>))
import           System.Environment
import           System.Exit
import           System.FilePath.Posix
import           System.IO
import           System.Process

-- | Describes options required for run environment
data RunOptions = RunOptions
        { RunOptions -> Bool
verbose            :: Bool -- ^ Verbose run?
        , RunOptions -> Bool
showStdout         :: Bool -- ^ Whether to show `stdout` for debugging
        , RunOptions -> [String]
compileArgs        :: [String] -- ^ GHC options
        , RunOptions -> [String]
additionalPackages :: [String] -- ^ Packages to expose
        }


instance Default RunOptions where
    def :: RunOptions
def = RunOptions :: Bool -> Bool -> [String] -> [String] -> RunOptions
RunOptions { verbose :: Bool
verbose            = Bool
False
                     , showStdout :: Bool
showStdout         = Bool
False
                     , compileArgs :: [String]
compileArgs        = []
                     , additionalPackages :: [String]
additionalPackages = []
                     }


data GhcTool = Runner | Compiler


-- | Call specified process with args and print its output when it fails.
--
callProcess' :: RunOptions -> FilePath -> [String] -> IO ExitCode
callProcess' :: RunOptions -> String -> [String] -> IO ExitCode
callProcess' RunOptions{..} cmd :: String
cmd args :: [String]
args = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Run \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\" with args: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
args
    (_, pstdout :: Maybe Handle
pstdout, pstderr :: Maybe Handle
pstderr, p :: ProcessHandle
p) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess ((String -> [String] -> CreateProcess
proc String
cmd [String]
args) { std_out :: StdStream
std_out = if Bool
showStdout then StdStream
Inherit else StdStream
CreatePipe, std_err :: StdStream
std_err = StdStream
CreatePipe })
    ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
p IO ExitCode -> (ExitCode -> IO ExitCode) -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        ExitSuccess -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
showStdout (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
whenMaybe Handle -> IO ()
hClose Maybe Handle
pstdout
            (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
whenMaybe Handle -> IO ()
hClose Maybe Handle
pstderr
            ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
        ExitFailure r :: Int
r -> do
            (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
whenMaybe (Handle -> Handle -> IO ()
dumpHandle Handle
stderr) Maybe Handle
pstdout
            (Handle -> IO ()) -> Maybe Handle -> IO ()
forall (m :: * -> *) a. Monad m => (a -> m ()) -> Maybe a -> m ()
whenMaybe (Handle -> Handle -> IO ()
dumpHandle Handle
stderr) Maybe Handle
pstderr
            String -> IO ExitCode
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ExitCode) -> String -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ["Running \"", String
cmd, "\" \"", [String] -> String
forall a. Show a => a -> String
show [String]
args, "\" has failed with \"", Int -> String
forall a. Show a => a -> String
show Int
r, "\""]
  where
    dumpHandle :: Handle -> Handle -> IO ()
dumpHandle outhndl :: Handle
outhndl inhnd :: Handle
inhnd = Handle -> IO String
hGetContents Handle
inhnd IO String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> String -> IO ()
hPutStr Handle
outhndl
    whenMaybe :: (a -> m ()) -> Maybe a -> m ()
whenMaybe a :: a -> m ()
a m :: Maybe a
m = m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) a -> m ()
a Maybe a
m


-- | Splits commandline-like strings into "words", i.e.
--   ```
--   -O0 --ghc-arg="-package scientific" --ghc-arg="-package xml-typelift"
--   ```
--   transformed into 3 "words":
--   ```
--   -O0
--   --ghc-arg="-package scientific"
--   --ghc-arg="-package xml-typelift"
--   ```
splitWithQuotes :: String -> [String]
splitWithQuotes :: String -> [String]
splitWithQuotes [] = []
splitWithQuotes (ch :: Char
ch:cs :: String
cs)
  | Char -> Bool
isSpace Char
ch = String -> [String]
splitWithQuotes (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace String
cs
  | Bool
otherwise = String
word String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitWithQuotes String
strrest
  where
    (word :: String
word, strrest :: String
strrest) = String -> (String, String)
takeWordOrQuote (Char
chChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
    takeWordOrQuote :: String -> (String, String)
    takeWordOrQuote :: String -> (String, String)
takeWordOrQuote str :: String
str = let (w' :: String
w', rest :: String
rest) = String -> Bool -> String -> (String, String)
takeWordOrQuote' "" Bool
False String
str in (String -> String
forall a. [a] -> [a]
reverse String
w', String
rest)
      where
        takeWordOrQuote' :: String -> Bool -> String -> (String, String)
takeWordOrQuote' acc :: String
acc _     ""         = (String
acc, "")
        takeWordOrQuote' acc :: String
acc True  ('"':"")   = (String
acc, "")
        takeWordOrQuote' acc :: String
acc True  ('"':c :: Char
c:rest :: String
rest)
          | Char -> Bool
isSpace Char
c = ('"'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc, String
rest)
          | Bool
otherwise = String -> Bool -> String -> (String, String)
takeWordOrQuote' ('"'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) Bool
False (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
rest)
        takeWordOrQuote' acc :: String
acc True  (c :: Char
c  :rest :: String
rest) = String -> Bool -> String -> (String, String)
takeWordOrQuote' (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) Bool
True String
rest
        takeWordOrQuote' acc :: String
acc False ('"':rest :: String
rest) = String -> Bool -> String -> (String, String)
takeWordOrQuote' ('"'Char -> String -> String
forall a. a -> [a] -> [a]
:String
acc) Bool
True String
rest
        takeWordOrQuote' acc :: String
acc False (c :: Char
c  :rest :: String
rest)
          | Char -> Bool
isSpace Char
c = (String
acc, String
rest)
          | Bool
otherwise = String -> Bool -> String -> (String, String)
takeWordOrQuote' (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
acc) Bool
False String
rest


findGhc :: RunOptions
        -> GhcTool
        -> IO (FilePath, [String]) -- ^ returns (exe, special tool arguments)
findGhc :: RunOptions -> GhcTool -> IO (String, [String])
findGhc RunOptions{..} ghcTool :: GhcTool
ghcTool = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let showEnv :: String -> IO ()
showEnv env :: String
env = String -> IO (Maybe String)
lookupEnv String
env IO (Maybe String) -> (Maybe String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\e :: Maybe String
e -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ">>> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
env String -> String -> String
forall a. [a] -> [a] -> [a]
++ " = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
e)
        String -> IO ()
showEnv "STACK_EXE"
        String -> IO ()
showEnv "CABAL_SANDBOX_CONFIG"
        String -> IO ()
showEnv "GHC_ENVIRONMENT"
        String -> IO ()
showEnv "GHC_PACKAGE_PATH"
        String -> IO ()
showEnv "HASKELL_DIST_DIR"
        String -> IO ()
showEnv "CI_GHC_ADDITIONAL_FLAGS"
        String -> IO ()
showEnv "CI_GHC_ADDITIONAL_PACKAGES"
        String -> IO ()
showEnv "CI_GHC_CABAL_STYLE"
        -- putStrLn "Environment: -----------"
        -- getEnvironment >>= (mapM_ $ \(env,val) -> putStrLn $ env ++ " = " ++ val)
        -- putStrLn "End of environment -----"
    Maybe String
stack    <- String -> IO (Maybe String)
lookupEnv "STACK_EXE"
    Maybe String
oldCabal <- String -> IO (Maybe String)
lookupEnv "CABAL_SANDBOX_CONFIG"
    Maybe String
newCabal <- String -> IO (Maybe String)
lookupEnv "HASKELL_DIST_DIR"
    [String]
additionalFlags        <- ([String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
splitWithQuotes)                    (Maybe String -> [String]) -> IO (Maybe String) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "CI_GHC_ADDITIONAL_FLAGS"
    [String]
additionalPackagesList <- (([String]
additionalPackages [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (Maybe String -> [String]) -> Maybe String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] String -> [String]
words))  (Maybe String -> [String]) -> IO (Maybe String) -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "CI_GHC_ADDITIONAL_PACKAGES"
    String
cabalStyle             <- (String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "v2" String -> String
forall a. a -> a
id)                               (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "CI_GHC_CABAL_STYLE"
    let cabalExec :: String
cabalExec = String
cabalStyle String -> String -> String
forall a. [a] -> [a] -> [a]
++ "-exec"
    let additionalPackagesArgs :: [String]
additionalPackagesArgs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
mkAdditionalPackagesArg [String]
additionalPackagesList

    let res :: (String, [String])
res@(exe :: String
exe, exeArgs' :: [String]
exeArgs') | Just stackExec :: String
stackExec <- Maybe String
stack    = (String
stackExec, [String
tool] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
additionalFlags
                                                                   [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String
stackPackageArg (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
additionalPackagesList)
                                                                   [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["--"])
                            | Just _         <- Maybe String
oldCabal = ("cabal", ["exec", String
tool, "--"])
                            | Just _         <- Maybe String
newCabal = ("cabal", [String
cabalExec, String
tool, "--"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
additionalPackagesArgs)
                            | Bool
otherwise                  = (String
tool, [])
        exeArgs :: [String]
exeArgs = case GhcTool
ghcTool of
                    Compiler -> [String]
exeArgs' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["-O0"]
                    Runner   -> [String]
exeArgs'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verbose (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Use exe \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exe String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\", and additional arguments: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
exeArgs
    (String, [String]) -> IO (String, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return (String, [String])
res
  where
    tool :: String
tool = case GhcTool
ghcTool of
               Runner   -> "runghc"
               Compiler -> "ghc"
    stackPackageArg :: String -> String
stackPackageArg arg :: String
arg = "--package=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg
    mkAdditionalPackagesArg :: String -> String
mkAdditionalPackagesArg arg :: String
arg = case GhcTool
ghcTool of
               Runner   -> "--ghc-arg=-package=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg
               Compiler ->           "-package=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
arg


passModuleToGhc :: RunOptions -> GhcTool -> FilePath -> [String] -> IO ExitCode
passModuleToGhc :: RunOptions -> GhcTool -> String -> [String] -> IO ExitCode
passModuleToGhc ro :: RunOptions
ro ghcTool :: GhcTool
ghcTool moduleFilename :: String
moduleFilename args :: [String]
args =
    (SomeException -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\(SomeException
e::SomeException) -> do SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ExitCode
forall a e. Exception e => e -> a
throw SomeException
e) (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
        (exe :: String
exe, exeArgs :: [String]
exeArgs) <- RunOptions -> GhcTool -> IO (String, [String])
findGhc RunOptions
ro GhcTool
ghcTool
        RunOptions -> String -> [String] -> IO ExitCode
callProcess' RunOptions
ro String
exe ([String]
exeArgs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
moduleFilenameString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
args)


-- | Find ghc with cabal or stack and compile Haskell module with specified arguments and run options
--
compileHaskellModule' :: RunOptions -> FilePath -> [String] -> IO ExitCode
compileHaskellModule' :: RunOptions -> String -> [String] -> IO ExitCode
compileHaskellModule' ro :: RunOptions
ro moduleFilename :: String
moduleFilename args :: [String]
args = RunOptions -> GhcTool -> String -> [String] -> IO ExitCode
passModuleToGhc RunOptions
ro GhcTool
Compiler String
moduleFilename [String]
args

-- | Find ghc with cabal or stack and compile Haskell module with specified arguments
--
compileHaskellModule :: FilePath -> [String] -> IO ExitCode
compileHaskellModule :: String -> [String] -> IO ExitCode
compileHaskellModule = RunOptions -> String -> [String] -> IO ExitCode
compileHaskellModule' RunOptions
forall a. Default a => a
def

-- | Find ghc with cabal or stack and run Haskell module in specified file with arguments and run options
--
runHaskellModule' :: RunOptions -> FilePath -> [String] -> IO ExitCode
runHaskellModule' :: RunOptions -> String -> [String] -> IO ExitCode
runHaskellModule' ro :: RunOptions
ro moduleFilename :: String
moduleFilename args :: [String]
args = RunOptions -> GhcTool -> String -> [String] -> IO ExitCode
passModuleToGhc RunOptions
ro GhcTool
Runner String
moduleFilename [String]
args


-- | Find ghc with cabal or stack and run Haskell module in specified file with arguments
--
runHaskellModule :: FilePath -> [String] -> IO ExitCode
runHaskellModule :: String -> [String] -> IO ExitCode
runHaskellModule = RunOptions -> String -> [String] -> IO ExitCode
runHaskellModule' RunOptions
forall a. Default a => a
def