Skip to content
This repository
tag: v612
Fetching contributors…

Cannot retrieve contributors at this time

file 195 lines (162 sloc) 6.576 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA 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 Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)

(**
Inclusion format for opa files during the bslregister process.

@author Mathieu Barbin
@author Mehdi Bouaziz
*)

(**
This module has no mli because it would duplicate the type definitions.

This module implements the inclusion format feature for macro
production of bypass and external types definitions in an opa file,
from definitions registred in bypass files.

Example:
{[
##include opa-function bslpervasives
]}
Is expanded as :
{[
`+` = %%bslpervasives.add_int%% : int, int -> int
`-` = %%bslpervasives.sub_int%% : int, int -> int
etc...
]}
*)

(** {6 Types of format} *)

(**
It looks like scary, but don't worry, you don't need to manipulate this
type directly, the types are exported just so that the parser and BslLib
can build them.

For a high level manipulation of inclusion formats, cf module [IFormat]
*)

type fmt_fvalue = string * string * string
type fmt_fprinter = fmt_fvalue -> string
type fmt_sep = string option
type 'a mfmt_elt = [ `Mfmt_name | `Mfmt_const of string | `Mfmt_iter of 'a]
type mfmt_iter = mfmt option * fmt_fprinter * fmt_sep (* None means #rec *)
and mfmt = [ `Mfmt_name | `Mfmt_const of string | `Mfmt_iter of mfmt_iter ] list
type ffmt = fmt_fprinter * fmt_sep
type fmt = Mfmt of mfmt | Ffmt of ffmt | Fmt_const of string


(** {6 High level API} *)

(**
The IFormat has a local table for storing format definitions.
It works together with the [BslRegisterParser], via the
[BslRegisterParserState] interface.
*)

module IFormat :
sig

  (** {6 Error report} *)
  (**
IFormat is a generic lib, so the errors does not uses OManager.
*)
  type error
  exception Exception of error
  val pp_error : error LangPrint.pprinter

  val pp_show_format : Format.formatter -> unit -> unit
  val add : string -> fmt -> unit
  val find_opt : string -> fmt option
  val reset : unit -> unit

  val empty : fmt
  val fmt_fprinter_empty : fmt_fprinter
  val fmt_sep_empty : fmt_sep
  val mfmt_empty : mfmt
  val mfmt_of_fmt : fmt -> mfmt
  val fprinter_opt_of_fmt : fmt -> fmt_fprinter option
  val concat : fmt -> fmt -> fmt
  val opt_list_to_iter : fmt option list -> mfmt_iter

end =
struct

  type error =
    | FormatTypeClash of string * string
    | MoreThanOne of string

  exception Exception of error

  let format_type_clash t1 t2 = raise (Exception (FormatTypeClash (t1, t2)))
  let more_than_one s = raise (Exception (MoreThanOne s))

  let pp_error fmt = function
    | FormatTypeClash (t1, t2) ->
        Format.fprintf fmt "Format type clash, cannot concat a format(%s)@ and a format(%s)@\n" t1 t2
    | MoreThanOne kind ->
        Format.fprintf fmt "More than one @{<bright>format(%s)@} in this iteration block" kind

  let tbl = Hashtbl.create 1

  let pp_show_format fmt () =
    Hashtbl.iter (fun name _ -> Format.fprintf fmt "+ %s@\n" name) tbl

  let add name fmt =
    (* #<< debug dddformat (sprintf "Adding format <%s> in my env" name); >>#; *)
    Hashtbl.add tbl name fmt
  let find_opt name = try Some(Hashtbl.find tbl name) with Not_found -> None
  let reset () =
    (* #<< debug dddformat "Reseting my format-env"; >>#; *)
    Hashtbl.clear tbl

  let empty = Fmt_const ""
  let fmt_fprinter_empty = ((fun _ -> "") : fmt_fprinter)
  let fmt_sep_empty = (None : fmt_sep)
  let mfmt_empty = ([] : mfmt)

  let mfmt_of_fmt = function
    | Mfmt mfmt -> mfmt
    | Ffmt (fprinter, sep) -> [`Mfmt_iter(Some mfmt_empty, fprinter, sep)]
    | Fmt_const str -> [`Mfmt_const str]

  let fprinter_opt_of_fmt = function
    | Mfmt _ -> None
    | Ffmt (fprinter, _) -> Some fprinter
    | Fmt_const str -> Some (fun _ -> str)

  let concat =
    fun fmt1 fmt2 -> match fmt1, fmt2 with
    | Mfmt mfmt1, Mfmt mfmt2 -> Mfmt (mfmt1 @ mfmt2)
    | Mfmt mfmt, Fmt_const str -> Mfmt (mfmt @ [`Mfmt_const str])
    | Mfmt _, Ffmt _ -> format_type_clash "module" "function"
    | Ffmt _, Mfmt _ -> format_type_clash "function" "module"
    | Ffmt (fprinter1, sep1), Ffmt (fprinter2, sep2) ->
        let fprinter = fun v -> (fprinter1 v) ^ (fprinter2 v) in
        let sep = match sep1, sep2 with
          | None, None -> None
          | Some s, None
          | None, Some s -> Some s
          | Some _, Some _ ->
              (* Mathieu Mon Aug 16 21:09:37 CEST 2010
After the refactoring of libbsl, I have no idea in what case this can happen.
TODO:(who find a example causing this assert false)
add a corresponding error message
*)
              assert false
        in
        Ffmt (fprinter, sep)
    | Ffmt (fprinter, sep), Fmt_const str ->
        let fprinter = fun v -> (fprinter v) ^ str in
        Ffmt (fprinter, sep)
    | Fmt_const str, Mfmt mfmt -> Mfmt ((`Mfmt_const str)::mfmt)
    | Fmt_const str, Ffmt (fprinter, sep) ->
        let fprinter = fun v -> str ^ (fprinter v) in
        Ffmt (fprinter, sep)
    | Fmt_const str1, Fmt_const str2 -> Fmt_const (str1 ^ str2)

  let opt_list_to_iter fmt_opt_list =
    let mfmt_opt_list, fmt_opt_list =
      List.partition
        (fun fmt_opt -> match fmt_opt with Some Mfmt _ -> true | None -> true | _ -> false) fmt_opt_list in
    let mfmt_opt = match mfmt_opt_list with
      | [] -> Some mfmt_empty
      | [None] -> None
      | [Some Mfmt mfmt] -> Some mfmt
      | _ -> more_than_one "module"
    in
    let ffmt_list, const_list =
      List.partition (fun fmt_opt -> match fmt_opt with Some Ffmt _ -> true | _ -> false) fmt_opt_list in
    let fprinter, sep = match ffmt_list, const_list with
      | [], [] -> fmt_fprinter_empty, fmt_sep_empty
      | [], [Some Fmt_const sep] -> fmt_fprinter_empty, Some sep
      | [Some Ffmt ffmt], [] -> ffmt
      | [Some Ffmt (fprinter, _)], [Some Fmt_const sep] -> fprinter, Some sep
      | _::_::_, _ -> more_than_one "function"
      | _, _ -> more_than_one "separator"
    in
    (mfmt_opt, fprinter, sep)
end
Something went wrong with that request. Please try again.