{-# LANGUAGE TypeFamilies, LambdaCase, DeriveFunctor, StandaloneDeriving #-}
module Data.Extensible.GetOpt (OptionDescr(..)
, OptDescr'
, getOptRecord
, withGetOpt
, optFlag
, optLastArg
, optNoArg
, optReqArg
, optionNoArg
, optionReqArg
, optionOptArg) 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.Functor.Identity
import Data.List (foldl')
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
data OptionDescr h a = forall s. OptionDescr (s -> h a) !s (OptDescr (s -> s))
deriving instance Functor h => Functor (OptionDescr h)
supplyOption :: Maybe String -> OptionDescr h a -> OptionDescr h a
supplyOption :: forall {k} (h :: k -> Type) (a :: k).
Maybe String -> OptionDescr h a -> OptionDescr h a
supplyOption Maybe String
str od :: OptionDescr h a
od@(OptionDescr s -> h a
k s
s opt :: OptDescr (s -> s)
opt@(Option String
_ [String]
_ ArgDescr (s -> s)
arg String
_)) = case (Maybe String
str, ArgDescr (s -> s)
arg) of
(Just String
a, ReqArg String -> s -> s
f String
_) -> (s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr s -> h a
k (String -> s -> s
f String
a s
s) OptDescr (s -> s)
opt
(Maybe String
Nothing, NoArg s -> s
f) -> (s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr s -> h a
k (s -> s
f s
s) OptDescr (s -> s)
opt
(Maybe String
a, OptArg Maybe String -> s -> s
f String
_) -> (s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr s -> h a
k (Maybe String -> s -> s
f Maybe String
a s
s) OptDescr (s -> s)
opt
(Maybe String, ArgDescr (s -> s))
_ -> OptionDescr h a
od
extendArg :: (Maybe String -> a -> b) -> ArgDescr a -> ArgDescr b
extendArg :: forall a b. (Maybe String -> a -> b) -> ArgDescr a -> ArgDescr b
extendArg Maybe String -> a -> b
f (NoArg a
a) = b -> ArgDescr b
forall a. a -> ArgDescr a
NoArg (b -> ArgDescr b) -> b -> ArgDescr b
forall a b. (a -> b) -> a -> b
$ Maybe String -> a -> b
f Maybe String
forall a. Maybe a
Nothing a
a
extendArg Maybe String -> a -> b
f (ReqArg String -> a
a String
ph) = (String -> b) -> String -> ArgDescr b
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (\String
s -> Maybe String -> a -> b
f (String -> Maybe String
forall a. a -> Maybe a
Just String
s) (String -> a
a String
s)) String
ph
extendArg Maybe String -> a -> b
f (OptArg Maybe String -> a
a String
ph) = (Maybe String -> b) -> String -> ArgDescr b
forall a. (Maybe String -> a) -> String -> ArgDescr a
OptArg (Maybe String -> a -> b
f (Maybe String -> a -> b)
-> (Maybe String -> a) -> Maybe String -> b
forall a b.
(Maybe String -> a -> b)
-> (Maybe String -> a) -> Maybe String -> b
forall (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe String -> a
a) String
ph
type OptDescr' = OptionDescr Identity
instance Wrapper (OptionDescr h) where
type Repr (OptionDescr h) a = OptionDescr h a
_Wrapper :: forall (f :: Type -> Type) (p :: Type -> Type -> Type) (v :: k).
(Functor f, Profunctor p) =>
Optic' p f (OptionDescr h v) (Repr (OptionDescr h) v)
_Wrapper = p (Repr (OptionDescr h) v) (f (Repr (OptionDescr h) v))
-> p (OptionDescr h v) (f (OptionDescr h v))
p (OptionDescr h v) (f (OptionDescr h v))
-> p (OptionDescr h v) (f (OptionDescr h v))
forall a. a -> a
id
optNoArg :: [Char]
-> [String]
-> String
-> OptDescr' Int
optNoArg :: String -> [String] -> String -> OptDescr' Int
optNoArg = (Int -> Identity Int)
-> String -> [String] -> String -> OptDescr' Int
forall {k} (h :: k -> Type) (a :: k).
(Int -> h a) -> String -> [String] -> String -> OptionDescr h a
optionNoArg Int -> Identity Int
forall a. a -> Identity a
Identity
optFlag :: [Char]
-> [String]
-> String
-> OptDescr' Bool
optFlag :: String -> [String] -> String -> OptDescr' Bool
optFlag = (Int -> Identity Bool)
-> String -> [String] -> String -> OptDescr' Bool
forall {k} (h :: k -> Type) (a :: k).
(Int -> h a) -> String -> [String] -> String -> OptionDescr h a
optionNoArg (Bool -> Identity Bool
forall a. a -> Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Bool -> Identity Bool) -> (Int -> Bool) -> Int -> Identity Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0))
optionNoArg :: (Int -> h a) -> [Char] -> [String] -> String -> OptionDescr h a
optionNoArg :: forall {k} (h :: k -> Type) (a :: k).
(Int -> h a) -> String -> [String] -> String -> OptionDescr h a
optionNoArg Int -> h a
f String
ss [String]
ls String
expl = (Int -> h a) -> Int -> OptDescr (Int -> Int) -> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr Int -> h a
f Int
0 (OptDescr (Int -> Int) -> OptionDescr h a)
-> OptDescr (Int -> Int) -> OptionDescr h a
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ArgDescr (Int -> Int)
-> String
-> OptDescr (Int -> Int)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
ss [String]
ls ((Int -> Int) -> ArgDescr (Int -> Int)
forall a. a -> ArgDescr a
NoArg (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) String
expl
optReqArg :: [Char]
-> [String]
-> String
-> String
-> OptDescr' [String]
optReqArg :: String -> [String] -> String -> String -> OptDescr' [String]
optReqArg = ([String] -> Identity [String])
-> String -> [String] -> String -> String -> OptDescr' [String]
forall {k} (h :: k -> Type) (a :: k).
([String] -> h a)
-> String -> [String] -> String -> String -> OptionDescr h a
optionReqArg [String] -> Identity [String]
forall a. a -> Identity a
Identity
optLastArg :: [Char]
-> [String]
-> String
-> String
-> OptDescr' (Maybe String)
optLastArg :: String -> [String] -> String -> String -> OptDescr' (Maybe String)
optLastArg String
ss [String]
ls String
ph String
expl = (Maybe String -> Identity (Maybe String))
-> Maybe String
-> OptDescr (Maybe String -> Maybe String)
-> OptDescr' (Maybe String)
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr Maybe String -> Identity (Maybe String)
forall a. a -> Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing (OptDescr (Maybe String -> Maybe String)
-> OptDescr' (Maybe String))
-> OptDescr (Maybe String -> Maybe String)
-> OptDescr' (Maybe String)
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ArgDescr (Maybe String -> Maybe String)
-> String
-> OptDescr (Maybe String -> Maybe String)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
ss [String]
ls ((String -> Maybe String -> Maybe String)
-> String -> ArgDescr (Maybe String -> Maybe String)
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (Maybe String -> Maybe String -> Maybe String
forall a b. a -> b -> a
const (Maybe String -> Maybe String -> Maybe String)
-> (String -> Maybe String)
-> String
-> Maybe String
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just) String
ph) String
expl
optionReqArg :: ([String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a
optionReqArg :: forall {k} (h :: k -> Type) (a :: k).
([String] -> h a)
-> String -> [String] -> String -> String -> OptionDescr h a
optionReqArg [String] -> h a
f String
ss [String]
ls String
ph String
expl = ([String] -> h a)
-> [String] -> OptDescr ([String] -> [String]) -> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr [String] -> h a
f [] (OptDescr ([String] -> [String]) -> OptionDescr h a)
-> OptDescr ([String] -> [String]) -> OptionDescr h a
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ArgDescr ([String] -> [String])
-> String
-> OptDescr ([String] -> [String])
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
ss [String]
ls ((String -> [String] -> [String])
-> String -> ArgDescr ([String] -> [String])
forall a. (String -> a) -> String -> ArgDescr a
ReqArg (:) String
ph) String
expl
optionOptArg :: ([Maybe String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a
optionOptArg :: forall {k} (h :: k -> Type) (a :: k).
([Maybe String] -> h a)
-> String -> [String] -> String -> String -> OptionDescr h a
optionOptArg [Maybe String] -> h a
f String
ss [String]
ls String
ph String
expl = ([Maybe String] -> h a)
-> [Maybe String]
-> OptDescr ([Maybe String] -> [Maybe String])
-> OptionDescr h a
forall {k} (h :: k -> Type) (a :: k) s.
(s -> h a) -> s -> OptDescr (s -> s) -> OptionDescr h a
OptionDescr [Maybe String] -> h a
f [] (OptDescr ([Maybe String] -> [Maybe String]) -> OptionDescr h a)
-> OptDescr ([Maybe String] -> [Maybe String]) -> OptionDescr h a
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ArgDescr ([Maybe String] -> [Maybe String])
-> String
-> OptDescr ([Maybe String] -> [Maybe String])
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
ss [String]
ls ((Maybe String -> [Maybe String] -> [Maybe String])
-> String -> ArgDescr ([Maybe String] -> [Maybe String])
forall a. (Maybe String -> a) -> String -> ArgDescr a
OptArg (:) String
ph) String
expl
getOptRecord :: RecordOf (OptionDescr h) xs
-> [String]
-> (RecordOf h xs, [String], [String], String -> String)
getOptRecord :: forall {v} {k} (h :: v -> Type) (xs :: [Assoc k v]).
RecordOf (OptionDescr h) xs
-> [String]
-> (RecordOf h xs, [String], [String], String -> String)
getOptRecord RecordOf (OptionDescr h) xs
descs [String]
args = (xs :& Field h
result, [String]
rs, [String]
es, (String
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> String)
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> String
-> String
forall a b c. (a -> b -> c) -> b -> a -> c
flip String
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> String
forall a. String -> [OptDescr a] -> String
usageInfo [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
updaters) where
([RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs]
fs, [String]
rs, [String]
es) = ArgOrder
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> [String]
-> ([RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs],
[String], [String])
forall a.
ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt ArgOrder
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
forall a. ArgOrder a
Permute [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
updaters [String]
args
updaters :: [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
updaters = (forall (x :: Assoc k v).
Membership xs x
-> Field (OptionDescr h) x
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)])
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> RecordOf (OptionDescr h) xs
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
forall {k} (xs :: [k]) (h :: k -> Type) r.
(forall (x :: k). Membership xs x -> h x -> r -> r)
-> r -> (xs :& h) -> r
hfoldrWithIndex
(\Membership xs x
i (Field (OptionDescr s -> h (TargetOf x)
_ s
_ (Option String
ss [String]
ls ArgDescr (s -> s)
arg String
expl))) -> (:)
(OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)])
-> OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
-> [OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)]
forall a b. (a -> b) -> a -> b
$ String
-> [String]
-> ArgDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> String
-> OptDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
forall a. String -> [String] -> ArgDescr a -> String -> OptDescr a
Option String
ss [String]
ls ((Maybe String
-> (s -> s)
-> RecordOf (OptionDescr h) xs
-> RecordOf (OptionDescr h) xs)
-> ArgDescr (s -> s)
-> ArgDescr
(RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
forall a b. (Maybe String -> a -> b) -> ArgDescr a -> ArgDescr b
extendArg (\Maybe String
a s -> s
_ -> Optic
(->)
Identity
(RecordOf (OptionDescr h) xs)
(RecordOf (OptionDescr h) xs)
(Field (OptionDescr h) x)
(Field (OptionDescr h) x)
-> (Field (OptionDescr h) x -> Field (OptionDescr h) x)
-> RecordOf (OptionDescr h) xs
-> RecordOf (OptionDescr h) xs
forall s t a b. Optic (->) Identity s t a b -> (a -> b) -> s -> t
over (Membership xs x
-> Optic
(->)
Identity
(RecordOf (OptionDescr h) xs)
(RecordOf (OptionDescr h) xs)
(Field (OptionDescr h) x)
(Field (OptionDescr h) x)
forall (xs :: [Assoc k v]) (h :: Assoc k v -> Type)
(x :: Assoc k v).
ExtensibleConstr (:&) xs h x =>
Membership xs x -> Optic' (->) Identity (xs :& h) (h x)
forall k (f :: Type -> Type) (p :: Type -> Type -> Type)
(t :: [k] -> (k -> Type) -> Type) (xs :: [k]) (h :: k -> Type)
(x :: k).
(Extensible f p t, ExtensibleConstr t xs h x) =>
Membership xs x -> Optic' p f (t xs h) (h x)
pieceAt Membership xs x
i) ((OptionDescr h (TargetOf x) -> OptionDescr h (TargetOf x))
-> Field (OptionDescr h) x -> Field (OptionDescr h) x
forall {v} {k} (g :: v -> Type) (kv :: Assoc k v) (h :: v -> Type).
(g (TargetOf kv) -> h (TargetOf kv)) -> Field g kv -> Field h kv
liftField (Maybe String
-> OptionDescr h (TargetOf x) -> OptionDescr h (TargetOf x)
forall {k} (h :: k -> Type) (a :: k).
Maybe String -> OptionDescr h a -> OptionDescr h a
supplyOption Maybe String
a))) ArgDescr (s -> s)
arg) String
expl)
[] RecordOf (OptionDescr h) xs
descs
result :: xs :& Field h
result = (forall (x :: Assoc k v). Field (OptionDescr h) x -> Field h x)
-> RecordOf (OptionDescr h) xs -> xs :& Field h
forall {k} (g :: k -> Type) (h :: k -> Type) (xs :: [k]).
(forall (x :: k). g x -> h x) -> (xs :& g) -> xs :& h
hmap (\(Field (OptionDescr s -> h (TargetOf x)
k s
x OptDescr (s -> s)
_)) -> h (TargetOf x) -> Field h x
forall v k (h :: v -> Type) (kv :: Assoc k v).
h (TargetOf kv) -> Field h kv
Field (s -> h (TargetOf x)
k s
x))
(RecordOf (OptionDescr h) xs -> xs :& Field h)
-> RecordOf (OptionDescr h) xs -> xs :& Field h
forall a b. (a -> b) -> a -> b
$ (RecordOf (OptionDescr h) xs
-> (RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs
-> [RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs]
-> RecordOf (OptionDescr h) xs
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs
-> (RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs
forall a b c. (a -> b -> c) -> b -> a -> c
flip (RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs)
-> RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs
forall a. a -> a
id) RecordOf (OptionDescr h) xs
descs [RecordOf (OptionDescr h) xs -> RecordOf (OptionDescr h) xs]
fs
withGetOpt :: MonadIO m => String
-> RecordOf (OptionDescr h) xs
-> (RecordOf h xs -> [String] -> m a)
-> m a
withGetOpt :: forall {v} {k} (m :: Type -> Type) (h :: v -> Type)
(xs :: [Assoc k v]) a.
MonadIO m =>
String
-> RecordOf (OptionDescr h) xs
-> (RecordOf h xs -> [String] -> m a)
-> m a
withGetOpt String
nonOptUsage RecordOf (OptionDescr h) xs
descs RecordOf h xs -> [String] -> m a
k = RecordOf (OptionDescr h) xs
-> [String]
-> (RecordOf h xs, [String], [String], String -> String)
forall {v} {k} (h :: v -> Type) (xs :: [Assoc k v]).
RecordOf (OptionDescr h) xs
-> [String]
-> (RecordOf h xs, [String], [String], String -> String)
getOptRecord RecordOf (OptionDescr h) xs
descs ([String] -> (RecordOf h xs, [String], [String], String -> String))
-> m [String]
-> m (RecordOf h xs, [String], [String], String -> String)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String] -> m [String]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO IO [String]
getArgs m (RecordOf h xs, [String], [String], String -> String)
-> ((RecordOf h xs, [String], [String], String -> String) -> m a)
-> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(RecordOf h xs
r, [String]
xs, [], String -> String
_) -> RecordOf h xs -> [String] -> m a
k RecordOf h xs
r [String]
xs
(RecordOf h xs
_, [String]
_, [String]
errs, String -> String
usage) -> IO a -> m a
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
(String -> IO ()) -> [String] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
stderr) [String]
errs
IO String
getProgName IO String -> (String -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO a
forall a. String -> IO a
die (String -> IO a) -> (String -> String) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
usage (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: String
nonOptUsage))