{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :  ELynx.Tools.ELynx
-- Description :  The ELynx transformer
-- Copyright   :  2021 Dominik Schrempf
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Creation date: Thu Sep  2 18:55:11 2021.
module ELynx.Tools.ELynx
  ( ELynx,
    eLynxWrapper,
    out,
    outHandle,
  )
where

import Control.Monad.IO.Class
import Control.Monad.Trans.Reader hiding (local)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL
import ELynx.Tools.Environment
import ELynx.Tools.InputOutput
import ELynx.Tools.Logger
import ELynx.Tools.Options
import ELynx.Tools.Reproduction
import System.IO
import System.Random.Stateful

-- | ELynx transformer to be used with all executables.
type ELynx a = ReaderT (Environment a) IO

fixSeed :: Reproducible a => a -> IO a
fixSeed :: forall a. Reproducible a => a -> IO a
fixSeed a
x = case forall a. Reproducible a => a -> Maybe SeedOpt
getSeed a
x of
  (Just SeedOpt
RandomUnset) -> do
    Int
s <- forall a g (m :: * -> *). (Uniform a, StatefulGen g m) => g -> m a
uniformM AtomicGenM StdGen
globalStdGen :: IO Int
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Reproducible a => a -> SeedOpt -> a
setSeed a
x (Int -> SeedOpt
RandomSet Int
s)
  Maybe SeedOpt
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x

eLynxRun ::
  forall a b.
  (Eq a, Reproducible a, Reproducible b, Show a, ToJSON a) =>
  (b -> a) ->
  ELynx b () ->
  ELynx b ()
eLynxRun :: forall a b.
(Eq a, Reproducible a, Reproducible b, Show a, ToJSON a) =>
(b -> a) -> ELynx b () -> ELynx b ()
eLynxRun b -> a
f ELynx b ()
worker = do
  -- Header.
  forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
String -> [String] -> Logger e ()
logInfoHeader (forall a. Reproducible a => String
cmdName @b) (forall a. Reproducible a => [String]
cmdDsc @b)
  Maybe SeedOpt
mso <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader (forall a. Reproducible a => a -> Maybe SeedOpt
getSeed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> a
localArguments)
  case Maybe SeedOpt
mso of
    Maybe SeedOpt
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (RandomSet Int
s) -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Seed: random; set to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
s forall a. Semigroup a => a -> a -> a
<> String
"."
    Just (Fixed Int
s) -> forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Seed: fixed to " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
s forall a. Semigroup a => a -> a -> a
<> String
"."
    Just SeedOpt
RandomUnset -> forall a. HasCallStack => String -> a
error String
"eLynxRun: Seed unset."
  -- Worker.
  ELynx b ()
worker
  -- Footer.
  Environment b
e <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let g :: GlobalArguments
g = forall a. Environment a -> GlobalArguments
globalArguments Environment b
e
      l :: b
l = forall a. Environment a -> a
localArguments Environment b
e
  case (GlobalArguments -> Bool
writeElynxFile GlobalArguments
g, GlobalArguments -> Maybe String
outFileBaseName GlobalArguments
g) of
    (Bool
False, Maybe String
_) ->
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"No elynx file option --- skip writing ELynx file for reproducible runs."
    (Bool
True, Maybe String
Nothing) ->
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"No output file given --- skip writing ELynx file for reproducible runs."
    (Bool
True, Just String
bn) -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Write ELynx reproduction file."
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
(Eq a, Show a, Reproducible a, ToJSON a) =>
String -> a -> IO ()
writeReproduction String
bn (forall a. GlobalArguments -> a -> Arguments a
Arguments GlobalArguments
g (b -> a
f b
l))
  -- Footer.
  forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoFooter

-- | The 'ReaderT' wrapper for ELynx. Prints a header and a footer, logs to
-- 'stdout' and possibly a log file, if provided. Initializes the seed if none
-- is provided.
eLynxWrapper ::
  (Eq a, Show a, Reproducible a, Reproducible b, ToJSON a) =>
  GlobalArguments ->
  -- Local arguments.
  b ->
  -- Local arguments across all commands.
  (b -> a) ->
  ELynx b () ->
  IO ()
eLynxWrapper :: forall a b.
(Eq a, Show a, Reproducible a, Reproducible b, ToJSON a) =>
GlobalArguments -> b -> (b -> a) -> ELynx b () -> IO ()
eLynxWrapper GlobalArguments
gArgs b
lArgs b -> a
f ELynx b ()
worker = do
  -- 1. Fix seed.
  b
lArgs' <- forall a. Reproducible a => a -> IO a
fixSeed b
lArgs

  -- 2. Initialize environment.
  Environment b
e <- forall a. GlobalArguments -> a -> IO (Environment a)
initializeEnvironment GlobalArguments
gArgs b
lArgs'

  -- 3. Run.
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a b.
(Eq a, Reproducible a, Reproducible b, Show a, ToJSON a) =>
(b -> a) -> ELynx b () -> ELynx b ()
eLynxRun b -> a
f ELynx b ()
worker) Environment b
e

  -- 4. Close environment.
  forall s. Environment s -> IO ()
