Parsec and CmdArgs in Action: A Small Example

In this post, I mentioned that I wrote a ~300 line Haskell program to take care of mounting/unmounting USB drives (especially useful for window-manager-only users like myself). Well, I’ve been using my program (creatively named usbmnt) very happily so far and would like to release it for public consumption. It’s released into the PUBLIC DOMAIN, because that’s how I roll, baby!

-- LICENSE: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
module Main where

import Control.Monad (when)
import System.Console.CmdArgs.Implicit
import System.IO
import System.Environment
import System.Exit
import System.Process
import Text.Parsec.Char hiding (upper)
import Text.Parsec.Combinator
import Text.Parsec.Prim
import Text.Parsec.String

data Opts = Opts
    { all_devices :: Bool
    , unmount :: Bool
    , unmount_all :: Bool
    , discover :: Bool
    , no_color :: Bool
    } deriving (Data, Typeable, Show, Eq)

progOpts :: Opts
progOpts = Opts
    { all_devices = def &= help "mount all USB devices"
    , unmount = def &= help "choose a USB device to unmount"
    , unmount_all = def &= name "U" &= help "unmount all USB devices"
    , discover = def &= help "list all mounted/unmounted USB devices"
    , no_color = def &= help "disable colors"
    }
    &= details
        [ "Notes:"
        , ""
        , "The default behavior without any options is to try to mount a USB device."
            ++ " Here, `device' means a device under the /dev directory, and in our context, is actually a file system partition."
            ++ " Many USB drives have only a single partition, in which case the term `device' means both the USB drive and the single partition it has."
        , ""
        , "Also, allowing the $USER to execute the mount and umount commands with sudo privileges (sudo visudo) will make things less clunky."
        ]

getOpts :: IO Opts
getOpts = cmdArgs $ progOpts
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= program _PROGRAM_NAME
    &= help _PROGRAM_DESC
    &= helpArg [explicit, name "help", name "h"]
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]

_PROGRAM_NAME, _PROGRAM_VERSION, _PROGRAM_INFO, _PROGRAM_DESC, _COPYRIGHT :: String
_PROGRAM_NAME = "usbmnt"
_PROGRAM_VERSION = "0.0.1"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_DESC = "mount/unmount USB device(s)"
_COPYRIGHT = "PUBLIC DOMAIN"

data BlockDevice = BlockDevice
    { shortname :: String
    , uuid :: String
    , fsys :: String
    , mountPoint :: MountPoint
    } deriving (Eq)

data MountPoint
    = MPath { path :: FilePath }
    | Swap
    | Unmounted
    | UnknownBlkidVal
    deriving (Eq)

instance Show BlockDevice where
    show BlockDevice{..} = unwords
        [ shortname
        , fsys
        , uuid
        , show mountPoint
        ]

instance Show MountPoint where
    show (MPath path) = path
    show Swap = "Swap"
    show Unmounted = "Unmounted"
    show UnknownBlkidVal = "UnknownBlkidVal"

blockdeviceDefault :: BlockDevice
blockdeviceDefault = BlockDevice
    { shortname = ""
    , uuid = ""
    , fsys = ""
    , mountPoint = MPath {path = ""}
    }

_ALPHANUM :: String
_ALPHANUM = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

data Color
    = Red
    | Green
    | Yellow
    | Blue
    | CNone
    deriving (Show, Eq)

colorize :: Color -> String -> String
colorize c s = case c of
    Blue -> "\x1b[1;34m" ++ s ++ "\x1b[0m"
    Green -> "\x1b[1;32m" ++ s ++ "\x1b[0m"
    Red -> "\x1b[1;31m" ++ s ++ "\x1b[0m"
    Yellow -> "\x1b[1;33m" ++ s ++ "\x1b[0m"
    _ -> s

main :: IO ()
main = do
    hSetBuffering stdout NoBuffering
    hSetBuffering stderr NoBuffering
    opts <- getOpts
    user <- getEnv "USER"
    errNo <- argsCheck opts user
    when (errNo > 0) $ exitWith $ ExitFailure errNo
    (devs, takenPaths) <- getDevices opts
    let mountablePaths = filter (\p -> not $ elem p takenPaths) $ map (\p -> "/mnt/u" ++ show p) [(0::Int)..]
        devsKV = zip (map show [(1::Int)..]) . zip devs $ mountablePaths
    prog opts user devsKV

