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

-- |
-- Module      :  ELynx.Tools.ELynx
-- Description :  The ELynx transformer
-- Copyright   :  (c) 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.MWC

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

fixSeed :: Reproducible a => a -> IO a
fixSeed :: a -> IO a
fixSeed a
x = case a -> Maybe SeedOpt
forall a. Reproducible a => a -> Maybe SeedOpt
getSeed a
x of
  (Just SeedOpt
RandomUnset) -> do
    Gen RealWorld
g <- IO (Gen RealWorld)
IO GenIO
createSystemRandom
    Vector Word32
s <- Seed -> Vector Word32
fromSeed (Seed -> Vector Word32) -> IO Seed -> IO (Vector Word32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenIO -> IO Seed
forall (m :: * -> *). PrimMonad m => Gen (PrimState m) -> m Seed
save Gen RealWorld
GenIO
g
    a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a -> SeedOpt -> a
forall a. Reproducible a => a -> SeedOpt -> a
setSeed a
x (Vector Word32 -> SeedOpt
RandomSet Vector Word32
s)
  Maybe SeedOpt
_ -> a -> IO a
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 :: (b -> a) -> ELynx b () -> ELynx b ()
eLynxRun b -> a
f ELynx b ()
worker = do
  -- Header.
  String -> [String] -> ELynx b ()
forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
String -> [String] -> Logger e ()
logInfoHeader (Reproducible b => String
forall a. Reproducible a => String
cmdName @b) (Reproducible b => [String]
forall a. Reproducible a => [String]
cmdDsc @b)
  Maybe SeedOpt
mso <- (Environment b -> Maybe SeedOpt)
-> ReaderT (Environment b) IO (Maybe SeedOpt)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
reader (b -> Maybe SeedOpt
forall a. Reproducible a => a -> Maybe SeedOpt
getSeed (b -> Maybe SeedOpt)
-> (Environment b -> b) -> Environment b -> Maybe SeedOpt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment b -> b
forall a. Environment a -> a
localArguments)
  case Maybe SeedOpt
mso of
    Maybe SeedOpt
Nothing -> () -> ELynx b ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (RandomSet Vector Word32
s) -> String -> ELynx b ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> ELynx b ()) -> String -> ELynx b ()
forall a b. (a -> b) -> a -> b
$ String
"Seed: random; set to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> String
forall a. Show a => a -> String
show Vector Word32
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
    Just (Fixed Vector Word32
s) -> String -> ELynx b ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> ELynx b ()) -> String -> ELynx b ()
forall a b. (a -> b) -> a -> b
$ String
"Seed: fixed to " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Vector Word32 -> String
forall a. Show a => a -> String
show Vector Word32
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
    Just SeedOpt
RandomUnset -> String -> ELynx b ()
forall a. HasCallStack => String -> a
error String
"eLynxRun: Seed unset."
  -- Worker.
  ELynx b ()
worker
  -- Footer.
  Environment b
e <- ReaderT (Environment b) IO (Environment b)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let g :: GlobalArguments
g = Environment b -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments Environment b
e
      l :: b
l = Environment b -> b
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
_) ->
      String -> ELynx b ()
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) ->
      String -> ELynx b ()
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
      String -> ELynx b ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS String
"Write ELynx reproduction file."
      IO () -> ELynx b ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx b ()) -> IO () -> ELynx b ()
forall a b. (a -> b) -> a -> b
$ String -> Arguments a -> IO ()
forall a.
(Eq a, Show a, Reproducible a, ToJSON a) =>
String -> a -> IO ()
writeReproduction String
bn (GlobalArguments -> a -> Arguments a
forall a. GlobalArguments -> a -> Arguments a
Arguments GlobalArguments
g (b -> a
f b
l))
  -- Footer.
  ELynx b ()
forall e.
(HasLock e, HasLogHandles e, HasStartingTime e, HasVerbosity e) =>
Logger e ()
logInfoFooter

-- | The 'ReaderT' and 'LoggingT' wrapper for ELynx. Prints a header and a
-- footer, logs to 'stderr' if no file is provided. Initializes the seed if none
-- is provided. If a log file is provided, log to the file and to 'stderr'.
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 :: GlobalArguments -> b -> (b -> a) -> ELynx b () -> IO ()
eLynxWrapper GlobalArguments
gArgs b
lArgs b -> a
f ELynx b ()
worker = do
  -- 1. Fix seed.
  b
