gopt/gopt.icl

   1 module gopt
   2
   3 import StdGeneric, StdOverloaded, StdClass, StdArray, StdChar, StdBool, StdList, StdMisc, StdFunc, StdTuple, StdString
   4
   5 import Data.List
   6 import Data.Error
   7 import Data.Func
   8 import Data.Functor
   9 import Data.Tuple
  10 import Control.Applicative
  11 import Control.Monad
  12 import System.CommandLine
  13
  14 :: Opt a
  15         = BinaryFlag (a -> a) (a -> a)
  16         | Flags [(String, Flag a)]
  17         | Positionals [String a -> (MaybeError [String] a)]
  18         | SubParsers [(String, Opt a)]
  19
  20 :: Flag a
  21         = Flag (a -> a)
  22         | Arg (String a -> (MaybeError [String] a))
  23
  24 class bifmap m :: (a -> b) (b -> a) (m b) -> m a
  25 instance bifmap Opt
  26 where
  27         bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
  28         //bifmap fr to (Flags fs) = Flags $ map (bifmap fr to) fs
  29         bifmap fr to (Positionals fs) = Positionals $ map (fmap $ \f->fm to o f o fr) fs
  30         bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
  31 instance bifmap Flag
  32 where
  33         bifmap fr to (Flag f) = Flag (to o f o fr)
  34         bifmap fr to (Arg f) = Arg (\s->fm to o f s o fr)
  35
  36 fm f (Ok a) = Ok (f a)
  37 fm f (Error e) = Error e
  38
  39 generic gopt a :: Opt a
  40 gopt{|Bool|} = BinaryFlag (const True) (const False)
  41 gopt{|Int|} = Positionals [\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])]
  42 gopt{|Char|} = Positionals [\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])]
  43 gopt{|String|} = Positionals [\s _->Ok s]
  44 gopt{|RECORD|} f = bifmap (\(RECORD a)->a) RECORD f
  45 gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) OBJECT f
  46 gopt{|FIELD of {gfd_name}|} f = case f of
  47         BinaryFlag set unset = Flags [(gfd_name, mapF (Flag set)), ("no-" +++ gfd_name, mapF (Flag unset))]
  48         Positionals [p] = Flags [(gfd_name, mapF (Arg p))]
  49         x = mapF f
  50 where
  51         mapF :: ((m a) -> m (FIELD a)) | bifmap m
  52         mapF = bifmap (\(FIELD a)->a) FIELD
  53 //gopt{|Maybe|} (Positionals [ReqArg f d]) = Positionals
  54 //              [OptArg (\ms _ ->case ms of
  55 //                      Nothing = Ok Nothing
  56 //                              // Is this necessary
  57 //                      Just s = case f s undef of
  58 //                              Ok a = Ok (Just a)
  59 //                              Error e = Error e
  60 //      ) d]
  61 //gopt{|PAIR|} fx fg = case (fx, fg) of
  62 //      (Options as, Options bs) = Options $
  63 //              [Option s r (topair (\(PAIR l r)->l) (\(PAIR _ r) l->PAIR l r) f) d\\(Option s r f d)<-as]
  64 //              ++ [Option s r (topair (\(PAIR l r)->r) (\(PAIR l _) r->PAIR l r) f) d\\(Option s r f d)<-bs]
  65 //topair fr to (NoArg fa) = NoArg \a->case fa (fr a) of
  66 //              Ok na = Ok (to a na)
  67 //              Error e = Error e
  68 //topair fr to (ReqArg fa d) = ReqArg (\s a->case fa s (fr a) of
  69 //              Ok na = Ok (to a na)
  70 //              Error e = Error e) d
  71 //topair fr to (OptArg fa d) = OptArg (\s a->case fa s (fr a) of
  72 //              Ok na = Ok (to a na)
  73 //              Error e = Error e) d
  74 //
  75 parseOpts :: (Opt a) [String] a -> MaybeError [String] a
  76 parseOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
  77 parseOpts (Positionals [p:ps]) [arg:args] a = p arg a >>= parseOpts (Positionals ps) args
  78 //parseOpts (Options opts) args i
  79 //      # (transformers, positionals, errors) = getOpt Permute [helpopt:opts] args
  80 //      | not (errors =: []) = Error [usageInfo "" [helpopt:opts]:errors]
  81 //      = case folder transformers i of
  82 //              Error e = Error [usageInfo "" [helpopt:opts]:e]
  83 //              Ok a = Ok a
  84 parseOpts _ _ i = Ok i
  85 //
  86 //helpopt = Option [] ["help"] (NoArg \a->Error []) ""
  87 //
  88 //folder [] i = Ok i
  89 //folder [tr:trs] i = tr i >>= folder trs
  90 //
  91 :: T =
  92         { field  :: Bool
  93 //      , field2 :: String
  94         }
  95 //:: T2 = T Int Int
  96 derive bimap Opt, [], (,), MaybeError, Flag
  97 derive gopt T
  98
  99 Start w
 100 # ([argv0:args], w) = getCommandLine w
 101 = t
 102
 103 t :: Opt T
 104 t = gopt{|*|}