{-# LANGUAGE TypeFamilies, LambdaCase, DeriveFunctor, StandaloneDeriving #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.GetOpt
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- A wrapper for 'System.Console.GetOpt'.
--
-- See also: <https://www.schoolofhaskell.com/user/fumieval/extensible/getopt-and-extensible-records GetOpt and extensible records - School of Haskell>
--
--------------------------------------------------------------------------------
module Data.Extensible.GetOpt (OptionDescr(..)
  , OptDescr'
  , getOptRecord
  , withGetOpt
  -- * Basic descriptors
  , optFlag
  , optLastArg
  -- * More generic descriptors
  , 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

-- | 'OptDescr' with a default
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 :: 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 :: (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 (f :: Type -> Type) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> Maybe String -> a
a) String
ph

-- | Simple option descriptor
type OptDescr' = OptionDescr Identity

instance Wrapper (OptionDescr h) where
  type Repr (OptionDescr h) a = OptionDescr h a
  _Wrapper :: Optic' p f (OptionDescr h v) (Repr (OptionDescr h) v)
_Wrapper = Optic' p f (OptionDescr h v) (Repr (OptionDescr h) v)
forall a. a -> a
id

-- | Option without an argument; the result is the total count of this option.
optNoArg :: [Char] -- ^ short option
    -> [String] -- ^ long option
    -> String -- ^ explanation
    -> 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

-- | True when specified
optFlag :: [Char] -- ^ short option
    -> [String] -- ^ long option
    -> String -- ^ explanation
    -> 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 (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))

-- | Wrapper-generic version of `optNoArg`
optionNoArg :: (Int -> h a) -> [Char] -> [String] -> String -> OptionDescr h a
optionNoArg :: (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

-- | Option with an argument
optReqArg :: [Char] -- ^ short option
    -> [String] -- ^ long option
    -> String -- ^ placeholder
    -> String -- ^ explanation
    -> 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

-- | Takes the last argument when more than one is specified.
optLastArg :: [Char] -- ^ short option
    -> [String] -- ^ long option
    -> String -- ^ placeholder
    -> String -- ^ explanation
    -> 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 (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

-- | Wrapper-generic version of `optReqArg`
optionReqArg :: ([String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a
optionReqArg :: ([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

-- | Construct an option with an optional argument
optionOptArg :: ([Maybe String] -> h a) -> [Char] -> [String] -> String -> String -> OptionDescr h a
optionOptArg :: ([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

-- | Parse option arguments.
getOptRecord :: RecordOf (OptionDescr h) xs -- ^ a record of option descriptors
    -> [String] -- ^ arguments
    -> (RecordOf h xs, [String], [String], String -> String) -- ^ (result, remaining non-options, errors, usageInfo)
getOptRecord :: RecordOf (OptionDescr h) xs
-> [String]
-> (RecordOf h xs, [String], [String], String -> String)
getOptRecord RecordOf (OptionDescr h) xs
descs [String]
args = (RecordOf h xs
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 _ _ (Option ss ls arg 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 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 :: RecordOf h xs
result = (forall (x :: Assoc k v). Field (OptionDescr h) x -> Field h x)
-> RecordOf (OptionDescr h) xs -> RecordOf h xs
forall k (g :: k -> Type) (h :: k -> Type) (xs :: [k]).
(forall (x :: k). g x -> h x) -> (xs :& g) -> xs :& h
hmap (\(Field (OptionDescr k x _)) -> 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 -> RecordOf h xs)
-> RecordOf (OptionDescr h) xs -> RecordOf h xs
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 (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

-- | An all-in-one utility function.
-- When there's an error, print it along with the usage info to stderr
-- and terminate with 'exitFailure'.
withGetOpt :: MonadIO m => String -- ^ Non-option usage
  -> RecordOf (OptionDescr h) xs -- ^ option desciptors
  -> (RecordOf h xs -> [String] -> m a) -- ^ the result and non-option arguments
  -> m a
withGetOpt :: 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 (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 (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 (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 (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))