lArgs' <- b -> IO b
forall a. Reproducible a => a -> IO a
fixSeed b
lArgs

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

  -- 3. Run.
  ELynx b () -> Environment b -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((b -> a) -> ELynx b () -> ELynx b ()
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.
  Environment b -> IO ()
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 :: String -> ELynx a (Maybe String)
getOutFilePath String
ext = do
  Environment a
a <- ReaderT (Environment a) IO (Environment a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let bn :: Maybe String
bn = GlobalArguments -> Maybe String
outFileBaseName (GlobalArguments -> Maybe String)
-> (Environment a -> GlobalArguments)
-> Environment a
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment a -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments (Environment a -> Maybe String) -> Environment a -> Maybe String
forall a b. (a -> b) -> a -> b
$ Environment a
a
      sfxs :: [String]
sfxs = a -> [String]
forall a. Reproducible a => a -> [String]
outSuffixes (a -> [String])
-> (Environment a -> a) -> Environment a -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment a -> a
forall a. Environment a -> a
localArguments (Environment a -> [String]) -> Environment a -> [String]
forall a b. (a -> b) -> a -> b
$ Environment a
a
  if String
ext String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
sfxs
    then Maybe String -> ELynx a (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> ELynx a (Maybe String))
-> Maybe String -> ELynx a (Maybe String)
forall a b. (a -> b) -> a -> b
$ (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ext) (String -> String) -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
bn
    else
      String -> ELynx a (Maybe String)
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 :: String -> ByteString -> String -> ELynx a ()
out String
name ByteString
res String
ext = do
  Maybe String
mfp <- String -> ELynx a (Maybe String)
forall a. Reproducible a => String -> ELynx a (Maybe String)
getOutFilePath String
ext
  case Maybe String
mfp of
    Maybe String
Nothing -> do
      String -> ELynx a ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> ELynx a ()) -> String -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ String
"Write " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to standard output."
      IO () -> ELynx a ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx a ()) -> IO () -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ()
BL.putStr ByteString
res
    Just String
fp -> do
      String -> ELynx a ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> ELynx a ()) -> String -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ String
"Write " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to file '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'."
      ExecutionMode
em <- GlobalArguments -> ExecutionMode
executionMode (GlobalArguments -> ExecutionMode)
-> (Environment a -> GlobalArguments)
-> Environment a
-> ExecutionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment a -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments (Environment a -> ExecutionMode)
-> ReaderT (Environment a) IO (Environment a)
-> ReaderT (Environment a) IO ExecutionMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Environment a) IO (Environment a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      IO () -> ELynx a ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ELynx a ()) -> IO () -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ ExecutionMode -> String -> ByteString -> IO ()
writeGZFile ExecutionMode
em String
fp ByteString
res

-- | 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 :: String -> String -> ELynx a Handle
outHandle String
name String
ext = do
  Maybe String
mfp <- String -> ELynx a (Maybe String)
forall a. Reproducible a => String -> ELynx a (Maybe String)
getOutFilePath String
ext
  case Maybe String
mfp of
    Maybe String
Nothing -> do
      String -> Logger (Environment a) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> Logger (Environment a) ())
-> String -> Logger (Environment a) ()
forall a b. (a -> b) -> a -> b
$ String
"Write " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to standard output."
      Handle -> ELynx a Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdout
    Just String
fp -> do
      String -> Logger (Environment a) ()
forall e.
(HasLock e, HasLogHandles e, HasVerbosity e) =>
String -> Logger e ()
logInfoS (String -> Logger (Environment a) ())
-> String -> Logger (Environment a) ()
forall a b. (a -> b) -> a -> b
$ String
"Write " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" to file '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'."
      ExecutionMode
em <- GlobalArguments -> ExecutionMode
executionMode (GlobalArguments -> ExecutionMode)
-> (Environment a -> GlobalArguments)
-> Environment a
-> ExecutionMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Environment a -> GlobalArguments
forall a. Environment a -> GlobalArguments
globalArguments (Environment a -> ExecutionMode)
-> ReaderT (Environment a) IO (Environment a)
-> ReaderT (Environment a) IO ExecutionMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Environment a) IO (Environment a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
      IO Handle -> ELynx a Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> ELynx a Handle) -> IO Handle -> ELynx a Handle
forall a b. (a -> b) -> a -> b
$ ExecutionMode -> String -> IO Handle
openFileWithExecutionMode ExecutionMode
em String
fp