Skip to content

Instantly share code, notes, and snippets.

@vst
Created April 9, 2021 02:42
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save vst/c428b7dc8b5fcec223619fd71e478249 to your computer and use it in GitHub Desktop.
Save vst/c428b7dc8b5fcec223619fd71e478249 to your computer and use it in GitHub Desktop.
Options.Generic Example
{-# 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 <> "!"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment