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.GetOpt
  13 import System.CommandLine
  14 //      = NoArg                   a         // ^   no argument expected
  15 //    | ReqArg (String       -> a) String // ^   option requires argument
  16 //    | OptArg ((Maybe String) -> a) String // ^   optional argument
  17 //
  18 :: Opt a
  19         = Positionals [ArgDescr (a -> *(MaybeError [String] a))]
  20         | Flag (a -> a) (a -> a)
  21         | Options [OptDescr (a -> *(MaybeError [String] a))]
  22
  23 //tr fr to (NoArg fa) = NoArg (fm to o fa o fr)
  24
  25 tr fr to (NoArg fa) = NoArg \a->case fa (fr a) of
  26         Ok a = Ok (to a)
  27         Error e = Error e
  28 tr fr to (ReqArg fa t) = ReqArg (\s a->case fa s (fr a) of
  29         Ok a = Ok (to a)
  30         Error e = Error e) t
  31 tr fr to (OptArg fa t) = OptArg (\ms a->case fa ms (fr a) of
  32         Ok a = Ok (to a)
  33         Error e = Error e) t
  34
  35 generic gopt a :: Opt a
  36 gopt{|Bool|} = Flag (const True) (const False)
  37 gopt{|Int|} = Positionals [ReqArg (\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])) "INT"]
  38 gopt{|Char|} = Positionals [ReqArg (\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])) "CHAR"]
  39 gopt{|String|} = Positionals [ReqArg (\s _->Ok s) "STRING"]
  40 gopt{|RECORD|} f = case f of
  41         Flag set unset = Flag (\(RECORD a)->RECORD (set a)) (\(RECORD a)->RECORD (unset a))
  42         Options opts = Options $ map (\(Option s l f h)->(Option s l (tr (\(RECORD a)->a) RECORD f) h)) opts
  43         Positionals p = Positionals (map (tr (\(RECORD a)->a) RECORD) p)
  44 gopt{|FIELD of {gfd_name}|} f = case f of
  45         Flag set unset = Options
  46                 [Option [] [gfd_name] (mapF (NoArg $ Ok o set)) ""
  47                 ,Option [] ["no-" +++ gfd_name] (mapF (NoArg $ Ok o unset)) ""
  48                 ]
  49         Positionals [p] = Options
  50                 [Option [] [gfd_name] (mapF p) ""]
  51 where
  52         mapF = tr (\(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 (Options opts) args i
  77         # (transformers, positionals, errors) = getOpt Permute [helpopt:opts] args
  78         | not (errors =: []) = Error [usageInfo "" [helpopt:opts]:errors]
  79         = case folder transformers i of
  80                 Error e = Error [usageInfo "" [helpopt:opts]:e]
  81                 Ok a = Ok a
  82 parseOpts _ _ i = Ok i
  83
  84 helpopt = Option [] ["help"] (NoArg \a->Error []) ""
  85
  86 folder [] i = Ok i
  87 folder [tr:trs] i = tr i >>= folder trs
  88
  89 :: T =
  90         { field  :: Maybe Int
  91         , field2 :: String
  92         }
  93 derive bimap Opt, [], (,),OptDescr, ArgDescr, MaybeError
  94 derive gopt T
  95
  96 Start w
  97 # ([argv0:args], w) = getCommandLine w
  98 = parseOpts t args { field = Just 42, field2 = ""}
  99
 100 t :: Opt T
 101 t = gopt{|*|}