From: Mart Lubbers Date: Tue, 29 May 2018 14:24:30 +0000 (+0200) Subject: up X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=42099428d4defde7cb94bb15cd89b35d5761f63d;p=clean-tests.git up --- diff --git a/gopt/gopt.icl b/gopt/gopt.icl index dd66154..6db4936 100644 --- a/gopt/gopt.icl +++ b/gopt/gopt.icl @@ -7,35 +7,34 @@ import Data.Error import Data.Func import Data.Functor import Data.Tuple +import Data.Maybe import Control.Applicative -import Control.Monad +import Control.Monad => qualified join import System.CommandLine +import Text :: Opt a = BinaryFlag (a -> a) (a -> a) - | Flags [(String, Flag a)] + | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))] | Positionals [String a -> (MaybeError [String] a)] | SubParsers [(String, Opt a)] -:: Flag a - = Flag (a -> a) - | Arg (String a -> (MaybeError [String] 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 (bifmap fr to) fs + 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 -instance bifmap Flag -where - bifmap fr to (Flag f) = Flag (to o f o fr) - bifmap fr to (Arg f) = Arg (\s->fm to o f s o fr) fm f (Ok a) = Ok (f a) fm f (Error e) = Error e +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) + +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"])] @@ -44,61 +43,87 @@ 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 - BinaryFlag set unset = Flags [(gfd_name, mapF (Flag set)), ("no-" +++ gfd_name, mapF (Flag unset))] - Positionals [p] = Flags [(gfd_name, mapF (Arg p))] - x = mapF f + //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 :: ((m a) -> m (FIELD a)) | bifmap m mapF = bifmap (\(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 + + 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 + +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 (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 -// -//helpopt = Option [] ["help"] (NoArg \a->Error []) "" -// -//folder [] i = Ok i -//folder [tr:trs] i = tr i >>= folder trs -// +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 :: Bool -// , field2 :: String + { field :: (Int,Int) + , field2 :: String + , t2 :: C } +:: T2 = {f :: Int} +:: C = A Int | B | C //:: T2 = T Int Int -derive bimap Opt, [], (,), MaybeError, Flag -derive gopt T +derive bimap Opt, [], (,), MaybeError +derive gopt T, T2, C Start w # ([argv0:args], w) = getCommandLine w -= t += parseOpts t args B//{field=(0, 0),field2="",t2=A} -t :: Opt T +t :: Opt C t = gopt{|*|}