{-# LANGUAGE OverloadedStrings #-}

module Poseidon.Utils (
    PoseidonException (..),
    renderPoseidonException,
    usePoseidonLogger,
    testLog,
    PoseidonIO,
    envLogAction,
    envInputPlinkMode,
    envErrorLength,
    LogMode (..),
    checkFile,
    getChecksum,
    logWarning,
    logInfo,
    logDebug,
    logError,
    LogA,
    noLog,
    logWithEnv,
    padRight, padLeft,
    determinePackageOutName,
    PlinkPopNameMode(..),
    TestMode(..),
    Env(..),
    uniquePO, uniqueRO,
    showParsecErr,
    ErrorLength(..)
) where

import           Paths_poseidon_hs      (version)

import           Colog                  (HasLog (..), LogAction (..), Message,
                                         Msg (..), Severity (..), cfilter,
                                         cmapM, logTextStderr, msgSeverity,
                                         msgText, showSeverity)
import           Control.Exception      (Exception, throwIO)
import           Control.Exception.Base (SomeException)
import           Control.Monad          (when)
import           Control.Monad.Catch    (throwM)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader   (ReaderT, asks, runReaderT)
import qualified Data.ByteString.Lazy   as LB
import           Data.Digest.Pure.MD5   (md5)
import qualified Data.Set               as Set
import           Data.Text              (Text, pack)
import           Data.Time              (defaultTimeLocale, formatTime,
                                         getCurrentTime, utcToLocalZonedTime)
import           Data.Version           (showVersion)
import           Data.Yaml              (ParseException,
                                         prettyPrintParseException)
import           GHC.Stack              (callStack, withFrozenCallStack)
import           Network.HTTP.Conduit   (HttpException (..))
import           SequenceFormats.Plink  (PlinkPopNameMode (..))
import           System.Directory       (doesFileExist)
import           System.FilePath.Posix  (takeBaseName)
import qualified Text.Parsec.Error      as P

type LogA = LogAction IO Message

data TestMode = Testing | Production deriving Int -> TestMode -> ShowS
[TestMode] -> ShowS
TestMode -> String
(Int -> TestMode -> ShowS)
-> (TestMode -> String) -> ([TestMode] -> ShowS) -> Show TestMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TestMode -> ShowS
showsPrec :: Int -> TestMode -> ShowS
$cshow :: TestMode -> String
show :: TestMode -> String
$cshowList :: [TestMode] -> ShowS
showList :: [TestMode] -> ShowS
Show

data Env = Env {
    Env -> LogA
_envLogAction      :: LogA,
    Env -> TestMode
_envTestMode       :: TestMode,
    Env -> PlinkPopNameMode
_envInputPlinkMode :: PlinkPopNameMode,
    Env -> ErrorLength
_envErrorLength    :: ErrorLength
}

defaultEnv :: LogA -> Env
defaultEnv :: LogA -> Env
defaultEnv LogA
logA = LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
logA TestMode
Production PlinkPopNameMode
PlinkPopNameAsFamily ErrorLength
CharInf

type PoseidonIO = ReaderT Env IO

-- just convenience helper functions
envLogAction :: PoseidonIO LogA
envLogAction :: PoseidonIO LogA
envLogAction = (Env -> LogA) -> PoseidonIO LogA
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> LogA
_envLogAction
envInputPlinkMode :: PoseidonIO PlinkPopNameMode
envInputPlinkMode :: PoseidonIO PlinkPopNameMode
envInputPlinkMode = (Env -> PlinkPopNameMode) -> PoseidonIO PlinkPopNameMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> PlinkPopNameMode
_envInputPlinkMode
envErrorLength :: PoseidonIO ErrorLength
envErrorLength :: PoseidonIO ErrorLength
envErrorLength = (Env -> ErrorLength) -> PoseidonIO ErrorLength
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> ErrorLength
_envErrorLength

data LogMode = NoLog
    | SimpleLog
    | DefaultLog
    | ServerLog
    | VerboseLog
    deriving Int -> LogMode -> ShowS
[LogMode] -> ShowS
LogMode -> String
(Int -> LogMode -> ShowS)
-> (LogMode -> String) -> ([LogMode] -> ShowS) -> Show LogMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LogMode -> ShowS
showsPrec :: Int -> LogMode -> ShowS
$cshow :: LogMode -> String
show :: LogMode -> String
$cshowList :: [LogMode] -> ShowS
showList :: [LogMode] -> ShowS
Show

usePoseidonLogger :: LogMode -> TestMode -> PlinkPopNameMode -> ErrorLength -> PoseidonIO a -> IO a
usePoseidonLogger :: forall a.
LogMode
-> TestMode
-> PlinkPopNameMode
-> ErrorLength
-> PoseidonIO a
-> IO a
usePoseidonLogger LogMode
NoLog      TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength = (PoseidonIO a -> Env -> IO a) -> Env -> PoseidonIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
noLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength)
usePoseidonLogger LogMode
SimpleLog  TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength = (PoseidonIO a -> Env -> IO a) -> Env -> PoseidonIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
simpleLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength)
usePoseidonLogger LogMode
DefaultLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength = (PoseidonIO a -> Env -> IO a) -> Env -> PoseidonIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
defaultLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength)
usePoseidonLogger LogMode
ServerLog  TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength = (PoseidonIO a -> Env -> IO a) -> Env -> PoseidonIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
serverLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength)
usePoseidonLogger LogMode
VerboseLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength = (PoseidonIO a -> Env -> IO a) -> Env -> PoseidonIO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> TestMode -> PlinkPopNameMode -> ErrorLength -> Env
Env LogA
verboseLog TestMode
testMode PlinkPopNameMode
plinkMode ErrorLength
errLength)

