gopt.icl

   1 module gopt
   2
   3 import StdEnv, StdGeneric
   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, 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 (appSnd $ 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 //generic gopt a :: Opt a
  40 gopt{|Bool|} = BinaryFlag (const True) (const False)
  41 gopt{|Int|} = Positionals [("INT", \s _->if (and [isDigit c\\c<-:s]) (Ok $ toInt s) (Error ["Not an integer"]))]
  42 gopt{|Char|} = Positionals [("CHAR", \s _->if (size s == 1) (Ok s.[0]) (Error ["Not a single character"]))]
  43 gopt{|String|} = Positionals [("STRING", \s _->Ok s)]
  44 gopt{|RECORD|} f = bifmap (\(RECORD a)->a) (\x->RECORD x) f
  45 gopt{|OBJECT|} f = bifmap (\(OBJECT a)->a) (\x->OBJECT x) f
  46 gopt{|FIELD of {gfd_name}|} f = case f of
  47         //Child is a boolean
  48         BinaryFlag set unset = mapF $ Flags [(gfd_name, ar0 gfd_name set), ("no-" +++ gfd_name, ar0 ("no-" +++ gfd_name) unset)]
  49         //Child is a basic value or a tuple
  50         Positionals ps = mapF $ Flags [(gfd_name, ptoarg ps)]
  51         //Child is another record, make the arguments ddstyle TODO
  52         Flags x = mapF (Flags x)
  53         //Child is a subparser
  54         SubParsers ps = mapF (Flags [(gfd_name, pOpts (SubParsers ps))])
  55         x = abort "Subparsers not supported"
  56 where
  57         mapF :: ((m a) -> m (FIELD a)) | bifmap m
  58         mapF = bifmap (\(FIELD a)->a) (\x->FIELD x)
  59
  60         ptoarg [p] [] i = Error ["Not enough arguments for " +++ gfd_name]
  61         ptoarg [(_, p):ps] [a:as] i = p a i >>= ptoarg ps as
  62         ptoarg [] as i = Ok (i, as)
  63 gopt{|PAIR|} l r = case (l, r) of
  64         (Positionals pl, Positionals pr)
  65                 = Positionals
  66                         $  map (appSnd $ combine PFst appPFst) pl
  67                         ++ map (appSnd $ combine PSnd appPSnd) pr
  68         (Flags fl, Flags fr)
  69                 = Flags
  70                         $  map (appSnd $ combine` PFst appPFst) fl
  71                         ++ map (appSnd $ combine` PSnd appPSnd) fr
  72         (x, y) = abort $ "gopt{|PAIR|}: " +++ consPrint x +++ " " +++ consPrint y
  73 where
  74         appPFst f (PAIR x y) = PAIR (f x) y
  75         appPSnd f (PAIR x y) = PAIR x (f y)
  76         PFst (PAIR x y) = x
  77         PSnd (PAIR x y) = y
  78 gopt{|UNIT|} = Positionals []
  79 gopt{|CONS of {gcd_name}|} c = bifmap (\(CONS a)->a) CONS $ SubParsers [(gcd_name, c)]
  80 gopt{|EITHER|} l r = case (l, r) of
  81         (SubParsers sl, SubParsers sr)
  82                 = SubParsers
  83                         $  map (appSnd $ bifmap (\(LEFT a)->a) LEFT) sl
  84                         ++ map (appSnd $ bifmap (\(RIGHT a)->a) RIGHT) sr
  85 gopt{|(,)|} l r = case (l, r) of
  86         (Positionals pl, Positionals pr)
  87                 = Positionals
  88                         $  map (appSnd $ combine fst appFst) pl
  89                         ++ map (appSnd $ combine snd appSnd) pr
  90 gopt{|(,,)|} f s t = case (f, s, t) of
  91         (Positionals pf, Positionals ps, Positionals pt)
  92                 = Positionals
  93                         $  map (appSnd $ combine fst3 appFst3) pf
  94                         ++ map (appSnd $ combine snd3 appSnd3) ps
  95                         ++ map (appSnd $ combine thd3 appThd3) pt
  96
  97 consPrint (Positionals x) = "Positionals"
  98 consPrint (BinaryFlag x _) = "BinaryFlag"
  99 consPrint (Flags x) = "Flags"
 100 consPrint (SubParsers x) = "SubParsers"
 101
 102 parseOpts :: [String] a -> MaybeError [String] (a, [String]) | gopt{|*|} a
 103 parseOpts args a = pOpts gopt{|*|} args a
 104
 105 pOpts :: (Opt a) [String] a -> MaybeError [String] (a, [String])
 106 pOpts (Positionals [p:ps]) [] a = Error [toString (length [p:ps]) +++ " positional arguments required"]
 107 pOpts (Positionals [p:ps]) [arg:args] a = (snd p) arg a >>= pOpts (Positionals ps) args
 108 pOpts (SubParsers ps) [arg:args] a = case find (\(l,p)->l==arg) ps of
 109         Nothing = Error ["Unrecognized subcommand"]
 110         Just (l, p) = pOpts p args a
 111 pOpts (SubParsers ps) [] a = Error ["One of these subcommands required: " +++ join ", " (map fst ps)]
 112 pOpts (Flags fs) [arg:args] a
 113         | not (startsWith "--" arg) = Ok (a, [arg:args])
 114         = case find (\(l,p)->"--" +++ l == arg) fs of
 115                 Nothing = Error ["Unrecognized option: " +++ arg]
 116                 Just (l, p) = p args a >>= \(a, args)->pOpts (Flags fs) args a
 117 pOpts (BinaryFlag yes no) args a
 118         = pOpts (Positionals [("BOOL", \s v->
 119                 if (s == "True")
 120                         (Ok (yes v))
 121                         (if (s == "False")
 122                                 (Ok (no v))
 123                                 (Error ["Not True or False"])
 124                         )
 125         )]) args a
 126 pOpts t args a = Ok (a, args)
 127
 128 pHelp :: (Opt a) -> [String]
 129 pHelp (Positionals []) = []
 130 pHelp (Positionals [(i, _):ps]) = [i, " ":pHelp $ Positionals ps]
 131 pHelp (SubParsers ps) =
 132         flatten
 133         [[n, " ":pHelp opt] ++ ["\n"]
 134         \\(n, opt)<-ps
 135         ]
 136 pHelp (Flags fs) =
 137         ["Flags\n"
 138         :
 139                 flatten
 140                 [["--",f, "\n"]
 141                 \\(f, p)<-fs
 142                 ]
 143         ]
 144
 145 :: T =
 146         { field  :: (Int,Int)
 147         , field2 :: String
 148         , t2 :: C
 149         }
 150 :: T2 = {f :: Int, f2 :: Bool}
 151 :: C = A Int | B | C Bool
 152
 153 :: ADT
 154         = ADT1
 155         | ADT2 Int String
 156
 157 derive binumap Opt, [], (,), MaybeError
 158 derive gopt T, T2, ADT, C
 159
 160 Start w
 161 # ([argv0:args], w) = getCommandLine w
 162 //= pHelp opt
 163 = parseOpts args {field=(0, 0),field2="",t2=A 4}
 164
 165 opt :: Opt T
 166 opt = gopt{|*|}