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