gopts

diff --git a/funcdeps/test.icl b/funcdeps/test.icl
new file mode 100644 (file)
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 (file)
--- 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\r
-//    | ReqArg (String       -> a) String // ^   option requires argument\r
-//    | OptArg ((Maybe String) -> a) String // ^   optional argument\r
-//
+
 :: 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{|*|}