module Data.Extensible.GetOpt (OptDescr'(..)
, optNoArg
, optReqArg
, getOptRecord
, withGetOpt) where
import Control.Monad.IO.Class
import Data.Extensible.Class
import Data.Extensible.Field
import Data.Extensible.Internal.Rig
import Data.Extensible.Product
import Data.Extensible.Wrapper
import Data.List (foldl')
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
data OptDescr' a = OptDescr' a (OptDescr (a -> a))
instance Wrapper OptDescr' where
type Repr OptDescr' a = OptDescr' a
_Wrapper = id
optNoArg :: [Char]
-> [String]
-> String
-> OptDescr' Int
optNoArg ss ls expl = OptDescr' 0 $ Option ss ls (NoArg (+1)) expl
optReqArg :: [Char]
-> [String]
-> String
-> String
-> OptDescr' [String]
optReqArg ss ls ph expl = OptDescr' [] $ Option ss ls (ReqArg (:) ph) expl
getOptRecord :: RecordOf OptDescr' xs
-> [String]
-> (Record xs, [String], [String], String -> String)
getOptRecord descs args = (foldl' (flip id) def fs, rs, es, flip usageInfo updaters) where
(fs, rs, es) = getOpt Permute updaters args
updaters = hfoldrWithIndex
(\i (Field (OptDescr' _ opt)) -> (:)
$ fmap (\f -> over (pieceAt i) (Field . fmap f . getField)) opt)
[] descs
def = hmap (\(Field (OptDescr' x _)) -> Field (pure x)) descs
withGetOpt :: MonadIO m => RecordOf OptDescr' xs
-> (Record xs -> [String] -> m a) -> m a
withGetOpt descs k = getOptRecord descs <$> liftIO getArgs >>= \case
(r, xs, [], _) -> k r xs
(_, _, errs, usage) -> liftIO $ do
mapM_ (hPutStrLn stderr) errs
getProgName >>= die . usage