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