{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      :  ELynx.Tools.InputOutput
-- Copyright   :  (c) Dominik Schrempf 2020
-- License     :  GPL-3.0-or-later
--
-- Maintainer  :  dominik.schrempf@gmail.com
-- Stability   :  unstable
-- Portability :  portable
--
-- Creation date: Thu Feb 14 13:30:37 2019.
--
-- Tools involving input, output, and parsing.
module ELynx.Tools.InputOutput
  ( -- * Input, output
    getOutFilePath,
    openFile',
    readGZFile,
    writeGZFile,
    out,
    outHandle,

    -- * Parsing
    runParserOnFile,
    parseFileWith,
    parseIOWith,
    parseFileOrIOWith,
    parseStringWith,
    parseByteStringWith,
  )
where

import Codec.Compression.GZip
  ( compress,
    decompress,
  )
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Monad ((<=<))
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Reader (ask)
import Data.Attoparsec.ByteString.Lazy
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.List (isSuffixOf)
import qualified Data.Text as T
import ELynx.Tools.Reproduction
  ( Arguments (..),
    ELynx,
    Force (..),
    Reproducible (..),
    forceReanalysis,
    outFileBaseName,
  )
import System.Directory (doesFileExist)
import System.IO

-- | 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
  Arguments a
a <- ReaderT (Arguments a) (LoggingT IO) (Arguments a)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  let bn :: Maybe String
bn = GlobalArguments -> Maybe String
outFileBaseName (GlobalArguments -> Maybe String)
-> (Arguments a -> GlobalArguments) -> Arguments a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments a -> GlobalArguments
forall a. Arguments a -> GlobalArguments
global (Arguments a -> Maybe String) -> Arguments a -> Maybe String
forall a b. (a -> b) -> a -> b
$ Arguments a
a
      sfxs :: [String]
sfxs = Arguments a -> [String]
forall a. Reproducible a => a -> [String]
outSuffixes Arguments 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."

checkFile :: Force -> FilePath -> IO ()
checkFile :: Force -> String -> IO ()
checkFile (Force Bool
True) String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkFile (Force Bool
False) String
fp =
  String -> IO Bool
doesFileExist String
fp IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
True ->
      String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"File exists: "
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
fp
          String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
". Please use the --force option to repeat an analysis."
    Bool
False -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Open existing files only if 'Force' is true.
openFile' :: Force -> FilePath -> IOMode -> IO Handle
openFile' :: Force -> String -> IOMode -> IO Handle
openFile' Force
frc String
fp IOMode
md = Force -> String -> IO ()
checkFile Force
frc String
fp IO () -> IO Handle -> IO Handle
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IOMode -> IO Handle
openFile String
fp IOMode
md

-- XXX: For now, all files are read strictly (see help of
-- Control.DeepSeq.force).
readFile' :: FilePath -> IO BL.ByteString
readFile' :: String -> IO ByteString
readFile' String
fn = String -> IOMode -> (Handle -> IO ByteString) -> IO ByteString
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
fn IOMode
ReadMode ((Handle -> IO ByteString) -> IO ByteString)
-> (Handle -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> IO ByteString
forall a. a -> IO a
evaluate (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
forall a. NFData a => a -> a
force) (ByteString -> IO ByteString)
-> (Handle -> IO ByteString) -> Handle -> IO ByteString
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Handle -> IO ByteString
BL.hGetContents

-- | Read file. If file path ends with ".gz", assume gzipped file and decompress
-- before read.
readGZFile :: FilePath -> IO BL.ByteString
readGZFile :: String -> IO ByteString
readGZFile String
f
  | String
".gz" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
f = ByteString -> ByteString
decompress (ByteString -> ByteString) -> IO ByteString -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
readFile' String
f
  | Bool
otherwise = String -> IO ByteString
readFile' String
f

-- | Write file. If file path ends with ".gz", assume gzipped file and compress
-- before write.
writeGZFile :: Force -> FilePath -> BL.ByteString -> IO ()
writeGZFile :: Force -> String -> ByteString -> IO ()
writeGZFile Force
frc String
f ByteString
r
  | String
".gz" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
f = Force -> String -> IO ()
checkFile Force
frc String
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ByteString -> IO ()
BL.writeFile String
f (ByteString -> ByteString
compress ByteString
r)
  | Bool
otherwise = Force -> String -> IO ()
checkFile Force
frc String
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> ByteString -> IO ()
BL.writeFile String
f ByteString
r

-- | Parse a possibly gzipped file.
runParserOnFile :: Parser a -> FilePath -> IO (Either String a)
runParserOnFile :: Parser a -> String -> IO (Either String a)
runParserOnFile Parser a
p String
f = Result a -> Either String a
forall r. Result r -> Either String r
eitherResult (Result a -> Either String a)
-> (ByteString -> Result a) -> ByteString -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
parse Parser a
p (ByteString -> Either String a)
-> IO ByteString -> IO (Either String a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
readGZFile String
f

-- | Parse a possibly gzipped file and extract the result.
parseFileWith :: Parser a -> FilePath -> IO a
parseFileWith :: Parser a -> String -> IO a
parseFileWith Parser a
p String
f = Parser a -> Maybe String -> IO a
forall a. Parser a -> Maybe String -> IO a
parseFileOrIOWith Parser a
p (String -> Maybe String
forall a. a -> Maybe a
Just String
f)

-- | Parse standard input.
parseIOWith :: Parser a -> IO a
parseIOWith :: Parser a -> IO a
parseIOWith Parser a
p = Parser a -> Maybe String -> IO a
forall a. Parser a -> Maybe String -> IO a
parseFileOrIOWith Parser a
p Maybe String
forall a. Maybe a
Nothing

-- | Parse a possibly gzipped file, or standard input, and extract the result.
parseFileOrIOWith :: Parser a -> Maybe FilePath -> IO a
parseFileOrIOWith :: Parser a -> Maybe String -> IO a
parseFileOrIOWith Parser a
p Maybe String
mf = do
  ByteString
s <- IO ByteString
-> (String -> IO ByteString) -> Maybe String -> IO ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO ByteString
BL.getContents String -> IO ByteString
readGZFile Maybe String
mf
  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
$ Parser a -> ByteString -> a
forall a. Parser a -> ByteString -> a
parseByteStringWith Parser a
p ByteString
s

-- | Parse a 'String' and extract the result.
parseStringWith :: Parser a -> String -> a
parseStringWith :: Parser a -> String -> a
parseStringWith Parser a
p String
x = Parser a -> ByteString -> a
forall a. Parser a -> ByteString -> a
parseByteStringWith Parser a
p (String -> ByteString
BL.pack String
x)

-- | Parse a 'BL.ByteString' and extract the result.
parseByteStringWith :: Parser a -> BL.ByteString -> a
parseByteStringWith :: Parser a -> ByteString -> a
parseByteStringWith Parser a
p ByteString
x = case Result a -> Either String a
forall r. Result r -> Either String r
eitherResult (Result a -> Either String a) -> Result a -> Either String a
forall a b. (a -> b) -> a -> b
$ Parser a -> ByteString -> Result a
forall a. Parser a -> ByteString -> Result a
parse Parser a
p ByteString
x of
  Left String
err -> String -> a
forall a. HasCallStack => String -> a
error String
err
  Right a
val -> a
val

-- | 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
      $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx a ()
(Text -> ELynx a ()) -> (Text -> Text) -> Text -> ELynx a ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> ELynx a ()) -> Text -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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
      $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc -> Text -> LogLevel -> Text -> ELynx a ()
(Text -> ELynx a ()) -> (Text -> Text) -> Text -> ELynx a ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> ELynx a ()) -> Text -> ELynx a ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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
"'."
      Force
frc <- GlobalArguments -> Force
forceReanalysis (GlobalArguments -> Force)
-> (Arguments a -> GlobalArguments) -> Arguments a -> Force
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments a -> GlobalArguments
forall a. Arguments a -> GlobalArguments
global (Arguments a -> Force)
-> ReaderT (Arguments a) (LoggingT IO) (Arguments a)
-> ReaderT (Arguments a) (LoggingT IO) Force
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Arguments a) (LoggingT IO) (Arguments 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
$ Force -> String -> ByteString -> IO ()
writeGZFile Force
frc 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
      $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc
-> Text
-> LogLevel
-> Text
-> ReaderT (Arguments a) (LoggingT IO) ()
(Text -> ReaderT (Arguments a) (LoggingT IO) ())
-> (Text -> Text) -> Text -> ReaderT (Arguments a) (LoggingT IO) ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> ReaderT (Arguments a) (LoggingT IO) ())
-> Text -> ReaderT (Arguments a) (LoggingT IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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
      $(Int
String
LogLevel
String -> Text
String -> String -> String -> CharPos -> CharPos -> Loc
Text -> Text
Loc
-> Text
-> LogLevel
-> Text
-> ReaderT (Arguments a) (LoggingT IO) ()
(Text -> ReaderT (Arguments a) (LoggingT IO) ())
-> (Text -> Text) -> Text -> ReaderT (Arguments a) (LoggingT IO) ()
forall a. a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
pack :: String -> Text
monadLoggerLog :: forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
id :: forall a. a -> a
. :: forall b c a. (b -> c) -> (a -> b) -> a -> c
logInfo) (Text -> ReaderT (Arguments a) (LoggingT IO) ())
-> Text -> ReaderT (Arguments a) (LoggingT IO) ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
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
"'."
      Force
frc <- GlobalArguments -> Force
forceReanalysis (GlobalArguments -> Force)
-> (Arguments a -> GlobalArguments) -> Arguments a -> Force
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arguments a -> GlobalArguments
forall a. Arguments a -> GlobalArguments
global (Arguments a -> Force)
-> ReaderT (Arguments a) (LoggingT IO) (Arguments a)
-> ReaderT (Arguments a) (LoggingT IO) Force
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT (Arguments a) (LoggingT IO) (Arguments 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
$ Force -> String -> IOMode -> IO Handle
openFile' Force
frc String
fp IOMode
WriteMode