parameter_builder.ml

(**************************************************************************)
(*                                                                        *)
(*  This file is part of Frama-C.                                         *)
(*                                                                        *)
(*  Copyright (C) 2007-2020                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  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, version 2.1.                                              *)
(*                                                                        *)
(*  It 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.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

open Cil_types

(* all the collection's internal states that depend on the AST.
   Forward dependency because of linking order (see special_hooks.ml). *)
let ast_dependencies: State.t list ref = ref []
let extend_ast_dependencies s = ast_dependencies := s :: !ast_dependencies

module D = Datatype (* hide after applying Parameter_state.Make *)
let empty_string = ""

let find_kf_by_name
  : (string -> kernel_function) ref
  = Extlib.mk_fun "Parameter_builder.find_kf_by_name"

let find_kf_def_by_name
  : (string -> kernel_function) ref
  = Extlib.mk_fun "Parameter_builder.find_kf_def_by_name"

let find_kf_decl_by_name
  : (string -> kernel_function) ref
  = Extlib.mk_fun "Parameter_builder.find_kf_decl_by_name"

let kf_category
  : (unit -> kernel_function Parameter_category.t) ref
  = Extlib.mk_fun "Parameter_builder.kf_category"

let kf_def_category
  : (unit -> kernel_function Parameter_category.t) ref
  = Extlib.mk_fun "Parameter_builder.kf_def_category"

let kf_decl_category
  : (unit -> kernel_function Parameter_category.t) ref
  = Extlib.mk_fun "Parameter_builder.kf_decl_category"

let fundec_category
  : (unit -> fundec Parameter_category.t) ref
  = Extlib.mk_fun "Parameter_builder.fundec_category"

let kf_string_category
  : (unit -> string Parameter_category.t) ref
  = Extlib.mk_fun "Parameter_builder.kf_string_category"

let force_ast_compute
  : (unit -> unit) ref
  = Extlib.mk_fun "Parameter_builder.force_ast_compute"

(* ************************************************************************* *)
(** {2 Specific functors} *)
(* ************************************************************************* *)

let iter_on_this_parameter stage =
  match !Parameter_customize.do_iterate_ref, stage with
  | Some false, _
  | None, (Cmdline.Early | Cmdline.Extending | Cmdline.Extended
          | Cmdline.Exiting | Cmdline.Loading) ->
    false
  | Some true, _ | None, Cmdline.Configuring ->
    true

module Make
    (P: sig
       val shortname: string
       val parameters: (string, Typed_parameter.t list) Hashtbl.t
       module L: sig
         val abort: ('a,'b) Log.pretty_aborter
         val warning: 'a Log.pretty_printer
       end
       val messages_group: Cmdline.Group.t
     end) =
struct

  module Build = Parameter_state.Make(P)

  let parameters_ref : Typed_parameter.t list ref = ref []
  let parameters () = !parameters_ref

  let add_parameter group stage param =
    if iter_on_this_parameter stage then begin
      parameters_ref := param :: !parameters_ref;
      let parameter_groups = P.parameters in
      try
        let group_name = Cmdline.Group.name group in
        let parameters = Hashtbl.find P.parameters group_name in
        Hashtbl.replace parameter_groups group_name (param :: parameters)
      with Not_found ->
        assert false
    end

  (* ************************************************************************ *)
  (** {3 Bool} *)
  (* ************************************************************************ *)

  module Bool(X:sig include Parameter_sig.Input val default: bool end) = struct

    include Build
        (struct
          include Datatype.Bool
          include X
          let default () = default
          let functor_name = "Bool"
        end)

    let on = register_dynamic "on" D.unit D.unit (fun () -> set true)
    let off = register_dynamic "off" D.unit D.unit (fun () -> set false)

    let generic_add_option name help visible value =
      Cmdline.add_option
        name
        ~plugin:P.shortname
        ~group
        ~help
        ~visible
        ~ext_help:!Parameter_customize.optional_help_ref
        stage
        (Cmdline.Unit (fun () -> set value))

    let negate_name name =
      (* do we match '-shortname-'? (one dash before, one after) *)
      let len = String.length P.shortname + 2  in
      if String.length name <= len || P.shortname = empty_string then
        "-no" ^ name
      else
        let bef = Str.string_before name len in
        if bef = "-" ^ P.shortname ^ "-" then
          bef ^ "no-" ^ Str.string_after name len
        else
          "-no" ^ name

    let negative_option_name name =
      let s = !Parameter_customize.negative_option_name_ref in
      match s with
      | None -> negate_name name
      | Some s ->
        assert (s <> empty_string);
        s

    let default_message opp = Format.asprintf " (set by default%s)" opp

    let add_option opp name =
      let opp_msg name = "opposite option is " ^ negative_option_name name in
      let help =
        if X.default then
          if X.help = empty_string then empty_string
          else
            X.help ^
            if opp then default_message (", " ^ opp_msg name)
            else default_message empty_string
        else
        if opp then Format.asprintf "%s (%s)" X.help (opp_msg name)
        else X.help
      in
      generic_add_option name help is_visible true

    let add_negative_option name =
      let neg_name = negative_option_name name in
      let mk_help s =
        if is_visible then
          if X.default then s else s ^ default_message empty_string
        else empty_string
      in
      let neg_help, neg_visible =
        match
          !Parameter_customize.negative_option_name_ref,
          !Parameter_customize.negative_option_help_ref
        with
        | None, "" -> (* no user-specific config: no help *) empty_string, false
        | Some _, "" ->
          mk_help ("opposite of option \"" ^ name ^ "\""), is_visible
        | _, s -> assert (s <> empty_string); mk_help s, is_visible
      in
      generic_add_option neg_name neg_help neg_visible false;
      neg_name

    let negative_option_ref = ref None

    let parameter =
      let negative_option =
        match !Parameter_customize.negative_option_name_ref, stage with
        | Some "", _  | None, Cmdline.Exiting ->
          add_option false X.option_name;
          None
        | _ ->
          add_option true X.option_name;
          Some (add_negative_option X.option_name)
      in
      negative_option_ref := negative_option;
      let accessor =
        Typed_parameter.Bool
          ({ Typed_parameter.get = get; set = set;
             add_set_hook = add_set_hook; add_update_hook = add_update_hook },
           negative_option)
      in
      let p =
        Typed_parameter.create ~name ~help:X.help ~accessor:accessor ~is_set
      in
      add_parameter !Parameter_customize.group_ref stage p;
      Parameter_customize.reset ();
      if is_dynamic then
        let plugin = empty_string in
        Dynamic.register
          ~plugin X.option_name Typed_parameter.ty ~journalize:false p
      else p

    let add_aliases list =
      add_aliases list;
      match !negative_option_ref with
      | None -> ()
      | Some negative_option ->
        let negative_list = List.map negate_name list in
        let plugin = P.shortname in
        Cmdline.add_aliases negative_option ~plugin ~group stage negative_list

  end

  module False(X: Parameter_sig.Input) =
    Bool(struct include X let default = false end)

  module True(X: Parameter_sig.Input) =
    Bool(struct include X let default = true end)

  module Action(X: Parameter_sig.Input) = struct

    (* [JS 2011/09/29]
       The ugly hack seems to be required anymore neither for Value nor Wp.
       Maybe it is time to remove it? :-) *)

    (* do not save it but restore the "good" behavior when creating by copy *)

    let () = Parameter_customize.do_not_save ()
    (* [JS 2011/01/19] Not saving this kind of options is a quite bad hack with
       several drawbacks (see Frama-C commits 2011/01/19, message of JS around
       15 PM). I'm quite sure there is a better way to not display results too
       many times (e.g. by using the "isset" flag).  That is also the origin of
       bug #687 *)

    include False(X)

    let () =
      Project.create_by_copy_hook
        (fun src p ->
           Project.copy
             ~selection:(State_selection.singleton Is_set.self) ~src p;
           let selection = State_selection.singleton self in
           let opt = Project.on ~selection src get () in
           if opt then Project.on ~selection p set true)

  end

  (* ************************************************************************ *)
  (** {3 Integer} *)
  (* ************************************************************************ *)

  module Int(X: sig include Parameter_sig.Input_with_arg val default: int end) =
  struct

    include Build
        (struct
          include Datatype.Int
          include X
          let default () = default
          let functor_name = "Int"
        end)

    let incr =
      let incr () = set (succ (get ())) in
      register_dynamic "incr" D.unit D.unit incr

    let add_option name =
      Cmdline.add_option
        name
        ~argname:X.arg_name
        ~help:X.help
        ~visible:is_visible
        ~ext_help:!Parameter_customize.optional_help_ref
        ~plugin:P.shortname
        ~group
        stage
        (Cmdline.Int set)

    let range = ref (min_int, max_int)
    let set_range ~min ~max = range := min, max
    let get_range () = !range

    let parameter =
      add_set_hook
        (fun _ n ->
           let min, max = !range in
           if n < min then
             P.L.abort "argument of %s must be at least %d." name min;
           if n > max then
             P.L.abort "argument of %s must be no more than %d." name max);
      let accessor =
        Typed_parameter.Int
          ({ Typed_parameter.get = get; set = set;
             add_set_hook = add_set_hook; add_update_hook = add_update_hook },
           get_range)
      in
      let p =
        Typed_parameter.create ~name ~help:X.help ~accessor ~is_set:is_set
      in
      add_parameter !Parameter_customize.group_ref stage p;
      add_option X.option_name;
      Parameter_customize.reset ();
      if is_dynamic then
        let plugin = empty_string in
        Dynamic.register
          ~plugin X.option_name Typed_parameter.ty ~journalize:false p
      else p

  end

  module Zero(X: Parameter_sig.Input_with_arg) =
    Int(struct include X let default = 0 end)

  (* ************************************************************************ *)
  (** {3 String} *)
  (* ************************************************************************ *)

  module String
      (X: sig include Parameter_sig.Input_with_arg val default: string end) =
  struct

    include Build
        (struct
          include Datatype.String
          include X
          let default () = default
          let functor_name = "String"
        end)

    let add_option name =
      Cmdline.add_option
        name
        ~argname:X.arg_name
        ~help:X.help
        ~visible:is_visible
        ~ext_help:!Parameter_customize.optional_help_ref
        ~plugin:P.shortname
        ~group
        stage
        (Cmdline.String set)

    let possible_values = ref []
    let set_possible_values s = possible_values := s
    let get_possible_values () = !possible_values

    let get_function_name =
      let allow_fundecl = !Parameter_customize.argument_may_be_fundecl_ref in
      fun () ->
        let s = get () in
        (* Using a parameter that is in fact a function name only makes sense
           if we have an AST somewhere. *)
        !force_ast_compute();
        let possible_funcs = Parameter_customize.get_c_ified_functions s in
        let possible_funcs =
          if allow_fundecl then possible_funcs
          else
            Cil_datatype.Kf.Set.filter
              (fun s ->
                 match s.fundec with
                 | Definition _ -> true
                 | Declaration _ -> false)
              possible_funcs
        in
        if Cil_datatype.Kf.Set.is_empty possible_funcs then
          P.L.abort
            "'%s' is not a %sfunction. \
             Please choose a valid function name for option %s"
            s (if allow_fundecl then "" else "defined ") name
        else begin
          if Cil_datatype.Kf.Set.cardinal possible_funcs > 1 then
            P.L.warning
              "ambiguous function name %s for option %s. \
               Choosing arbitrary function with corresponding name."
              s name;
          (Cil_datatype.Kf.vi
             (Cil_datatype.Kf.Set.choose possible_funcs)).vname
        end

    let get_plain_string = get

    let get =
      if !Parameter_customize.argument_is_function_name_ref then
        get_function_name
      else get

    let parameter =
      add_set_hook
        (fun _ s ->
           match !possible_values with
           | [] -> ()
           | v when List.mem s v -> ()
           | v ->
             P.L.abort
               "invalid input '%s' for option %s.@ Possible values are: %a"
               s
               name
               (Pretty_utils.pp_list ~sep:",@ " Format.pp_print_string) v);
      let accessor =
        Typed_parameter.String
          ({ Typed_parameter.get = get_plain_string; set = set;
             add_set_hook = add_set_hook; add_update_hook = add_update_hook },
           get_possible_values)
      in
      let p =
        Typed_parameter.create ~name ~help:X.help ~accessor ~is_set
      in
      add_parameter !Parameter_customize.group_ref stage p;
      add_option X.option_name;
      Parameter_customize.reset ();
      if is_dynamic then
        let plugin = empty_string in
        Dynamic.register
          ~plugin X.option_name Typed_parameter.ty ~journalize:false p
      else
        p

  end

  module Empty_string(X: Parameter_sig.Input_with_arg) =
    String(struct include X let default = empty_string end)

  (* ************************************************************************ *)
  (** {3 Filepath} *)
  (* ************************************************************************ *)

  module Fc_Filepath = Filepath

  let normalize_filepath ~existence ~file_kind s =
    try
      Filepath.Normalized.of_string ~existence s
    with
    | Filepath.No_file ->
      P.L.abort "%s%sfile '%s' does not exist"
        file_kind
        (if file_kind = "" then "" else " ")
        (Filepath.Normalized.(to_pretty_string (of_string s)))
    | Filepath.File_exists ->
      P.L.abort "%s%sfile '%s' already exists"
        file_kind
        (if file_kind = "" then "" else " ")
        (Filepath.Normalized.(to_pretty_string (of_string s)))

  module Filepath
      (X: sig
         include Parameter_sig.Input_with_arg
         val existence : Filepath.existence
         val file_kind: string
       end) =
  struct

    include Build
        (struct
          include Datatype.Filepath
          include X
          let default () = Filepath.Normalized.unknown
          let functor_name = "Filepath"
        end)

    let convert f oldstr newstr =
      let oldfp = Filepath.Normalized.to_pretty_string oldstr in
      let newfp = Filepath.Normalized.to_pretty_string newstr in
      f oldfp newfp

    let set_str s =
      set (normalize_filepath ~existence:X.existence ~file_kind:X.file_kind s)

    let add_option name =
      Cmdline.add_option
        name
        ~argname:X.arg_name
        ~help:X.help
        ~visible:is_visible
        ~ext_help:!Parameter_customize.optional_help_ref
        ~plugin:P.shortname
        ~group
        stage
        (Cmdline.String set_str)

    let parameter_get fp = Filepath.Normalized.to_pretty_string (get fp)
    let parameter_add_set_hook f = add_set_hook (convert f)
    let parameter_add_update_hook f = add_update_hook (convert f)

    let parameter =
      let accessor =
        Typed_parameter.String
          ({ Typed_parameter.get = parameter_get;
             set = set_str;
             add_set_hook = parameter_add_set_hook;
             add_update_hook = parameter_add_update_hook },
           fun () -> [])
      in
      let p =
        Typed_parameter.create ~name ~help:X.help ~accessor ~is_set
      in
      add_parameter !Parameter_customize.group_ref stage p;
      add_option X.option_name;
      Parameter_customize.reset ();
      if is_dynamic then
        let plugin = empty_string in
        Dynamic.register
          ~plugin X.option_name Typed_parameter.ty ~journalize:false p
      else
        p

  end

  (* ************************************************************************ *)
  (** {3 Collections} *)
  (* ************************************************************************ *)

  type collect_action = Add | Remove

  exception Cannot_build of string

  let cannot_build msg = raise (Cannot_build msg)
  let no_element_of_string msg = cannot_build msg

  module Make_collection
      (E: sig (* element in the collection *)
         type t
         val ty: t Type.t
         val of_string: string -> t (* may raise [Cannot_build] *)
         val to_string: t -> string
       end)
      (C: sig (* the collection, as a persistent datastructure *)
         type t
         val equal: t -> t -> bool
         val empty: t
         val is_empty: t -> bool
         val mem: E.t -> t -> bool
         val add: E.t -> t -> t
         val remove: E.t -> t -> t
         val iter: (E.t -> unit) -> t -> unit
         val fold: (E.t -> 'a -> 'a) -> t -> 'a -> 'a
         val of_singleton_string: string -> t
         (* For specific ways to parse a collection from a single string.
            If physically equal to [no_element_of_string], we revert back to
            using [E.of_string]
         *)
         val reorder: t -> t
         (* Used after having parsed a comma-separated string representing
            parameters. The add actions are done in the reverse order with
            respect to the list. Can be [Extlib.id] for unordered collections.
         *)
       end)
      (S: sig (* the collection, as a state *)
         include State_builder.S
         val memo: (unit -> C.t) -> C.t
         val clear: unit -> unit
       end)
      (X: (* standard option builder *) sig
         include Parameter_sig.Input_collection
         val default: C.t
       end)
  =
  struct

    type t = C.t
    type elt = E.t

    (* ********************************************************************** *)
    (* Categories *)
    (* ********************************************************************** *)

    type category = E.t Parameter_category.t

    (* the available custom categories for this option *)
    let available_categories
      : category Datatype.String.Hashtbl.t
      = Datatype.String.Hashtbl.create 7

    module Category = struct

      type elt = E.t
      type t = category

      let check_category_name s =
        if Datatype.String.Hashtbl.mem available_categories s
        || Datatype.String.equal s "all"
        || Datatype.String.equal s ""
        || Datatype.String.equal s "default"
        then
          P.L.abort "invalid category name '%s'" s

      let use categories =
        List.iter
          (fun c ->
             Parameter_category.use S.self c;
             Datatype.String.Hashtbl.add
               available_categories
               (Parameter_category.get_name c)
               c)
          categories

      let unsafe_add name states accessor =
        let c =
          Parameter_category.create name E.ty ~register:false states accessor
        in
        use [ c ];
        c

      let add name states get_values =
        check_category_name name;
        unsafe_add name states get_values

      let none =
        let o = object
          method fold: 'b. ('a -> 'b -> 'b) -> 'b -> 'b = (fun _ acc -> acc);
          method mem = fun _ -> false
        end in
        unsafe_add "" [] o

      let default_ref =
        let o = object
          method fold
            : 'b. ('a -> 'b -> 'b) -> 'b -> 'b
            = fun f acc -> C.fold f X.default acc
          method mem x = C.mem x X.default
        end in
        let c = unsafe_add "default" [] o in
        Datatype.String.Hashtbl.add available_categories "default" c;
        ref c

      let default () = !default_ref
      let set_default c =
        Datatype.String.Hashtbl.replace available_categories "default" c;
        default_ref := c

      let all_ref: t ref = ref none
      let all () = !all_ref

      let on_enable_all c =
        (* interpretation may have change:
           reset the state to force the interpretation again *)
        S.clear ();
        all_ref := c

      let enable_all_as c =
        use [ c ];
        let all = Parameter_category.copy_and_rename "all" ~register:false c in
        Datatype.String.Hashtbl.add available_categories "all" all;
        on_enable_all all

      let enable_all states get_values =
        let all = unsafe_add "all" states get_values in
        on_enable_all all;
        all

    end

    (* ********************************************************************** *)
    (* Parsing *)
    (* ********************************************************************** *)

    let use_category = !Parameter_customize.use_category_ref

    (* parsing builds a list of triples  (action, is_category?, word) *)

    let add_action a l = (a, false, None) :: l

    let add_char c = function
      | [] -> assert false
      | (a, f, None) :: l ->
        (* first char of a new word *)
        let b = Buffer.create 7 in
        Buffer.add_char b c;
        (a, f, Some b) :: l
      | ((_, _, Some b) :: _) as l ->
        (* extend the current word *)
        Buffer.add_char b c;
        l

    let set_category_flag = function
      | (a, false, None) :: l -> (a, true, None) :: l
      | _ -> assert false

    type position =
      | Start (* the very beginning or after a comma *)
      | Word of (* action already specified, word is being read *)
          bool (* [true] iff beginning a category with '@' is allowed *)
      | Escaped (* the next char is escaped in the current word *)

    let parse_error msg =
      P.L.abort "@[@[incorrect argument for option %s@ (%s).@]"
        X.option_name msg

    (* return the list of tokens, in reverse order *)
    let parse s =
      let len = Stdlib.String.length s in
      let rec aux acc pos i s =
        if i = len then acc
        else
          let next = i + 1 in
          let read_char_in_word f_acc new_pos =
            (* assume 'Add' by default *)
            let acc = if pos = Start then add_action Add acc else acc in
            aux (f_acc acc) new_pos next s
          in
          let read_std_char_in_word c =
            read_char_in_word (add_char c) (Word false)
          in
          let read_backslash_and_char c =
            (* read '\\' and [c], without considering than '\\' is the escaping
               character *)
            read_char_in_word
              (fun acc -> add_char c (add_char '\\' acc)) (Word false)
          in
          match Stdlib.String.get s i, pos with
          | '+', Start when use_category ->
            aux (add_action Add acc) (Word true) next s
          | '-', Start when use_category ->
            aux (add_action Remove acc) (Word true) next s
          | '\\', (Start | Word _) -> read_char_in_word (fun x -> x) Escaped
          | ',', (Start | Word _) -> read_char_in_word (fun x -> x) Start
          | (' ' | '\t' | '\n' | '\r'), Start ->
            (* ignore whitespace at beginning of words (must be escaped) *)
            aux acc pos next s
          | '@', (Start | Word true) when use_category ->
            read_char_in_word set_category_flag (Word false)
          | c, (Start | Word _) -> read_std_char_in_word c
          | (',' | '\\' as c), Escaped -> read_std_char_in_word c
          | ('+' | '-' | '@' | ' ' | '\t' | '\n' | '\r' as c),
            Escaped when i = 1 ->
            if use_category then read_std_char_in_word c
            else read_backslash_and_char c
          | c, Escaped ->
            read_backslash_and_char c
      in
      aux [] Start 0 s

    (* ********************************************************************** *)
    (* The parameter itself, as a special string option *)
    (* ********************************************************************** *)

    let string_of_collection c =
      if C.is_empty c then ""
      else
        let b = Buffer.create 17 in
        let first = ref true in
        C.iter
          (fun e ->
             let s = E.to_string e in
             if !first then begin if s <> "" then first := false end
             else Buffer.add_string b ",";
             Buffer.add_string b (E.to_string e))
          c;
        Buffer.contents b

    (* a collection is a standard string option... *)
    module As_string = struct

      include String(struct
          include X
          let default = string_of_collection X.default
        end)

      let () = Parameter_state.collections :=
          State.Set.add self !Parameter_state.collections

      let get () =
        (* the default string may have a custom interpretation when the
           category @default has been customized:
           in that case, interpret "@default" to get it *)
        if use_category && is_default () then "@default" else get ()

    end

    (* ... which is cumulative, when set from the cmdline (but uniquely from
       this way since it is very counter-intuitive from the other ways
       (i.e. programmatically or the GUI). *)
    let () =
      Cmdline.replace_option_setting
        X.option_name
        ~plugin:P.shortname
        ~group:As_string.group
        (Cmdline.String
           (fun s ->
              let old = As_string.get () in
              As_string.set
                (if Datatype.String.equal old empty_string then s
                 else old ^ "," ^ s)))

    (* JS personal note: I'm still not fully convinced by this cumulative
       semantics. *)

    let () =
      (* the typed state depends on the string representation *)
      State_dependency_graph.add_codependencies
        ~onto:S.self
        (As_string.self :: X.dependencies)

    let check_possible_value elt =
      let a = Category.all () in
      if a != Category.none && not (Parameter_category.get_mem a elt) then
        parse_error ("impossible value " ^  E.to_string elt)

    (* may be costly: use it with parsimony *)
    let collection_of_string ~check s =
      (*        Format.printf "READING %s: %s@." X.option_name s;*)
      let tokens = parse s in
      (* remember: tokens are in reverse order. So handle the last one
         first. *)
      let unparsable, col =
        List.fold_right
          (fun (action, is_category, word) (unparsable, col) ->
             let extend = match action with
               | Add -> C.add
               | Remove -> C.remove
             in
             let word = match word with
               | None -> ""
               | Some b -> Buffer.contents b
             in
             (*              Format.printf "TOKEN %s@." word;*)
             if is_category then
               try
                 let c =
                   Datatype.String.Hashtbl.find available_categories word
                 in
                 if word = "all" then
                   match action with
                   | Add ->
                     unparsable, Parameter_category.get_fold c C.add C.empty
                   | Remove ->
                     (* -@all is always equal to the emptyset, even if there
                        were previous elements which are now impossible *)
                     None, C.empty
                 else
                   unparsable, Parameter_category.get_fold c extend col
               with Not_found ->
                 parse_error ("unknown category '" ^ word ^ "'")
             else (* not is_category *)
               try
                 if C.of_singleton_string == no_element_of_string then begin
                   let elt = E.of_string word in
                   unparsable, extend elt col
                 end else begin
                   let elts = C.of_singleton_string word in
                   unparsable, C.fold extend elts col
                 end
               with Cannot_build msg ->
                 Some msg, col)
          tokens
          (None, C.empty)
      in
      let col = C.reorder col in
      (* check each element after parsing all of them,
         since an element may be added, then removed later (e.g +h,-@all):
         that has to be accepted *)
      if check then begin
        Extlib.may parse_error unparsable;
        C.iter check_possible_value col
      end;
      col

    (* ********************************************************************** *)
    (* Memoized access to the state *)
    (* ********************************************************************** *)

    let get_nomemo () = S.memo (fun () -> raise Not_found)

    let get () =
      let compute () =
        let s = As_string.get () in
        (*let c =*) collection_of_string ~check:true s (*in*)
        (*Format.printf "GET %s@." (As_string.get ());
          C.iter (fun s -> Format.printf "ELT %s@." (E.to_string s)) c;
          c*)
      in
      S.memo compute

    (* ********************************************************************** *)
    (* Implement the state, by overseded [As_string]:

       not the more efficient, but the simplest way that prevent to introduce
       subtle bugs *)
    (* ********************************************************************** *)

    let set c = As_string.set (string_of_collection c)
    let unsafe_set c = As_string.unsafe_set (string_of_collection c)

    let convert_and_apply f = fun old new_ ->
      f
        (collection_of_string ~check:false old)
        (collection_of_string ~check:true new_)

    let add_set_hook f = As_string.add_set_hook (convert_and_apply f)
    let add_update_hook f = As_string.add_update_hook (convert_and_apply f)

    (* ********************************************************************** *)
    (* Implement operations *)
    (* ********************************************************************** *)

    let add e = set (C.add e (get ()))
    let is_empty () = C.is_empty (get ())
    let iter f = C.iter f (get ())
    let fold f acc = C.fold f (get ()) acc

    (* ********************************************************************** *)
    (* Re-export values *)
    (* ********************************************************************** *)

    let name = As_string.name
    let option_name = As_string.option_name
    let is_default = As_string.is_default
    let is_set = As_string.is_set
    let clear = As_string.clear
    let print_help = As_string.print_help
    let add_aliases = As_string.add_aliases
    let self = As_string.self
    let parameter = As_string.parameter

    let equal = C.equal
    let is_computed = S.is_computed
    let mark_as_computed = S.mark_as_computed

    (* [Datatype] is fully abstract from outside anyway *)
    module Datatype = As_string.Datatype

    (* cannot be called anyway since [Datatype] is abstract *)
    let howto_marshal _marshal _unmarshal =
      P.L.abort "[how_to_marshal] cannot be implemented for %s." X.option_name

    (* same as above *)
    let add_hook_on_update _ =
      P.L.abort "[add_hook_on_update] cannot be implemented for %s."
        X.option_name

  end

  module Make_set
      (E: Parameter_sig.String_datatype_with_collections)
      (X: sig
         include Parameter_sig.Input_collection
         val default: E.Set.t
       end):
  sig
    include Parameter_sig.Set with type elt = E.t and type t = E.Set.t
    module S: sig val self: State.t end (* typed state *)
  end =
  struct

    module C = struct
      include E.Set
      let reorder = Extlib.id
      let of_singleton_string = E.of_singleton_string
    end

    module S = struct

      include State_builder.Option_ref
          (E.Set)
          (struct
            let name = X.option_name ^ " set"
            let dependencies = X.dependencies
          end)

      let memo f = memo f (* ignore the optional argument *)
    end

    include Make_collection(E)(C)(S)(X)

    (* ********************************************************************** *)
    (* Accessors *)
    (* ********************************************************************** *)

    let mem e = E.Set.mem e (get ())
    let exists f = E.Set.exists f (get ())

  end

  module String_for_collection = struct
    include Datatype.String
    let of_string = Datatype.identity
    let to_string = Datatype.identity
    let of_singleton_string = no_element_of_string
  end