Commits

Markus Mottl committed 9fbfac3

Merged type-conv 3.0.4 from OCaml Forge

  • Participants
  • Parent commits 9e986bf

Comments (0)

Files changed (6)

File base/type-conv/Changelog

+2011-09-15:  Fixes to improve package dependency resolution.
+
+2011-08-02:  Added missing module type case for "module type of".
+
+2011-07-04:  Merged with Jane Street version.  API changes:
+
+             Removed functions:
+
+               * Gen.ide
+               * Gen.idp
+
+             Removed location arguments from:
+
+               * type_is_recursive
+               * drop_variance_annotations
+
+2010-12-22:  Merged with Jane Street version.  No code changes.
+
+2010-09-25:  Added a missing type case to type_is_recursive.
+             Thanks to Michael Wawrzoniak <mhw@cs.princeton.edu> for this
+             patch!
+
 2010-07-07:  Major changes for compatibility with OCaml 3.12.
 
 2010-06-03:  Improved determination of type-conv paths.

File base/type-conv/LICENSE.Tywith

----------------------------------------------------------------------------
-Copyright (c) 2004 Martin Sandin
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions
-are met:
-1. Redistributions of source code must retain the above copyright
-   notice, this list of conditions and the following disclaimer.
-2. Redistributions in binary form must reproduce the above copyright
-   notice, this list of conditions and the following disclaimer in the
-   documentation and/or other materials provided with the distribution.
-3. The name of the author may not be used to endorse or promote products
-   derived from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
-IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
-OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
-IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
-NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
-THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
----------------------------------------------------------------------------
+---------------------------------------------------------------------------
+Copyright (c) 2004 Martin Sandin
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. The name of the author may not be used to endorse or promote products
+   derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+---------------------------------------------------------------------------

File base/type-conv/oasis.sh

 
 cat >$HERE/_oasis <<EOF
 #AUTOGENERATED FILE; EDIT oasis.sh INSTEAD
-OASISFormat:  0.1
-OCamlVersion: >= 3.11
+OASISFormat:  0.2
+OCamlVersion: >= 3.12
 Name:         type-conv
-Version:      2.3.0
+Version:      3.0.4
 Synopsis:     support library for preprocessor type conversions
 Authors:      Martin Sandin,
               Markus Mottl,
-              Jane street capital
+              Jane Street Capital, LLC
 License:      LGPL-2.1 with OCaml linking exception
 LicenseFile:  LICENSE
 Plugins:      StdFiles (0.2),
               DevFiles (0.2),
               META (0.2)
-BuildTools:   ocamlbuild
+BuildTools:   ocamlbuild, camlp4o
 XStdFilesAUTHORS: false
 XStdFilesINSTALLFilename: INSTALL
 XStdFilesREADME: false
   Path:               syntax
   Modules:            Pa_type_conv
   FindlibName:        type-conv
-  BuildDepends:       camlp4.lib, camlp4.quotations , camlp4.extend
+  BuildDepends:       camlp4.quotations, camlp4.extend
   CompiledObject:     byte
   XMETAType:          syntax
   XMETARequires:      camlp4

File base/type-conv/syntax/META

 # OASIS_START
-# DO NOT EDIT (digest: b651fcddae83a0b465ce4d37e1e3eb78)
-version = "2.3.0"
+# DO NOT EDIT (digest: 930d721afe073d0e739f92d37dec9f02)
+version = "3.0.4"
 description = "Syntax extension for type-conv"
 requires = "camlp4"
 archive(syntax,preprocessor) = "pa_type_conv.cma"

File base/type-conv/syntax/pa_type_conv.ml

 (* General purpose code generation module *)
 
 module Gen = struct
-
   let gensym =
     let cnt = ref 0 in
-    fun ?(prefix="_x") () ->
+    fun ?(prefix = "_x") () ->
       incr cnt;
       sprintf "%s__%03i_" prefix !cnt
 
