(* camlp4r q_MLast.cmo pa_extend.cmo *)
(* $Id$ *)

open Pcaml;

value not_impl name x =
  let desc =
    if Obj.is_block (Obj.repr x) then
      "tag = " ^ string_of_int (Obj.tag (Obj.repr x))
    else "int_val = " ^ string_of_int (Obj.magic x)
  in
  do {
    print_newline (); failwith ("pa_extfun: not impl " ^ name ^ " " ^ desc)
  }
;

value rec mexpr p =
  let loc = MLast.loc_of_patt p in
  match p with
  [ <:patt< $p1$ $p2$ >> ->
      loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
        fun
        [ <:patt< $p1$ $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
        | p -> <:expr< Extfun.Eapp [$mexpr p$ :: $el$] >> ]
  | <:patt< $p1$ . $p2$ >> ->
      loop <:expr< [$mexpr p2$] >> p1 where rec loop el =
        fun
        [ <:patt< $p1$ . $p2$ >> -> loop <:expr< [$mexpr p2$ :: $el$] >> p1
        | p -> <:expr< Extfun.Eacc [$mexpr p$ :: $el$] >> ]
  | <:patt< ($list:pl$) >> -> <:expr< Extfun.Etup $mexpr_list loc pl$ >>
  | <:patt< $uid:id$ >> -> <:expr< Extfun.Econ $str:id$ >>
  | <:patt< ` $id$ >> -> <:expr< Extfun.Econ $str:id$ >>
  | <:patt< $int:s$ >> -> <:expr< Extfun.Eint $str:s$ >>
  | <:patt< $str:s$ >> -> <:expr< Extfun.Estr $str:s$ >>
  | <:patt< ($p1$ as $_$) >> -> mexpr p1
  | <:patt< $lid:_$ >> -> <:expr< Extfun.Evar () >>
  | <:patt< _ >> -> <:expr< Extfun.Evar () >>
  | <:patt< $p1$ | $p2$ >> ->
      Stdpp.raise_with_loc loc (Failure "or patterns not allowed in extfun")
  | p -> not_impl "mexpr" p ]
and mexpr_list loc =
  fun
  [ [] -> <:expr< [] >>
  | [e :: el] -> <:expr< [$mexpr e$ :: $mexpr_list loc el$] >> ]
;

value rec catch_any =
  fun
  [ <:patt< $uid:id$ >> -> False
  | <:patt< ` $_$ >> -> False
  | <:patt< $lid:_$ >> -> True
  | <:patt< _ >> -> True
  | <:patt< ($list:pl$) >> -> List.for_all catch_any pl
  | <:patt< $p1$ $p2$ >> -> False
  | <:patt< $p1$ | $p2$ >> -> False
  | <:patt< $int:_$ >> -> False
  | <:patt< $str:_$ >> -> False
  | <:patt< ($p1$ as $_$) >> -> catch_any p1
  | p -> not_impl "catch_any" p ]
;

value conv (p, wo, e) =
  let tst = mexpr p in
  let loc = (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr e)) in
  let e =
    if wo = None && catch_any p then <:expr< fun $p$ -> Some $e$ >>
    else <:expr< fun [ $p$ $when:wo$ -> Some $e$ | _ -> None ] >>
  in
  let has_when =
    match wo with
    [ Some _ -> <:expr< True >>
    | None -> <:expr< False >> ]
  in
  <:expr< ($tst$, $has_when$, $e$) >>
;

value rec conv_list tl =
  fun
  [ [pe :: pel] ->
      let loc = MLast.loc_of_expr tl in
      <:expr< [$conv pe$ :: $conv_list tl pel$] >>
  | [] -> tl ]
;

value rec split_or =
  fun
  [ [(<:patt< $p1$ | $p2$ >>, wo, e) :: pel] ->
      split_or [(p1, wo, e); (p2, wo, e) :: pel]
  | [(<:patt< ($p1$ | $p2$ as $p$) >>, wo, e) :: pel] ->
      let p1 =
        let loc = MLast.loc_of_patt p1 in
        <:patt< ($p1$ as $p$) >>
      in
      let p2 =
        let loc = MLast.loc_of_patt p2 in
        <:patt< ($p2$ as $p$) >>
      in
      split_or [(p1, wo, e); (p2, wo, e) :: pel]
  | [pe :: pel] -> [pe :: split_or pel]
  | [] -> [] ]
;

EXTEND
  GLOBAL: expr;
  expr: LEVEL "top"
    [ [ "extfun"; e = SELF; "with"; "["; list = match_case_list; "]" ->
          <:expr< Extfun.extend $e$ $list$ >> ] ]
  ;
  match_case_list:
    [ [ pel = LIST0 match_case SEP "|" ->
          conv_list <:expr< [] >> (split_or pel) ] ]
  ;
  match_case:
    [ [ p = patt; aso = OPT [ "as"; p = patt -> p ];
        w = OPT [ "when"; e = expr -> e ]; "->"; e = expr ->
          let p =
            match aso with
            [ Some p2 -> <:patt< ($p$ as $p2$) >>
            | _ -> p ]
          in
          (p, w, e) ] ]
  ;
END;