1: %{ 2: (* parser header *) 3: exception EndOfInput 4: open Flx_ast 5: open Flx_mtypes1 6: open Flx_typing 7: open Flx_typing2 8: open Flx_srcref 9: open Flx_print 10: open Flx_charset 11: open Flx_exceptions 12: open List 13: open Flx_util 14: 15: let list_last lst = List.hd (List.rev lst) 16: let generated = ("Generated by Parser",0,0,0,0) 17: let parse_error (s : string) = 18: raise (Flx_exceptions.ParseError "Error parsing input") 19: 20: (* model infix operator as function call *) 21: let apl2 (sri:srcref) (fn : string) (tup:expr_t list) = 22: let sr = rslist tup in 23: `AST_apply 24: ( 25: sr, 26: ( 27: `AST_name (slift sri,fn,[]), 28: `AST_tuple (sr,tup) 29: ) 30: ) 31: 32: (* model prefix operator as function call *) 33: let apl (sri:srcref) (fn : string) (arg:expr_t):expr_t = 34: let sr = src_of_expr arg in 35: `AST_apply 36: ( 37: sr, 38: ( 39: `AST_name (slift sri, fn,[]), 40: arg 41: ) 42: ) 43: 44: (* model unary operator as procedure call *) 45: let call1 (op:string) (sr:range_srcref) (sri:srcref) l = 46: `AST_call 47: ( 48: sr, `AST_name (slift sri, op,[]), l 49: ) 50: 51: (* model unary operator as procedure call *) 52: let call2 (op:string) (sr:range_srcref) (sri:srcref) l r = 53: `AST_call 54: ( 55: sr, 56: `AST_name (slift sri, op,[]), 57: `AST_tuple(sr,[l;r]) 58: ) 59: 60: let mkcurry sr name vs (args:params_t list) return_type kind body = 61: `AST_curry (sr,name,vs,args,return_type,kind,body) 62: 63: let cal_funkind adjs fk = 64: match fk with 65: | sr,`CFunction -> sr,`CFunction 66: | sr,`Generator -> sr,`Generator 67: | sr,`Function -> match adjs with 68: | [] -> sr,`Function 69: | h :: t -> sr,snd h 70: 71: (* handle curried type functions *) 72: let mktypefun sr name vs (args: (string * typecode_t) list list) return_type body = 73: let argtyp t = match t with 74: | [] -> failwith "Lambda abstraction requires nonunit parameter" 75: | [x] -> x 76: | x -> `TYP_type_tuple x 77: in 78: let body = 79: let p = ref (List.rev args) in 80: let r = ref return_type in 81: let b = ref body in 82: while !p <> [] do 83: let arg = List.hd !p in 84: p := List.tl !p; 85: b := `TYP_typefun (arg, !r, !b); 86: r := `TYP_function(argtyp (List.map snd (arg)),!r) 87: done; 88: !b 89: in 90: `AST_type_alias 91: ( 92: sr, 93: name, 94: vs, 95: body 96: ) 97: 98: let dfltvs = 99: [], 100: { 101: raw_type_constraint=`TYP_tuple []; 102: raw_typeclass_reqs=[] 103: } 104: 105: %} 106: