Munge option names in an optparse-applicative parser

demo.hs

module Main where

import Control.Applicative
import Data.Char
import Data.List
import Options.Applicative
import Options.Applicative.Types

-- * Options parsers

-- | Job configuration; describes the work to be performed.
data Cfg = Cfg
    { cfgLoud :: Bool
    , cfgName :: String
    , cfgFriend :: String
    }
  deriving (Show, Eq)

-- | Standard optparse-applicative parser for the 'Cfg' type.
cfgParser :: Parser Cfg
cfgParser = Cfg <$> loudP <*> nameP <*> friendP
  where
    loudP = switch $ long "loud" <> short 'l' <> help "Produce loud output"
    nameP = option return $ long "name" <> short 'n' <> help "Your name"
    friendP = option return $ long "friend" <> short 'f' <> help "Friend's name"

-- | Options; additional settings.
data Opt = Opt
    { optVerbose :: Bool
    , optLogging :: Int
    , optFile    :: FilePath
    }
  deriving (Show, Eq)

-- | Standard optparse-applicative parser for the 'Opt' type.
optParser :: Parser Opt
optParser = Opt <$> verbP <*> logP <*> fileP
  where
    verbP = switch $ long "verbose" <> short 'v' <> help "Produce verbose output"
    logP = option auto $ long "log" <> short 'l' <> help "Log level"
    fileP = option return $ long "file" <> short 'f' <> help "Output file"

-- * Parser munging
-- | Munge a 'Parser' to use a prefix on all long arguments.
munge :: String -> Parser a -> Parser a
munge prefix p = case p of
    OptP (Option r p) -> OptP (Option (decorateReader prefix r) p)
    MultP p1 p2 -> MultP (munge prefix p1) (munge prefix p2)
    AltP p1 p2 -> AltP (munge prefix p1) (munge prefix p2)
    _ -> p

-- | Add a prefix to the names of an 'OptReader' value.
decorateReader :: String -> OptReader a -> OptReader a
decorateReader prefix r =
    case r of
        OptReader ns r e -> OptReader (map massageName ns) r e
        FlagReader ns a  -> FlagReader (map massageName ns) a
        _                -> r
  where
    massageName n =
        case n of
            OptLong l -> OptLong (prefix ++ l)
            OptShort c -> OptLong (prefix ++ [c])

-- * Example

-- | Compose 'cfgParser' and 'optParser' above, adding a prefix to both.
augmented :: Parser (Cfg, Opt)
augmented = (,) <$> munge "job-" cfgParser <*> munge "opt-" optParser

main :: IO ()
main = do
    (cfg, opt) <- execParser $ info (helper <*> augmented) fullDesc
    say cfg
  where
    say (Cfg l n f) =
        let msg = intercalate " " ["Hello", f, "from", n]
        in putStrLn . (if l then map toUpper else id) $ msg