argsCheck :: Opts -> String -> IO Int
argsCheck Opts{..} user
    | null user = e "could not get environment variable $USER" 1
    | otherwise = return 0
    where
        e :: String -> Int -> IO Int
        e str num = errMsg str >> return num

prog :: Opts -> String -> [(String, (BlockDevice, FilePath))] -> IO ()
prog opts@Opts{..} user devsKV
    | discover = do
        putStrLn "all devices:"
        mapM_ (\(_, (d, _)) -> putStrLn $ cshow d) devsKV
    | otherwise = do
        putStrLn (if (unmount || unmount_all)
            then "USB device(s) to unmount:"
            else "USB device(s) to mount:")
        mapM_ (\(n, (d, _)) -> putStrLn $ "    " ++ n ++ ") " ++ show' d) devsKV
        putStrLn ""
        mountMenu opts user devsKV
    where
        cshow :: BlockDevice -> String
        cshow b@BlockDevice{..}
            | no_color = show b
            | otherwise = case mountPoint of
                Unmounted -> colorize Green $ show b
                MPath _ -> if not $ null $ getUSBMountPath b
                    then colorize Blue $ show b
                    else show b
                _ -> show b
        show' :: BlockDevice -> String
        show' = if not (unmount || unmount_all)
            then show
            else unwords . init . words . show

mountMenu :: Opts -> String -> [(String, (BlockDevice, FilePath))] -> IO ()
mountMenu Opts{..} user devsKV
    | unmount = if length devsKV == 1
        then do
            putStrLn "only 1 USB device to unmount"
            tryMount False user (snd . head $ devsKV) >>= exitWith
        else chooseDev prompt user devsKV (tryMount False)
    | unmount_all = do
        putStrLn "unmounting all USB devices..."
        mapM_ (tryMount False user) (map snd devsKV)
        return ()
    | all_devices = do
        putStrLn "mounting all USB devices..."
        mapM_ (tryMount True user) (map snd devsKV)
        return ()
    | length devsKV == 1 = do
        putStrLn "only 1 USB device to mount"
        tryMount True user (snd . head $ devsKV) >>= exitWith
    | otherwise = chooseDev prompt  user devsKV (tryMount True)
    where
        prompt :: String
        prompt = if (unmount || unmount_all)
            then "choose USB device to unmount (q to exit)"
            else "choose USB device to mount (q to exit)"

chooseDev :: String -> String -> [(String, (BlockDevice, FilePath))] -> (String -> (BlockDevice, FilePath) -> IO ExitCode) -> IO ()
chooseDev prompt user devsKV func = do
    putStrLn prompt
    key <- getLine
    case lookup key devsKV of
        Just dev -> func user dev >>= exitWith
        _ -> case key of
            "q" -> return ()
            _ -> chooseDev prompt user devsKV func

tryMount :: Bool -> String -> (BlockDevice, FilePath) -> IO ExitCode
tryMount mount user (BlockDevice{..}, mp) = do
    when (null $ mountArgs fsys user) $ do
        errMsg $ "unsupported file system " ++ squote fsys ++ "\nsupported file systems: " ++ (unwords $ map fst (fileSystemArgs user))
        exitWith (ExitFailure 1)
    putStr $ (if mount then "" else "un")
        ++ "mounting "
        ++ shortname
        ++ " (" ++ fsys ++ ") "
        ++ (if mount then "to " ++ mp else "from " ++ show mountPoint)
        ++ ".."
    (_, _, _, p) <- createProcess $ cmd (mountArgs fsys user) shortname
    exitStatus <- waitForProcess p
    if (exitStatus == ExitSuccess)
        then do
            putStrLn "OK"
            return ExitSuccess
        else do
            putStr "FAILED\n"
            errMsg $ (if mount
                then "mount error (perhaps " ++ squote mp ++ " does not exist)"
                else "unmount error")
            return (ExitFailure 1)
    where
        cmd arguments devPath = CreateProcess
            { cmdspec = ShellCommand (if mount
                then "sudo mount -t " ++ arguments ++ " " ++ devPath ++ " " ++ mp ++ " &>/dev/null"
                else "sudo umount " ++ show mountPoint)
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

fileSystemArgs :: String -> [(String, String)]
fileSystemArgs user =
    [ ("ext2", "ext2 -o rw,relatime")
    , ("vfat", "vfat -o rw,uid=" ++ user ++ ",gid=" ++ user)
    ]

mountArgs :: String -> String -> String
mountArgs fsys user = case lookup fsys (fileSystemArgs user) of
    Just a -> a
    _ -> []

getDevices :: Opts -> IO ([BlockDevice], [String])
getDevices Opts{..} = do
    (_, sout, _, p) <- createProcess cmdBlkid
    devs <- case sout of
        Just h -> hGetContents h
        Nothing -> return []
    _ <- waitForProcess p
    let devs' = (map (unwords . words)) . drop 2 . lines $ devs
    devs'' <- mapM parseBlkid devs'
    let toMount = filter (\BlockDevice{..} -> mountPoint == Unmounted) devs''
        toUnmount = filter (\dev -> not $ null $ getUSBMountPath dev) devs''
        takenPaths = filter (not . null) . map getUSBMountPath $ devs''
    when (not discover && null toMount && (not (unmount || unmount_all))) $ do
        errMsg $ "cannot find USB devices to mount"
        exitWith (ExitFailure 1)
    when (not discover && null toUnmount && (unmount || unmount_all)) $ do
        errMsg $ "cannot find USB devices to unmount"
        exitWith (ExitFailure 1)
    return $ formatDevs devs'' toMount toUnmount takenPaths
    where
        formatDevs :: [BlockDevice] -> [BlockDevice] -> [BlockDevice] -> [String] -> ([BlockDevice], [String])
        formatDevs ds m um takenPaths
            | discover = (ds, takenPaths)
            | unmount || unmount_all = (um, takenPaths)
            | otherwise = (m, takenPaths)
        cmdBlkid = CreateProcess
            { cmdspec = ShellCommand ("sudo blkid -o list")
            , cwd = Nothing
            , env = Nothing
            , std_in = CreatePipe
            , std_out = CreatePipe
            , std_err = Inherit
            , close_fds = False
            }

getUSBMountPath :: BlockDevice -> String
getUSBMountPath BlockDevice{..} = case mountPoint of
    MPath str -> if take 6 str == "/mnt/u" && (all (\c -> elem c ['0'..'9']) (drop 6 str))
        then str
        else ""
    _ -> ""

errMsg :: String -> IO ()
errMsg msg = hPutStrLn stderr $ "error: " ++ msg

squote :: String -> String
squote s = "`" ++ s ++ "'"

-- Parsing
parserIdentifier :: Parser String
parserIdentifier = many1 $ oneOf $ _ALPHANUM ++ "/-_"

parserWhitespace :: Parser String
parserWhitespace = many1 $ oneOf " \t\n\r"

parserMP :: Parser MountPoint
parserMP =
    try ( do
        a <- oneOf "<(" -- "(not mounted)" or "<swap>"
        b <- manyTill anyChar (lookAhead $ (oneOf ">)"))
        _ <- oneOf ">)"
        let mp = case a of
                '<' -> Swap
                '(' -> case b of
                    "not mounted" -> Unmounted
                    _ -> UnknownBlkidVal
                _ -> UnknownBlkidVal
        return mp
        )
    <|> (parserIdentifier >>= (\s -> return MPath {path = s})) -- e.g., "/mnt/blah"
    <?> "blkid's mount point description"

blkidParser :: Parser BlockDevice
blkidParser =
    try ( do
        sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        _ <- parserIdentifier -- leave out the "label" column, even if it exists
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
           { shortname = sname
           , uuid = uid
           , fsys = fs
           , mountPoint = mp
           }
        )
    <|>
    do  sname <- parserIdentifier
        _ <- parserWhitespace
        fs <- parserIdentifier
        _ <- parserWhitespace
        mp <- parserMP
        _ <- parserWhitespace
        uid <- parserIdentifier
        eof
        return BlockDevice
            { shortname = sname
            , uuid = uid
            , fsys = fs
            , mountPoint = mp
            }
    <?> "5 or 4 fields to parse"

parseBlkid :: String -> IO BlockDevice
parseBlkid src =
    case parse blkidParser "output of `sudo blkid -o list'" src of
        Left parseError -> errMsg (show parseError) >> return blockdeviceDefault
        Right result -> return result

This example compiles with ghc –make -O2 -Wall -Werror. The only 2 dependencies are Parsec, and CmdArgs.

Looking back at it, I think it’s a great example of a real-world Haskell program out in the wild. It uses Parsec to correctly parse the output from blkid, CmdArgs for sane argument handling, and also does some system calls with the createProcess command. Coding-style-wise, it uses the simple where expression wherever possible, for maximum readability and tries to keep leading whitespace to a minimum. The code is written very verbosely, with explicit type signatures for every function, because, well, it helps me keep my sanity.

I think the code is pretty straightforward. It only supports 2 file systems: the ext2 type (recommended for Linux-only USB drives), and vfat (the FAT file system used for legacy Windows support), but this could be easily extended to support ext3, ext4, or any other file system, since it just wraps around the standard mount command.

The only tricky part is blkidParser, which tries to parse 5 fields or 4 fields. The reason behind this is because blkid -o’s output looks like this:

$ sudo blkid -o list
device       fs_type label    mount point      UUID
-----------------------------------------------------------------------------------
/dev/sda1    ntfs             /mnt/windows-xp  XXXXXXXXXXXXXXXX
/dev/sda2    ext4             /                XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda3    ext4             /home            XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda6    swap             <swap>           XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sda5    ext4             /mnt/data        XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sdb1    ext2             (not mounted)    XXXXXXXX-XXXX-XXXX-XXXX-XXXXXXXXXXXX
/dev/sdc1    vfat             (not mounted)    XXXX-XXXX

Sometimes, the label field is empty, as in the example above. So, we will end up with just 4 fields instead of 5.

I hope this sample, working program will help newbies out (esp. you who are frustrated by Real World Haskell’s clunky Parsec examples…). And for those looking to actually use it themselves for easy USB mounting/unmounting, here are some additional notes:

  • Create mount points (i.e., directories) /mnt/u0, /mnt/u1, /mnt/u2, etc. so that the mount command won’t choke.
  • Use shell aliases or keyboard hotkeys to avoid typing out “usbmnt -U” every single time.
  • Tweak the options passed to the mount command to suit your needs (see the fileSystemArgs function).

(1) A simple exercise would be to extend usbmnt so that it reads a very simple configuration file to detect the right user-defined options to pass to mount depending on the partition’s UUID. The only additional thing you would have to do is read a file from disk and store it as a String.

(2) An eye-opening exercises for Parsec newcomers would be to pass to the parsing functions a ByteString instead of String. (The transition to a ByteString is extremely straight-forward, and requires minimal changes.)

I will do the exercises myself later on and post them in a couple weeks at the latest.

UPDATE: December 1, 2011: Here are some convenience links for those coming in from Google for the solutions to the 2 exercises: Solution for #1 Solution for #2

Happy hacking!

EDIT: December 1, 2011: Fix typo.

Haskell: Using CmdArgs (Single and Multi-Mode)

I use the CmdArgs module all the time for all of my personal Haskell projects. CmdArgs is really the one-stop solution for all of your command-line option handling needs. Its “killer” feature is the ability to support multi-mode options (e.g., “myprog mode1 [mode1 options]”, “myprog mode2 [mode2 options]”, etc.). Unfortunately, not many people know about CmdArgs, it seems. So, I’m writing this post to help spread its popularity among fellow newbie/intermediate Haskellers. I’m including two sample programs — a traditional single-mode program, and a multi-mode program, for your tinkering pleasure. They are hereby released into the PUBLIC DOMAIN.

The following is a simple single-mode program, singleMode.hs.

-- singleMode.hs
-- License: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}

import System.Console.CmdArgs
import System.Environment (getArgs, withArgs)
import System.Exit
import Control.Monad (when)

data MyOptions = MyOptions
    { color :: Bool
    , first_name :: String
    , age :: Int
    , directory :: FilePath
    } deriving (Data, Typeable, Show, Eq)

-- Customize your options, including help messages, shortened names, etc.
myProgOpts :: MyOptions
myProgOpts = MyOptions
    { color = def &= help "use color"
    , first_name = def &= help "your first name"
    , age = def &= explicit &= name "g" &= name "age" &= help "your age"
    , directory = def &= typDir &= help "your first name"
    }

getOpts :: IO MyOptions
getOpts = cmdArgs $ myProgOpts
    &= verbosityArgs [explicit, name "Verbose", name "V"] []
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= help _PROGRAM_ABOUT
    &= helpArg [explicit, name "help", name "h"]
    &= program _PROGRAM_NAME

_PROGRAM_NAME = "myProg"
_PROGRAM_VERSION = "0.1.2.3"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_ABOUT = "a sample CmdArgs program for you tinkering pleasure"
_COPYRIGHT = "(C) Your Name Here 2011"

main :: IO ()
main = do
    args <- getArgs
    -- If the user did not specify any arguments, pretend as "--help" was given
    opts <- (if null args then withArgs ["--help"] else id) getOpts
    optionHandler opts

-- Before directly calling your main program, you should warn your user about incorrect arguments, if any.
optionHandler :: MyOptions -> IO ()
optionHandler opts@MyOptions{..}  = do
    -- Take the opportunity here to weed out ugly, malformed, or invalid arguments.
    when (null first_name) $ putStrLn "--first-name is blank!" >> exitWith (ExitFailure 1)
    when (age < 5) $ putStrLn "you must be at least 5 years old to run this program" >> exitWith (ExitFailure 1)
    -- When you're done, pass the (corrected, or not) options to your actual program.
    exec opts

exec :: MyOptions -> IO ()
exec opts@MyOptions{..} = do
    putStrLn $ "Hello, " ++ firstname ++ "!"
    putStrLn $ "You are " ++ showAge ++ " years old."
    where
        firstname = if color
            then "\x1b[1;31m" ++ first_name ++ "\x1b[0m"
            else first_name
        showAge = if color
            then "\x1b[1;32m" ++ show age ++ "\x1b[0m"
            else show age

Screenshot:

Don’t you just love how CmdArgs handles all the formatting and line breaking for you automagically? Anyway, onto the discussion.

You first specify your program’s options by declaring a data type (in this case, MyOptions). Pretty self-explanatory. The myProgOpts function is where you specify your program’s options. You can pass in “annotations” (as CmdArgs calls them) to your options. Here, I used the explicit annotation to prevent CmdArgs from auto-generating the shorter name for the age option. The typ &= “NAME” makes it so that we get “NAME” in the help message for the –first-name option. typDir is just a shortcut for typ &= “DIR” because it’s so common.

The def function is just a sane default type for many data types, such as Bool (False), String (“”), Int (0), and others. Generally, you should use def unless you really want a different default value for an option.

Notice how the option full_name turned into –full-name? The use of underscores in your options is converted into dashes by CmdArgs. Neat!

The getOpts function has some customizations: we use -v for –version instead of -V (the default), and also use -h for the short name for –help (-? is the default). We also specify the program’s metadata (copyright info, etc.).

In the main function, if no arguments are given, we display the default help message (and exit). It took me a while to figure this one out, so take heed!

If you don’t want the –verbose or –quiet options, then just remove the line “&= verbosityArgs …”.

The RecordWildCards pragma makes the code extremely concise and easy to use. I must admit, ever since stumbling upon this pragma, I’ve used it everywhere in my own code in other projects as well.

OK, so that’s what a simple single-mode program looks like. How about multi-mode programs? Here is one, multiMode.hs:

-- multiMode.hs
-- License: PUBLIC DOMAIN
{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}

import System.Console.CmdArgs
import System.Environment (getArgs, withArgs)
import System.Exit
import Control.Monad (when)

data MyOptions =
    Mode1   { first_name :: String
            , last_name :: String
            }
    |
    Mode2   { height :: Double
            , weight :: Double
            } deriving (Data, Typeable, Show, Eq)

mode1 :: MyOptions
mode1 = Mode1
    { first_name = "FIRSTNAME" &= help "your first name"
    , last_name = "LASTNAME" &= help "your last name"
    }
    &= details  [ "Examples:"
                , "Blah blah blah."
                ]

mode2 :: MyOptions
mode2 = Mode2
    { height = def &= help "your height, in centimeters"
    , weight = def &= help "your weight, in kilograms"
    }
    &= details  [ "Examples:"
                , "Blah blah blah again."
                ]

myModes :: Mode (CmdArgs MyOptions)
myModes = cmdArgsMode $ modes [mode1, mode2]
    &= verbosityArgs [explicit, name "Verbose", name "V"] []
    &= versionArg [explicit, name "version", name "v", summary _PROGRAM_INFO]
    &= summary (_PROGRAM_INFO ++ ", " ++ _COPYRIGHT)
    &= help _PROGRAM_ABOUT
    &= helpArg [explicit, name "help", name "h"]
    &= program _PROGRAM_NAME

_PROGRAM_NAME = "myProg"
_PROGRAM_VERSION = "0.1.2.3"
_PROGRAM_INFO = _PROGRAM_NAME ++ " version " ++ _PROGRAM_VERSION
_PROGRAM_ABOUT = "a sample CmdArgs program for you tinkering pleasure"
_COPYRIGHT = "(C) Your Name Here 2011"

main :: IO ()
main = do
    args <- getArgs
    -- If the user did not specify any arguments, pretend as "--help" was given
    opts <- (if null args then withArgs ["--help"] else id) $ cmdArgsRun myModes
    optionHandler opts

optionHandler :: MyOptions -> IO ()
optionHandler opts@Mode1{..}  = do
    when (null first_name) $ putStrLn "warning: --first-name is blank"
    when (null last_name) $ putStrLn "warning: --last-name is blank"
    exec opts
optionHandler opts@Mode2{..}  = do
    when (height == 0.0) $ putStrLn "warning: --height is 0.0"
    when (weight == 0.0) $ putStrLn "warning: --weight is 0.0"
    exec opts

exec :: MyOptions -> IO ()
exec opts@Mode1{..} = putStrLn $ "Hello, " ++ first_name ++ " " ++ last_name ++ "!"
exec opts@Mode2{..} = putStrLn $ "You are " ++ show height ++ "cm tall, and weigh " ++ show weight ++ "kg!"

Screenshot:

The program uses 2 modes, mode1 and mode2. If you use modes without overlapping letters, then you can invoke them with the least amount of unambiguous letters. E.g., if the modes were named foo and bar, you could just do “multiMode f …” and foo mode would be in effect. CmdArgs does this for us.

If your modes have lots and lots of options, then calling “multiMode -h” would give a brief summary, instead of giving each mode’s detailed help message. Here, the modes have only a couple options each, so that’s why the default help message is very detailed.

You might have noticed that I included a details annotation for both modes. This annotation is useful if you want to give examples on which options to use in what way.

Happy coding!

UPDATE April 26, 2011: Victor from the comments asked a question about including a custom type as an option parameter. I never needed this option, but, it’s do-able (with the new CmdArgs 0.6.9). Anyway, here is my minimal example:

instance Default MyComplexType where
    def = MyComplexType { brand = "BRAND"
                        , eggs = 0
                        , flowers = 0
                        , nest = Nestor { books = 0, tag = "TAG", author = "AUTHOR" }
                        }

data MyComplexType = MyComplexType
    { brand :: String
    , eggs :: Int
    , flowers :: Integer
    , nest :: Nestor
    } deriving (Data, Typeable, Show, Eq)

data Nestor = Nestor
    { books :: Int
    , tag :: String
    , author :: String
    } deriving (Data, Typeable, Show, Eq)

data MyOptions = MyOptions
    { color :: Bool
    , first_name :: String
    , age :: Int
    , directory :: FilePath
    , custom :: MyComplexType
    } deriving (Data, Typeable, Show, Eq)

Can you believe it? CmdArgs can even handle nested, custom complex types! Here’s how CmdArgs renders the above, in the help message:

CmdArgs will automatically expect a string of comma-separate values (CSVs). If you don’t like the auto-generated “ITEM,INT,INT,INT,ITEM,…” description, you could easily replace it with a custom string, with a &= typ “X,Y,Z,…” annotation.

If you don’t like the CSV format that CmdArgs imposes on your custom complex type, you’re out of luck. Your best option is to just use a single String type as the option argument, and then parse that with Parsec on your own (probably in the optionHandler function, in case of any errors) and then pass on the parsed data into your main program.

UPDATE July 21, 2011: I tried out CmdArgs with a custom algebraic datatype (something like “data Color = Red | Green | Blue | ColorNone”) and it still works! Your argument for this sort of data type will be, e.g., “–color-rgb red” and the “red” argument will be interpreted as the “Red” type. Actually, CmdArgs is very lenient and will accept any non-ambiguous argument, so here, “–color-rgb r” will also be interpreted as “Red”. Here is an example of the relevant portions:

instance Default Color where
    def = ColorNone

data Color = Red
           | Green
           | Blue
           | ColorNone
    deriving (Data, Typeable, Show, Eq)

myProgOpts = MyOptions
    { ...
    , color_rgb = def &= help "select an RGB color (Red, Green, or Blue)"
    ...
    }

UPDATE August 5, 2011: You can even specify an option as a list:

data Format     = Text
                | TeX
                | HTML
                | FNone
    deriving (Data, Typeable, Show, Eq)

data MyOptions = MyOptions
    { ...
    , format :: [Format]
    , ...
    } deriving (Data, Typeable, Show, Eq)

myProgOpts = MyOptions
    { ...
    , format = [] &= help "format of output"
    , ...
    }

Here, you can do something like “-f TeX -f HTML -f Text” to set the format option to the value [TeX, HTML, Text]. This possibility to use a list as an option parameter is quite useful (such as the example here, where you want to specify multiple output targets).