{-# LANGUAGE TemplateHaskell #-}
module ELynx.Tools.Options
(
logHeader
, logFooter
, parseArgumentsWith
, Verbosity (..)
, GlobalArguments (..)
, globalArguments
, seedOpt
, megaReadM
, fillParagraph
) where
import Control.Monad.Logger (LogLevel (..))
import Data.List hiding (group)
import Data.Time
import Data.Version (showVersion)
import Data.Void
import Data.Word
import Language.Haskell.TH
import Options.Applicative hiding (empty)
import Options.Applicative.Help.Pretty
import System.Environment
import Text.Megaparsec (Parsec, errorBundlePretty,
runParser)
import ELynx.Tools.Misc
import Paths_elynx_tools (version)
versionString :: String
versionString = "ELynx Suite version " ++ showVersion version ++ "."
copyrightString :: String
copyrightString = "Developed by Dominik Schrempf."
compilationString :: String
compilationString = "Compiled on "
++ $(stringE =<< runIO
( formatTime defaultTimeLocale "%B %-e, %Y, at %H:%M %P, %Z."
`fmap` Data.Time.getCurrentTime ))
hdr :: String
hdr = intercalate "\n" [ versionString
, copyrightString
, compilationString
]
time :: IO String
time = formatTime defaultTimeLocale "%B %-e, %Y, at %H:%M %P, %Z." `fmap` Data.Time.getCurrentTime
logHeader :: String -> IO String
logHeader desc = do
t <- time
p <- getProgName
as <- getArgs
let l = length desc
return $ intercalate "\n"
[ replicate (l+3) '-'
, "-- " <> desc
, hdr
, "Time: " ++ t
, "Command line: " ++ p ++ " " ++ unwords as ]
logFooter :: IO String
logFooter = do
t <- time
return $ "Time: " ++ t
versionOpt :: Parser (a -> a)
versionOpt = infoOption hdr
( long "version"
<> short 'V'
<> help "Show version"
<> hidden )
evoModSuiteFooter :: [Doc]
evoModSuiteFooter =
[ empty
, text "The ELynx Suite."
, fillParagraph "A Haskell library and a tool set for computational biology. The goal of the ELynx Suite is reproducible research. Evolutionary sequences and phylogenetic trees can be read, viewed, modified and simulated. Exact specification of all options is necessary, and nothing is assumed about the data (e.g., the type of code). The command line with all arguments is consistently, and automatically logged. The work overhead in the beginning usually pays off in the end."
, fill 9 (text "slynx") <+> text "Analyze, modify, and simulate evolutionary sequences."
, fill 9 (text "tlynx") <+> text "Analyze, modify, and simulate phylogenetic trees." ]
parseArgumentsWith :: [String] -> [String] -> Parser a -> IO a
parseArgumentsWith desc ftr p = execParser $
info (helper <*> versionOpt <*> p)
(fullDesc
<> header hdr
<> progDesc dsc'
<> footerDoc (Just ftr'))
where
dsc' = unlines desc
ftr' = vsep $ map pretty ftr ++ evoModSuiteFooter
data Verbosity = Quiet | Warning | Info | Debug
deriving (Show, Read, Eq, Enum, Bounded, Ord)
toLogLevel :: Verbosity -> LogLevel
toLogLevel Quiet = LevelError
toLogLevel Warning = LevelWarn
toLogLevel Info = LevelInfo
toLogLevel Debug = LevelDebug
data GlobalArguments = GlobalArguments
{ verbosity :: LogLevel
, outFileBaseName :: Maybe FilePath }
globalArguments :: Parser GlobalArguments
globalArguments = GlobalArguments
<$> (toLogLevel <$> verbosityOpt)
<*> optional outFileBaseNameOpt
verbosityOpt :: Parser Verbosity
verbosityOpt = option auto
( long "verbosity"
<> short 'v'
<> metavar "VALUE"
<> value Info
<> showDefault
<> help ("Be verbose; one of: " ++ unwords (map show vs) ))
where
vs = allValues :: [Verbosity]
outFileBaseNameOpt :: Parser FilePath
outFileBaseNameOpt = strOption
( long "output-file-basename"
<> short 'o'
<> metavar "NAME"
<> help "Specify base name of output file")
seedOpt :: Parser (Maybe [Word32])
seedOpt = optional $ option auto
( long "seed"
<> short 'S'
<> metavar "[INT]"
<> help ("Seed for random number generator; "
++ "list of 32 bit integers with up to 256 elements (default: random)" ) )
megaReadM :: Parsec Void String a -> ReadM a
megaReadM p = eitherReader $ \input ->
let eea = runParser p "" input
in
case eea of
Left eb -> Left $ errorBundlePretty eb
Right a -> Right a
fillParagraph :: String -> Doc
fillParagraph = fillSep . map text . words