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 Data.Maybe
  11 import Control.Applicative
  12 import Control.Monad => qualified join
  13 import System.CommandLine
  14 import Text
  15
  16 :: Opt a
  17         = BinaryFlag (a -> a) (a -> a)
  18         | Flags [(String, ([String] a -> (MaybeError [String] (a, [String]))))]
  19         | Positionals [String a -> (MaybeError [String] a)]
  20         | SubParsers [(String, Opt a)]
  21
  22 class bifmap m :: (a -> b) (b -> a) (m b) -> m a
  23 instance bifmap Opt
  24 where
  25         bifmap fr to (BinaryFlag set unset) = BinaryFlag (to o set o fr) (to o unset o fr)
  26         bifmap fr to (Flags fs) = Flags $ map (appSnd $ (\f s->fm (appFst to) o f s o fr)) fs
  27         bifmap fr to (Positionals fs) = Positionals $ map (fmap $ \f->fm to o f o fr) fs
  28         bifmap fr to (SubParsers sp) = SubParsers $ map (appSnd (bifmap fr to)) sp
  29
  30 fm f (Ok a) = Ok (f a)
  31 fm f (Error e) = Error e
  32
  33 combine sel app p s t = p s (sel t) >>= \l->pure (app (const l) t)
  34 combine` sel app p s t = p s (sel t) >>= \(l, as)->pure ((app (const l) t), as)
  35
  36 ar0 s f as = Ok o flip tuple as o f
  37
  38 generic gopt a :: Opt a
  39 gopt{|Bool|} = BinaryFlag (const True) (const False)
  40 gopt{|Int|} = Positionals [\s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"])]
  41 gopt{|Char|} = Positionals [\s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"])]
  42 gopt{|String|} = Positionals [\s _->Ok s]
  43 gopt{|RECORD|} f = bifmap (\(RECORD a)->a) RECORD f
  44 gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) OBJECT f
  45 gopt{|FIELD of {gfd_name}|} f = case f of
  46         //Child is a boolean
  47         BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
  48         //Child is a basic value or a tuple
  49         Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
  50         //Child is another record, make the arguments ddstyle TODO
  51         Flags x = mapF (Flags x)
  52         //Child is a subparser
  53         x = abort "Subparsers not supported"
  54 where
  55         mapF :: ((m a) -> m (FIELD a)) | bifmap m
  56         mapF = bifmap (\(FIELD a)->a) FIELD
  57
  58         ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
  59         ptoarg [p:ps] [a:as] i = p a i >>= ptoarg ps as
  60         ptoarg [] as i = Ok (i, as)
  61 gopt{|PAIR|} l r = case (l, r) of
  62         (Positionals pl, Positionals pr)
  63                 = Positionals
  64                         $  map (combine PFst appPFst) pl
  65                         ++ map (combine PSnd appPSnd) pr
  66         (Flags fl, Flags fr)
  67                 = Flags
  68                         $  map (appSnd $ combine` PFst appPFst) fl
  69                         ++ map (appSnd $ combine` PSnd appPSnd) fr
  70 where
  71         appPFst f (PAIR x y) = PAIR (f x) y
  72         appPSnd f (PAIR x y) = PAIR x (f y)
  73         PFst (PAIR x y) = x
  74         PSnd (PAIR x y) = y
  75 gopt{|UNIT|} = Positionals []
  76 gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
  77 gopt{|EITHER|} l r = case (l, r) of
  78         (SubParsers sl, SubParsers sr)
  79                 = SubParsers
  80                         $  map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
  81                         ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
  82 gopt{|(,)|} l r = case (l, r) of
  83         (Positionals pl, Positionals pr)
  84                 = Positionals
  85                         $  map (combine fst appFst) pl
  86                         ++ map (combine snd appSnd) pr
  87 gopt{|(,,)|} f s t = case (f, s, t) of
  88         (Positionals pf, Positionals ps, Positionals pt)
  89                 = Positionals
  90                         $  map (combine fst3 appFst3) pf
  91                         ++ map (combine snd3 appSnd3) ps
  92                         ++ map (combine thd3 appThd3) pt
  93
  94 consPrint (Positionals x) = "Positionals"
  95 consPrint (BinaryFlag x _) = "BinaryFlag"
  96 consPrint (Flags x) = "Flags"
  97 consPrint (SubParsers x) = "SubParsers"
  98
  99 parseOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
 100 parseOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
 101 parseOpts (Positionals [p:ps]) [arg:args] a = p arg a >>= parseOpts (Positionals ps) args
 102 parseOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
 103         Nothing = Error ["Unrecognized subcommand"]
 104         Just (l, p) = parseOpts p args a
 105 parseOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
 106 parseOpts (Flags fs) [arg:args] a
 107         | not (startsWith "--" arg) = Ok (a, [arg:args])
 108         = case find (\(l,p)->"--" +++ l == arg) fs of
 109                 Nothing = Error ["Unrecognized option: " +++ arg]
 110                 Just (l, p) = p args a >>= \(a, args)->parseOpts (Flags fs) args a
 111 parseOpts _ args a = Ok (a, args)
 112
 113 :: T =
 114         { field  :: (Int,Int)
 115         , field2 :: String
 116         , t2 :: C
 117         }
 118 :: T2 = {f :: Int}
 119 :: C = A Int | B | C
 120 //:: T2 = T Int Int
 121 derive bimap Opt, [], (,), MaybeError
 122 derive gopt T, T2, C
 123
 124 Start w
 125 # ([argv0:args], w) = getCommandLine w
 126 = parseOpts t args B//{field=(0, 0),field2="",t2=A}
 127
 128 t :: Opt C
 129 t = gopt{|*|}