-  (* Like ast.exSem_of_list but for application *)
+  (* Like Ast.exSem_of_list but for application *)
   let exApp_of_list l =
-    let rec aux =
-      function
-        | [] -> Ast.ExNil Loc.ghost
-        | [x] -> x
-        | x :: xs ->
-          let loc = Ast.loc_of_expr x
-          in <:expr@loc< $aux xs$ $x$ >>
-    (* App associativity *)
-    in aux (List.rev l)
+    let rec aux = function
+      | [] -> Ast.ExNil Loc.ghost
+      | [x] -> x
+      | x :: xs ->
+        let loc = Ast.loc_of_expr x in
+        <:expr@loc< $aux xs$ $x$ >>
+    in
+    aux (List.rev l)
 
   let rec tyArr_of_list = function
     | [] -> Ast.TyNil Loc.ghost
-    | [ x ] -> x
+    | [x] -> x
     | x :: xs ->
       let loc = loc_of_ctyp x in
       <:ctyp@loc< $x$ -> $tyArr_of_list xs$ >>
 
   let rec paOr_of_list = function
     | [] -> Ast.PaNil Loc.ghost
-    | [ x ] -> x
+    | [x] -> x
     | x :: xs ->
       let loc = loc_of_patt x in
       <:patt@loc< $x$ | $paOr_of_list xs$ >>
 
+  module PP = Camlp4.Printers.OCaml.Make (Syntax)
+  let conv_ctyp = (new PP.printer ())#ctyp
+
   let string_of_ctyp ctyp =
     try
-      let module PP = Camlp4.Printers.OCaml.Make (Syntax) in
-      let conv_ctyp = (new PP.printer ())#ctyp in
-      let buffer    = Buffer.create 32 in
-      Format.bprintf buffer "%a%!" conv_ctyp ctyp;
-      let s = Buffer.contents buffer in
-      Some s
+      let buffer = Buffer.create 32 in
+      Format.bprintf buffer "%a@?" conv_ctyp ctyp;
+      Some (Buffer.contents buffer)
     with _ -> None
 
   let error tp ~fn ~msg =
     let loc = Ast.loc_of_ctyp tp in
-    match string_of_ctyp tp with
-    | Some srep ->
-      Loc.raise loc (Failure (fn ^ ": " ^ msg ^ "\n" ^ srep))
-    | None -> Loc.raise loc (Failure (fn ^ ": " ^ msg))
+    let failure =
+      match string_of_ctyp tp with
+      | Some tp_str -> sprintf "%s: %s\n%s" fn msg tp_str
+      | None -> sprintf "%s: %s" fn msg
+    in
+    Loc.raise loc (Failure failure)
 
   let unknown_type tp fn = error tp ~fn ~msg:"unknown type"
 
   let abstract _loc = List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>)
   let apply _loc = List.fold_left (fun f arg -> <:expr< $f$ $arg$ >>)
 
-  let idp _loc id = <:patt< $lid:id$ >>
-  let ide _loc id = <:expr< $lid:id$ >>
-
   let switch_tp_def ~alias ~sum ~record ~variants ~mani ~nil tp =
     let rec loop = function
       | <:ctyp< private $tp$ >> -> loop tp
     | tp -> error tp ~fn:"get_tparam_id" ~msg:"not a type parameter"
 
   let type_is_recursive type_name tp =
+    let bad_type tp = unknown_type tp "type_is_recursive" in
     let rec loop = function
       | <:ctyp< private $tp$>> -> loop tp
       | <:ctyp< $tp1$ $tp2$ >>
       | <:ctyp< $tp1$ == $tp2$ >>
       | <:ctyp< $tp1$ and $tp2$ >>
       | <:ctyp< $tp1$ & $tp2$ >>
