-let (expression_tag_RE, action_tag_RE, advanced_tag_RE,
- advanced_checked_RE, simple_checked_RE,
- title_tag_RE, no_choices_tag_RE, current_choices_tag_RE,
- choices_tag_RE, msg_tag_RE, id_to_uris_RE, id_RE, iden_tag_RE,
- interpretations_RE, interpretations_labels_RE, results_RE, new_aliases_RE,
- form_RE, variables_initialization_RE, search_engine_url_RE)
- =
- (Pcre.regexp "@EXPRESSION@", Pcre.regexp "@ACTION@", Pcre.regexp "@ADVANCED@",
- Pcre.regexp "@ADVANCED_CHECKED@", Pcre.regexp "@SIMPLE_CHECKED@",
- Pcre.regexp "@TITLE@", Pcre.regexp "@NO_CHOICES@",
- Pcre.regexp "@CURRENT_CHOICES@",
- Pcre.regexp "@CHOICES@", Pcre.regexp "@MSG@",
- Pcre.regexp "@ID_TO_URIS@", Pcre.regexp "@ID@", Pcre.regexp "@IDEN@",
- Pcre.regexp "@INTERPRETATIONS@", Pcre.regexp "@INTERPRETATIONS_LABELS@",
- Pcre.regexp "@RESULTS@", Pcre.regexp "@NEW_ALIASES@", Pcre.regexp "@FORM@",
- Pcre.regexp "@VARIABLES_INITIALIZATION@", Pcre.regexp "@SEARCH_ENGINE_URL@")
-let server_and_port_url_RE = Pcre.regexp "^http://([^/]+)/.*$"
-
-(* let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" *)
-let pp_error title msg =
- sprintf "<hr size='1' /><div><b class='error'>%s:</b> %s</div>" title msg
-
-let bad_request body outchan =
- Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
- outchan
-
-let contype = "Content-Type", "text/html"
-
-(* SEARCH ENGINE functions *)
-
-let get_constraints term =
- function
- | "/elim" ->
- None,
- (CGLocateInductive.get_constraints term),
- (None,None,None)
- | "/match" ->
- let constr_obj, constr_rel, constr_sort =
- CGSearchPattern.get_constraints term in
- (Some CGSearchPattern.universe),
- (constr_obj, constr_rel, constr_sort),
- (Some constr_obj, Some constr_rel, Some constr_sort)
- | "/hint" ->
- let list_of_must, only = CGMatchConclusion.get_constraints [] [] term in
-(* FG: there is no way to choose the block number ***************************)
- let block = pred (List.length list_of_must) in
- (Some CGMatchConclusion.universe),
- (List.nth list_of_must block, [], []), (Some only, None, None)
- | _ -> assert false
-
-(*
- format:
- <must_obj> ':' <must_rel> ':' <must_sort> ':' <only_obj> ':' <only_rel> ':' <only_sort>
-
- <must_*> ::= ('0'|'1') ('_'|<int>) (',' ('0'|'1') ('_'|<int>))*
- <only> ::= '0'|'1'
-*)
-let add_user_constraints ~constraints
- ((obj, rel, sort), (only_obj, only_rel, only_sort))
-=
- let parse_must s =
- let l = Pcre.split ~pat:"," s in
- (try
- List.map
- (fun s ->
- let subs = Pcre.extract ~pat:"^(.)(\\d+|_)$" s in
- (bool_of_string' subs.(1), int_of_string' subs.(2)))
- l
- with
- Not_found -> failwith ("Can't parse constraint string: " ^ constraints)
- )
- in
- (* to be used on "obj" *)
- let add_user_must33 user_must must =
- List.map2
- (fun (b, i) (p, u) ->
- if b then Some (U.set_full_position p i, u) else None)
- user_must must
- in
- (* to be used on "rel" *)
- let add_user_must22 user_must must =
- List.map2
- (fun (b, i) p -> if b then Some (U.set_main_position p i) else None)
- user_must must
- in
- (* to be used on "sort" *)
- let add_user_must32 user_must must =
- List.map2
- (fun (b, i) (p, s)-> if b then Some (U.set_main_position p i, s) else None)
- user_must must
- in
- match Pcre.split ~pat:":" constraints with
- | [user_obj;user_rel;user_sort;user_only_obj;user_only_rel;user_only_sort] ->
- let
- (user_obj,user_rel,user_sort,user_only_obj,user_only_rel,user_only_sort)
- =
- (parse_must user_obj,
- parse_must user_rel,
- parse_must user_sort,
- bool_of_string' user_only_obj,
- bool_of_string' user_only_rel,
- bool_of_string' user_only_sort)
- in
- let only' =
- (if user_only_obj then only_obj else None),
- (if user_only_rel then only_rel else None),
- (if user_only_sort then only_sort else None)
- in
- let must' =
- let rec filter_some =
- function
- [] -> []
- | None::tl -> filter_some tl
- | (Some x)::tl -> x::(filter_some tl)
- in
- filter_some (add_user_must33 user_obj obj),
- filter_some (add_user_must22 user_rel rel),
- filter_some (add_user_must32 user_sort sort)
- in
- (must', only')
- | _ -> failwith ("Can't parse constraint string: " ^ constraints)