1 module Getops where
    2 
    3 import Core_datatype
    4 
    5 import Vtslib
    6 
    7 import Type_defs
    8 
    9 import Edlib
   10 
   11 
   12 
   13 {-
   14 (******************************************************************************)
   15 (*   Syntax of flags:                                                         *)
   16 (*                                                                            *)
   17 (*   flags  ::= '--'                                     *)
   18 (*           '-' option [ flags]                                           *)
   19 (*   option ::= <flag_char>+                                                  *)
   20 (*              <arg_char> <arg>                                              *)
   21 (******************************************************************************)
   22 -}
   23 
   24 
   25 data ArgType = Flag | Arg 
   26 
   27 
   28 
   29 
   30 getops :: [Char] -> [[Char]] -> MayBe ([(Char, Option [Char])], [[Char]]) [Char]
   31 
   32 getops template argL 
   33         = Ok ( [ ('t',SOME "Trm")], ["hello"])
   34 --      = process_flags (gen_pattern template) argL
   35 
   36 
   37 
   38 process_flags :: [(Char, ArgType)] -> [[Char]] 
   39                          -> MayBe ([(Char, Option [Char])], [[Char]]) [Char]
   40 
   41 process_flags pattern [] = Ok ([], [])
   42 
   43 process_flags pattern ("--" : argL) 
   44         = Ok ([], argL)
   45 
   46 {-
   47 process_flags pattern (arg : argL) 
   48         | is_option arg
   49             = process_options pattern True (tail arg) argL |>|
   50               process_flags pattern                        |@|
   51               ( \ ( opts' , opts ) argL' -> Ok (opts' ++ opts, argL'))  
   52         | otherwise 
   53             = Ok ([], arg : argL)
   54 -}
   55 
   56 
   57 
   58 
   59 
   60 process_options :: [(Char, ArgType)] -> Bool -> [Char] -> [a] 
   61                                 -> MayBe ([(Char, Option a)], [a]) [Char]
   62 
   63 process_options pattern allow_arg (opt : optL) argL 
   64         = case (assoc opt pattern, (allow_arg, optL, argL)) of
   65               (NONE,_)  -> Bad ( "Bad option: " <: opt )
   66               (SOME Flag,_) 
   67                         -> process_options pattern False optL argL        |@|
   68                            ( \ opts argL' -> Ok ((opt,NONE):opts, argL') )
   69                            
   70               (SOME Arg, (True,[],arg:argL)) 
   71                         -> Ok ([(opt,SOME arg)], argL)
   72               (SOME Arg, (True,[],[])) 
   73                         -> Bad (opt : " requires an argument")
   74               (SOME Arg, _) 
   75                         -> Bad ("Option syntax error")
   76 
   77 process_options pattern allow_arg "" argL = Ok ([],argL)
   78 
   79 
   80 
   81 
   82 
   83 is_option :: [Char] -> Bool
   84 
   85 is_option ( '-' : _ ) = True 
   86 
   87 is_option _ = False
   88             
   89 
   90 
   91 
   92 
   93 gen_pattern :: [Char] -> [(Char, ArgType)]
   94 
   95 gen_pattern [] = []
   96 
   97 gen_pattern (opt : ':' : optL) 
   98         = (opt,Arg) : gen_pattern optL
   99 
  100 gen_pattern (opt : optL) 
  101         = (opt,Flag) : gen_pattern optL
  102 
  103 
  104 
  105 
  106 
  107 {-
  108 assoc _ [] = NONE 
  109 
  110 assoc x ((y,z):l) 
  111         | x==y = SOME z 
  112         | x/=y = assoc x l
  113 -}
  114 
  115