-      | <:ctyp< $tp1$,$tp2$ >>
+      | <:ctyp< $tp1$, $tp2$ >>
+      | <:ctyp< [ < $tp1$ > $tp2$ ] >>
       | <:ctyp< $tp1$ | $tp2$ >> -> loop tp1 || loop tp2
       | <:ctyp< ( $tup:tp$ ) >> | <:ctyp< { $tp$ } >>
       | <:ctyp< [ $tp$ ] >>
       | <:ctyp< $_$ : $tp$ >>
       | <:ctyp< ~ $_$ : $tp$ >>
       | <:ctyp< ? $_$ : $tp$ >>
-      | <:ctyp< < $tp$ ; $..:_$ > >>
+      | <:ctyp< < $tp$; $..:_$ > >>
       | <:ctyp< mutable $tp$ >>
       | <:ctyp< $_$ of & $tp$ >>
       | <:ctyp< $_$ of $tp$ >>
-      | <:ctyp< [ < $_$ > $tp$ ] >>
+      | <:ctyp< $tp$ as $_$ >>
       | <:ctyp< [< $tp$ ] >> | <:ctyp< [> $tp$ ] >> | <:ctyp< [= $tp$ ] >>
       | <:ctyp< ! $_$ . $tp$ >> -> loop tp
       | <:ctyp< $lid:id$ >> -> id = type_name
       | <:ctyp< +'$_$ >>
       | <:ctyp< _ >>
       | <:ctyp< >> -> false
-      |( Ast.TyDcl _
-       | <:ctyp< $_$ as $_$ >>
-       | <:ctyp< (module $_$) >>
-       | (Ast.TyAnt _)) as tp ->
-        unknown_type tp "type_is_recursive"
+      | <:ctyp< (module $module_type$) >> -> loop_module_type module_type
+      | Ast.TyDcl _
+      | Ast.TyAnt _ as tp -> bad_type tp
+    and loop_module_type = function
+      | <:module_type< $module_type$ with $with_constr$ >> ->
+          let rec loop_with_constr = function
+            | <:with_constr< type $_$ = $tp$ >>
+            | <:with_constr< type $_$ := $tp$ >> -> loop tp
+            | <:with_constr< $wc1$ and $wc2$ >> ->
+                loop_with_constr wc1 || loop_with_constr wc2
+            | <:with_constr< module $_$ = $_$ >>
+            | <:with_constr< module $_$ := $_$ >>
+            | <:with_constr< >> -> false
+            | Ast.WcAnt _ -> bad_type tp
+          in
+          loop_with_constr with_constr || loop_module_type module_type
+      | <:module_type< $id:_$ >>
+      | <:module_type< '$_$ >>
+      | <:module_type< >> -> false
+      | <:module_type< functor ($_$ : $_$) -> $_$ >>
+      | <:module_type< sig $_$ end >>
+      | <:module_type< module type of $_$ >>
+      | Ast.MtAnt _ -> bad_type tp
     in
     loop tp
 
 
 (* Functions for interpreting derivation types *)
 
-let find_generator ~name haystack = (); fun tp (needle,arg) ->
+let find_generator ~name haystack = (); fun tp (needle, arg) ->
   let genf =
-    try Hashtbl.find haystack  needle
+    try Hashtbl.find haystack needle
     with Not_found ->
       let keys = Hashtbl.fold (fun key _ acc -> key :: acc) haystack [] in
-      let gen_names =
-        String.concat "," keys
-      in
+      let gen_names = String.concat ", " keys in
       let msg =
         Printf.sprintf
-          "Pa_type_conv: %S is not a supported %s generator. (supported generators: %s)"
+          "Pa_type_conv: \
+          %S is not a supported %s generator. (supported generators: %s)"
           needle
           name
           gen_names

File base/type-conv/syntax/pa_type_conv.mli

 (** {6 General purpose code generation module} *)
 
 module Gen : sig
-
   val exApp_of_list : expr list -> expr
