From 5ca0aeeb9cd8f264c1dafcd54082e429571f59c1 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Tue, 29 May 2018 08:46:02 +0200 Subject: [PATCH] gopts --- funcdeps/test.icl | 18 ++++++ gopt/gopt.icl | 145 +++++++++++++++++++++++----------------------- 2 files changed, 92 insertions(+), 71 deletions(-) create mode 100644 funcdeps/test.icl diff --git a/funcdeps/test.icl b/funcdeps/test.icl new file mode 100644 index 0000000..5a03545 --- /dev/null +++ b/funcdeps/test.icl @@ -0,0 +1,18 @@ +module test + +import StdMisc + +:: Zero = Zero +:: Succ a = Succ + +:: Ar3 a b c :== (a -> b -> c) + +class C m :: (m b) + +instance C ((->) a) where C = \x->undef + +Start :: (a -> b -> c) +Start = t + +t :: (Ar3 a b c) +t = C diff --git a/gopt/gopt.icl b/gopt/gopt.icl index 69ac02b..dd66154 100644 --- a/gopt/gopt.icl +++ b/gopt/gopt.icl @@ -9,93 +9,96 @@ import Data.Functor import Data.Tuple import Control.Applicative import Control.Monad -import System.GetOpt import System.CommandLine -// = NoArg a // ^ no argument expected -// | ReqArg (String -> a) String // ^ option requires argument -// | OptArg ((Maybe String) -> a) String // ^ optional argument -// + :: 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, Flag a)] + | Positionals [String a -> (MaybeError [String] a)] + | SubParsers [(String, Opt a)] -//tr fr to (NoArg fa) = NoArg (fm to o fa o fr) +:: Flag a + = Flag (a -> a) + | Arg (String a -> (MaybeError [String] a)) -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 +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 (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 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) +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) ""] + 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 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 - + 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 -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 (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 - +// +//helpopt = Option [] ["help"] (NoArg \a->Error []) "" +// +//folder [] i = Ok i +//folder [tr:trs] i = tr i >>= folder trs +// :: T = - { field :: Maybe Int - , field2 :: String + { field :: Bool +// , field2 :: String } -derive bimap Opt, [], (,),OptDescr, ArgDescr, MaybeError +//:: T2 = T Int Int +derive bimap Opt, [], (,), MaybeError, Flag derive gopt T Start w # ([argv0:args], w) = getCommandLine w -= parseOpts t args { field = Just 42, field2 = ""} += t t :: Opt T t = gopt{|*|} -- 2.20.1