diff --git a/lib/GEODE/Options.hs b/lib/GEODE/Options.hs index af2c293e0769c78cee11796273a0a543ae8d18b8..2f4741d4215e0c7b1c760281ff8bf59c23276b67 100644 --- a/lib/GEODE/Options.hs +++ b/lib/GEODE/Options.hs @@ -1,23 +1,54 @@ {-# LANGUAGE NamedFieldPuns #-} module GEODE.Options - ( Output(..) - , atLeastOne + ( Input(..) + , IOConfig(..) + , Output(..) + , input + , ioConfig , output ) where -import Control.Applicative ((<|>), empty, many, optional) -import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import Data.Maybe (catMaybes) +import Control.Applicative ((<|>)) +import Data.List.NonEmpty (NonEmpty(..)) import Options.Applicative - ( Parser, flag', help, long, metavar, short - , strOption ) + ( Parser, argument, flag', help, long, metavar, short, str, strOption, value ) +import Options.Applicative.Types (oneM, manyM, fromM) +import Text.Printf (printf) + +data Input = StdIn | File FilePath + +input :: String -> Parser Input +input stdinSemantics = + argument + (File <$> str) + ( value StdIn + <> metavar "INPUT_FILE" + <> help (printf "path of the file to process (%s)" stdinSemantics) ) data Output = Metadata | TextRoot FilePath | XMLRoot FilePath output :: Parser Output output = - flag' Metadata ( long "metadata" <> short 'm') - <|> (TextRoot <$> strOption ( long "text-root" <> short 't')) - <|> (TextRoot <$> strOption ( long "xml-root" <> short 'x')) + flag' Metadata ( long "metadata" + <> short 'm' + <> help "Print metadata for splitted files on stdout" ) + <|> (TextRoot <$> strOption + ( long "text-root" + <> short 't' + <> help "Root path where to output text files" )) + <|> (XMLRoot <$> strOption + ( long "xml-root" + <> short 'x' + <> help "Root path where to output XML files" )) + +data IOConfig = IOConfig + { from :: Input + , to :: NonEmpty Output } -atLeastOne :: Parser a -> Parser (NonEmpty a) -atLeastOne p = (:|) <$> p <*> many p +ioConfig :: String -> Parser IOConfig +ioConfig stdinSemantics = IOConfig + <$> input stdinSemantics + <*> some output + where + -- trick needed to avoid duplicated options in help message (occurring when + -- working directly at the Applicative level) + some p = fromM ((:|) <$> oneM p <*> manyM p)