-  (** [expr_app_of_list l] takes a list of expressions [e1;e2;e3...] and returns
-      the expression [e1 e2 e3]. c.f.: Ast.exSem_of_list *)
+  (** [expr_app_of_list l] takes list [l] of expressions [e1; e2; e3; ...]
+      and returns the expression [e1 e2 e3].  C.f.: [Ast.exSem_of_list]. *)
 
   val tyArr_of_list : ctyp list -> ctyp
-  (** [tyArr_of_list l] takes a list of types [e1;e2;e3...] and returns
-      the type [e1 e2 e3]. c.f.: Ast.exSem_of_list *)
+  (** [tyArr_of_list l] takes list [l] of types [e1; e2; e3; ...] and
+      returns the type [e1 e2 e3].  C.f.: [Ast.exSem_of_list]. *)
 
   val paOr_of_list : patt list -> patt
-  (** [paOr_of_list l] takes a list of patterns [p1;p2;p3...] and returns the
-      pattern [p1 | p2 | p3]... *)
+  (** [paOr_of_list l] takes list [l] of patterns [p1; p2; p3; ...] and returns
+      the pattern [p1 | p2 | p3 | ...] *)
 
-  val gensym : ?prefix:string -> unit -> string
-  (** [gensym ?prefix ()] generates a fresh variable name with the prefix
-      [prefix]. The default value for prefix is "_x". When used with the default
-      parameters it will generate return: [_x__001],[_x__002],[_x__003]...
+  val gensym : ?prefix : string -> unit -> string
+  (** [gensym ?prefix ()] generates a fresh variable name with [prefix].
+      When used with the default parameters, it will return: [_x__001],
+      [_x__002], [_x__003], ...
+
+      @param prefix default = "_x"
   *)
 
-  val error : ctyp -> fn:string -> msg:string -> _
-  (** [error tp ~fn ~msg] raises an error with [msg] on type [tp]
-      occuring in function [fn] *)
+  val error : ctyp -> fn : string -> msg : string -> _
+  (** [error tp ~fn ~msg] raises an error with [msg] on type [tp] occuring
+      in function [fn]. *)
 
   val unknown_type : ctyp -> string -> _
-  (** [unknown_type tp fn] type [tp] is not handled by the function [fn] *)
+  (** [unknown_type tp fn] type [tp] cannot be handled by function [fn]. *)
 
   val ty_var_list_of_ctyp : ctyp -> string list -> string list
   (** [ty_var_list_of_ctyp tp acc] accumulates a list of type parameters
       [arg_exprs].  @return an expression in which the function is
       applied to its arguments. *)
 
-  val idp : Loc.t -> string -> patt
-  (* DEPRECATED: use quotations instead*)
-  (** [idp loc name] @return a pattern matching a lowercase identifier
-      [name]. *)
-
-  val ide : Loc.t -> string -> expr
-  (* DEPRECATED: use quotations instead*)
-  (** [ide loc name] @return an expression of a lowercase identifier
-      [name]. *)
-
   val switch_tp_def :
     alias : (Loc.t -> ctyp -> 'a) ->
     sum : (Loc.t -> ctyp -> 'a) ->
       [tp] if it is a type parameter.  @raise Failure otherwise. *)
 
   val type_is_recursive : string -> ctyp -> bool
-  (** [type_is_recursive _loc id tp] @return whether the type [tp]
-      with name [id] refers to itself, assuming that it is not mutually
-      recursive with another type. *)
+  (** [type_is_recursive id tp] @return whether the type [tp] with name [id]
+      refers to itself, assuming that it is not mutually recursive with
+      another type. *)
 
   val drop_variance_annotations : ctyp -> ctyp
-  (** [drop_variance_annotations _loc tp] @return the type resulting
-      from dropping all variance annotations in [tp]. *)
+  (** [drop_variance_annotations tp] @return the type resulting from dropping
+      all variance annotations in [tp]. *)
 end