3 import StdEnv, StdGeneric
11 import Control.Applicative
12 import Control.Monad => qualified join
13 import System.CommandLine
17 = BinaryFlag (a -> a) (a -> a)
18 | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
19 | Positionals [(String, String a -> (MaybeError [String] a))]
20 | SubParsers [(String, Opt a)]
22 class bifmap m :: (a -> b) (b -> a) (m b) -> m a
25 bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
26 bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs
27 bifmap fr to (Positionals fs) = Positionals $ map (appSnd $ fmap $ \f->fm to o f o fr) fs
28 bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
30 fm f (Ok a) = Ok (f a)
31 fm f (Error e) = Error e
33 combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
34 combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)
36 ar0 s f as = Ok o flip tuple as o f
38 generic gopt a *! :: Opt a
39 //generic gopt a :: Opt a
40 gopt{|Bool|} = BinaryFlag (const True) (const False)
41 gopt{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))]
42 gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))]
43 gopt{|String|} = Positionals [("STRING", \s _->Ok s)]
44 gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f
45 gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) f
46 gopt{|FIELD of {gfd_name}|} f = case f of
48 BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
49 //Child is a basic value or a tuple
50 Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
51 //Child is another record, make the arguments ddstyle TODO
52 Flags x = mapF (Flags x)
53 //Child is a subparser
54 SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))])
55 x = abort "Subparsers not supported"
57 mapF :: ((m a) -> m (FIELD a)) | bifmap m
58 mapF = bifmap (\(FIELD a)->a) (\x->FIELD x)
60 ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
61 ptoarg [(_, p):ps] [a:as] i = p a i >>= ptoarg ps as
62 ptoarg [] as i = Ok (i, as)
63 gopt{|PAIR|} l r = case (l, r) of
64 (Positionals pl, Positionals pr)
66 $ map (appSnd $ combine PFst appPFst) pl
67 ++ map (appSnd $ combine PSnd appPSnd) pr
70 $ map (appSnd $ combine` PFst appPFst) fl
71 ++ map (appSnd $ combine` PSnd appPSnd) fr
72 (x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y
74 appPFst f (PAIR x y) = PAIR (f x) y
75 appPSnd f (PAIR x y) = PAIR x (f y)
78 gopt{|UNIT|} = Positionals []
79 gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
80 gopt{|EITHER|} l r = case (l, r) of
81 (SubParsers sl, SubParsers sr)
83 $ map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
84 ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
85 gopt{|(,)|} l r = case (l, r) of
86 (Positionals pl, Positionals pr)
88 $ map (appSnd $ combine fst appFst) pl
89 ++ map (appSnd $ combine snd appSnd) pr
90 gopt{|(,,)|} f s t = case (f, s, t) of
91 (Positionals pf, Positionals ps, Positionals pt)
93 $ map (appSnd $ combine fst3 appFst3) pf
94 ++ map (appSnd $ combine snd3 appSnd3) ps
95 ++ map (appSnd $ combine thd3 appThd3) pt
97 consPrint (Positionals x) = "Positionals"
98 consPrint (BinaryFlag x _) = "BinaryFlag"
99 consPrint (Flags x) = "Flags"
100 consPrint (SubParsers x) = "SubParsers"
102 parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a
103 parseOpts args a = pOpts gopt{|*|} args a
105 pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
106 pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
107 pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args
108 pOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
109 Nothing = Error ["Unrecognized subcommand"]
110 Just (l, p) = pOpts p args a
111 pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
112 pOpts (Flags fs) [arg:args] a
113 | not (startsWith "--" arg) = Ok (a, [arg:args])
114 = case find (\(l,p)->"--" +++ l == arg) fs of
115 Nothing = Error ["Unrecognized option: " +++ arg]
116 Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a
117 pOpts (BinaryFlag yes no) args a
118 = pOpts (Positionals [("BOOL", \s v->
123 (Error ["Not True or False"])
126 pOpts t args a = Ok (a, args)
128 pHelp :: (Opt a) -> [String]
129 pHelp (Positionals []) = []
130 pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps]
131 pHelp (SubParsers ps) =
133 [[n, " ":pHelp opt] ++ ["\n"]
150 :: T2 = {f :: Int, f2 :: Bool}
151 :: C = A Int | B | C Bool
157 derive binumap Opt, [], (,), MaybeError
158 derive gopt T, T2, ADT, C
161 # ([argv0:args], w) = getCommandLine w
163 = parseOpts args {field=(0, 0),field2="",t2=A 4}