Options.Generic Example

Main.hs

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators      #-}

module Main where

import           Data.Char                          (isUpper, toLower)
import           Data.Version                       (showVersion)
import qualified Options.Applicative                as OA
import           Options.Generic
                 ( Generic
                 , Modifiers(constructorNameModifier)
                 , ParseRecord(..)
                 , Unwrapped
                 , Wrapped
                 , defaultModifiers
                 , parseRecordWithModifiers
                 , type (:::)
                 , type (<!>)
                 , type (<?>)
                 , unwrapRecord
                 )
import           Paths_main                         (version)
import           System.Exit                        (ExitCode, exitSuccess, exitWith)

data Command w
    = CommandGreet
        { whom :: w ::: (String <?> "Whom to greet" <!> "World")
        }
    | CommandGreetCustom
        { what :: w ::: (String <?> "Greeting" <!> "Hello")
        , whom :: w :::  (String <?> "Whom to greet" <!> "World")
        }
    | CommandVersion
    deriving (Generic)

instance ParseRecord (Command Wrapped) where
  parseRecord = parseRecordWithModifiers $ defaultModifiers { constructorNameModifier = lispCase . drop 7 }
    where
      lispCase = dropWhile (== '-') . (>>= lower) . dropWhile (== '_')
      lower c = if isUpper c then ['-', toLower c] else [c]

deriving instance Show (Command Unwrapped)

main :: IO ()
main = do
  command <- unwrapRecord "CHANGE-ME"
  case command of
    CommandGreet w         -> greeting "Hello" w >> exitSuccess
    CommandGreetCustom g w -> greeting g w >> exitSuccess
    CommandVersion         -> putStrLn (showVersion version)

-- | Outputs a greeting.
greeting :: String -> String -> IO ()
greeting g w = putStrLn $ compileMessage g w


-- | Compiles a message.
--
-- >>> compileMessage "" ""
-- " !"
-- >>> compileMessage "Hello" "World"
-- "Hello World!"
compileMessage :: String -> String -> String
compileMessage g w = g <> " " <> w <> "!"