5.16.1. Header

Start data section to src/flx_parse.mly[1 /35 ] Next Last
     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: 
End data section to src/flx_parse.mly[1]