testLog :: PoseidonIO a -> IO a
testLog :: forall a. PoseidonIO a -> IO a
testLog = LogMode
-> TestMode
-> PlinkPopNameMode
-> ErrorLength
-> PoseidonIO a
-> IO a
forall a.
LogMode
-> TestMode
-> PlinkPopNameMode
-> ErrorLength
-> PoseidonIO a
-> IO a
usePoseidonLogger LogMode
NoLog TestMode
Testing PlinkPopNameMode
PlinkPopNameAsFamily ErrorLength
CharInf
--testLog = usePoseidonLogger VerboseLog Testing PlinkPopNameAsFamily

noLog      :: LogA
noLog :: LogA
noLog      = (Msg Severity -> Bool) -> LogA -> LogA
forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter (Bool -> Msg Severity -> Bool
forall a b. a -> b -> a
const Bool
False) LogA
simpleLog
simpleLog  :: LogA
simpleLog :: LogA
simpleLog  = (Msg Severity -> Bool) -> LogA -> LogA
forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter (\Msg Severity
msg -> Msg Severity -> Severity
forall sev. Msg sev -> sev
msgSeverity Msg Severity
msg Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
Debug) (LogA -> LogA) -> LogA -> LogA
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> LogA
compileLogMsg Bool
False Bool
False
defaultLog :: LogA
defaultLog :: LogA
defaultLog = (Msg Severity -> Bool) -> LogA -> LogA
forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter (\Msg Severity
msg -> Msg Severity -> Severity
forall sev. Msg sev -> sev
msgSeverity Msg Severity
msg Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
Debug) (LogA -> LogA) -> LogA -> LogA
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> LogA
compileLogMsg Bool
True Bool
False
serverLog  :: LogA
serverLog :: LogA
serverLog  = (Msg Severity -> Bool) -> LogA -> LogA
forall (m :: * -> *) msg.
Applicative m =>
(msg -> Bool) -> LogAction m msg -> LogAction m msg
cfilter (\Msg Severity
msg -> Msg Severity -> Severity
forall sev. Msg sev -> sev
msgSeverity Msg Severity
msg Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
/= Severity
Debug) (LogA -> LogA) -> LogA -> LogA
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> LogA
compileLogMsg Bool
True Bool
True
verboseLog :: LogA
verboseLog :: LogA
verboseLog = Bool -> Bool -> LogA
compileLogMsg Bool
True Bool
True

