module System.Console.YAOP
(
deriveModM
, ArgReq (..)
, Opt
, OptM
, option
, (=:)
, dummy
, firstM
, secondM
, ParsingConf (..)
, defaultParsingConf
, parseOptions
)
where
import System.Exit
import System.Console.GetOpt
import Control.Monad.Writer
import Data.List
import Language.Haskell.TH
mkModM :: Name -> Q Dec
mkModM fname = do
let modName = mkName ("modM_" ++ nameBase fname)
fn <- newName "fn"
rec <- newName "rec"
val <- newName "val"
body <- [|let set = $(return $ LamE [VarP val] (RecUpdE (VarE rec) [(fname,VarE val)])) in $(return $ VarE fn) ($(return $ VarE fname) $(return $ VarE rec)) >>= return . set|]
return $ FunD modName [Clause [VarP fn,VarP rec] (NormalB body) []]
deriveModM :: Name -> Q [Dec]
deriveModM t = do
TyConI (DataD _ _ _ constructors _) <- reify t
let mkFieldsModM :: Con -> Q [Dec]
mkFieldsModM (RecC name fields) = do
let fnames = map (\(name,_,_) -> name) fields
mapM mkModM fnames
mkFieldsModM _ = error "Only records are supported"
decs <- mapM mkFieldsModM constructors
return (concat decs)
data ArgReq = NoA | OptA String | ReqA String deriving (Show)
data Opt a = Opt String [String] ArgReq String (Maybe String -> a -> IO a)
instance Show (Opt a) where
show (Opt s l r h _) = "Opt " ++ unwords [show s, show l, show r, show h] ++ " <fn>"
option :: String
-> [String]
-> ArgReq
-> String
-> (Maybe String -> a -> IO a)
-> OptM a ()
option s l r h f = tell [ Opt s l r h f ]
newtype OptM a r = OptM (Writer [Opt a] r) deriving (Monad, MonadWriter [Opt a])
runOptM (OptM writer) = execWriter writer
dummy :: Monad m => (() -> m a) -> b -> m b
dummy f t = f () >> return t
firstM :: Monad m => (t -> m t1) -> (t, t2) -> m (t1, t2)
firstM f (x,y) = f x >>= \x' -> return (x', y)
secondM :: Monad m => (t -> m t2) -> (t1, t) -> m (t1, t2)
secondM f (x,y) = f y >>= \y' -> return (x, y')
(=:) :: (MonadWriter [Opt t] (OptM t)) =>
((t -> IO t) -> a -> IO a)
-> OptM t ()
-> OptM a ()
(=:) f optm = do
let os = runOptM optm
os' = map (fmapM f) os
tell os'
where
fmapM f (Opt s l r h x) = Opt s l r h (\arg a -> f (x arg) a)
genOptDescr :: [Opt a] -> [OptDescr (a -> IO a)]
genOptDescr = let arg (NoA) f = NoArg (f Nothing)
arg (OptA h) f = OptArg f h
arg (ReqA h) f = ReqArg (f . Just) h
convert (Opt s l r h f) = Option s l (arg r f) h
in map convert
data ParsingConf = ParsingConf { pcUsageHeader :: String
, pcHelpFlag :: Maybe String
, pcHelpExtraInfo :: String
, pcPermuteArgs :: Bool
}
defaultParsingConf :: ParsingConf
defaultParsingConf = ParsingConf { pcUsageHeader = "USAGE: ... [FLAGS]"
, pcHelpFlag = Just "help"
, pcHelpExtraInfo = ""
, pcPermuteArgs = True
}
parseOptions :: OptM t ()
-> t
-> ParsingConf
-> [String]
-> IO (t, [String])
parseOptions options defaultOptions conf rawArgs = do
let helpStr = usageInfo (unlines [pcUsageHeader conf,pcHelpExtraInfo conf]) optdescr
showHelp opts = do
putStrLn helpStr
exitWith ExitSuccess
return opts
helpdescr = case pcHelpFlag conf of
Just flag -> [ Option [] [flag] (NoArg showHelp) "Print help message and exit." ]
Nothing -> []
optdescr = helpdescr ++ genOptDescr (runOptM options)
argorder = case pcPermuteArgs conf of
True -> Permute
False -> RequireOrder
let (actions, args, msgs) = getOpt argorder optdescr rawArgs
mapM_ (error . flip (++) helpStr) msgs
opts <- foldl' (>>=) (return defaultOptions) actions
return (opts, args)