Prototype mix of implicit and explicit CmdArgs

hledger-cli.hs

#!/usr/bin/env stack
{- stack runghc --verbosity info
  --package hledger
-}
{-# LANGUAGE DeriveDataTypeable #-}

import Data.Monoid
import Data.Maybe
import System.Console.CmdArgs.Implicit
import Hledger.Cli

-- | Additional options for addon
data Sample = Sample
        { enabled :: Bool
        , greeting :: String
        }
    deriving (Show, Data)

-- | Aggregation of base options of hledger CLI infrastructure and addon
-- options
data SampleOpts = SampleOpts
    { raw :: RawOpts -- ^ base options
    , opts :: Sample -- ^ additional options
    }
    deriving (Show, Data)

-- | Build an implicit mode from data but without CmdArgs wrapper
implicitMode :: Data a => a -> Mode a
implicitMode value0 = mode' where
    modeCmdArgs = cmdArgsMode value0
    valueCmdArgs0 = modeValue modeCmdArgs
    mode' = remap cmdArgsValue reembed modeCmdArgs
    reembed y = (valueCmdArgs0 { cmdArgsValue = y }, cmdArgsValue)

sampleMode :: Mode SampleOpts
sampleMode = mode' where
    -- default values for additional options
    defValue = Sample False ""
    optmode = implicitMode defValue -- implicit mode
    optmode', cmdmode' :: Mode SampleOpts
    optmode' = remap embed reembed optmode where
        embed opts' = (modeValue cmdmode') { opts = opts' }
        reembed wrap = (opts wrap, \opts' -> wrap { opts = opts' })
    -- command mode
    cmdmode = defCommandMode ["cli"] -- explicit mode
    cmdmode' = remap embed reembed cmdmode where
        embed raw' = SampleOpts raw' defValue
        reembed wrap = (raw wrap, \raw' -> wrap { raw = raw' })
    -- merged mode
    mode' = cmdmode'
        { modeNames = modeNames cmdmode' <> modeNames optmode'
        , modeGroupFlags = modeGroupFlags cmdmode' <> modeGroupFlags optmode'
        , modeArgs = args'
        }
    -- merged arguments
    args' = ( mappendMap (fst . modeArgs) cmdmode' optmode'
            , listToMaybe $ mappendMap (maybeToList .snd . modeArgs) cmdmode' optmode'
            )
    mappendMap f a b = f a <> f b

main :: IO ()
main = do
    print sampleMode
    sampleOpts <- processArgs sampleMode
    print sampleOpts