compileLogMsg :: Bool -> Bool -> LogA
compileLogMsg :: Bool -> Bool -> LogA
compileLogMsg Bool
severity Bool
time = (Msg Severity -> IO Text) -> LogAction IO Text -> LogA
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LogAction m b -> LogAction m a
cmapM Msg Severity -> IO Text
prepareMessage LogAction IO Text
forall (m :: * -> *). MonadIO m => LogAction m Text
logTextStderr
    where
        prepareMessage :: Message -> IO Text
        prepareMessage :: Msg Severity -> IO Text
prepareMessage Msg Severity
msg = do
            let textMessage :: Text
textMessage = Msg Severity -> Text
forall sev. Msg sev -> Text
msgText Msg Severity
msg
                textSeverity :: Text
textSeverity = if Bool
severity
                    then Severity -> Text
showSeverity (Msg Severity -> Severity
forall sev. Msg sev -> sev
msgSeverity Msg Severity
msg)
                    else Text
forall a. Monoid a => a
mempty
            Text
textTime <- if Bool
time
                    then do
                        ZonedTime
zonedTime <- IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO ZonedTime) -> IO ZonedTime
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UTCTime -> IO ZonedTime
utcToLocalZonedTime
                        Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %T" ZonedTime
zonedTime String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "
                    else IO Text
forall a. Monoid a => a
mempty
            Text -> IO Text
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
textSeverity Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
textTime Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
textMessage

logMsg :: Severity -> String -> PoseidonIO ()
logMsg :: Severity -> String -> PoseidonIO ()
logMsg Severity
sev String
msg = do
    {-
    Using asks getLogAction here gives us a bit of flexibility. If in the future we'd like to expand the
    ReaderT environment by adding more options or parameters to LogA, perhaps even the command line options,
    we can do so, we just need to adapt the HasLog instance, which tells us how to get the logAction out of the
    environment.
    -}
    LogAction Msg Severity -> IO ()
logF <- (Env -> LogA) -> PoseidonIO LogA
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (LogA -> LogA
forall env msg (m :: * -> *).
HasLog env msg m =>
env -> LogAction m msg
getLogAction (LogA -> LogA) -> (Env -> LogA) -> Env -> LogA
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> LogA
_envLogAction)
    IO () -> PoseidonIO ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PoseidonIO ())
-> (Msg Severity -> IO ()) -> Msg Severity -> PoseidonIO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
(HasCallStack => IO ()) -> IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (IO () -> IO ())
-> (Msg Severity -> IO ()) -> Msg Severity -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg Severity -> IO ()
logF (Msg Severity -> PoseidonIO ()) -> Msg Severity -> PoseidonIO ()
forall a b. (a -> b) -> a -> b
$ Severity -> CallStack -> Text -> Msg Severity
forall sev. sev -> CallStack -> Text -> Msg sev
Msg Severity
sev CallStack
HasCallStack => CallStack
callStack (String -> Text
pack String
msg)

logWarning :: String -> PoseidonIO ()
logWarning :: String -> PoseidonIO ()
logWarning = Severity -> String -> PoseidonIO ()
logMsg Severity
Warning

logInfo :: String -> PoseidonIO ()
logInfo :: String -> PoseidonIO ()
logInfo = Severity -> String -> PoseidonIO ()
logMsg Severity
Info

logDebug :: String -> PoseidonIO ()
logDebug :: String -> PoseidonIO ()
logDebug = Severity -> String -> PoseidonIO ()
logMsg Severity
Debug

logError :: String -> PoseidonIO ()
logError :: String -> PoseidonIO ()
logError = Severity -> String -> PoseidonIO ()
logMsg Severity
Error

logWithEnv :: (MonadIO m) => LogA -> PoseidonIO () -> m ()
logWithEnv :: forall (m :: * -> *). MonadIO m => LogA -> PoseidonIO () -> m ()
logWithEnv LogA
logA = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ())
-> (PoseidonIO () -> IO ()) -> PoseidonIO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoseidonIO () -> Env -> IO ()) -> Env -> PoseidonIO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip PoseidonIO () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogA -> Env
defaultEnv LogA
logA)

