ffeed-0.2: examples/Util/GetOpts.hs
-- |
--
-- Module : Util.GetOpts
-- Copyright : (c) 2004-2008, Sigbjorn Finne.
--
-- Maintainer : sof@forkIO.com
-- Stability : provisional
-- Portability : portable
--
-- Accumulator-style command-line option parsing; minor extension
-- of @System.Console.GetOpt@ (whose interface this module re-exports).
--
-- So, to correctly attribute the source of the bulk of the functionality
-- provided, here's its module header:
--
-- Module : System.Console.GetOpt
-- Copyright : (c) Sven Panne Oct. 1996 (small changes Dec. 1997)
-- License : BSD-style (see the file libraries\/core\/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- A Haskell port of GNU's getopt library
--
module Util.GetOpts
( module System.Console.GetOpt
, getOpt2 -- :: ArgOrder (a->a)
-- -> [OptDescr (a->a)]
-- -> [String]
-- -> a
-- -> (a,[String],[String])
, usageInfo2 -- :: String -> [OptDescr a] -> String
) where
import Prelude
import Data.List ( isPrefixOf )
import Text.PrettyPrint
--import Util.Pretty
import System.Console.GetOpt
{- |
The @getOpt@ provided @System.Console.GetOpt@ returns a list of
values representing the options found present in an @argv@-vector.
@getOpt2@ offers a different view -- the options are represented
by a single value instead, i.e., you define a labelled field record
type representing the options supported, and have the OptDescr
elements just update the contents of that record. This has proven
to be quite a bit less cumbersome to work with, leaving you at
the end with a single value (the record) packaging up all the
options setting.
With @getOpt@, you normally end up (essentially) having to
write a sub parser of the list of values returned, which just
adds even more bulk to your code, for very little benefit.
-}
getOpt2 :: ArgOrder (a -> a) -- non-option handling
-> [OptDescr (a -> a)] -- option descriptors
-> [String] -- the commandline arguments
-> a -- initial state
-> (a,[String],[String]) -- (options,non-options,error messages)
getOpt2 _ _ [] st = (st,[],[])
getOpt2 ordering optDescr (arg:args) st = procNextOpt opt ordering
where procNextOpt (Opt f) _ = (f st',xs,es)
procNextOpt (NonOpt x) RequireOrder = (st,x:rest,[])
procNextOpt (NonOpt x) Permute = (st',x:xs,es)
procNextOpt (NonOpt x) (ReturnInOrder f) = (f x st', xs,es)
procNextOpt EndOfOpts RequireOrder = (st',rest,[])
procNextOpt EndOfOpts Permute = (st',rest,[])
procNextOpt EndOfOpts (ReturnInOrder f) = (foldr f st' rest,[],[])
procNextOpt (OptErr e) _ = (st',xs,e:es)
(opt,rest) = getNext arg args optDescr
(st',xs,es) = getOpt2 ordering optDescr rest st
-- getOpt2 supporting code - copied verbatim from System.Console.GetOpt
-- as it isn't exported.
data OptKind a -- kind of cmd line arg (internal use only):
= Opt a -- an option
| NonOpt String -- a non-option
| EndOfOpts -- end-of-options marker (i.e. "--")
| OptErr String -- something went wrong...
-- take a look at the next cmd line arg and decide what to do with it
getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
getNext a rest _ = (NonOpt a,rest)
-- handle long option
longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
longOpt ls rs optDescr = long ads arg rs
where (opt,arg) = break (=='=') ls
options = [ o | o@(Option _ xs _ _) <- optDescr,
l <- xs,
opt `isPrefixOf` l
]
ads = [ ad | Option _ _ ad _ <- options ]
optStr = ("--"++opt)
long (_:_:_) _ rest = (errAmbig options optStr,rest)
long [NoArg a ] [] rest = (Opt a,rest)
long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
long [ReqArg _ d] [] [] = (errReq d optStr,[])
long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
long [OptArg f _] [] rest = (Opt (f Nothing),rest)
long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
long _ _ rest = (errUnrec optStr,rest)
-- handle short option
shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
shortOpt x ys rest1 optDescr = short ads ys rest1
where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, x == s ]
ads = [ ad | Option _ _ ad _ <- options ]
optStr = '-':[x]
short (_:_:_) _ rest = (errAmbig options optStr,rest)
short (NoArg a :_) [] rest = (Opt a,rest)
short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
short [] [] rest = (errUnrec optStr,rest)
short [] xs rest = (errUnrec optStr,('-':xs):rest)
-- miscellaneous error formatting
errAmbig :: [OptDescr a] -> String -> OptKind a
errAmbig ods optStr =
OptErr $ usageInfo header ods
where header = "option '" ++ optStr ++ "' is ambiguous; could be one of:"
errReq :: String -> String -> OptKind a
errReq d optStr =
OptErr $ "option '" ++ optStr ++ "' requires an argument " ++ d
errUnrec :: String -> OptKind a
errUnrec optStr =
OptErr $ "unrecognized option '" ++ optStr ++ "'"
errNoArg :: String -> OptKind a
errNoArg optStr =
OptErr $ "option '" ++ optStr ++ "' doesn't allow an argument"
usageInfo2 :: String -- header
-> [OptDescr a] -- option descriptors
-> String -- nicely formatted decription of options
usageInfo2 header optDescr = render $ vcat $ text header : table
where
(ss, ls, descs) = unzip3 $ map fmtOpt optDescr
table =
let (c1, ssd) = sameLen ss
(c2, lsd) = sameLen ls
in
zipWith3 (paste (74 - c1 - c2)) ssd lsd descs
paste c3 x y z = nest 2 $ x <+> space <> y <> space <+> fitText c3 z
sameLen xs =
let width = maximum $ map length xs
in
(width, flushLeft width xs)
flushLeft n xs = [ text $ take n (x ++ repeat ' ') | x <- xs ]
fmtOpt :: OptDescr a -> (String, String, String)
fmtOpt (Option sos los argdesc descr) =
( render $ hcat $ punctuate comma $ map (fmtShort argdesc) sos
, render $ hcat $ punctuate comma $ map (fmtLong argdesc) los
, descr
)
where
fmtShort :: ArgDescr a -> Char -> Doc
fmtShort (NoArg _ ) so = char '-' <> char so
fmtShort (ReqArg _ ad) so = char '-' <> char so <+> text ad
fmtShort (OptArg _ ad) so = char '-' <> char so <+> brackets (text ad)
fmtLong :: ArgDescr a -> String -> Doc
fmtLong (NoArg _ ) lo = text "--" <> text lo
fmtLong (ReqArg _ ad) lo = text "--" <> text lo <> equals <> text ad
fmtLong (OptArg _ ad) lo = text "--" <> text lo <> equals <>
brackets (text ad)
-- | Simple line formatting of a paragraph, introducing line breaks
-- whenever length exceeds that of the first argument.
fitText :: Int -> String -> Doc
fitText width s =
vcat $ map (hsep . (map text))
(fit 0 [] (words s))
where
-- fill up lines left-to-right, introducing line breaks
-- whenever line length exceeds 'width'.
fit :: Int -> [String] -> [String] -> [[String]]
fit _ acc [] = [reverse acc]
fit n acc (w:ws)
| (n + l) >= width = (reverse (w:acc)) : fit 0 [] ws
| otherwise = fit (n+l+1{-word space-}) (w:acc) ws
where
l = length w