#load "pa_extend.cmo" ;;
#load "q_MLast.cmo" ;;

(* 
   pa_records.ml:
   Camlp4 syntax extension for record expressions and pattern-matching
   
   see http://oandrieu.nerim.net/ocaml/index.html#pa_records 
   © Olivier Andrieu, 2002
*)

let rec list_last = function
  | [] -> failwith "empty list"
  | [ x ] -> x
  | _ :: n -> list_last n


(* ************************************************** *)
(*    PATTERNS                                        *)
(* ************************************************** *)

let collapse_id loc li = 
  List.fold_left
    (fun acc i ->
      <:patt< $acc$ . $i$ >>) 
    (List.hd li) (List.tl li)

let prepend_n_collapse loc uids field_pats =
  List.map
    (fun (f, p) ->
      (collapse_id loc (uids @ f), p))
    field_pats

EXTEND
  GLOBAL: Pcaml.patt ; 

  Pcaml.patt: LEVEL "simple" 
    [ [ s = UIDENT ; "." ; (ul, ro) = uid_or_field_patt_list ->
        let u = <:patt< $uid:s$ >> in
        begin match ro with
        | None -> collapse_id loc (u :: ul)
        | Some lpl ->
	    let lpl' = prepend_n_collapse loc (u :: ul) lpl in
            <:patt< { $list:lpl'$ } >>
        end
      | "{" ; lpl = field_patt_list; "}" ->
	  let lpl' = prepend_n_collapse loc [] lpl in
          <:patt< { $list:lpl'$ } >> ] ] ;

  uid_or_field_patt_list:
    [ [ s = UIDENT ; "." ; (ul, ro) = SELF ->
        ( <:patt< $uid:s$ >> :: ul, ro )
      | "{" ; lpl = field_patt_list; "}" ->
	( [], Some lpl)
      | s = UIDENT ->
	( [ <:patt< $uid:s$ >> ], None) ] ] ; 

  field_patt_list: 
    [ [ le = field_patt; ";"; lel = SELF -> le :: lel
      | le = field_patt; ";" -> [le] 
      | le = field_patt -> [le] ] ] ;

  field_patt:
    [ [ ul = patt_field_ident; "="; p = Pcaml.patt -> 
        ( ul, p )
      | ul = patt_field_ident ->
        ( ul, list_last ul ) 
    ] ] ;

  patt_field_ident:
    [ [ u = UIDENT; "." ; ul = SELF ->
        <:patt< $uid:u$ >> :: ul 
      | p = LIDENT -> 
        [ <:patt< $lid:p$ >> ] 
    ] ] ; 

END


(* ************************************************** *)
(*    EXPRESSIONS                                     *)
(* ************************************************** *)

let collapse_id_expr loc = function
  | u :: n ->
      List.fold_left
	(fun acc i ->
	  <:expr< $acc$ . $uid:i$ >>)
	<:expr< $uid:u$ >> n
  | _ -> invalid_arg "collapse_id_expr"

let collapse_id_patt loc = function
  | u :: n ->
      List.fold_left
	(fun acc i ->
	  <:patt< $acc$ . $uid:i$ >>)
	<:patt< $uid:u$ >> n
  | _ -> invalid_arg "collapse_id_patt"

let prepend_n_collapse loc uids field_pats =
  List.map
    (fun (f, e) ->
      (collapse_id_patt loc (uids @ f), e))
    field_pats

let stream_peek_nth n strm =
  let toks = Stream.npeek n strm in
  try Some (List.nth toks (pred n))
  with Failure _ -> None

let test_no_with =
  let rec test lev strm =
    match stream_peek_nth lev strm with
    | Some ("", "(") 
    | Some ("", "with") -> raise Stream.Failure
    | Some (("UIDENT", _) | ("LIDENT", _) | ("", "."))  ->  
	test (succ lev) strm
    | _ -> ()
  in
  Grammar.Entry.of_parser Pcaml.gram "test_no_with" (test 1)

let test_accolade =
  let rec test lev strm =
    match stream_peek_nth lev strm with
    | Some (("UIDENT", _) | ("", ".")) -> test (succ lev) strm
    | Some ("", "{") -> ()
    | _  -> raise Stream.Failure
  in
  Grammar.Entry.of_parser Pcaml.gram "test_accolade" (test 1)


type field_info = (string list * MLast.expr) list
type record_info =
  | No_record
  | Simple_record of field_info
  | With_record of field_info * MLast.expr

EXTEND
  GLOBAL: Pcaml.expr ; 

  Pcaml.expr: LEVEL "." 
    [ [ test_accolade ; s = UIDENT ; "." ; (ul, ro) = uid_or_field_expr_list ->
        begin match ro with
        | No_record -> collapse_id_expr loc (s :: ul)
        | Simple_record lpl ->
	    let lpl' = prepend_n_collapse loc (s :: ul) lpl in
            <:expr< { $list:lpl'$ } >>
        | With_record (lpl, e) ->
	    let lpl' = prepend_n_collapse loc (s :: ul) lpl in
            <:expr< { ($e$) with $list:lpl'$ } >>
        end ] ] ;

  Pcaml.expr: LEVEL "simple"
    [ [ "{" ; test_no_with; lpl = field_expr_list; "}" ->
	  let lpl' = prepend_n_collapse loc [] lpl in
          <:expr< { $list:lpl'$ } >> 
      | "{"; e = Pcaml.expr LEVEL "."; "with"; lel = field_expr_list; "}" ->
	  let lel' = prepend_n_collapse loc [] lel in
          <:expr< { ($e$) with $list:lel'$ } >> ] ] ;

  uid_or_field_expr_list:
    [ [ s = UIDENT ; "." ; (ul, ro) = SELF ->
        ( s :: ul, ro)
      | "{" ; test_no_with; lpl = field_expr_list; "}" ->
	( [], Simple_record lpl)
      | "{"; e = Pcaml.expr LEVEL "."; "with"; lel = field_expr_list; "}" ->
	( [], With_record (lel, e) )
      | s = UIDENT ->
	( [ s ], No_record) ] ] ;

  field_expr_list: 
    [ [ le = field_expr; ";"; lel = SELF -> le :: lel
      | le = field_expr; ";" -> [le] 
      | le = field_expr -> [le] ] ] ;

  field_expr:
    [ [ ul = patt_field_ident; "="; e = Pcaml.expr LEVEL "expr1" -> 
        ( ul, e )
      | ul = patt_field_ident ->
	let p = list_last ul in
        ( ul, <:expr< $lid:p$ >> )
    ] ] ;

  patt_field_ident:
    [ [ u = UIDENT; "." ; ul = SELF -> u :: ul
      | p = LIDENT -> [ p ]
    ] ] ; 


END


(* Local Variables: *)
(* compile-command: "ocamlc -pp camlp4o -c -I +camlp4 pa_records.ml" *)
(* End: *)