-- | A data type for error length settings
data ErrorLength = CharInf | CharCount Int deriving Int -> ErrorLength -> ShowS
[ErrorLength] -> ShowS
ErrorLength -> String
(Int -> ErrorLength -> ShowS)
-> (ErrorLength -> String)
-> ([ErrorLength] -> ShowS)
-> Show ErrorLength
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrorLength -> ShowS
showsPrec :: Int -> ErrorLength -> ShowS
$cshow :: ErrorLength -> String
show :: ErrorLength -> String
$cshowList :: [ErrorLength] -> ShowS
showList :: [ErrorLength] -> ShowS
Show

truncateErr :: ErrorLength -> String -> String
truncateErr :: ErrorLength -> ShowS
truncateErr ErrorLength
CharInf         String
s = String
s
truncateErr (CharCount Int
len) String
s
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len          = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
len String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"... (see more with --errLength)"
    | Bool
otherwise               = String
s

-- | A Poseidon Exception data type with several concrete constructors
data PoseidonException =
      PoseidonYamlParseException FilePath ParseException -- ^ An exception to represent YAML parsing errors
    | PoseidonPackageException String -- ^ An exception to represent a logical error in a package
    | PoseidonPackageVersionException FilePath String -- ^ An exception to represent an issue with a package version
    | PoseidonPackageMissingVersionException FilePath -- ^ An exception to indicate a missing poseidonVersion field
    | PoseidonIndSearchException String -- ^ An exception to represent an error when searching for individuals or populations
    | PoseidonGenotypeException String -- ^ An exception to represent errors in the genotype data
    | PoseidonGenotypeExceptionForward ErrorLength SomeException -- ^ An exception to represent errors in the genotype data forwarded from the sequence-formats library
    | PoseidonHttpExceptionForward HttpException -- ^ An exception to represent errors in the remote data loading forwarded from simpleHttp
    | PoseidonFileRowException FilePath String String -- ^ An exception to represent errors when trying to parse the janno or seqSource file
    | PoseidonFileConsistencyException FilePath String -- ^ An exception to represent consistency errors in janno or seqSource files
    | PoseidonCrossFileConsistencyException String String -- ^ An exception to represent inconsistencies across multiple files in a package
    | PoseidonCollectionException String -- ^ An exception to represent logical issues in a poseidon package Collection
    | PoseidonFileExistenceException FilePath -- ^ An exception to represent missing files
    | PoseidonFileChecksumException FilePath -- ^ An exception to represent failed checksum tests
    | PoseidonFStatsFormatException String -- ^ An exception type to represent FStat specification errors
    | PoseidonBibTeXException FilePath String -- ^ An exception to represent errors when trying to parse the .bib file
    | PoseidonPoseidonEntityParsingException P.ParseError -- ^ An exception to indicate failed entity parsing
    | PoseidonForgeEntitiesException String -- ^ An exception to indicate issues in the forge selection
    | PoseidonEmptyForgeException -- ^ An exception to throw if there is nothing to be forged
    | PoseidonNewPackageConstructionException String -- ^ An exception to indicate an issue in newPackageTemplate
    | PoseidonRemoteJSONParsingException String -- ^ An exception to indicate failed remote info JSON parsing
    | PoseidonGenericException String -- ^ A catch-all for any other type of exception
    | PoseidonEmptyOutPacNameException -- ^ An exception to throw if the output package lacks a name
    | PoseidonUnequalBaseDirException FilePath FilePath FilePath -- ^ An exception to throw if genotype data files don't share a common base directory
    | PoseidonServerCommunicationException String -- ^ An exception to mark server communication errors
    | PoseidonUnzipException SomeException -- ^ An exception for unzipping issues in fetch
    | PoseidonChronicleException String -- ^ An exception for issues in chronicle
    | PoseidonGitException FilePath String -- ^ An exception for issues with git
    | PoseidonCantPreserveException -- ^ An exception for issues with --preservePyml
    deriving (Int -> PoseidonException -> ShowS
[PoseidonException] -> ShowS
PoseidonException -> String
(Int -> PoseidonException -> ShowS)
-> (PoseidonException -> String)
-> ([PoseidonException] -> ShowS)
-> Show PoseidonException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PoseidonException -> ShowS
showsPrec :: Int -> PoseidonException -> ShowS
$cshow :: PoseidonException -> String
show :: PoseidonException -> String
$cshowList :: [PoseidonException] -> ShowS
showList :: [PoseidonException] -> ShowS
Show)

