A type-conv syntax extension to convert constant constructors into consecutive integers.

ty_enum_to_int.ml

(*pp camlp4orf *)

(* ty_enum_to_int : Camlp4 (3.10) Syntax extension
    type test = | A | B | C | D with to_int 
translates to :
   type test = | A | B | C | D
   let test_to_int = function | A -> 0 | B -> 1 | C -> 2 | D -> 3
   let test_of_int = function | 0 -> A | 1 -> B | 2 -> C | 3 -> D

Compilation command :
ocamlfind ocamlc -package camlp4,type-conv -pp camlp4orf -c ty_enum_to_int.ml

Use command :
camlp4o `ocamlfind query -i-format type-conv`\
 pa_type_conv.cmo ty_enum_to_int.cmo test.ml


*)

(* 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
*)

open Camlp4.PreCast

let error ty msg =
  failwith (Pa_type_conv.get_loc_err (Ast.loc_of_ctyp ty) msg)

let sum name ty =
  let rec items = function
  | <:ctyp@loc< $a$ | $b$ >> -> items a @ items b
  | <:ctyp@loc< $uid:constr$ >> -> [constr, 0, loc]
  | <:ctyp@loc< $uid:constr$ of $args$ >> ->
    let rec arity = function
    | <:ctyp< $a$ and $b$ >> -> arity a + arity b
      | _ -> 1
    in [constr, arity args, loc]
  | ty -> error ty "invalid sum part"
  in

  let to_int i (constr, arity, _loc) =
    let patt =
      Array.fold_left (fun p () -> <:patt< $p$ _ >> )
        <:patt< $uid:constr$ >> (Array.make arity ())
    in <:match_case< $patt$ -> $`int:i$ >>
  and of_int i (constr, arity, _loc) =
    let expr =
      if arity = 0 then <:expr< $uid:constr$ >>
      else <:expr< failwith $`str:"can't convert to a constructor \
                                   with parameters: " ^ constr$ >>
    in <:match_case< $`int:i$ -> $expr$ >>
  in
  
  let tab = Array.of_list (items ty) in
  let match_list f = Ast.mcOr_of_list (Array.to_list (Array.mapi f tab)) in
  let _loc = Ast.loc_of_ctyp ty in
  let error = <:expr< $lid:"invalid_argument"$ $`str:name ^ "_of_int"$ >> in
  <:expr< fun [ $match_list to_int$ ] >>,
  <:expr< fun [ $match_list of_int$ | _ -> $error$ ] >>


let merge _loc f a b = <:str_item< $f a$; $f b$ >>

let generator ctyp =
  let extract name = function
  | <:ctyp@_loc< [ $ty$ ] >> ->
    let to_int, of_int = sum name ty in
    <:str_item< value $lid:name ^ "_to_int"$ = $to_int$;
                value $lid:name ^ "_of_int"$ = $of_int$ >>
  | other -> error other "type declaration non-compatible with to_int"
  in
  
  let rec reduce = function
  | <:ctyp@loc< $a$ and $b$ >> -> merge loc reduce a b
  | Ast.TyDcl (_, name, _, decl, _) -> extract name decl
  | ty -> error ty "invalid type part"
  in
  reduce ctyp

let () = Pa_type_conv.add_generator "to_int" generator