(* pa_refutable : Camlp4 (3.10) Syntax extension

This extension enables an explicit use of non-irrefutable pattern matching in a "let" declaration :
let refutable hd::tl = my_list
let refutable [a; b; c] = List.map foo ['a'; 'b'; 'c']
let rec refutable func (Some thing) = ...

This may be useful when you have to manipulate lists whose you're sure
they're non-empty (as in the second example), or functions that are only defined on
one constructor of a type (List.hd, List.tl, etc.) : you won't have to handle the error case yourself,
but you won't have a warning from the compiler (which is cumbersome in this case, but useful in others)

Compilation :
ocamlc -I +camlp4 camlp4lib.cma -pp camlp4rf -c pa_refutable.ml -o pa_refutable.cmo

Use :
camlp4o pa_refutable.cmo test.ml
ocamlc -pp 'camlp4o pa_refutable.cmo' test.ml

Could be improved :
- the error handling is a bit ad-hoc : is there a way to do better ?
- binds_patt and bind_expr are quite repetitive : how could i factorize that part ?
- the "rec" handling is awkward, but using opt_rec raised problems : non-refutable declarations wouldn't work anymore

*)

(* Copyright (C) 2007-

      Author: Bluestorm
      email: bluestorm dot dylc on-the-server gmail dot com

   This library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Lesser General Public
   License as published by the Free Software Foundation; either
   version 2 of the License, or (at your option) any later version.

   This library is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public
   License along with this library; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
*)

(*
  Implementation :
  
  I distinct two cases : refutable parameters of a function (let foo (hd::tl) = ...),
  and the immediate pattern (let hd::tl = ...).
  
  The first case is handled by refutable_func :
  function parameters are recursively traversed,
  and each refutable parameter is changed into a 'function'
  handling the match failure :
    let refutable foo (hd::tl) = ...
    translates to
    let foo = function (hd::tl) -> ... | _ -> failwith ...
  
  The second case is a bit trickier : by folding the AST,
  i get a list of identifiers bounded by the pattern.
  Then the refutable binding is replaced by a tuple binding the same identifiers :
    let refutable hd::tl = foo
    translates to
    let (hd, tl) = (match foo with hd::tl -> (hd, tl) | _ -> failwith ...)
*)

open Camlp4;

module Id : Sig.Id = struct
  value name = "Refutable let";
  value version = "0.4";
end;

module Make (Syntax : Sig.Camlp4Syntax) = struct
  open Sig;
  include Syntax;

  value refutable_err patt =
    let _loc = Ast.loc_of_patt patt in
    let err =
      Printf.sprintf "Refutable pattern failed (%s)"
        (String.escaped (Loc.to_string _loc)) in
    <:expr< failwith $str:err$ >> ;
  
  value refutable_func decl =
    let rec rebuild = fun
    [ <:expr@_loc< fun $p$ -> $e$ >> ->
        if Ast.is_irrefut_patt p
        then <:expr< fun $p$ -> $rebuild e$ >>
        else <:expr< fun [ $p$ -> $rebuild e$ | _ -> $refutable_err p$ ] >>
    | body -> body ]
    in rebuild decl ;

  value refutable_mono patt expr _loc =
    let id_folder = object
      inherit Ast.fold as super;
      value binds = [];
      method get_binds = binds;
      method patt = fun
      [ <:patt@loc< $lid:id$ >> -> {< binds = [(id, loc) :: binds] >}
      | p -> super#patt p ];
    end in
    let binds = (id_folder#patt patt)#get_binds in
    let (binds_patt, binds_expr) =
      let patt_of_id (id, _loc) = <:patt< $lid:id$ >> in
      let expr_of_id (id, _loc) = <:expr< $lid:id$ >> in
      match binds with
      [ [] -> ( <:patt< () >> , <:expr< () >> )
      | [hd] -> ( patt_of_id hd, expr_of_id hd )
      | [hd::tl] ->
         ( <:patt< ( $patt_of_id hd$, $list:List.map patt_of_id tl$ ) >>,
           <:expr< ( $expr_of_id hd$, $list:List.map expr_of_id tl$ ) >> ) ]
    in
    <:binding< $binds_patt$ = match $expr$ with
                  [ $patt$ -> $binds_expr$
                  | _ -> $refutable_err patt$ ] >> ;

  value refutable = fun
  [ <:binding@_loc< $p$ = $e$ >> ->
    if Ast.is_irrefut_patt p
    then <:binding< $p$ = $refutable_func e$ >>
    else refutable_mono p e _loc
  | _ -> assert False ];


  EXTEND Gram
    expr: LEVEL "top" [[
      "let"; r = opt_rec; "refutable"; bi = binding; "in"; x = expr LEVEL ";" ->
       <:expr< let $rec:r$ $refutable bi$ in $x$ >>
    ]];

    str_item: LEVEL "top" [[
      "let"; r = opt_rec; "refutable"; bi = binding; "in"; x = expr ->
        <:str_item< let $rec:r$ $refutable bi$ in $x$ >>
    | "let"; r = opt_rec; "refutable"; bi = binding ->
        <:str_item< value $rec:r$ $refutable bi$ >>
    ]];
  END;
end;

let module M = Register.OCamlSyntaxExtension Id Make in ();