instance Exception PoseidonException

renderPoseidonException :: PoseidonException -> String
renderPoseidonException :: PoseidonException -> String
renderPoseidonException (PoseidonYamlParseException String
fn ParseException
e) =
    String
"Could not parse YAML file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseException -> String
prettyPrintParseException ParseException
e
renderPoseidonException (PoseidonPackageException String
s) =
    String
"Encountered a logical error with a package: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonPackageVersionException String
p String
s) =
    String
"Poseidon version mismatch in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
". This package is build according to Poseidon schema v" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
", which is not supported by poseidon-hs v" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
showVersion Version
version String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
". Modify the package, or switch to a newer (or older) version of this software."
renderPoseidonException (PoseidonPackageMissingVersionException String
p) =
    String
"The POSEIDON.yml file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has no poseidonVersion field. " String -> ShowS
forall a. [a] -> [a] -> [a]
++
    String
"This is mandatory."
renderPoseidonException (PoseidonIndSearchException String
s) =
    ShowS
forall a. Show a => a -> String
show String
s
renderPoseidonException (PoseidonGenotypeException String
s) =
    String
"Genotype data structurally inconsistent: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
renderPoseidonException (PoseidonGenotypeExceptionForward ErrorLength
errLength SomeException
e) =
    String
"Issues in genotype data parsing: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ErrorLength -> ShowS
truncateErr ErrorLength
errLength (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
renderPoseidonException (PoseidonHttpExceptionForward (HttpExceptionRequest Request
_ HttpExceptionContent
content)) =
    String
"Issues in HTTP-communication with server:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    HttpExceptionContent -> String
forall a. Show a => a -> String
show HttpExceptionContent
content
renderPoseidonException (PoseidonHttpExceptionForward HttpException
e) =
    String
"Issues in HTTP-communication with server: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ HttpException -> String
forall a. Show a => a -> String
show HttpException
e
renderPoseidonException (PoseidonFileRowException String
f String
i String
s) =
    String
"Can't read sample in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in line " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonFileConsistencyException String
f String
s) =
    String
"Consistency issues in file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonCrossFileConsistencyException String
p String
s) =
    String
"Cross-file consistency issue in package " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonCollectionException String
s) =
    String
"The package collection is broken: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonFileExistenceException String
f) =
    String
"File " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not exist"
renderPoseidonException (PoseidonFileChecksumException String
f) =
    String
"File checksum test failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f
renderPoseidonException (PoseidonFStatsFormatException String
s) =
    String
"Fstat specification error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonBibTeXException String
f String
s) =
    String
"BibTex problem in file " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonPoseidonEntityParsingException ParseError
e) =
    String
"Error when parsing the forge selection (either -f or --forgeFile): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ParseError -> String
showParsecErr ParseError
e
renderPoseidonException (PoseidonForgeEntitiesException String
s) =
    String
"Error in the forge selection: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException PoseidonException
PoseidonEmptyForgeException =
    String
"Nothing to be forged"
renderPoseidonException (PoseidonNewPackageConstructionException String
s) =
    ShowS
forall a. Show a => a -> String
show String
s
renderPoseidonException (PoseidonRemoteJSONParsingException String
s) =
    String
"Error in parsing JSON: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
renderPoseidonException (PoseidonGenericException String
s) = String
s
renderPoseidonException PoseidonException
PoseidonEmptyOutPacNameException =
    String
"Error when preparing the new package: The output package does not have a name. Add one with: -n YourPackageName"
renderPoseidonException (PoseidonUnequalBaseDirException String
g String
s String
i) =
    String
"The base directories of these genotype files are not equal."
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --genoFile: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
g
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --snpFile: "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --indFile: "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
i
renderPoseidonException (PoseidonServerCommunicationException String
e) = String
e
renderPoseidonException (PoseidonUnzipException SomeException
e) =
    String
