import Data.Func
import Data.Functor
import Data.Tuple
+import Data.Maybe
import Control.Applicative
-import Control.Monad
-import System.GetOpt
+import Control.Monad => qualified join
import System.CommandLine
-// = NoArg a // ^ no argument expected\r
-// | ReqArg (String -> a) String // ^ option requires argument\r
-// | OptArg ((Maybe String) -> a) String // ^ optional argument\r
-//
+import Text
+
:: Opt a
- = Positionals [ArgDescr (a -> *(MaybeError [String] a))]
- | Flag (a -> a) (a -> a)
- | Options [OptDescr (a -> *(MaybeError [String] a))]
+ = BinaryFlag (a -> a) (a -> a)
+ | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
+ | Positionals [String a -> (MaybeError [String] a)]
+ | SubParsers [(String, Opt a)]
+
+class bifmap m :: (a -> b) (b -> a) (m b) -> m a
+instance bifmap Opt
+where
+ bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
+ bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs
+ bifmap fr to (Positionals fs) = Positionals $ map (fmap $ \f->fm to o f o fr) fs
+ bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
-//tr fr to (NoArg fa) = NoArg (fm to o fa o fr)
+fm f (Ok a) = Ok (f a)
+fm f (Error e) = Error e
-tr fr to (NoArg fa) = NoArg \a->case fa (fr a) of
- Ok a = Ok (to a)
- Error e = Error e
-tr fr to (ReqArg fa t) = ReqArg (\s a->case fa s (fr a) of
- Ok a = Ok (to a)
- Error e = Error e) t
-tr fr to (OptArg fa t) = OptArg (\ms a->case fa ms (fr a) of
- Ok a = Ok (to a)
- Error e = Error e) t
+combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
+combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)
-generic gopt a :: Opt a
-gopt{|Bool|} = Flag (const True) (const False)
-gopt{|Int|} = Positionals [ReqArg (\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])) "INT"]
-gopt{|Char|} = Positionals [ReqArg (\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])) "CHAR"]
-gopt{|String|} = Positionals [ReqArg (\s _->Ok s) "STRING"]
-gopt{|RECORD|} f = case f of
- Flag set unset = Flag (\(RECORD a)->RECORD (set a)) (\(RECORD a)->RECORD (unset a))
- Options opts = Options $ map (\(Option s l f h)->(Option s l (tr (\(RECORD a)->a) RECORD f) h)) opts
- Positionals p = Positionals (map (tr (\(RECORD a)->a) RECORD) p)
+ar0 s f as = Ok o flip tuple as o f
+
+generic gopt a *! :: Opt a
+gopt{|Bool|} = BinaryFlag (const True) (const False)
+gopt{|Int|} = Positionals [\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])]
+gopt{|Char|} = Positionals [\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])]
+gopt{|String|} = Positionals [\s _->Ok s]
+gopt{|RECORD|} f = bifmap (\(RECORD a)->a) RECORD f
+gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) OBJECT f
gopt{|FIELD of {gfd_name}|} f = case f of
- Flag set unset = Options
- [Option [] [gfd_name] (mapF (NoArg $ Ok o set)) ""
- ,Option [] ["no-" +++ gfd_name] (mapF (NoArg $ Ok o unset)) ""
- ]
- Positionals [p] = Options
- [Option [] [gfd_name] (mapF p) ""]
+ //Child is a boolean
+ BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
+ //Child is a basic value or a tuple
+ Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
+ //Child is another record, make the arguments ddstyle TODO
+ Flags x = mapF (Flags x)
+ //Child is a subparser
+ x = abort "Subparsers not supported"
where
- mapF = tr (\(FIELD a)->a) FIELD
-gopt{|Maybe|} (Positionals [ReqArg f d]) = Positionals
- [OptArg (\ms _ ->case ms of
- Nothing = Ok Nothing
- // Is this necessary
- Just s = case f s undef of
- Ok a = Ok (Just a)
- Error e = Error e
- ) d]
-gopt{|PAIR|} fx fg = case (fx, fg) of
- (Options as, Options bs) = Options $
- [Option s r (topair (\(PAIR l r)->l) (\(PAIR _ r) l->PAIR l r) f) d\\(Option s r f d)<-as]
- ++ [Option s r (topair (\(PAIR l r)->r) (\(PAIR l _) r->PAIR l r) f) d\\(Option s r f d)<-bs]
-topair fr to (NoArg fa) = NoArg \a->case fa (fr a) of
- Ok na = Ok (to a na)
- Error e = Error e
-topair fr to (ReqArg fa d) = ReqArg (\s a->case fa s (fr a) of
- Ok na = Ok (to a na)
- Error e = Error e) d
-topair fr to (OptArg fa d) = OptArg (\s a->case fa s (fr a) of
- Ok na = Ok (to a na)
- Error e = Error e) d
-
-parseOpts :: (Opt a) [String] a -> MaybeError [String] a
-parseOpts (Options opts) args i
- # (transformers, positionals, errors) = getOpt Permute [helpopt:opts] args
- | not (errors =: []) = Error [usageInfo "" [helpopt:opts]:errors]
- = case folder transformers i of
- Error e = Error [usageInfo "" [helpopt:opts]:e]
- Ok a = Ok a
-parseOpts _ _ i = Ok i
+ mapF :: ((m a) -> m (FIELD a)) | bifmap m
+ mapF = bifmap (\(FIELD a)->a) FIELD
-helpopt = Option [] ["help"] (NoArg \a->Error []) ""
+ ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
+ ptoarg [p:ps] [a:as] i = p a i >>= ptoarg ps as
+ ptoarg [] as i = Ok (i, as)
+gopt{|PAIR|} l r = case (l, r) of
+ (Positionals pl, Positionals pr)
+ = Positionals
+ $ map (combine PFst appPFst) pl
+ ++ map (combine PSnd appPSnd) pr
+ (Flags fl, Flags fr)
+ = Flags
+ $ map (appSnd $ combine` PFst appPFst) fl
+ ++ map (appSnd $ combine` PSnd appPSnd) fr
+where
+ appPFst f (PAIR x y) = PAIR (f x) y
+ appPSnd f (PAIR x y) = PAIR x (f y)
+ PFst (PAIR x y) = x
+ PSnd (PAIR x y) = y
+gopt{|UNIT|} = Positionals []
+gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
+gopt{|EITHER|} l r = case (l, r) of
+ (SubParsers sl, SubParsers sr)
+ = SubParsers
+ $ map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
+ ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
+gopt{|(,)|} l r = case (l, r) of
+ (Positionals pl, Positionals pr)
+ = Positionals
+ $ map (combine fst appFst) pl
+ ++ map (combine snd appSnd) pr
+gopt{|(,,)|} f s t = case (f, s, t) of
+ (Positionals pf, Positionals ps, Positionals pt)
+ = Positionals
+ $ map (combine fst3 appFst3) pf
+ ++ map (combine snd3 appSnd3) ps
+ ++ map (combine thd3 appThd3) pt
-folder [] i = Ok i
-folder [tr:trs] i = tr i >>= folder trs
+consPrint (Positionals x) = "Positionals"
+consPrint (BinaryFlag x _) = "BinaryFlag"
+consPrint (Flags x) = "Flags"
+consPrint (SubParsers x) = "SubParsers"
+
+parseOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
+parseOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
+parseOpts (Positionals [p:ps]) [arg:args] a = p arg a >>= parseOpts (Positionals ps) args
+parseOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
+ Nothing = Error ["Unrecognized subcommand"]
+ Just (l, p) = parseOpts p args a
+parseOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
+parseOpts (Flags fs) [arg:args] a
+ | not (startsWith "--" arg) = Ok (a, [arg:args])
+ = case find (\(l,p)->"--" +++ l == arg) fs of
+ Nothing = Error ["Unrecognized option: " +++ arg]
+ Just (l, p) = p args a >>= \(a, args)->parseOpts (Flags fs) args a
+parseOpts _ args a = Ok (a, args)
:: T =
- { field :: Maybe Int
+ { field :: (Int,Int)
, field2 :: String
+ , t2 :: C
}
-derive bimap Opt, [], (,),OptDescr, ArgDescr, MaybeError
-derive gopt T
+:: T2 = {f :: Int}
+:: C = A Int | B | C
+//:: T2 = T Int Int
+derive binumap Opt, [], (,), MaybeError
+derive gopt T, T2, C
Start w
# ([argv0:args], w) = getCommandLine w
-= parseOpts t args { field = Just 42, field2 = ""}
+= parseOpts t args B//{field=(0, 0),field2="",t2=A}
-t :: Opt T
+t :: Opt C
t = gopt{|*|}