closeEnvironment Environment b
e

-- Get out file path with extension.
getOutFilePath ::
  forall a. Reproducible a => String -> ELynx a (Maybe FilePath)
getOutFilePath :: forall a. Reproducible a => String -> ELynx a (Maybe String)
getOutFilePath String
ext = do
  Environment a
a <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let bn :: Maybe String
bn = GlobalArguments -> Maybe String
outFileBaseName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> GlobalArguments
globalArguments forall a b. (a -> b) -> a -> b
$ Environment a
a
      sfxs :: [String]
sfxs = forall a. Reproducible a => a -> [String]
outSuffixes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> a
localArguments forall a b. (a -> b) -> a -> b
$ Environment a
a
  if String
ext forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
sfxs
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a] -> [a]
++ String
ext) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
bn
    else
      forall a. HasCallStack => String -> a
error
        String
"getOutFilePath: out file suffix not registered; please contact maintainer."

-- | Write a result with a given name to file with given extension or standard
-- output. Supports compression.
out :: Reproducible a => String -> BL.ByteString -> String -> ELynx a ()
out :: forall a.
Reproducible a =>
String -> ByteString -> String -> ELynx a ()
out String
name ByteString
res String
ext = do
  Maybe String
mfp <- forall a. Reproducible a => String -> ELynx a (Maybe String)
getOutFilePath String
ext
  case Maybe String
mfp of
    Maybe String
Nothing -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Write " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
" to standard output."
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BL.putStr ByteString
res
    Just String
fp -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Write " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
" to file '" forall a. Semigroup a => a -> a -> a
<> String
fp forall a. Semigroup a => a -> a -> a
<> String
"'."
      ExecutionMode
em <- GlobalArguments -> ExecutionMode
executionMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> GlobalArguments
globalArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ExecutionMode -> String -> ByteString -> IO ()
writeGZFile ExecutionMode
em String
fp ByteString
res

-- BUG: 'outHandle' is flawed. If '-o BASENAME' is not provided, the output
-- handle is stdout, but then, when closing the handle, stdout will be closed!
-- Big Bug.

-- | Get an output handle, does not support compression. The handle has to be
-- closed after use!
outHandle :: Reproducible a => String -> String -> ELynx a Handle
outHandle :: forall a. Reproducible a => String -> String -> ELynx a Handle
outHandle String
name String
ext = do
  Maybe String
mfp <- forall a. Reproducible a => String -> ELynx a (Maybe String)
getOutFilePath String
ext
  case Maybe String
mfp of
    Maybe String
Nothing -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Write " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
" to standard output."
      forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
    Just String
fp -> do
      forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS forall a b. (a -> b) -> a -> b
$ String
"Write " forall a. Semigroup a => a -> a -> a
<> String
name forall a. Semigroup a => a -> a -> a
<> String
" to file '" forall a. Semigroup a => a -> a -> a
<> String
fp forall a. Semigroup a => a -> a -> a
<> String
"'."
      ExecutionMode
em <- GlobalArguments -> ExecutionMode
executionMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Environment a -> GlobalArguments
globalArguments forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ExecutionMode -> String -> IO Handle
openFileWithExecutionMode ExecutionMode
em String
fp