"Error during unzipping: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
renderPoseidonException (PoseidonChronicleException String
s) =
    String
"Error when preparing the chronicle file: "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException (PoseidonGitException String
p String
s) =
    String
"Failed to load .git directory in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
renderPoseidonException PoseidonException
PoseidonCantPreserveException =
    String
"Can't used --preservePyml if there is more than one relevant source package."

-- helper function to check if a file exists
checkFile :: FilePath -> Maybe String -> IO ()
checkFile :: String -> Maybe String -> IO ()
checkFile String
fn Maybe String
maybeChkSum = do
    Bool
fe <- String -> IO Bool
doesFileExist String
fn
    if Bool -> Bool
not Bool
fe
    then PoseidonException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> PoseidonException
PoseidonFileExistenceException String
fn)
    else
        case Maybe String
maybeChkSum of
            Maybe String
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just String
chkSum -> do
                String
fnChkSum <- String -> IO String
getChecksum String
fn
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
fnChkSum String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
chkSum) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ PoseidonException -> IO ()
forall e a. Exception e => e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (String -> PoseidonException
PoseidonFileChecksumException String
fn)

-- helper functions to get the checksum of a file
getChecksum :: FilePath -> IO String
getChecksum :: String -> IO String
getChecksum String
f = do
    ByteString
fileContent <- String -> IO ByteString
LB.readFile String
f
    let md5Digest :: MD5Digest
md5Digest = ByteString -> MD5Digest
md5 ByteString
fileContent
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ MD5Digest -> String
forall a. Show a => a -> String
show MD5Digest
md5Digest

-- helper functions to pad and cut strings
padRight :: Int -> String -> String
padRight :: Int -> ShowS
padRight Int
n String
s
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n String
s
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' '
    | Bool
otherwise    = String
s

padLeft :: Int -> String -> String
padLeft :: Int -> ShowS
padLeft Int
n String
s
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n = ShowS
forall a. [a] -> [a]
reverse (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
n (ShowS
forall a. [a] -> [a]
reverse String
s))
    | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    | Bool
otherwise    = String
s

-- helper function to determine the package name depending on -n and -o
determinePackageOutName :: Maybe String -> FilePath -> IO String
determinePackageOutName :: Maybe String -> String -> IO String
determinePackageOutName Maybe String
maybeOutName String
outPath = do
    case Maybe String
maybeOutName of -- take basename of outPath, if name is not provided
            Just String
x  -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
            Maybe String
Nothing -> case ShowS
takeBaseName String
outPath of -- check if outPath is empty
                String
"" -> PoseidonException -> IO String
forall e a. Exception e => e -> IO a
throwIO PoseidonException
PoseidonEmptyOutPacNameException
                String
y  -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
y

-- two helper functions to reduce a lists to the unique elements in it
-- see https://github.com/nh2/haskell-ordnub#dont-use-nub
-- preserves the original order
uniquePO :: (Ord a) => [a] -> [a]
uniquePO :: forall a. Ord a => [a] -> [a]
uniquePO = Set a -> [a] -> [a]
forall {a}. Ord a => Set a -> [a] -> [a]
go Set a
forall a. Set a
Set.empty
  where
    go :: Set a -> [a] -> [a]
go Set a
_ [] = []
    go Set a
s (a
x:[a]
xs) =
        if a
x a -> Set a -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set a
s
        then Set a -> [a] -> [a]
go Set a
s [a]
xs
        else a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Set a -> [a] -> [a]
go (a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
x Set a
s) [a]
xs

-- reorderes the list according to the Ord instance of a
uniqueRO :: (Ord a) => [a] -> [a]
uniqueRO :: forall a. Ord a => [a] -> [a]
uniqueRO = Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList

-- helper function to render parsec errors neatly
showParsecErr :: P.ParseError -> String
showParsecErr :: ParseError -> String
showParsecErr ParseError
err =
    String
-> String -> String -> String -> String -> [Message] -> String
P.showErrorMessages
        String
"or" String
"unknown parse error"
        String
"expecting" String
"unexpected" String
"end of input"
        (ParseError -> [Message]
P.errorMessages ParseError
err)