"; + loop indent q; + Buffer.add_string b ""; + loop indent tl + end + | Ref(rc, name, text, fallback) as e :: tl -> + begin match override e with + | Some s -> + Buffer.add_string b s; + loop indent tl + | None -> + begin match rc#get_ref name with + | Some(href, title) -> + loop indent + (Url(htmlentities ~md:true href, + [Text(text)], + htmlentities ~md:true title) + ::tl) + | None -> + loop indent (fallback#to_t); + loop indent tl + end + end + | Img_ref(rc, name, alt, fallback) as e :: tl -> + begin match override e with + | Some s -> + Buffer.add_string b s; + loop indent tl + | None -> + begin match rc#get_ref name with + | Some(src, title) -> + loop indent + (Img(htmlentities ~md:true alt, + htmlentities ~md:true src, + htmlentities ~md:true title)::tl) + | None -> + loop indent (fallback#to_t); + loop indent tl + end + end + | Paragraph [] :: tl -> loop indent tl + | Paragraph md as e :: tl -> + begin match override e with + | Some s -> + Buffer.add_string b s; + loop indent tl + | None -> + (let s = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in + if empty s then + () + else + begin + Buffer.add_string b "
"; + Buffer.add_string b (remove_trailing_blanks s); + Buffer.add_string b "
\n"; + end); + loop indent tl + end + | Img(alt, src, title) as e :: tl -> + begin match override e with + | Some s -> + Buffer.add_string b s; + loop indent tl + | None -> + Buffer.add_string b "- "
+ | _ -> "
- "; + loop (indent+2) li; + Buffer.add_string b " " + ) + l; + Buffer.add_string b (match e with + | Ol _|Olp _ -> "
- ");
+ List.iter
+ (
+ fun li ->
+ Buffer.add_string b "
"
+ else if lang = "" then
+ bprintf b ""
+ !default_language !default_language
+ else
+ bprintf b "" lang lang;
+ let new_c = code_style ~lang:lang c in
+ if c = new_c then
+ Buffer.add_string b (htmlentities ~md:false c)
+ else
+ Buffer.add_string b new_c;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | Code(lang, c) as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ if lang = "" && !default_language = "" then
+ Buffer.add_string b ""
+ else if lang = "" then
+ bprintf b "" !default_language
+ else
+ bprintf b "" lang;
+ let new_c = code_style ~lang:lang c in
+ if c = new_c then
+ Buffer.add_string b (htmlentities ~md:false c)
+ else
+ Buffer.add_string b new_c;
+ Buffer.add_string b "";
+ loop indent tl
+ end
+ | Br as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | Hr as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | Raw s as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Buffer.add_string b s;
+ loop indent tl
+ end
+ | Raw_block s as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Buffer.add_string b s;
+ loop indent tl
+ end
+ | Html(tagname, attrs, []) as e :: tl
+ when StringSet.mem tagname html_void_elements ->
+ let attrs = filter_text_omd_rev attrs in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Printf.bprintf b " />";
+ loop indent tl
+ end
+ | Html(tagname, attrs, body) as e :: tl ->
+ let attrs = filter_text_omd_rev attrs in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Buffer.add_string b ">";
+ loop indent body;
+ Printf.bprintf b "" tagname;
+ loop indent tl
+ end
+ | Html_block(tagname, attrs, body) as e :: tl ->
+ let attrs = filter_text_omd_rev attrs in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ if body = [] && StringSet.mem tagname html_void_elements then
+ (
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Buffer.add_string b " />";
+ loop indent tl
+ )
+ else
+ (
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Buffer.add_string b ">";
+ loop indent body;
+ Printf.bprintf b "" tagname;
+ loop indent tl
+ )
+ end
+ | Html_comment s as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ Buffer.add_string b s;
+ loop indent tl
+ end
+ | Url (href,s,title) as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let s = html_of_md ~override ~pindent ~nl2br ~cs:code_style s in
+ Buffer.add_string b " "" then
+ begin
+ Buffer.add_string b " title='";
+ Buffer.add_string b (htmlentities ~md:true title);
+ Buffer.add_string b "'";
+ end;
+ Buffer.add_string b ">";
+ Buffer.add_string b s;
+ Buffer.add_string b "";
+ loop indent tl
+ end
+ | (H1 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H1 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | (H2 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H2 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | (H3 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H3 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | (H4 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H4 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | (H5 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H5 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | (H6 md as e) :: tl ->
+ let e, md =
+ if not remove_header_links then
+ e, md
+ else
+ let md = remove_links md in
+ H6 md, md in
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ let ih = html_of_md ~override ~pindent ~nl2br ~cs:code_style md in
+ let id = id_of_string ids (text_of_md md) in
+ headers := (e, id, ih) :: !headers;
+ Buffer.add_string b "";
+ Buffer.add_string b ih;
+ Buffer.add_string b "
";
+ loop indent tl
+ end
+ | NL as e :: tl ->
+ begin match override e with
+ | Some s ->
+ Buffer.add_string b s;
+ loop indent tl
+ | None ->
+ if nl2br then
+ Buffer.add_string b "
"
+ else
+ Buffer.add_string b "\n";
+ loop indent tl
+ end
+ | [] ->
+ ()
+ in
+ loop 0 md;
+ Buffer.contents b, List.rev !headers
+
+and string_of_attrs attrs =
+ let b = Buffer.create 1024 in
+ List.iter
+ (function
+ | (a, Some v) ->
+ if not(String.contains v '\'') then
+ Printf.bprintf b " %s='%s'" a v
+ else if not(String.contains v '"') then
+ Printf.bprintf b " %s=\"%s\"" a v
+ else
+ Printf.bprintf b " %s=\"%s\"" a v
+ | a, None ->
+ (* if html4 then *)
+ (* Printf.bprintf b " %s='%s'" a a *)
+ (* else *)
+ Printf.bprintf b " %s=''" a (* HTML5 *)
+ )
+ attrs;
+ Buffer.contents b
+
+and html_of_md
+ ?(override=(fun (_e:element) -> (None:string option)))
+ ?(pindent=false)
+ ?(nl2br=false)
+ ?cs
+ md
+ =
+ fst (html_and_headers_of_md ~override ~pindent ~nl2br ?cs md)
+and headers_of_md ?remove_header_links md =
+ snd (html_and_headers_of_md ?remove_header_links md)
+
+
+let rec sexpr_of_md md =
+ let b = Buffer.create 64 in
+ let rec loop = function
+ | X x :: tl ->
+ (match x#to_t md with
+ | Some t ->
+ Buffer.add_string b "(X";
+ loop t;
+ Buffer.add_string b ")"
+ | None ->
+ match x#to_sexpr sexpr_of_md md with
+ | Some s ->
+ Buffer.add_string b "(X";
+ Buffer.add_string b s;
+ Buffer.add_string b ")"
+ | None ->
+ match x#to_html ~indent:0 html_of_md md with
+ | Some s ->
+ Buffer.add_string b "(X";
+ Buffer.add_string b s;
+ Buffer.add_string b ")"
+ | None -> ());
+ loop tl
+ | Blockquote q :: tl ->
+ Buffer.add_string b "(Blockquote";
+ loop q;
+ Buffer.add_string b ")";
+ loop tl
+ | Ref(_rc, name, text, _) :: tl ->
+ bprintf b "(Ref %S %S)" name text;
+ loop tl
+ | Img_ref(_rc, name, alt, _) :: tl ->
+ bprintf b "(Img_ref %S %S)" name alt;
+ loop tl
+ | Paragraph md :: tl ->
+ Buffer.add_string b "(Paragraph";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | Img(alt, src, title) :: tl ->
+ bprintf b "(Img %S %S %S)" alt src title;
+ loop tl
+ | Text t :: tl ->
+ bprintf b "(Text %S" t;
+ let rec f = function
+ | Text t :: tl ->
+ bprintf b " %S" t;
+ f tl
+ | x -> x
+ in
+ let tl = f tl in
+ bprintf b ")";
+ loop tl
+ | Emph md :: tl ->
+ Buffer.add_string b "(Emph";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | Bold md :: tl ->
+ Buffer.add_string b "(Bold";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | Ol l :: tl ->
+ bprintf b "(Ol";
+ List.iter(fun li -> bprintf b "(Li "; loop li; bprintf b ")") l;
+ bprintf b ")";
+ loop tl
+ | Ul l :: tl ->
+ bprintf b "(Ul";
+ List.iter(fun li -> bprintf b "(Li "; loop li;bprintf b ")") l;
+ bprintf b ")";
+ loop tl
+ | Olp l :: tl ->
+ bprintf b "(Olp";
+ List.iter(fun li -> bprintf b "(Li "; loop li; bprintf b ")") l;
+ bprintf b ")";
+ loop tl
+ | Ulp l :: tl ->
+ bprintf b "(Ulp";
+ List.iter(fun li -> bprintf b "(Li "; loop li;bprintf b ")") l;
+ bprintf b ")";
+ loop tl
+ | Code(_lang, c) :: tl ->
+ bprintf b "(Code %S)" c;
+ loop tl
+ | Code_block(_lang, c) :: tl ->
+ bprintf b "(Code_block %s)" c;
+ loop tl
+ | Br :: tl ->
+ Buffer.add_string b "(Br)";
+ loop tl
+ | Hr :: tl ->
+ Buffer.add_string b "(Hr)";
+ loop tl
+ | Raw s :: tl ->
+ bprintf b "(Raw %S)" s;
+ loop tl
+ | Raw_block s :: tl ->
+ bprintf b "(Raw_block %S)" s;
+ loop tl
+ | Html(tagname, attrs, body) :: tl ->
+ bprintf b "(Html %s %s " tagname (string_of_attrs attrs);
+ loop body;
+ bprintf b ")";
+ loop tl
+ | Html_block(tagname, attrs, body) :: tl ->
+ bprintf b "(Html_block %s %s " tagname (string_of_attrs attrs);
+ loop body;
+ bprintf b ")";
+ loop tl
+ | Html_comment s :: tl ->
+ bprintf b "(Html_comment %S)" s;
+ loop tl
+ | Url (href,s,title) :: tl ->
+ bprintf b "(Url %S %S %S)" href (html_of_md s) title;
+ loop tl
+ | H1 md :: tl ->
+ Buffer.add_string b "(H1";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | H2 md :: tl ->
+ Buffer.add_string b "(H2";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | H3 md :: tl ->
+ Buffer.add_string b "(H3";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | H4 md :: tl ->
+ Buffer.add_string b "(H4";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | H5 md :: tl ->
+ Buffer.add_string b "(H5";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | H6 md :: tl ->
+ Buffer.add_string b "(H6";
+ loop md;
+ Buffer.add_string b ")";
+ loop tl
+ | NL :: tl ->
+ Buffer.add_string b "(NL)";
+ loop tl
+ | [] -> ()
+ in
+ loop md;
+ Buffer.contents b
+
+
+let escape_markdown_characters s =
+ let b = Buffer.create (String.length s * 2) in
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ | '.' as c ->
+ if i > 0 &&
+ match s.[i-1] with
+ | '0' .. '9' -> i+1 < String.length s && s.[i+1] = ' '
+ | _ -> false
+ then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '-' as c ->
+ if (i = 0 || match s.[i-1] with ' '| '\n' -> true | _ -> false)
+ && (i+1 < String.length s && (s.[i+1] = ' '||s.[i+1] = '-'))
+ then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '+' as c ->
+ if (i = 0 || match s.[i-1] with ' '| '\n' -> true | _ -> false)
+ && (i+1 < String.length s && s.[i+1] = ' ')
+ then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '!' as c ->
+ if i+1 < String.length s && s.[i+1] = '[' then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '<' as c ->
+ if i <> String.length s - 1 &&
+ (match s.[i+1] with 'a' .. 'z' | 'A' .. 'Z' -> false | _ -> true)
+ then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '>' as c ->
+ if i = 0 ||
+ (match s.[i-1] with ' ' | '\n' -> false | _ -> true)
+ then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '#' as c ->
+ if i = 0 || s.[i-1] = '\n' then
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | '\\' | '[' | ']' | '(' | ')' | '`' | '*' as c ->
+ Buffer.add_char b '\\';
+ Buffer.add_char b c
+ | c ->
+ Buffer.add_char b c
+ done;
+ Buffer.contents b
+
+let rec markdown_of_md md =
+ if debug then eprintf "(OMD) markdown_of_md(%S)\n%!" (sexpr_of_md md);
+ let quote ?(indent=0) s =
+ let b = Buffer.create (String.length s) in
+ let l = String.length s in
+ let rec loop nl i =
+ if i < l then
+ begin
+ if nl && i < l - 1 then
+ (for i = 1 to indent do
+ Buffer.add_char b ' '
+ done;
+ Buffer.add_string b "> ");
+ match s.[i] with
+ | '\n' ->
+ Buffer.add_char b '\n';
+ loop true (succ i)
+ | c ->
+ Buffer.add_char b c;
+ loop false (succ i)
+ end
+ else
+ Buffer.contents b
+ in loop true 0
+ in
+ let b = Buffer.create 64 in
+ let add_spaces n = for i = 1 to n do Buffer.add_char b ' ' done in
+ let references = ref None in
+ let rec loop ?(fst_p_in_li=true) ?(is_in_list=false) list_indent l =
+ (* [list_indent: int] is the indentation level in number of spaces. *)
+ (* [is_in_list: bool] is necessary to know if we are inside a paragraph
+ which is inside a list item because those need to be indented! *)
+ let loop ?(fst_p_in_li=fst_p_in_li) ?(is_in_list=is_in_list) list_indent l =
+ loop ~fst_p_in_li:fst_p_in_li ~is_in_list:is_in_list list_indent l
+ in
+ match l with
+ | X x :: tl ->
+ (match x#to_t md with
+ | Some t -> loop list_indent t
+ | None ->
+ match x#to_html ~indent:0 html_of_md md with
+ | Some s -> Buffer.add_string b s
+ | None -> ());
+ loop list_indent tl
+ | Blockquote q :: tl ->
+ Buffer.add_string b (quote ~indent:list_indent (markdown_of_md q));
+ if tl <> [] then Buffer.add_string b "\n";
+ loop list_indent tl
+ | Ref(rc, _name, _text, fallback) :: tl ->
+ if !references = None then references := Some rc;
+ loop list_indent (Raw(fallback#to_string)::tl)
+ | Img_ref(rc, _name, _alt, fallback) :: tl ->
+ if !references = None then references := Some rc;
+ loop list_indent (Raw(fallback#to_string)::tl)
+ | Paragraph [] :: tl -> loop list_indent tl
+ | Paragraph md :: tl ->
+ if is_in_list then
+ if fst_p_in_li then
+ add_spaces (list_indent-2)
+ else
+ add_spaces list_indent;
+ loop ~fst_p_in_li:false list_indent md;
+ Printf.bprintf b "\n\n";
+ loop ~fst_p_in_li:false list_indent tl
+ | Img(alt, src, title) :: tl ->
+ Printf.bprintf b "![%s](%s \"%s\")" alt src title;
+ loop list_indent tl
+ | Text t :: tl ->
+ Printf.bprintf b "%s" (escape_markdown_characters t);
+ loop list_indent tl
+ | Emph md :: tl ->
+ Buffer.add_string b "*";
+ loop list_indent md;
+ Buffer.add_string b "*";
+ loop list_indent tl
+ | Bold md :: tl ->
+ Buffer.add_string b "**";
+ loop list_indent md;
+ Buffer.add_string b "**";
+ loop list_indent tl
+ | Ol l :: tl ->
+ if Buffer.length b > 0 && Buffer.nth b (Buffer.length b - 1) <> '\n' then
+ Buffer.add_char b '\n';
+ let c = ref 0 in (* don't use List.iteri because it's not in 3.12 *)
+ List.iter(fun li ->
+ incr c;
+ add_spaces list_indent;
+ Printf.bprintf b "%d. " !c;
+ loop ~is_in_list:true (list_indent+4) li;
+ Buffer.add_char b '\n';
+ ) l;
+ if list_indent = 0 then Buffer.add_char b '\n';
+ loop list_indent tl
+ | Ul l :: tl ->
+ if Buffer.length b > 0 && Buffer.nth b (Buffer.length b - 1) <> '\n' then
+ Buffer.add_char b '\n';
+ List.iter(fun li ->
+ add_spaces list_indent;
+ Printf.bprintf b "- ";
+ loop ~is_in_list:true (list_indent+4) li;
+ Buffer.add_char b '\n';
+ ) l;
+ if list_indent = 0 then Buffer.add_char b '\n';
+ loop list_indent tl
+ | Olp l :: tl ->
+ let c = ref 0 in (* don't use List.iteri because it's not in 3.12 *)
+ List.iter(fun li ->
+ if Buffer.length b > 0 && Buffer.nth b (Buffer.length b - 1) <> '\n'
+ then Buffer.add_char b '\n';
+ add_spaces list_indent;
+ incr c;
+ bprintf b "%d. " !c;
+ loop ~is_in_list:true (list_indent+4) li;
+ (* Paragraphs => No need of '\n' *)
+ ) l;
+ loop list_indent tl
+ | Ulp l :: tl ->
+ List.iter(fun li ->
+ if Buffer.length b > 0 && Buffer.nth b (Buffer.length b - 1) <> '\n'
+ then Buffer.add_char b '\n';
+ add_spaces list_indent;
+ bprintf b "+ ";
+ loop ~is_in_list:true (list_indent+4) li;
+ (* Paragraphs => No need of '\n' *)
+ ) l;
+ begin match tl with
+ | (H1 _ | H2 _ | H3 _ | H4 _ | H5 _ | H6 _)::_
+ | NL::(H1 _ | H2 _ | H3 _ | H4 _ | H5 _ | H6 _)::_ ->
+ Buffer.add_char b '\n'
+ | _ -> ()
+ end;
+ loop list_indent tl
+ | Code(_lang, c) :: tl -> (* FIXME *)
+ let n = (* compute how many backquotes we need to use *)
+ let filter (n:int) (s:int list) =
+ if n > 0 && n < 10 then
+ List.filter (fun e -> e <> n) s
+ else
+ s
+ in
+ let l = String.length c in
+ let rec loop s x b i =
+ if i = l then
+ match filter b s with
+ | hd::_ -> hd
+ | [] -> x+1
+ else
+ match c.[i] with
+ | '`' -> loop s x (succ b) (succ i)
+ | _ -> loop (filter b s) (max b x) 0 (succ i)
+ in
+ loop [1;2;3;4;5;6;7;8;9;10] 0 0 0
+ in
+ begin
+ Printf.bprintf b "%s" (String.make n '`');
+ if (String.length c > 0) && c.[0] = '`' then Buffer.add_char b ' ';
+ Printf.bprintf b "%s" c;
+ if (String.length c > 0) && c.[String.length c - 1] = '`' then Buffer.add_char b ' ';
+ Printf.bprintf b "%s" (String.make n '`');
+ end;
+ loop list_indent tl
+ | Code_block(lang, c) :: tl ->
+ let n = (* compute how many backquotes we need to use *)
+ let filter n s =
+ if n > 0 && n < 10 then
+ List.filter (fun e -> e <> n) s
+ else
+ s
+ in
+ let l = String.length c in
+ let rec loop s b i =
+ if i = l then
+ match filter b s with
+ | hd::_ -> hd
+ | [] -> 0
+ else
+ match c.[i] with
+ | '`' -> loop s (succ b) (succ i)
+ | _ -> loop (filter b s) 0 (succ i)
+ in
+ loop [3;4;5;6;7;8;9;10] 0 0
+ in
+ let output_indented_block n s =
+ let rec loop p i =
+ if i = String.length s then
+ ()
+ else
+ match p with
+ | '\n' ->
+ Printf.bprintf b "%s" (String.make n ' ');
+ Buffer.add_char b s.[i];
+ loop s.[i] (succ i)
+ | _ ->
+ Buffer.add_char b s.[i];
+ loop s.[i] (succ i)
+ in loop '\n' 0
+ in
+ if n = 0 then (* FIXME *)
+ begin
+ (* case where we can't use backquotes *)
+ Buffer.add_char b '\n';
+ output_indented_block (4+list_indent) c;
+ if tl <> [] then Buffer.add_string b "\n\n"
+ end
+ else
+ begin
+ Buffer.add_string b (String.make (list_indent) ' ');
+ Printf.bprintf b "%s%s\n" (String.make n '`')
+ (if lang = "" then !default_language else lang);
+ output_indented_block (list_indent) c;
+ if Buffer.nth b (Buffer.length b - 1) <> '\n' then
+ Buffer.add_char b '\n';
+ Buffer.add_string b (String.make (list_indent) ' ');
+ Printf.bprintf b "%s\n" (String.make n '`');
+ end;
+ loop list_indent tl
+ | Br :: tl ->
+ Buffer.add_string b "
";
+ loop list_indent tl
+ | Hr :: tl ->
+ Buffer.add_string b "* * *\n";
+ loop list_indent tl
+ | Raw s :: tl ->
+ Buffer.add_string b s;
+ loop list_indent tl
+ | Raw_block s :: tl ->
+ Buffer.add_char b '\n';
+ Buffer.add_string b s;
+ Buffer.add_char b '\n';
+ loop list_indent tl
+ | Html(tagname, attrs, []) :: tl
+ when StringSet.mem tagname html_void_elements ->
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Buffer.add_string b " />";
+ loop list_indent tl
+ | Html(tagname, attrs, body) :: tl ->
+ let a = filter_text_omd_rev attrs in
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs a);
+ Buffer.add_string b ">";
+ if a == attrs then
+ loop list_indent body
+ else
+ Buffer.add_string b (html_of_md body);
+ Printf.bprintf b "" tagname;
+ loop list_indent tl
+ | (Html_block(tagname, attrs, body))::tl ->
+ let needs_newlines =
+ match tl with
+ | NL :: Paragraph p :: _
+ | Paragraph p :: _ -> p <> []
+ | (H1 _ | H2 _ | H3 _ | H4 _ | H5 _ | H6 _
+ | Ul _ | Ol _ | Ulp _ | Olp _ | Code (_, _) | Code_block (_, _)
+ | Text _ | Emph _ | Bold _ | Br |Hr | Url (_, _, _)
+ | Ref (_, _, _, _) | Img_ref (_, _, _, _)
+ | Html (_, _, _)
+ | Blockquote _ | Img (_, _, _)) :: _ -> true
+ | ( Html_block (_, _, _) | Html_comment _
+ | Raw _|Raw_block _) :: _-> false
+ | X _ :: _ -> false
+ | NL :: _ -> false
+ | [] -> false
+ in
+ if body = [] && StringSet.mem tagname html_void_elements then
+ (
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs attrs);
+ Buffer.add_string b " />";
+ if needs_newlines then Buffer.add_string b "\n\n";
+ loop list_indent tl
+ )
+ else
+ (
+ let a = filter_text_omd_rev attrs in
+ Printf.bprintf b "<%s" tagname;
+ Buffer.add_string b (string_of_attrs a);
+ Buffer.add_string b ">";
+ if a == attrs then
+ loop list_indent body
+ else
+ Buffer.add_string b (html_of_md body);
+ Printf.bprintf b "" tagname;
+ if needs_newlines then Buffer.add_string b "\n\n";
+ loop list_indent tl
+ )
+ | Html_comment s :: tl ->
+ Buffer.add_string b s;
+ loop list_indent tl
+ | Url (href,s,title) :: tl ->
+ if title = "" then
+ bprintf b "[%s](%s)" (markdown_of_md s) href
+ else
+ bprintf b "[%s](%s \"%s\")" (markdown_of_md s) href title;
+ loop list_indent tl
+ | H1 md :: tl ->
+ Buffer.add_string b "# ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | H2 md :: tl ->
+ Buffer.add_string b "## ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | H3 md :: tl ->
+ Buffer.add_string b "### ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | H4 md :: tl ->
+ Buffer.add_string b "#### ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | H5 md :: tl ->
+ Buffer.add_string b "##### ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | H6 md :: tl ->
+ Buffer.add_string b "###### ";
+ loop list_indent md;
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | NL :: tl ->
+ if Buffer.length b = 1
+ || (Buffer.length b > 1 &&
+ not(Buffer.nth b (Buffer.length b - 1) = '\n'
+ && Buffer.nth b (Buffer.length b - 2) = '\n'))
+ then
+ Buffer.add_string b "\n";
+ loop list_indent tl
+ | [] -> ()
+ in
+ loop 0 md;
+ begin match !references with
+ | None -> ()
+ | Some r ->
+ Buffer.add_char b '\n';
+ List.iter
+ (fun (name, (url, title)) ->
+ if title = "" then
+ bprintf b "[%s]: %s \n" name url
+ else
+ bprintf b "[%s]: %s \"%s\"\n" name url title
+ )
+ r#get_all
+ end;
+ let res = Buffer.contents b in
+ if debug then
+ eprintf "(OMD) markdown_of_md(%S) => %S\n%!"
+ (sexpr_of_md md) res;
+ res
diff --git a/analysis/src/vendor/omd/omd_backend.mli b/analysis/src/vendor/omd/omd_backend.mli
new file mode 100644
index 000000000..cbdad2e56
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_backend.mli
@@ -0,0 +1,97 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+type code_stylist = lang:string -> string -> string
+(** Function that takes a language name and some code and returns
+ that code with style. *)
+
+val default_language : string ref
+(** default language for code blocks can be set to any name,
+ by default it is the empty string *)
+
+val html_of_md :
+ ?override:(Omd_representation.element -> string option) ->
+ ?pindent:bool ->
+ ?nl2br:bool ->
+ ?cs:code_stylist ->
+ Omd_representation.t -> string
+(** [html_of_md md] returns a string containing the HTML version of
+ [md]. Note that [md] uses the internal representation of
+ Markdown.
+
+ The optional parameter [override] allows to override an precise
+ behaviour for a constructor of Omd_representation.element,
+ as in the following example:
+
+let customized_to_html =
+ Omd.html_of_md
+ ~override:(function
+ | Url (href,s,title) ->
+ Some(" "" then
+ " title='" ^ (Omd_utils.htmlentities ~md:true title) ^ "'"
+ else "")
+ ^ ">"
+ ^ Omd_backend.html_of_md s ^ " target='_blank'")
+ | _ -> None)
+ *)
+
+val headers_of_md :
+ ?remove_header_links:bool ->
+ Omd_representation.t ->
+ (Omd_representation.element * string * string) list
+(** [headers_of_md md] returns a list of 3-tuples; in each of them the
+ first element is the header (e.g., [H1(foo)]), the second is the
+ HTML id (as produced by [html_of_md]), and the third element is
+ the HTML version of [foo]. The third elements of those 3-tuples
+ exist because if you use [html_and_headers_of_md], then you have
+ the guarantee that the HTML version of [foo] is the same for
+ both the headers and the HTML version of [md].
+ If [remove_header_links], then remove links inside headers (h1, h2, ...).
+ Default value of [remove_header_links]: cf. [html_and_headers_of_md].
+ *)
+
+val html_and_headers_of_md :
+ ?remove_header_links:bool ->
+ ?override:(Omd_representation.element -> string option) ->
+ ?pindent:bool ->
+ ?nl2br:bool ->
+ ?cs:code_stylist ->
+ Omd_representation.t ->
+ string *
+ (Omd_representation.element * Omd_utils.StringSet.elt * string) list
+(** [html_and_headers_of_md md] is the same as [(html_of_md md,
+ headers_of_md md)] except that it's two times faster.
+ If you need both headers and html, don't use [html_of_md]
+ and [headers_of_md] but this function instead.
+ If [remove_header_links], then remove links inside headers (h1, h2, ...).
+ Default value of [remove_header_links]: false.
+*)
+
+val escape_markdown_characters : string -> string
+(** [escape_markdown_characters s] returns a string where
+ markdown-significant characters in [s] have been
+ backslash-escaped. Note that [escape_markdown_characters] takes a
+ "raw" string, therefore it doesn't have the whole context in which
+ the string appears, thus the escaping cannot really be
+ minimal. However the implementation tries to minimalise the extra
+ escaping. *)
+
+val text_of_md : Omd_representation.t -> string
+(** [text_of_md md] is basically the same as [html_of_md md] but without
+ the HTML tags in the output. *)
+
+val markdown_of_md : Omd_representation.t -> string
+(** [markdown_of_md md] is basically the same as [html_of_md md] but
+ with the output in Markdown syntax rather than HTML. *)
+
+val sexpr_of_md : Omd_representation.t -> string
+(** [sexpr_of_md md] is basically the same as [html_of_md md] but with
+ the output in s-expressions rather than HTML. This is mainly used
+ for debugging. *)
+
diff --git a/analysis/src/vendor/omd/omd_html.ml b/analysis/src/vendor/omd/omd_html.ml
new file mode 100644
index 000000000..6dffb5b22
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_html.ml
@@ -0,0 +1,61 @@
+(***********************************************************************)
+(* OMD: Markdown tool in OCaml *)
+(* (c) 2014 by Philippe Wang *)
+(* Licence: ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+type html = html_node list
+
+and html_node =
+ | Node of nodename * attributes * html
+ | Data of string
+ | Rawdata of string
+ | Comment of string
+
+and nodename = string
+
+and attributes = attribute list
+
+and attribute = string * string option
+
+let to_string html =
+ let b = Buffer.create 1024 in
+ let pp f = Printf.bprintf b f in
+ let rec loop = function
+ | Node(nodename, attributes, html) ->
+ pp "<%s" nodename;
+ ppa attributes;
+ pp ">";
+ List.iter loop html;
+ pp "" nodename
+ | Data s -> pp "%s" s
+ | Rawdata s -> pp "%s" s
+ | Comment c -> pp "" c
+ and ppa attrs =
+ List.iter
+ (function
+ | (a, Some v) ->
+ if not (String.contains v '\'') then
+ pp " %s='%s'" a v
+ else if (not (String.contains v '"')) then
+ pp " %s=\"%s\"" a v
+ else
+ (
+ pp " %s=\"" a;
+ for i = 0 to String.length v - 1 do
+ match v.[i] with
+ | '"' -> pp """
+ | c -> pp "%c" c
+ done;
+ pp "\""
+ )
+ | a, None ->
+ Printf.bprintf b " %s=''" a (* HTML5 *)
+ )
+ attrs
+ in
+ List.iter loop html;
+ Buffer.contents b
+
+
diff --git a/analysis/src/vendor/omd/omd_lexer.ml b/analysis/src/vendor/omd/omd_lexer.ml
new file mode 100644
index 000000000..3c4e8d533
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_lexer.ml
@@ -0,0 +1,375 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+(* Implementation notes *********************************************
+
+ * - This module should depend on OCaml's standard library only and
+ * should be as 'pure OCaml' (i.e. depend as least as possible on
+ * external tools) as possible.
+
+ * - `while' loops are sometimes preferred to recursion because this
+ * may be used on systems where tail recursion is not well
+ * supported. (I tried to write "while" as often as possible, but it
+ * turned out that it was pretty inconvenient, so I do use
+ * recursion. When I have time, I'll do some tests and see if I
+ * need to convert recursive loops into iterative loops. Sorry if it
+ * makes it harder to read.)
+
+*)
+
+(* class type tag = object method is_me : 'a. 'a -> bool end *)
+
+open Omd_representation
+
+type token = Omd_representation.tok
+type t = Omd_representation.tok list
+
+let string_of_token = function
+ | Tag (name, o) ->
+ if Omd_utils.debug then "TAG("^name^")" ^ o#to_string else o#to_string
+ | Ampersand -> "&"
+ | Ampersands n -> assert (n >= 0); String.make (2+n) '&'
+ | At -> "@"
+ | Ats n -> assert (n >= 0); String.make (2+n) '@'
+ | Backquote -> "`"
+ | Backquotes n -> assert (n >= 0); String.make (2+n) '`'
+ | Backslash -> "\\"
+ | Backslashs n -> assert (n >= 0); String.make (2+n) '\\'
+ | Bar -> "|"
+ | Bars n -> assert (n >= 0); String.make (2+n) '|'
+ | Caret -> "^"
+ | Carets n -> assert (n >= 0); String.make (2+n) '^'
+ | Cbrace -> "}"
+ | Cbraces n -> assert (n >= 0); String.make (2+n) '}'
+ | Colon -> ":"
+ | Colons n -> assert (n >= 0); String.make (2+n) ':'
+ | Comma -> ","
+ | Commas n -> assert (n >= 0); String.make (2+n) ','
+ | Cparenthesis -> ")"
+ | Cparenthesiss n -> assert (n >= 0); String.make (2+n) ')'
+ | Cbracket -> "]"
+ | Cbrackets n -> assert (n >= 0); String.make (2+n) ']'
+ | Dollar -> "$"
+ | Dollars n -> assert (n >= 0); String.make (2+n) '$'
+ | Dot -> "."
+ | Dots n -> assert (n >= 0); String.make (2+n) '.'
+ | Doublequote -> "\""
+ | Doublequotes n -> assert (n >= 0); String.make (2+n) '"'
+ | Exclamation -> "!"
+ | Exclamations n -> assert (n >= 0); String.make (2+n) '!'
+ | Equal -> "="
+ | Equals n -> assert (n >= 0); String.make (2+n) '='
+ | Greaterthan -> ">"
+ | Greaterthans n -> assert (n >= 0); String.make (2+n) '>'
+ | Hash -> "#"
+ | Hashs n -> assert (n >= 0); String.make (2+n) '#'
+ | Lessthan -> "<"
+ | Lessthans n -> assert (n >= 0); String.make (2+n) '<'
+ | Minus -> "-"
+ | Minuss n -> assert (n >= 0); String.make (2+n) '-'
+ | Newline -> "\n"
+ | Newlines n -> assert (n >= 0); String.make (2+n) '\n'
+ | Number s -> s
+ | Obrace -> "{"
+ | Obraces n -> assert (n >= 0); String.make (2+n) '{'
+ | Oparenthesis -> "("
+ | Oparenthesiss n -> assert (n >= 0); String.make (2+n) '('
+ | Obracket -> "["
+ | Obrackets n -> assert (n >= 0); String.make (2+n) '['
+ | Percent -> "%"
+ | Percents n -> assert (n >= 0); String.make (2+n) '%'
+ | Plus -> "+"
+ | Pluss n -> assert (n >= 0); String.make (2+n) '+'
+ | Question -> "?"
+ | Questions n -> assert (n >= 0); String.make (2+n) '?'
+ | Quote -> "'"
+ | Quotes n -> assert (n >= 0); String.make (2+n) '\''
+ | Semicolon -> ";"
+ | Semicolons n -> assert (n >= 0); String.make (2+n) ';'
+ | Slash -> "/"
+ | Slashs n -> assert (n >= 0); String.make (2+n) '/'
+ | Space -> " "
+ | Spaces n -> assert (n >= 0); String.make (2+n) ' '
+ | Star -> "*"
+ | Stars n -> assert (n >= 0); String.make (2+n) '*'
+ | Tab -> " "
+ | Tabs n -> assert (n >= 0); String.make ((2+n)*4) ' '
+ | Tilde -> "~"
+ | Tildes n -> assert (n >= 0); String.make (2+n) '~'
+ | Underscore -> "_"
+ | Underscores n -> assert (n >= 0); String.make (2+n) '_'
+ | Word s -> s
+
+
+let size_and_newlines = function
+ | Tag _ -> (0, 0)
+ | Ampersand | At | Backquote | Backslash | Bar | Caret | Cbrace
+ | Colon | Comma | Cparenthesis | Cbracket | Dollar | Dot
+ | Doublequote | Exclamation | Equal | Greaterthan | Hash | Lessthan
+ | Minus | Obrace | Oparenthesis | Obracket | Percent | Plus
+ | Question | Quote | Semicolon | Slash | Space | Star | Tab
+ | Tilde | Underscore -> (1, 0)
+ | Ampersands x | Ats x | Backquotes x | Backslashs x | Bars x | Carets x
+ | Cbraces x | Colons x | Commas x | Cparenthesiss x | Cbrackets x
+ | Dollars x | Dots x
+ | Doublequotes x | Exclamations x | Equals x | Greaterthans x | Hashs x
+ | Lessthans x
+ | Minuss x | Obraces x | Oparenthesiss x | Obrackets x | Percents x | Pluss x
+ | Questions x | Quotes x | Semicolons x | Slashs x | Spaces x | Stars x
+ | Tabs x
+ | Tildes x | Underscores x -> (2+x, 0)
+ | Newline -> (0, 1)
+ | Newlines x -> (0, 2+x)
+ | Number s | Word s -> (String.length s, 0)
+
+let length t =
+ let c, nl = size_and_newlines t in
+ c + nl
+
+let split_first = function
+ | Ampersands n -> Ampersand, (if n > 0 then Ampersands(n-1) else Ampersand)
+ | Ats n -> At, (if n > 0 then Ats(n-1) else At)
+ | Backquotes n -> Backquote, (if n > 0 then Backquotes(n-1) else Backquote)
+ | Backslashs n -> Backslash, (if n > 0 then Backslashs(n-1) else Backslash)
+ | Bars n -> Bar, (if n > 0 then Bars(n-1) else Bar)
+ | Carets n -> Caret, (if n > 0 then Carets(n-1) else Caret)
+ | Cbraces n -> Cbrace, (if n > 0 then Cbraces(n-1) else Cbrace)
+ | Colons n -> Colon, (if n > 0 then Colons(n-1) else Colon)
+ | Commas n -> Comma, (if n > 0 then Commas(n-1) else Comma)
+ | Cparenthesiss n -> Cparenthesis, (if n > 0 then Cparenthesiss(n-1)
+ else Cparenthesis)
+ | Cbrackets n -> Cbracket, (if n > 0 then Cbrackets(n-1) else Cbracket)
+ | Dollars n -> Dollar, (if n > 0 then Dollars(n-1) else Dollar)
+ | Dots n -> Dot, (if n > 0 then Dots(n-1) else Dot)
+ | Doublequotes n -> Doublequote, (if n > 0 then Doublequotes(n-1)
+ else Doublequote)
+ | Exclamations n -> Exclamation, (if n > 0 then Exclamations(n-1)
+ else Exclamation)
+ | Equals n -> Equal, (if n > 0 then Equals(n-1) else Equal)
+ | Greaterthans n -> Greaterthan, (if n > 0 then Greaterthans(n-1)
+ else Greaterthan)
+ | Hashs n -> Hash, (if n > 0 then Hashs(n-1) else Hash)
+ | Lessthans n -> Lessthan, (if n > 0 then Lessthans(n-1) else Lessthan)
+ | Minuss n -> Minus, (if n > 0 then Minuss(n-1) else Minus)
+ | Newlines n -> Newline, (if n > 0 then Newlines(n-1) else Newline)
+ | Obraces n -> Obrace, (if n > 0 then Obraces(n-1) else Obrace)
+ | Oparenthesiss n -> Oparenthesis, (if n > 0 then Oparenthesiss(n-1)
+ else Oparenthesis)
+ | Obrackets n -> Obracket, (if n > 0 then Obrackets(n-1) else Obracket)
+ | Percents n -> Percent, (if n > 0 then Percents(n-1) else Percent)
+ | Pluss n -> Plus, (if n > 0 then Pluss(n-1) else Plus)
+ | Questions n -> Question, (if n > 0 then Questions(n-1) else Question)
+ | Quotes n -> Quote, (if n > 0 then Quotes(n-1) else Quote)
+ | Semicolons n -> Semicolon, (if n > 0 then Semicolons(n-1) else Semicolon)
+ | Slashs n -> Slash, (if n > 0 then Slashs(n-1) else Slash)
+ | Spaces n -> Space, (if n > 0 then Spaces(n-1) else Space)
+ | Stars n -> Star, (if n > 0 then Stars(n-1) else Star)
+ | Tabs n -> Tab, (if n > 0 then Tabs(n-1) else Tab)
+ | Tildes n -> Tilde, (if n > 0 then Tildes(n-1) else Tilde)
+ | Underscores n -> Underscore, (if n > 0 then Underscores(n-1)
+ else Underscore)
+ | Ampersand | At | Backquote | Backslash | Bar | Caret | Cbrace | Colon
+ | Comma | Cparenthesis | Cbracket | Dollar | Dot | Doublequote
+ | Exclamation | Equal | Greaterthan | Hash | Lessthan | Minus
+ | Newline | Number _ | Obrace | Oparenthesis | Obracket | Percent
+ | Plus | Question | Quote | Semicolon | Slash | Space | Star | Tab
+ | Tilde | Underscore | Tag _ | Word _ ->
+ invalid_arg "Omd_lexer.split_first"
+
+module type Input =
+sig
+ type t
+ val length : t -> int
+ val get : t -> int -> char
+ val sub : t -> pos:int -> len:int -> string
+end
+
+module Lex(I : Input) :
+sig
+ val lex : I.t -> t
+end =
+struct
+ let lex (s : I.t) =
+ let result = ref [] in
+ let i = ref 0 in
+ let l = I.length s in
+ let rcount c =
+ (* [rcount c] returns the number of immediate consecutive
+ occurrences of [c]. By side-effect, it increases the reference
+ counter [i]. *)
+ let rec loop r =
+ if !i = l then r
+ else if I.get s !i = c then (incr i; loop (r+1))
+ else r
+ in
+ loop 1
+ in
+ let word () =
+ let start = !i in
+ let rec loop () =
+ begin
+ if !i = l then
+ Word(I.sub s ~pos:start ~len:(!i-start))
+ else
+ match I.get s !i with
+ | ' ' | '\t' | '\n' | '\r' | '#' | '*' | '-' | '+' | '`' | '\''
+ | '"' | '\\' | '_' | '[' | ']' | '{' | '}' | '(' | ')' | ':'
+ | ';' | '>' | '~' | '<' | '@' | '&' | '|' | '^' | '.' | '/'
+ | '$' | '%' | '!' | '?' | '=' ->
+ Word(I.sub s ~pos:start ~len:(!i-start))
+ | _s -> incr i; loop()
+ end
+ in
+ loop()
+ in
+ let maybe_number () =
+ let start = !i in
+ while
+ !i < l &&
+ match I.get s !i with
+ | '0' .. '9' -> true
+ | _ -> false
+ do
+ incr i
+ done;
+ if !i = l then
+ Number(I.sub s ~pos:start ~len:(!i-start))
+ else
+ begin match I.get s !i with
+ | ' ' | '\t' | '\n' | '\r' | '#' | '*' | '-' | '+' | '`' | '\'' | '"'
+ | '\\' | '_' | '[' | ']' | '{' | '}' | '(' | ')' | ':' | ';' | '>'
+ | '~' | '<' | '@' | '&' | '|' | '^' | '.' | '/' | '$' | '%' | '!'
+ | '?' | '=' ->
+ Number(I.sub s ~pos:start ~len:(!i-start))
+ | _ ->
+ i := start;
+ word()
+ end
+ in
+
+ let n_occ c = incr i; rcount c in
+
+ while !i < l do
+ let c = I.get s !i in
+ let w = match c with
+ | ' ' -> let n = n_occ c in if n = 1 then Space else Spaces (n-2)
+ | '\t' -> let n = n_occ c in if n = 1 then Spaces(2) else Spaces(4*n-2)
+ | '\n' -> let n = n_occ c in if n = 1 then Newline else Newlines (n-2)
+ | '\r' -> (* eliminating \r by converting all styles to unix style *)
+ incr i;
+ let rec count_rn x =
+ if !i < l && I.get s (!i) = '\n' then
+ if !i + 1 < l && I.get s (!i+1) = '\r' then
+ (i := !i + 2; count_rn (x+1))
+ else
+ x
+ else
+ x
+ in
+ let rn = 1 + count_rn 0 in
+ if rn = 1 then
+ match n_occ c with
+ | 1 -> Newline
+ | x -> assert(x>=2); Newlines(x-2)
+ else
+ (assert(rn>=2);Newlines(rn-2))
+ | '#' -> let n = n_occ c in if n = 1 then Hash else Hashs (n-2)
+ | '*' -> let n = n_occ c in if n = 1 then Star else Stars (n-2)
+ | '-' -> let n = n_occ c in if n = 1 then Minus else Minuss (n-2)
+ | '+' -> let n = n_occ c in if n = 1 then Plus else Pluss (n-2)
+ | '`' -> let n = n_occ c in if n = 1 then Backquote else Backquotes (n-2)
+ | '\'' -> let n = n_occ c in if n = 1 then Quote else Quotes (n-2)
+ | '"' -> let n = n_occ c in if n = 1 then Doublequote
+ else Doublequotes (n-2)
+ | '\\' -> let n = n_occ c in if n = 1 then Backslash
+ else Backslashs (n-2)
+ | '_' -> let n = n_occ c in if n = 1 then Underscore
+ else Underscores (n-2)
+ | '[' -> let n = n_occ c in if n = 1 then Obracket
+ else Obrackets (n-2)
+ | ']' -> let n = n_occ c in if n = 1 then Cbracket else Cbrackets (n-2)
+ | '{' -> let n = n_occ c in if n = 1 then Obrace else Obraces (n-2)
+ | '}' -> let n = n_occ c in if n = 1 then Cbrace else Cbraces (n-2)
+ | '(' -> let n = n_occ c in if n = 1 then Oparenthesis
+ else Oparenthesiss (n-2)
+ | ')' -> let n = n_occ c in if n = 1 then Cparenthesis
+ else Cparenthesiss (n-2)
+ | ':' -> let n = n_occ c in if n = 1 then Colon else Colons (n-2)
+ | ';' -> let n = n_occ c in if n = 1 then Semicolon else Semicolons (n-2)
+ | '>' -> let n = n_occ c in if n = 1 then Greaterthan
+ else Greaterthans (n-2)
+ | '~' -> let n = n_occ c in if n = 1 then Tilde else Tildes (n-2)
+ | '<' -> let n = n_occ c in if n = 1 then Lessthan else Lessthans (n-2)
+ | '@' -> let n = n_occ c in if n = 1 then At else Ats (n-2)
+ | '&' -> let n = n_occ c in if n = 1 then Ampersand else Ampersands (n-2)
+ | '|' -> let n = n_occ c in if n = 1 then Bar else Bars (n-2)
+ | '^' -> let n = n_occ c in if n = 1 then Caret else Carets (n-2)
+ | ',' -> let n = n_occ c in if n = 1 then Comma else Commas (n-2)
+ | '.' -> let n = n_occ c in if n = 1 then Dot else Dots (n-2)
+ | '/' -> let n = n_occ c in if n = 1 then Slash else Slashs (n-2)
+ | '$' -> let n = n_occ c in if n = 1 then Dollar else Dollars (n-2)
+ | '%' -> let n = n_occ c in if n = 1 then Percent else Percents (n-2)
+ | '=' -> let n = n_occ c in if n = 1 then Equal else Equals (n-2)
+ | '!' -> let n = n_occ c in if n = 1 then Exclamation
+ else Exclamations (n-2)
+ | '?' -> let n = n_occ c in if n = 1 then Question else Questions (n-2)
+ | '0' .. '9' -> maybe_number()
+ | _ -> word() in
+ result := w :: !result
+ done;
+ List.rev !result
+end
+
+module Lex_string = Lex(StringLabels)
+let lex = Lex_string.lex
+let make_space = function
+ | 0 -> invalid_arg "Omd_lexer.make_space"
+ | 1 -> Space
+ | n -> if n < 0 then invalid_arg "Omd_lexer.make_space" else Spaces (n-2)
+
+
+(*
+(** [string_of_tl l] returns the string representation of l.
+ [estring_of_tl l] returns the escaped string representation of l
+ (same semantics as [String.escaped (string_of_tl l)]). *)
+let string_of_tl, estring_of_tl =
+ let g escaped tl =
+ let b = Buffer.create 42 in
+ let rec loop : 'a t list -> unit = function
+ | e::tl ->
+ Buffer.add_string b (if escaped then String.escaped (string_of_t e)
+ else string_of_t e);
+ loop tl
+ | [] ->
+ ()
+ in
+ Buffer.contents (loop tl; b)
+ in g false, g true
+*)
+
+let string_of_tokens tl =
+ let b = Buffer.create 128 in
+ List.iter (fun e -> Buffer.add_string b (string_of_token e)) tl;
+ Buffer.contents b
+
+
+let destring_of_tokens ?(limit=max_int) tl =
+ let b = Buffer.create 1024 in
+ let rec loop (i:int) (tlist:tok list) : unit = match tlist with
+ | e::tl ->
+ if limit = i then
+ loop i []
+ else
+ begin
+ Buffer.add_string b (String.escaped (string_of_token e));
+ Buffer.add_string b "::";
+ loop (succ i) tl
+ end
+ | [] ->
+ Buffer.add_string b "[]"
+ in
+ Buffer.contents (loop 0 tl; b)
diff --git a/analysis/src/vendor/omd/omd_lexer.mli b/analysis/src/vendor/omd/omd_lexer.mli
new file mode 100644
index 000000000..bcebdd368
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_lexer.mli
@@ -0,0 +1,38 @@
+type token = Omd_representation.tok
+type t = token list
+
+val lex : string -> t
+(** Translate a raw string into tokens for the parser. To implement
+ an extension to the lexer, one may process its result before
+ giving it to the parser. To implement an extension to the
+ parser, one may extend it using the constructor [Tag]
+ from type [tok] and/or using the extensions mechanism
+ of the parser (cf. the optional argument [extensions]).
+ The main difference is that [Tag] is processed by the parser
+ in highest priority whereas functions in [extensions] are applied
+ with lowest priority. *)
+
+val string_of_tokens : t -> string
+(** [string_of_tokens t] return the string corresponding to the token
+ list [t]. *)
+
+val length : token -> int
+(** [length t] number of characters of the string represented as [t]
+ (i.e. [String.length(string_of_token t)]). *)
+
+val string_of_token : token -> string
+(** [string_of_token tk] return the string corresponding to the token
+ [tk]. *)
+
+val make_space : int -> token
+
+val split_first : token -> token * token
+(** [split_first(Xs n)] returns [(X, X(n-1))] where [X] is a token
+ carrying an int count.
+
+ @raise Invalid_argument is passed a single token. *)
+
+
+val destring_of_tokens : ?limit:int -> t -> string
+(** Converts the tokens to a simple string representation useful for
+ debugging. *)
diff --git a/analysis/src/vendor/omd/omd_parser.ml b/analysis/src/vendor/omd/omd_parser.ml
new file mode 100644
index 000000000..174ade358
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_parser.ml
@@ -0,0 +1,4453 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013-2014 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+open Printf
+open Omd_representation
+open Omd_utils
+module L = Omd_lexer
+
+type r = Omd_representation.t
+(** accumulator (beware, reversed tokens) *)
+
+and p = Omd_representation.tok list
+(** context information: previous elements *)
+
+and l = Omd_representation.tok list
+(** tokens to parse *)
+
+and main_loop =
+ ?html:bool ->
+ r -> (* accumulator (beware, reversed tokens) *)
+ p -> (* info: previous elements *)
+ l -> (* tokens to parse *)
+ Omd_representation.t (* final result *)
+(** most important loop *)
+
+
+(** N.B. Please do not use tabulations in your Markdown file! *)
+
+module type Env = sig
+ val rc: Omd_representation.ref_container
+ val extensions : Omd_representation.extensions
+ val default_lang : string
+ val gh_uemph_or_bold_style : bool
+ val blind_html : bool
+ val strict_html : bool
+ val warning : bool
+ val warn_error : bool
+end
+
+module Unit = struct end
+
+module Default_env (Unit:sig end) : Env = struct
+ let rc = new Omd_representation.ref_container
+ let extensions = []
+ let default_lang = ""
+ let gh_uemph_or_bold_style = true
+ let blind_html = false
+ let strict_html = false
+ let warning = false
+ let warn_error = false
+end
+
+module Make (Env:Env) =
+struct
+ include Env
+
+ let warn = Omd_utils.warn ~we:warn_error
+
+ (** set of known HTML codes *)
+ let htmlcodes_set = StringSet.of_list (* This list should be checked... *)
+ (* list extracted from: http://www.w3.org/TR/html4/charset.html *)
+ [ "AElig"; "Aacute"; "Acirc"; "Agrave"; "Alpha"; "Aring"; "Atilde";
+ "Auml"; "Beta"; "Ccedil"; "Chi"; "Dagger"; "Delta"; "ETH"; "Eacute";
+ "Ecirc"; "Egrave"; "Epsilon"; "Eta"; "Euml"; "Gamma"; "Iacute";
+ "Icirc"; "Igrave"; "Iota"; "Iuml"; "Kappa"; "Lambda"; "Mu"; "Ntilde";
+ "Nu"; "OElig"; "Oacute"; "Ocirc"; "Ograve"; "Omega"; "Omicron";
+ "Oslash"; "Otilde"; "Ouml"; "Phi"; "Pi"; "Prime"; "Psi"; "Rho";
+ "Scaron"; "Sigma"; "THORN"; "Tau"; "Theta"; "Uacute"; "Ucirc";
+ "Ugrave"; "Upsilon"; "Uuml"; "Xi"; "Yacute"; "Yuml"; "Zeta"; "aacute";
+ "acirc"; "acute"; "aelig"; "agrave"; "alefsym"; "alpha"; "amp"; "and";
+ "ang"; "aring"; "asymp"; "atilde"; "auml"; "bdquo"; "beta"; "brvbar";
+ "bull"; "cap"; "ccedil"; "cedil"; "cent"; "chi"; "circ"; "clubs";
+ "cong"; "copy"; "crarr"; "cup"; "curren"; "dArr"; "dagger"; "darr";
+ "deg"; "delta"; "diams"; "divide"; "eacute"; "ecirc"; "egrave";
+ "empty"; "emsp"; "ensp"; "epsilon"; "equiv"; "eta"; "eth"; "euml";
+ "euro"; "exist"; "fnof"; "forall"; "frac12"; "frac14"; "frac34";
+ "frasl"; "gamma"; "ge"; "gt"; "hArr"; "harr"; "hearts"; "hellip";
+ "iacute"; "icirc"; "iexcl"; "igrave"; "image"; "infin"; "int"; "iota";
+ "iquest"; "isin"; "iuml"; "kappa"; "lArr"; "lambda"; "lang"; "laquo";
+ "larr"; "lceil"; "ldquo"; "le"; "lfloor"; "lowast"; "loz"; "lrm";
+ "lsaquo"; "lsquo"; "lt"; "macr"; "mdash"; "micro"; "middot"; "minus";
+ "mu"; "nabla"; "nbsp"; "ndash"; "ne"; "ni"; "not"; "notin"; "nsub";
+ "ntilde"; "nu"; "oacute"; "ocirc"; "oelig"; "ograve"; "oline";
+ "omega"; "omicron"; "oplus"; "or"; "ordf"; "ordm"; "oslash"; "otilde";
+ "otimes"; "ouml"; "para"; "part"; "permil"; "perp"; "phi"; "pi";
+ "piv"; "plusmn"; "pound"; "prime"; "prod"; "prop"; "psi"; "quot";
+ "rArr"; "radic"; "rang"; "raquo"; "rarr"; "rceil"; "rdquo"; "real";
+ "reg"; "rfloor"; "rho"; "rlm"; "rsaquo"; "rsquo"; "sbquo"; "scaron";
+ "sdot"; "sect"; "shy"; "sigma"; "sigmaf"; "sim"; "spades"; "sub";
+ "sube"; "sum"; "sup"; "sup1"; "sup2"; "sup3"; "supe"; "szlig"; "tau";
+ "there4"; "theta"; "thetasym"; "thinsp"; "thorn"; "tilde"; "times";
+ "trade"; "uArr"; "uacute"; "uarr"; "ucirc"; "ugrave"; "uml"; "upsih";
+ "upsilon"; "uuml"; "weierp"; "xi"; "yacute"; "yen"; "yuml"; "zeta";
+ "zwj"; "zwnj"; ]
+
+
+ (** set of known inline HTML tags *)
+ let inline_htmltags_set =
+ (StringSet.of_list
+ (* from https://developer.mozilla.org/en-US/docs/HTML/Inline_elements *)
+ [ "b";"big";"i";"small";"tt";
+ "abbr";"acronym";"cite";"code";"dfn";"em";"kbd";"strong";"samp";"var";
+ "a";"bdo";"br";"img";"map";"object";"q";"span";"sub";"sup";
+ "button";"input";"label";"select";"textarea";])
+
+ (** N.B. it seems that there is no clear distinction between inline
+ tags and block-level tags: in HTML4 it was not clear, in HTML5
+ it's even more complicated. So, the choice *here* is to specify
+ a set of tags considered as "inline", cf. [inline_htmltags_set].
+ So there will be inline tags, non-inline tags, and unknown
+ tags.*)
+
+ (** set of HTML tags that may appear out of a body *)
+ let notinbodytags = StringSet.of_list
+ [
+ "title";
+ "link";
+ "meta";
+ "style";
+ "html";
+ "head";
+ "body";
+ ]
+
+ (** All known HTML tags *)
+ let htmltags_set =
+ StringSet.union notinbodytags
+ (StringSet.union inline_htmltags_set
+ (StringSet.of_list
+ [
+ "a";"abbr";"acronym";"address";"applet";"area";"article";"aside"
+ ;"audio";"b";"base";"basefont";"bdi";"bdo";"big";"blockquote"
+ ;"br";"button";"canvas";"caption";"center";"cite";"code";"col"
+ ;"colgroup";"command";"datalist";"dd";"del";"details";"dfn"
+ ;"dialog";"dir";"div";"dl";"dt";"em";"embed";"fieldset"
+ ;"figcaption";"figure";"font";"footer";"form";"frame";"frameset"
+ ;"h2";"h3";"h4";"h5";"h6"
+ ;"h1";"header";"hr";"i";"iframe";"img";"input";"ins";"kbd"
+ ;"keygen";"label";"legend";"li";"map";"mark";"menu";"meter";"nav"
+ ;"noframes";"noscript";"object";"ol";"optgroup";"option";"output"
+ ;"p";"param";"pre";"progress";"q";"rp";"rt";"ruby";"s";"samp"
+ ;"script";"section";"select";"small";"source";"span";"strike"
+ ;"strong";"style";"sub";"summary";"sup";"table";"tbody";"td"
+ ;"textarea";"tfoot";"th";"thead";"time";"tr";"track";"tt";"u"
+ ;"ul";"var";"video";"wbr"
+ ]))
+
+
+ (** This functions fixes bad lexing trees, which may be built when
+ extraction a portion of another lexing tree. *)
+ let fix l =
+ let rec loop accu = function
+ | Ampersand::Ampersand::tl ->
+ if trackfix then eprintf "(OMD) Ampersand 1\n";
+ loop accu (Ampersands 0::tl)
+ | Ampersands n::Ampersand::tl ->
+ if trackfix then eprintf "(OMD) Ampersand 2\n";
+ loop accu (Ampersands(n+1)::tl)
+ | Ampersand::Ampersands n::tl ->
+ if trackfix then eprintf "(OMD) Ampersand 3\n";
+ loop accu (Ampersands(n+1)::tl)
+ | Ampersands a::Ampersands b::tl ->
+ if trackfix then eprintf "(OMD) Ampersand 4\n";
+ loop accu (Ampersands(a+b+2)::tl)
+ | At::At::tl ->
+ if trackfix then eprintf "(OMD) At 1\n";
+ loop accu (Ats 0::tl)
+ | Ats n::At::tl ->
+ if trackfix then eprintf "(OMD) At 2\n";
+ loop accu (Ats(n+1)::tl)
+ | At::Ats n::tl ->
+ if trackfix then eprintf "(OMD) At 3\n";
+ loop accu (Ats(n+1)::tl)
+ | Ats a::Ats b::tl ->
+ if trackfix then eprintf "(OMD) At 4\n";
+ loop accu (Ats(a+b+2)::tl)
+ | Backquote::Backquote::tl ->
+ if trackfix then eprintf "(OMD) Backquote 1\n";
+ loop accu (Backquotes 0::tl)
+ | Backquotes n::Backquote::tl ->
+ if trackfix then eprintf "(OMD) Backquote 2\n";
+ loop accu (Backquotes(n+1)::tl)
+ | Backquote::Backquotes n::tl ->
+ if trackfix then eprintf "(OMD) Backquote 3\n";
+ loop accu (Backquotes(n+1)::tl)
+ | Backquotes a::Backquotes b::tl ->
+ if trackfix then eprintf "(OMD) Backquote 4\n";
+ loop accu (Backquotes(a+b+2)::tl)
+ | Backslash::Backslash::tl ->
+ if trackfix then eprintf "(OMD) Backslash 1\n";
+ loop accu (Backslashs 0::tl)
+ | Backslashs n::Backslash::tl ->
+ if trackfix then eprintf "(OMD) Backslash 2\n";
+ loop accu (Backslashs(n+1)::tl)
+ | Backslash::Backslashs n::tl ->
+ if trackfix then eprintf "(OMD) Backslash 3\n";
+ loop accu (Backslashs(n+1)::tl)
+ | Backslashs a::Backslashs b::tl ->
+ if trackfix then eprintf "(OMD) Backslash 4\n";
+ loop accu (Backslashs(a+b+2)::tl)
+ | Bar::Bar::tl ->
+ if trackfix then eprintf "(OMD) Bar 1\n";
+ loop accu (Bars 0::tl)
+ | Bars n::Bar::tl ->
+ if trackfix then eprintf "(OMD) Bar 2\n";
+ loop accu (Bars(n+1)::tl)
+ | Bar::Bars n::tl ->
+ if trackfix then eprintf "(OMD) Bar 3\n";
+ loop accu (Bars(n+1)::tl)
+ | Bars a::Bars b::tl ->
+ if trackfix then eprintf "(OMD) Bar 4\n";
+ loop accu (Bars(a+b+2)::tl)
+ | Caret::Caret::tl ->
+ if trackfix then eprintf "(OMD) Caret 1\n";
+ loop accu (Carets 0::tl)
+ | Carets n::Caret::tl ->
+ if trackfix then eprintf "(OMD) Caret 2\n";
+ loop accu (Carets(n+1)::tl)
+ | Caret::Carets n::tl ->
+ if trackfix then eprintf "(OMD) Caret 3\n";
+ loop accu (Carets(n+1)::tl)
+ | Carets a::Carets b::tl ->
+ if trackfix then eprintf "(OMD) Caret 4\n";
+ loop accu (Carets(a+b+2)::tl)
+ | Cbrace::Cbrace::tl ->
+ if trackfix then eprintf "(OMD) Cbrace 1\n";
+ loop accu (Cbraces 0::tl)
+ | Cbraces n::Cbrace::tl ->
+ if trackfix then eprintf "(OMD) Cbrace 2\n";
+ loop accu (Cbraces(n+1)::tl)
+ | Cbrace::Cbraces n::tl ->
+ if trackfix then eprintf "(OMD) Cbrace 3\n";
+ loop accu (Cbraces(n+1)::tl)
+ | Cbraces a::Cbraces b::tl ->
+ if trackfix then eprintf "(OMD) Cbrace 4\n";
+ loop accu (Cbraces(a+b+2)::tl)
+ | Colon::Colon::tl ->
+ if trackfix then eprintf "(OMD) Colon 1\n";
+ loop accu (Colons 0::tl)
+ | Colons n::Colon::tl ->
+ if trackfix then eprintf "(OMD) Colon 2\n";
+ loop accu (Colons(n+1)::tl)
+ | Colon::Colons n::tl ->
+ if trackfix then eprintf "(OMD) Colon 3\n";
+ loop accu (Colons(n+1)::tl)
+ | Colons a::Colons b::tl ->
+ if trackfix then eprintf "(OMD) Colon 4\n";
+ loop accu (Colons(a+b+2)::tl)
+ | Comma::Comma::tl ->
+ if trackfix then eprintf "(OMD) Comma 1\n";
+ loop accu (Commas 0::tl)
+ | Commas n::Comma::tl ->
+ if trackfix then eprintf "(OMD) Comma 2\n";
+ loop accu (Commas(n+1)::tl)
+ | Comma::Commas n::tl ->
+ if trackfix then eprintf "(OMD) Comma 3\n";
+ loop accu (Commas(n+1)::tl)
+ | Commas a::Commas b::tl ->
+ if trackfix then eprintf "(OMD) Comma 4\n";
+ loop accu (Commas(a+b+2)::tl)
+ | Cparenthesis::Cparenthesis::tl ->
+ if trackfix then eprintf "(OMD) Cparenthesis 1\n";
+ loop accu (Cparenthesiss 0::tl)
+ | Cparenthesiss n::Cparenthesis::tl ->
+ if trackfix then eprintf "(OMD) Cparenthesis 2\n";
+ loop accu (Cparenthesiss(n+1)::tl)
+ | Cparenthesis::Cparenthesiss n::tl ->
+ if trackfix then eprintf "(OMD) Cparenthesis 3\n";
+ loop accu (Cparenthesiss(n+1)::tl)
+ | Cparenthesiss a::Cparenthesiss b::tl ->
+ if trackfix then eprintf "(OMD) Cparenthesis 4\n";
+ loop accu (Cparenthesiss(a+b+2)::tl)
+ | Cbracket::Cbracket::tl ->
+ if trackfix then eprintf "(OMD) Cbracket 1\n";
+ loop accu (Cbrackets 0::tl)
+ | Cbrackets n::Cbracket::tl ->
+ if trackfix then eprintf "(OMD) Cbracket 2\n";
+ loop accu (Cbrackets(n+1)::tl)
+ | Cbracket::Cbrackets n::tl ->
+ if trackfix then eprintf "(OMD) Cbracket 3\n";
+ loop accu (Cbrackets(n+1)::tl)
+ | Cbrackets a::Cbrackets b::tl ->
+ if trackfix then eprintf "(OMD) Cbracket 4\n";
+ loop accu (Cbrackets(a+b+2)::tl)
+ | Dollar::Dollar::tl ->
+ if trackfix then eprintf "(OMD) Dollar 1\n";
+ loop accu (Dollars 0::tl)
+ | Dollars n::Dollar::tl ->
+ if trackfix then eprintf "(OMD) Dollar 2\n";
+ loop accu (Dollars(n+1)::tl)
+ | Dollar::Dollars n::tl ->
+ if trackfix then eprintf "(OMD) Dollar 3\n";
+ loop accu (Dollars(n+1)::tl)
+ | Dollars a::Dollars b::tl ->
+ if trackfix then eprintf "(OMD) Dollar 4\n";
+ loop accu (Dollars(a+b+2)::tl)
+ | Dot::Dot::tl ->
+ if trackfix then eprintf "(OMD) Dot 1\n";
+ loop accu (Dots 0::tl)
+ | Dots n::Dot::tl ->
+ if trackfix then eprintf "(OMD) Dot 2\n";
+ loop accu (Dots(n+1)::tl)
+ | Dot::Dots n::tl ->
+ if trackfix then eprintf "(OMD) Dot 3\n";
+ loop accu (Dots(n+1)::tl)
+ | Dots a::Dots b::tl ->
+ if trackfix then eprintf "(OMD) Dot 4\n";
+ loop accu (Dots(a+b+2)::tl)
+ | Doublequote::Doublequote::tl ->
+ if trackfix then eprintf "(OMD) Doublequote 1\n";
+ loop accu (Doublequotes 0::tl)
+ | Doublequotes n::Doublequote::tl ->
+ if trackfix then eprintf "(OMD) Doublequote 2\n";
+ loop accu (Doublequotes(n+1)::tl)
+ | Doublequote::Doublequotes n::tl ->
+ if trackfix then eprintf "(OMD) Doublequote 3\n";
+ loop accu (Doublequotes(n+1)::tl)
+ | Doublequotes a::Doublequotes b::tl ->
+ if trackfix then eprintf "(OMD) Doublequote 4\n";
+ loop accu (Doublequotes(a+b+2)::tl)
+ | Exclamation::Exclamation::tl ->
+ if trackfix then eprintf "(OMD) Exclamation 1\n";
+ loop accu (Exclamations 0::tl)
+ | Exclamations n::Exclamation::tl ->
+ if trackfix then eprintf "(OMD) Exclamation 2\n";
+ loop accu (Exclamations(n+1)::tl)
+ | Exclamation::Exclamations n::tl ->
+ if trackfix then eprintf "(OMD) Exclamation 3\n";
+ loop accu (Exclamations(n+1)::tl)
+ | Exclamations a::Exclamations b::tl ->
+ if trackfix then eprintf "(OMD) Exclamation 4\n";
+ loop accu (Exclamations(a+b+2)::tl)
+ | Equal::Equal::tl ->
+ if trackfix then eprintf "(OMD) Equal 1\n";
+ loop accu (Equals 0::tl)
+ | Equals n::Equal::tl ->
+ if trackfix then eprintf "(OMD) Equal 2\n";
+ loop accu (Equals(n+1)::tl)
+ | Equal::Equals n::tl ->
+ if trackfix then eprintf "(OMD) Equal 3\n";
+ loop accu (Equals(n+1)::tl)
+ | Equals a::Equals b::tl ->
+ if trackfix then eprintf "(OMD) Equal 4\n";
+ loop accu (Equals(a+b+2)::tl)
+ | Greaterthan::Greaterthan::tl ->
+ if trackfix then eprintf "(OMD) Greaterthan 1\n";
+ loop accu (Greaterthans 0::tl)
+ | Greaterthans n::Greaterthan::tl ->
+ if trackfix then eprintf "(OMD) Greaterthan 2\n";
+ loop accu (Greaterthans(n+1)::tl)
+ | Greaterthan::Greaterthans n::tl ->
+ if trackfix then eprintf "(OMD) Greaterthan 3\n";
+ loop accu (Greaterthans(n+1)::tl)
+ | Greaterthans a::Greaterthans b::tl ->
+ if trackfix then eprintf "(OMD) Greaterthan 4\n";
+ loop accu (Greaterthans(a+b+2)::tl)
+ | Hash::Hash::tl ->
+ if trackfix then eprintf "(OMD) Hash 1\n";
+ loop accu (Hashs 0::tl)
+ | Hashs n::Hash::tl ->
+ if trackfix then eprintf "(OMD) Hash 2\n";
+ loop accu (Hashs(n+1)::tl)
+ | Hash::Hashs n::tl ->
+ if trackfix then eprintf "(OMD) Hash 3\n";
+ loop accu (Hashs(n+1)::tl)
+ | Hashs a::Hashs b::tl ->
+ if trackfix then eprintf "(OMD) Hash 4\n";
+ loop accu (Hashs(a+b+2)::tl)
+ | Lessthan::Lessthan::tl ->
+ if trackfix then eprintf "(OMD) Lessthan 1\n";
+ loop accu (Lessthans 0::tl)
+ | Lessthans n::Lessthan::tl ->
+ if trackfix then eprintf "(OMD) Lessthan 2\n";
+ loop accu (Lessthans(n+1)::tl)
+ | Lessthan::Lessthans n::tl ->
+ if trackfix then eprintf "(OMD) Lessthan 3\n";
+ loop accu (Lessthans(n+1)::tl)
+ | Lessthans a::Lessthans b::tl ->
+ if trackfix then eprintf "(OMD) Lessthan 4\n";
+ loop accu (Lessthans(a+b+2)::tl)
+ | Minus::Minus::tl ->
+ if trackfix then eprintf "(OMD) Minus 1\n";
+ loop accu (Minuss 0::tl)
+ | Minuss n::Minus::tl ->
+ if trackfix then eprintf "(OMD) Minus 2\n";
+ loop accu (Minuss(n+1)::tl)
+ | Minus::Minuss n::tl ->
+ if trackfix then eprintf "(OMD) Minus 3\n";
+ loop accu (Minuss(n+1)::tl)
+ | Minuss a::Minuss b::tl ->
+ if trackfix then eprintf "(OMD) Minus 4\n";
+ loop accu (Minuss(a+b+2)::tl)
+ | Newline::Newline::tl ->
+ if trackfix then eprintf "(OMD) Newline 1\n";
+ loop accu (Newlines 0::tl)
+ | Newlines n::Newline::tl ->
+ if trackfix then eprintf "(OMD) Newline 2\n";
+ loop accu (Newlines(n+1)::tl)
+ | Newline::Newlines n::tl ->
+ if trackfix then eprintf "(OMD) Newline 3\n";
+ loop accu (Newlines(n+1)::tl)
+ | Newlines a::Newlines b::tl ->
+ if trackfix then eprintf "(OMD) Newline 4\n";
+ loop accu (Newlines(a+b+2)::tl)
+ | Obrace::Obrace::tl ->
+ if trackfix then eprintf "(OMD) Obrace 1\n";
+ loop accu (Obraces 0::tl)
+ | Obraces n::Obrace::tl ->
+ if trackfix then eprintf "(OMD) Obrace 2\n";
+ loop accu (Obraces(n+1)::tl)
+ | Obrace::Obraces n::tl ->
+ if trackfix then eprintf "(OMD) Obrace 3\n";
+ loop accu (Obraces(n+1)::tl)
+ | Obraces a::Obraces b::tl ->
+ if trackfix then eprintf "(OMD) Obrace 4\n";
+ loop accu (Obraces(a+b+2)::tl)
+ | Oparenthesis::Oparenthesis::tl ->
+ if trackfix then eprintf "(OMD) Oparenthesis 1\n";
+ loop accu (Oparenthesiss 0::tl)
+ | Oparenthesiss n::Oparenthesis::tl ->
+ if trackfix then eprintf "(OMD) Oparenthesis 2\n";
+ loop accu (Oparenthesiss(n+1)::tl)
+ | Oparenthesis::Oparenthesiss n::tl ->
+ if trackfix then eprintf "(OMD) Oparenthesis 3\n";
+ loop accu (Oparenthesiss(n+1)::tl)
+ | Oparenthesiss a::Oparenthesiss b::tl ->
+ if trackfix then eprintf "(OMD) Oparenthesis 4\n";
+ loop accu (Oparenthesiss(a+b+2)::tl)
+ | Obracket::Obracket::tl ->
+ if trackfix then eprintf "(OMD) Obracket 1\n";
+ loop accu (Obrackets 0::tl)
+ | Obrackets n::Obracket::tl ->
+ if trackfix then eprintf "(OMD) Obracket 2\n";
+ loop accu (Obrackets(n+1)::tl)
+ | Obracket::Obrackets n::tl ->
+ if trackfix then eprintf "(OMD) Obracket 3\n";
+ loop accu (Obrackets(n+1)::tl)
+ | Obrackets a::Obrackets b::tl ->
+ if trackfix then eprintf "(OMD) Obracket 4\n";
+ loop accu (Obrackets(a+b+2)::tl)
+ | Percent::Percent::tl ->
+ if trackfix then eprintf "(OMD) Percent 1\n";
+ loop accu (Percents 0::tl)
+ | Percents n::Percent::tl ->
+ if trackfix then eprintf "(OMD) Percent 2\n";
+ loop accu (Percents(n+1)::tl)
+ | Percent::Percents n::tl ->
+ if trackfix then eprintf "(OMD) Percent 3\n";
+ loop accu (Percents(n+1)::tl)
+ | Percents a::Percents b::tl ->
+ if trackfix then eprintf "(OMD) Percent 4\n";
+ loop accu (Percents(a+b+2)::tl)
+ | Plus::Plus::tl ->
+ if trackfix then eprintf "(OMD) Plus 1\n";
+ loop accu (Pluss 0::tl)
+ | Pluss n::Plus::tl ->
+ if trackfix then eprintf "(OMD) Plus 2\n";
+ loop accu (Pluss(n+1)::tl)
+ | Plus::Pluss n::tl ->
+ if trackfix then eprintf "(OMD) Plus 3\n";
+ loop accu (Pluss(n+1)::tl)
+ | Pluss a::Pluss b::tl ->
+ if trackfix then eprintf "(OMD) Plus 4\n";
+ loop accu (Pluss(a+b+2)::tl)
+ | Question::Question::tl ->
+ if trackfix then eprintf "(OMD) Question 1\n";
+ loop accu (Questions 0::tl)
+ | Questions n::Question::tl ->
+ if trackfix then eprintf "(OMD) Question 2\n";
+ loop accu (Questions(n+1)::tl)
+ | Question::Questions n::tl ->
+ if trackfix then eprintf "(OMD) Question 3\n";
+ loop accu (Questions(n+1)::tl)
+ | Questions a::Questions b::tl ->
+ if trackfix then eprintf "(OMD) Question 4\n";
+ loop accu (Questions(a+b+2)::tl)
+ | Quote::Quote::tl ->
+ if trackfix then eprintf "(OMD) Quote 1\n";
+ loop accu (Quotes 0::tl)
+ | Quotes n::Quote::tl ->
+ if trackfix then eprintf "(OMD) Quote 2\n";
+ loop accu (Quotes(n+1)::tl)
+ | Quote::Quotes n::tl ->
+ if trackfix then eprintf "(OMD) Quote 3\n";
+ loop accu (Quotes(n+1)::tl)
+ | Quotes a::Quotes b::tl ->
+ if trackfix then eprintf "(OMD) Quote 4\n";
+ loop accu (Quotes(a+b+2)::tl)
+ | Semicolon::Semicolon::tl ->
+ if trackfix then eprintf "(OMD) Semicolon 1\n";
+ loop accu (Semicolons 0::tl)
+ | Semicolons n::Semicolon::tl ->
+ if trackfix then eprintf "(OMD) Semicolon 2\n";
+ loop accu (Semicolons(n+1)::tl)
+ | Semicolon::Semicolons n::tl ->
+ if trackfix then eprintf "(OMD) Semicolon 3\n";
+ loop accu (Semicolons(n+1)::tl)
+ | Semicolons a::Semicolons b::tl ->
+ if trackfix then eprintf "(OMD) Semicolon 4\n";
+ loop accu (Semicolons(a+b+2)::tl)
+ | Slash::Slash::tl ->
+ if trackfix then eprintf "(OMD) Slash 1\n";
+ loop accu (Slashs 0::tl)
+ | Slashs n::Slash::tl ->
+ if trackfix then eprintf "(OMD) Slash 2\n";
+ loop accu (Slashs(n+1)::tl)
+ | Slash::Slashs n::tl ->
+ if trackfix then eprintf "(OMD) Slash 3\n";
+ loop accu (Slashs(n+1)::tl)
+ | Slashs a::Slashs b::tl ->
+ if trackfix then eprintf "(OMD) Slash 4\n";
+ loop accu (Slashs(a+b+2)::tl)
+ | Space::Space::tl ->
+ if trackfix then eprintf "(OMD) Space 1\n";
+ loop accu (Spaces 0::tl)
+ | Spaces n::Space::tl ->
+ if trackfix then eprintf "(OMD) Space 2\n";
+ loop accu (Spaces(n+1)::tl)
+ | Space::Spaces n::tl ->
+ if trackfix then eprintf "(OMD) Space 3\n";
+ loop accu (Spaces(n+1)::tl)
+ | Spaces a::Spaces b::tl ->
+ if trackfix then eprintf "(OMD) Space 4\n";
+ loop accu (Spaces(a+b+2)::tl)
+ | Star::Star::tl ->
+ if trackfix then eprintf "(OMD) Star 1\n";
+ loop accu (Stars 0::tl)
+ | Stars n::Star::tl ->
+ if trackfix then eprintf "(OMD) Star 2\n";
+ loop accu (Stars(n+1)::tl)
+ | Star::Stars n::tl ->
+ if trackfix then eprintf "(OMD) Star 3\n";
+ loop accu (Stars(n+1)::tl)
+ | Stars a::Stars b::tl ->
+ if trackfix then eprintf "(OMD) Star 4\n";
+ loop accu (Stars(a+b+2)::tl)
+ | Tab::Tab::tl ->
+ if trackfix then eprintf "(OMD) Tab 1\n";
+ loop accu (Tabs 0::tl)
+ | Tabs n::Tab::tl ->
+ if trackfix then eprintf "(OMD) Tab 2\n";
+ loop accu (Tabs(n+1)::tl)
+ | Tab::Tabs n::tl ->
+ if trackfix then eprintf "(OMD) Tab 3\n";
+ loop accu (Tabs(n+1)::tl)
+ | Tabs a::Tabs b::tl ->
+ if trackfix then eprintf "(OMD) Tab 4\n";
+ loop accu (Tabs(a+b+2)::tl)
+ | Tilde::Tilde::tl ->
+ if trackfix then eprintf "(OMD) Tilde 1\n";
+ loop accu (Tildes 0::tl)
+ | Tildes n::Tilde::tl ->
+ if trackfix then eprintf "(OMD) Tilde 2\n";
+ loop accu (Tildes(n+1)::tl)
+ | Tilde::Tildes n::tl ->
+ if trackfix then eprintf "(OMD) Tilde 3\n";
+ loop accu (Tildes(n+1)::tl)
+ | Tildes a::Tildes b::tl ->
+ if trackfix then eprintf "(OMD) Tilde 4\n";
+ loop accu (Tildes(a+b+2)::tl)
+ | Underscore::Underscore::tl ->
+ if trackfix then eprintf "(OMD) Underscore 1\n";
+ loop accu (Underscores 0::tl)
+ | Underscores n::Underscore::tl ->
+ if trackfix then eprintf "(OMD) Underscore 2\n";
+ loop accu (Underscores(n+1)::tl)
+ | Underscore::Underscores n::tl ->
+ if trackfix then eprintf "(OMD) Underscore 3\n";
+ loop accu (Underscores(n+1)::tl)
+ | Underscores a::Underscores b::tl ->
+ if trackfix then eprintf "(OMD) Underscore 4\n";
+ loop accu (Underscores(a+b+2)::tl)| x::tl -> loop (x::accu) tl
+ | [] -> List.rev accu
+ in
+ loop [] l
+
+
+ (* Remove all [NL] and [Br] at the beginning. *)
+ let rec remove_initial_newlines = function
+ | [] -> []
+ | (NL | Br) :: tl -> remove_initial_newlines tl
+ | l -> l
+
+
+ (** - recognizes paragraphs
+ - glues following blockquotes *)
+ let make_paragraphs md =
+ let rec loop cp accu = function (* cp means current paragraph *)
+ | [] ->
+ let accu =
+ match cp with
+ | [] | [NL] | [Br] -> accu
+ | (NL|Br)::cp -> Paragraph(List.rev cp)::accu
+ | cp -> Paragraph(List.rev cp)::accu
+ in
+ List.rev accu
+ | Blockquote b1 :: Blockquote b2 :: tl ->
+ loop cp accu (Blockquote(b1@b2):: tl)
+ | Blockquote b :: tl ->
+ let e = Blockquote(loop [] [] b) in
+ (match cp with
+ | [] | [NL] | [Br] -> loop cp (e::accu) tl
+ | _ -> loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | (Ulp b) :: tl ->
+ let e = Ulp(List.map (fun li -> loop [] [] li) b) in
+ (match cp with
+ | [] | [NL] | [Br] -> loop cp (e::accu) tl
+ | _ -> loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | (Olp b) :: tl ->
+ let e = Olp(List.map (fun li -> loop [] [] li) b) in
+ (match cp with
+ | [] | [NL] | [Br] -> loop cp (e::accu) tl
+ | _ -> loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | Html_comment _ as e :: tl ->
+ (match cp with
+ | [] -> loop [] (e::accu) tl
+ | [NL] | [Br] -> loop [] (e::NL::accu) tl
+ | _ -> loop (e::cp) accu tl)
+ | (Raw_block _ | Html_block _) as e :: tl ->
+ (match cp with
+ | [] | [NL] | [Br] -> loop cp (e::cp@accu) tl
+ | _ -> loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | (Code_block _ | H1 _ | H2 _ | H3 _ | H4 _ | H5 _ | H6 _
+ | Ol _ | Ul _) as e :: tl ->
+ (match cp with
+ | [] | [NL] | [Br] -> loop cp (e::accu) tl
+ | _ -> loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | Text "\n" :: _ | Paragraph _ :: _ ->
+ invalid_arg "Omd_parser.make_paragraphs"
+ | (NL|Br) :: (NL|Br) :: tl ->
+ let tl = remove_initial_newlines tl in
+ begin match cp with
+ | [] | [NL] | [Br] -> loop [] (NL::NL::accu) tl
+ | _ -> loop [] (Paragraph(List.rev cp)::accu) tl
+ end
+ | X(x) as e :: tl ->
+ (* If the extension returns a block as first element,
+ then consider the extension as a block. However
+ don't take its contents as it is yet, the contents
+ of the extension shall be considered final as late
+ as possible. *)
+ begin match x#to_t md with
+ | None -> loop (e::cp) accu tl
+ | Some(t) ->
+ match t with
+ | ( H1 _
+ | H2 _
+ | H3 _
+ | H4 _
+ | H5 _
+ | H6 _
+ | Paragraph _
+ | Ul _
+ | Ol _
+ | Ulp _
+ | Olp _
+ | Code_block _
+ | Hr
+ | Html_block _
+ | Raw_block _
+ | Blockquote _
+ ) :: _
+ ->
+ (match cp with
+ | [] | [NL] | [Br] ->
+ loop cp (e::accu) tl
+ | _ ->
+ loop [] (e::Paragraph(List.rev cp)::accu) tl)
+ | _ ->
+ loop (e::cp) accu tl
+ end
+ | e::tl ->
+ loop (e::cp) accu tl
+ in
+ let remove_white_crumbs l =
+ let rec loop = function
+ | [] -> []
+ | Text " " :: tl
+ | NL::tl
+ | Br::tl
+ ->
+ loop tl
+ | l -> l
+ in
+ List.rev (loop (List.rev l))
+ in
+ let rec clean_paragraphs =
+ if debug then eprintf "(OMD) clean_paragraphs\n";
+ function
+ | [] -> []
+ | Paragraph[]::tl -> tl
+ | Paragraph(p) :: tl ->
+ Paragraph(clean_paragraphs
+ (remove_initial_newlines
+ (remove_white_crumbs(normalise_md p))))
+ :: clean_paragraphs tl
+ | H1 v :: tl -> H1(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | H2 v :: tl -> H2(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | H3 v :: tl -> H3(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | H4 v :: tl -> H4(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | H5 v :: tl -> H5(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | H6 v :: tl -> H6(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Emph v :: tl -> Emph(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Bold v :: tl -> Bold(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Ul v :: tl -> Ul(List.map clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Ol v :: tl -> Ol(List.map clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Ulp v :: tl -> Ulp(List.map clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Olp v :: tl -> Olp(List.map clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Blockquote v :: tl -> Blockquote(clean_paragraphs v)
+ :: clean_paragraphs tl
+ | Url(href,v,title) :: tl -> Url(href,(clean_paragraphs v),title)
+ :: clean_paragraphs tl
+ | Text _
+ | Code _
+ | Code_block _
+ | Br
+ | Hr
+ | NL
+ | Ref _
+ | Img_ref _
+ | Raw _
+ | Raw_block _
+ | Html _
+ | Html_block _
+ | Html_comment _
+ | Img _
+ | X _ as v :: tl -> v :: clean_paragraphs tl
+ in
+ let r = clean_paragraphs(loop [] [] md)
+ in
+ if debug then eprintf "(OMD) clean_paragraphs %S --> %S\n%!"
+ (Omd_backend.sexpr_of_md md)
+ (Omd_backend.sexpr_of_md r);
+ r
+
+
+ (** [assert_well_formed] is a developer's function that helps to
+ track badly constructed token lists. This function has an
+ effect only if [trackfix] is [true]. *)
+ let assert_well_formed (l:tok list) : unit =
+ if trackfix then
+ let rec equiv l1 l2 = match l1, l2 with
+ | [], [] -> true
+ | Tag _::tl1, Tag _::tl2-> equiv tl1 tl2
+ | e1::tl1, e2::tl2 -> e1 = e2 && equiv tl1 tl2
+ | _ -> false
+ in
+ assert(equiv (fix l) l);
+ ()
+
+ (** Generate fallback for references. *)
+ let extract_fallback _main_loop remains l =
+ if debug then eprintf "(OMD) Omd_parser.extract_fallback\n%!";
+ let rec loop accu = function
+ | [] -> List.rev accu
+ | e::tl as r ->
+ if r == remains then
+ List.rev accu
+ else
+ match e, remains with
+ | Cbrackets 0, Cbracket::r when tl = r ->
+ let accu = Word "]" :: accu in
+ List.rev accu
+ | Cbrackets n, Cbrackets m::r when m + 1 = n && tl = r ->
+ let accu = Word "]" :: accu in
+ List.rev accu
+ | _ ->
+ loop (e::accu) tl
+ in
+ let a = loop [] l in
+ object
+ method to_string = L.string_of_tokens a
+ method to_t = [Text(L.string_of_tokens a)]
+ end
+
+
+ let unindent_rev n lexemes =
+ if debug then eprintf "(OMD) CALL: Omd_parser.unindent_rev\n%!";
+ assert_well_formed lexemes;
+ let rec loop accu cl = function
+ | Newlines x::(Space|Spaces _)::Newlines y::tl ->
+ loop accu cl (Newlines(x+y+2)::tl)
+ | Newline::(Space|Spaces _)::Newlines x::tl ->
+ loop accu cl (Newlines(1+x)::tl)
+ | Newlines x::(Space|Spaces _)::Newline::tl ->
+ loop accu cl (Newlines(1+x)::tl)
+ | Newline::(Space|Spaces _)::Newline::tl ->
+ loop accu cl (Newlines(0)::tl)
+
+ | (Newline|Newlines 0 as nl)::(Space|Spaces _ as s)::(
+ (Number _::Dot::(Space|Spaces _)::_)
+ | ((Star|Plus|Minus)::(Space|Spaces _)::_)
+ as tl) as l ->
+ if n = L.length s then
+ loop (nl::cl@accu) [] tl
+ else
+ (cl@accu), l
+ | (Newline|Newlines 0 as nl)::(Space|Spaces _ as s)::tl ->
+ let x = L.length s - n in
+ loop (nl::cl@accu)
+ (if x > 0 then [L.make_space x] else [])
+ tl
+ | Newlines(_)::_ as l ->
+ (cl@accu), l
+ | Newline::_ as l ->
+ (cl@accu), l
+ | e::tl ->
+ loop accu (e::cl) tl
+ | [] as l ->
+ (cl@accu), l
+ in
+ match loop [] [] lexemes with
+ | [], right -> [], right
+ | l, right ->
+ assert_well_formed l;
+ l, right
+
+ let unindent n lexemes =
+ let fst, snd = unindent_rev n lexemes in
+ List.rev fst, snd
+
+ let rec is_blank = function
+ | (Space | Spaces _ | Newline | Newlines _) :: tl ->
+ is_blank tl
+ | [] -> true
+ | _ -> false
+
+ let semph_or_bold (n:int) (l:l) =
+ (* FIXME: use rpl call/return convention *)
+ assert_well_formed l;
+ assert (n>0 && n<4);
+ match
+ fsplit
+ ~excl:(function Newlines _ :: _ -> true | _ -> false)
+ ~f:(function
+ | Backslash::Star::tl ->
+ Continue_with([Star;Backslash],tl)
+ | Backslash::Stars 0::tl ->
+ Continue_with([Star;Backslash],Star::tl)
+ | Backslash::Stars n::tl ->
+ Continue_with([Star;Backslash],Stars(n-1)::tl)
+ | (Backslashs b as x)::Star::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],Star::tl)
+ else
+ Continue_with([Star;x],tl)
+ | (Backslashs b as x)::(Stars 0 as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Star;x],Star::tl)
+ | (Backslashs b as x)::(Stars n as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Star;x],Stars(n-1)::tl)
+ | (Space|Spaces _ as x)::(Star|Stars _ as s)::tl ->
+ Continue_with([s;x],tl)
+ | (Star|Stars _ as s)::tl ->
+ if L.length s = n then
+ Split([],tl)
+ else
+ Continue
+ | _ -> Continue)
+ l
+ with
+ | None ->
+ None
+ | Some(left,right) ->
+ if is_blank left then None else Some(left,right)
+
+ let sm_uemph_or_bold (n:int) (l:l) =
+ assert_well_formed l;
+ (* FIXME: use rpl call/return convention *)
+ assert (n>0 && n<4);
+ match
+ fsplit
+ ~excl:(function Newlines _ :: _ -> true | _ -> false)
+ ~f:(function
+ | Backslash::Underscore::tl ->
+ Continue_with([Underscore;Backslash],tl)
+ | Backslash::Underscores 0::tl ->
+ Continue_with([Underscore;Backslash],Underscore::tl)
+ | Backslash::Underscores n::tl ->
+ Continue_with([Underscore;Backslash],Underscores(n-1)::tl)
+ | (Backslashs b as x)::Underscore::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],Underscore::tl)
+ else
+ Continue_with([Underscore;x],tl)
+ | (Backslashs b as x)::(Underscores 0 as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Underscore;x],Underscore::tl)
+ | (Backslashs b as x)::(Underscores n as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Underscore;x],Underscores(n-1)::tl)
+ | (Space|Spaces _ as x)::(Underscore|Underscores _ as s)::tl ->
+ Continue_with([s;x],tl)
+ | (Underscore|Underscores _ as s)::tl ->
+ if L.length s = n then
+ Split([],tl)
+ else
+ Continue
+ | _ -> Continue)
+ l
+ with
+ | None ->
+ None
+ | Some(left,right) ->
+ if is_blank left then None else Some(left,right)
+
+
+ let gh_uemph_or_bold (n:int) (l:l) =
+ assert_well_formed l;
+ (* FIXME: use rpl call/return convention *)
+ assert (n>0 && n<4);
+ match
+ fsplit
+ ~excl:(function Newlines _ :: _ -> true | _ -> false)
+ ~f:(function
+ | Backslash::Underscore::tl ->
+ Continue_with([Underscore;Backslash],tl)
+ | Backslash::Underscores 0::tl ->
+ Continue_with([Underscore;Backslash],Underscore::tl)
+ | Backslash::Underscores n::tl ->
+ Continue_with([Underscore;Backslash],Underscores(n-1)::tl)
+ | (Backslashs b as x)::Underscore::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],Underscore::tl)
+ else
+ Continue_with([Underscore;x],tl)
+ | (Backslashs b as x)::(Underscores 0 as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Underscore;x],Underscore::tl)
+ | (Backslashs b as x)::(Underscores n as s)::tl ->
+ if b mod 2 = 0 then
+ Continue_with([x],s::tl)
+ else
+ Continue_with([Underscore;x],Underscores(n-1)::tl)
+ | (Space|Spaces _ as x)::(Underscore|Underscores _ as s)::tl ->
+ Continue_with([s;x],tl)
+ | (Underscore|Underscores _ as s)::(Word _|Number _ as w):: tl ->
+ Continue_with([w;s],tl)
+ | (Underscore|Underscores _ as s)::tl ->
+ if L.length s = n then
+ Split([],tl)
+ else
+ Continue
+ | _ -> Continue)
+ l
+ with
+ | None ->
+ None
+ | Some(left,right) ->
+ if is_blank left then None else Some(left,right)
+
+
+ let uemph_or_bold n l =
+ assert_well_formed l;
+ (* FIXME: use rpl call/return convention *)
+ if gh_uemph_or_bold_style then
+ gh_uemph_or_bold n l
+ else
+ sm_uemph_or_bold n l
+
+ let eat_blank =
+ eat (function |Space|Spaces _|Newline|Newlines _ -> true| _ -> false)
+
+
+ (* used by tag__maybe_h1 and tag__maybe_h2 *)
+ let setext_title main_loop (l:l) : (Omd_representation.tok list * l) option =
+ assert_well_formed l;
+ let rec detect_balanced_bqs n r l =
+ (* If there's a balanced (complete) backquote-started code block
+ then it should be "ignored", else it means the line that
+ follows is part of a code block, so it's not defining a
+ setext-style title. *)
+ if debug then
+ eprintf "(OMD) detect_balanced_bqs n=%d r=%S l=%S\n%!"
+ n (L.string_of_tokens r) (L.string_of_tokens l);
+ match l with
+ | [] ->
+ None
+ | (Newline|Newlines _)::_ ->
+ None
+ | Backslash::Backquote::tl ->
+ detect_balanced_bqs n (Backquote::Backslash::r) tl
+ | Backslash::Backquotes 0::tl ->
+ detect_balanced_bqs n (Backquote::Backslash::r) (Backquote::tl)
+ | Backslash::Backquotes x::tl ->
+ detect_balanced_bqs n (Backquote::Backslash::r) (Backquotes(x-1)::tl)
+ | Backslashs(m) as b::Backquote::tl when m mod 2 = 1 ->
+ detect_balanced_bqs n (Backquote::b::r) tl
+ | Backslashs(m) as b::Backquotes 0::tl when m mod 2 = 1 ->
+ detect_balanced_bqs n (Backquote::b::r) (Backquote::tl)
+ | Backslashs(m) as b::Backquotes x::tl when m mod 2 = 1 ->
+ detect_balanced_bqs n (Backquote::b::r) (Backquotes(x-1)::tl)
+ | (Backquote as b)::tl when n = 1 ->
+ Some(List.rev (b::r), tl)
+ | (Backquotes x as b)::tl when n = x+2 ->
+ Some(List.rev (b::r), tl)
+ | e::tl ->
+ detect_balanced_bqs n (e::r) tl
+ in
+ let rec loop r = function
+ | [] ->
+ if r = [] then
+ None
+ else
+ Some(List.rev r, [])
+ | Backslash::Backquote::tl ->
+ loop (Backquote::Backslash::r) tl
+ | Backslashs(m) as b::Backquote::tl when m mod 2 = 1 ->
+ loop (Backquote::b::r) tl
+ | Backslash::Backquotes 0::tl ->
+ loop (Backquote::Backslash::r) (Backquote::tl)
+ | Backslash::Backquotes x::tl ->
+ loop (Backquote::Backslash::r) (Backquotes(x-1)::tl)
+ | Backslashs(m) as b::Backquotes 0::tl when m mod 2 = 1 ->
+ loop (Backquote::b::r) (Backquote::tl)
+ | Backslashs(m) as b::Backquotes x::tl when m mod 2 = 1 ->
+ loop (Backquote::b::r) (Backquotes(x-1)::tl)
+ | Backquote::tl ->
+ begin match detect_balanced_bqs 1 [] tl with
+ | Some(bl,tl) -> loop (bl@r) tl
+ | _ -> None
+ end
+ | Backquotes(x)::tl ->
+ begin match detect_balanced_bqs (x+2) [] tl with
+ | Some(bl,tl) -> loop (bl@r) tl
+ | _ -> None
+ end
+ | Newline::(Equal|Equals _|Minus|Minuss _)::tl ->
+ if r = [] then
+ None
+ else
+ Some(List.rev r, tl)
+ | (Newline|Newlines _)::_ ->
+ if debug then
+ eprintf "(OMD) Omd_parser.setext_title is wrongly used!\n%!";
+ None
+ | e::tl ->
+ loop (e::r) tl
+ in
+ if match l with
+ | Lessthan::Word _::_ ->
+ begin match main_loop [] [] l with
+ | (Html_block _ | Code_block _ | Raw_block _)::_ ->
+ true
+ | _ ->
+ false
+ end
+ | _ -> false
+ then
+ None
+ else
+ let result = loop [] l in
+ if debug then
+ eprintf "(OMD) setext_title l=%S result=%S,%S\n%!"
+ (L.string_of_tokens l)
+ (match result with
+ | None -> ""
+ | Some (x,_tl) -> L.string_of_tokens x)
+ (match result with
+ | None -> ""
+ | Some (_x,tl) -> L.string_of_tokens tl);
+ result
+
+ let tag__maybe_h1 (main_loop:main_loop) =
+ Tag("tag__maybe_h1",
+ object
+ method parser_extension r p l =
+ match p with
+ | ([]|[Newline|Newlines _]) ->
+ begin match setext_title main_loop l with
+ | None ->
+ None
+ | Some(title, tl) ->
+ let title = H1(main_loop [] [] title) in
+ Some((title::r), [Newline], tl)
+ end
+ | _ ->
+ if debug then
+ eprintf "(OMD) Warning: Omd_parser.tag__maybe_h1 is wrongly \
+ used (p=%S)!\n"
+ (L.string_of_tokens p);
+ None
+ method to_string = ""
+ end
+ )
+
+ let tag__maybe_h2 (main_loop:main_loop) =
+ Tag("tag__maybe_h2",
+ object
+ method parser_extension r p l =
+ match p with
+ | ([]|[Newline|Newlines _]) ->
+ begin match setext_title main_loop l with
+ | None ->
+ None
+ | Some(title, tl) ->
+ let title = H2(main_loop [] [] title) in
+ Some((title::r), [Newline], tl)
+ end
+ | _ ->
+ if debug then
+ eprintf "(OMD) Warning: Omd_parser.tag__maybe_h2 is wrongly \
+ used (p=%S)!\n"
+ (L.string_of_tokens p);
+ None
+ method to_string = ""
+ end
+ )
+
+ let tag__md md = (* [md] should be in reverse *)
+ Tag("tag__md",
+ object
+ method parser_extension r _p l = Some(md@r, [], l)
+ method to_string = ""
+ end
+ )
+
+ (* Let's tag the lines that *might* be titles using setext-style.
+ "might" because if they are, for instance, in a code section,
+ then they are not titles at all. *)
+ let tag_setext main_loop lexemes =
+ assert_well_formed lexemes;
+ let rec loop pl res = function
+ | [] | [Newline|Newlines _] ->
+ pl@res
+ | (Newline as e1)::(Equal|Equals _ as e2)::tl -> (* might be a H1. *)
+ begin
+ match
+ fsplit_rev
+ ~f:(function
+ | (Space|Spaces _|Equal|Equals _)::_tl -> Continue
+ | [] -> Split([],[])
+ | _::_ as l -> Split([], l))
+ tl
+ with
+ | Some(rleft, (([]|(Newline|Newlines _)::_) as right)) ->
+ loop [] (rleft@(e2::e1::pl@tag__maybe_h1 main_loop::res)) right
+ | Some(rleft, right) ->
+ loop [] (rleft@(e2::e1::pl@res)) right
+ | None ->
+ loop [] (e2::e1::pl@res) []
+ end
+ | (Newline as e1)::(Minus|Minuss _ as e2)::tl -> (* might be a H2. *)
+ begin
+ match
+ fsplit_rev
+ ~f:(function
+ | (Space|Spaces _|Minus|Minuss _)::_tl -> Continue
+ | [] -> Split([],[])
+ | _::_ as l -> Split([], l))
+ tl
+ with
+ | Some(rleft, (([]|(Newline|Newlines _)::_) as right)) ->
+ loop [] (rleft@(e2::e1::pl@tag__maybe_h2 main_loop::res)) right
+ | Some(rleft, right) ->
+ loop [] (rleft@(e2::e1::pl@res)) right
+ | None ->
+ loop [] (e2::e1::pl@res) []
+ end
+ | (Newline | Newlines _ as e1)::tl ->
+ loop [] (e1::pl@res) tl
+ | e::tl ->
+ loop (e::pl) res tl
+ in
+ List.rev (loop [] [] lexemes)
+
+
+ let hr_m l =
+ assert_well_formed l;
+ let rec loop n = function
+ | ((Newlines _|Newline)::tl) | ([] as tl) ->
+ if n >= 3 then Some tl else None
+ | (Space|Spaces _)::tl ->
+ loop n tl
+ | Minus::tl ->
+ loop (n+1) tl
+ | Minuss x::tl ->
+ loop (x+2+n) tl
+ | _::_ ->
+ None
+ in loop 0 l
+
+ let hr_s l =
+ assert_well_formed l;
+ let rec loop n = function
+ | ((Newline|Newlines _)::tl) | ([] as tl) ->
+ if n >= 3 then Some tl else None
+ | (Space|Spaces _)::tl ->
+ loop n tl
+ | Star::tl ->
+ loop (n+1) tl
+ | Stars x::tl ->
+ loop (x+2+n) tl
+ | _::_ ->
+ None
+ in loop 0 l
+
+ let hr l =
+ match hr_m l with
+ | None -> hr_s l
+ | Some _ as tl -> tl
+
+ (** [bcode] parses code that's delimited by backquote(s) *)
+ let bcode ?(default_lang=default_lang) r p l =
+ assert_well_formed l;
+ let e, tl =
+ match l with
+ | (Backquote|Backquotes _ as e)::tl -> e, tl
+ | _ -> failwith "Omd_parser.bcode is wrongly called"
+ in
+ let rec code_block accu = function
+ | [] ->
+ None
+ | Backquote::tl ->
+ if e = Backquote then
+ match accu with
+ | Newline::accu ->
+ Some(List.rev accu, tl)
+ | _ ->
+ Some(List.rev accu, tl)
+ else
+ code_block (Backquote::accu) tl
+ | (Backquotes _n as b)::tl ->
+ if e = b then
+ match accu with
+ | Newline::accu ->
+ Some(List.rev accu, tl)
+ | _ ->
+ Some(List.rev accu, tl)
+ else
+ code_block (b::accu) tl
+ | Tag(_, _)::tl ->
+ code_block accu tl
+
+ | Backslash :: (Backquote as t) :: tl ->
+ code_block (t :: accu) tl
+ | Backslash :: Backquotes 0 :: tl -> (* \````... *)
+ code_block (Backquote :: accu) tl
+ | Backslash :: Backquotes n :: tl -> assert (n >= 0); (* \````... *)
+ code_block (Backquotes n :: accu) tl
+
+ | e::tl ->
+ code_block (e::accu) tl
+ in
+ match code_block [] tl with
+ | None -> None
+ | Some(cb, l) ->
+ if List.exists (function (Newline|Newlines _) -> true | _ -> false) cb
+ && (match p with []|[Newline|Newlines _] -> true | _ -> false)
+ && (match e with Backquotes n when n > 0 -> true | _ -> false)
+ then
+ match cb with
+ | Word lang :: (Space|Spaces _) :: Newline :: tl
+ | Word lang :: Newline :: tl ->
+ let code = L.string_of_tokens tl in
+ Some(Code_block(lang, code) :: r, [Backquote], l)
+ | Word lang :: (Space|Spaces _) :: Newlines 0 :: tl
+ | Word lang :: Newlines 0 :: tl ->
+ let code = L.string_of_tokens(Newline::tl) in
+ Some(Code_block(lang, code) :: r, [Backquote], l)
+ | Word lang :: (Space|Spaces _) :: Newlines n :: tl
+ | Word lang :: Newlines n :: tl ->
+ let code = L.string_of_tokens (Newlines(n-1)::tl) in
+ Some(Code_block(lang, code) :: r, [Backquote], l)
+ | Newline :: tl ->
+ let code = L.string_of_tokens tl in
+ Some(Code_block(default_lang, code) :: r, [Backquote], l)
+ | _ ->
+ let rec loop collector cb = match cb with
+ | [] -> None
+ | Newline :: tl ->
+ let code = L.string_of_tokens tl in
+ Some(Code_block(L.string_of_tokens (List.rev collector), code) :: r, [Backquote], l)
+ | something :: tl -> loop (something :: collector) tl
+ in
+ loop [] cb
+ else
+ let clean_bcode s =
+ let rec loop1 i =
+ if i = String.length s then 0
+ else match s.[i] with
+ | ' ' -> loop1(i+1)
+ | _ -> i
+ in
+ let rec loop2 i =
+ if i = -1 then String.length s
+ else match s.[i] with
+ | ' ' -> loop2(i-1)
+ | _ -> i+1
+ in
+ match loop1 0, loop2 (String.length s - 1) with
+ | 0, n when n = String.length s - 1 -> s
+ | i, n -> String.sub s i (n-i)
+ in
+ let code = L.string_of_tokens cb in
+ if debug then
+ eprintf "(OMD) clean_bcode %S => %S\n%!" code (clean_bcode code);
+ Some(Code(default_lang, clean_bcode code) :: r, [Backquote], l)
+
+
+ exception NL_exception
+ exception Premature_ending
+
+ (* !!DO NOT DELETE THIS!!
+ The program that generates the generated part that follows right after.
+ List.iter (fun (a,b,c) ->
+ print_endline ("let read_until_"^a^" ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: ("^b^" as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: ("^b^"s 0) :: tl ->
+ loop ("^b^"::accu) n ("^b^"::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl"
+ ^(if c<>"" then "
+ | Backslash :: ("^c^" as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: ("^c^"s 0) :: tl ->
+ loop ("^c^"::accu) n ("^c^"::tl)
+ | "^c^" as e :: tl ->
+ loop (e::accu) (n+1) tl
+ | "^c^"s x as e :: tl ->
+ loop (e::accu) (n+x+2) tl
+ " else "")^
+ " | "^b^" as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | "^b^"s 0 :: tl ->
+ if n = 0 then
+ List.rev accu, "^b^"::tl
+ else
+ loop ("^b^"::accu) (n-1) ("^b^"::tl)
+ | "^b^"s x :: tl ->
+ if n = 0 then
+ List.rev accu, "^b^"s(x-1)::tl
+ else
+ loop
+ (match accu with
+ | "^b^"::accu -> "^b^"s(0)::accu
+ | "^b^"s x::accu -> "^b^"s(x+1)::accu
+ | _ -> "^b^"::accu)
+ (n-1)
+ ("^b^"s(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf \"Omd_parser.read_until_"^a^" %S bq=%b no_nl=%b\\n%!\" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf \"Omd_parser.read_until_"^a^" %S bq=%b no_nl=%b => %S\\n%!\" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+"))
+
+ [ "gt", "Greaterthan", "Lessthan";
+ "lt", "Lessthan", "";
+ "cparenth", "Cparenthesis", "Oparenthesis";
+ "oparenth", "Oparenthesis", "";
+ "dq", "Doublequote", "";
+ "q", "Quote", "";
+ "obracket", "Obracket", "";
+ "cbracket", "Cbracket", "Obracket";
+ "space", "Space", "";
+ ]
+ *)
+
+ (* begin generated part *)
+
+let read_until_gt ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Greaterthan as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Greaterthans 0) :: tl ->
+ loop (Greaterthan::accu) n (Greaterthan::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl
+ | Backslash :: (Lessthan as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Lessthans 0) :: tl ->
+ loop (Lessthan::accu) n (Lessthan::tl)
+ | Lessthan as e :: tl ->
+ loop (e::accu) (n+1) tl
+ | Lessthans x as e :: tl ->
+ loop (e::accu) (n+x+2) tl
+ | Greaterthan as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Greaterthans 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Greaterthan::tl
+ else
+ loop (Greaterthan::accu) (n-1) (Greaterthan::tl)
+ | Greaterthans x :: tl ->
+ if n = 0 then
+ List.rev accu, Greaterthans(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Greaterthan::accu -> Greaterthans(0)::accu
+ | Greaterthans x::accu -> Greaterthans(x+1)::accu
+ | _ -> Greaterthan::accu)
+ (n-1)
+ (Greaterthans(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_gt %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_gt %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_lt ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Lessthan as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Lessthans 0) :: tl ->
+ loop (Lessthan::accu) n (Lessthan::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Lessthan as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Lessthans 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Lessthan::tl
+ else
+ loop (Lessthan::accu) (n-1) (Lessthan::tl)
+ | Lessthans x :: tl ->
+ if n = 0 then
+ List.rev accu, Lessthans(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Lessthan::accu -> Lessthans(0)::accu
+ | Lessthans x::accu -> Lessthans(x+1)::accu
+ | _ -> Lessthan::accu)
+ (n-1)
+ (Lessthans(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_lt %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_lt %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_cparenth ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Cparenthesis as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Cparenthesiss 0) :: tl ->
+ loop (Cparenthesis::accu) n (Cparenthesis::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl
+ | Backslash :: (Oparenthesis as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Oparenthesiss 0) :: tl ->
+ loop (Oparenthesis::accu) n (Oparenthesis::tl)
+ | Oparenthesis as e :: tl ->
+ loop (e::accu) (n+1) tl
+ | Oparenthesiss x as e :: tl ->
+ loop (e::accu) (n+x+2) tl
+ | Cparenthesis as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Cparenthesiss 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Cparenthesis::tl
+ else
+ loop (Cparenthesis::accu) (n-1) (Cparenthesis::tl)
+ | Cparenthesiss x :: tl ->
+ if n = 0 then
+ List.rev accu, Cparenthesiss(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Cparenthesis::accu -> Cparenthesiss(0)::accu
+ | Cparenthesiss x::accu -> Cparenthesiss(x+1)::accu
+ | _ -> Cparenthesis::accu)
+ (n-1)
+ (Cparenthesiss(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_cparenth %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_cparenth %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_oparenth ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Oparenthesis as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Oparenthesiss 0) :: tl ->
+ loop (Oparenthesis::accu) n (Oparenthesis::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Oparenthesis as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Oparenthesiss 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Oparenthesis::tl
+ else
+ loop (Oparenthesis::accu) (n-1) (Oparenthesis::tl)
+ | Oparenthesiss x :: tl ->
+ if n = 0 then
+ List.rev accu, Oparenthesiss(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Oparenthesis::accu -> Oparenthesiss(0)::accu
+ | Oparenthesiss x::accu -> Oparenthesiss(x+1)::accu
+ | _ -> Oparenthesis::accu)
+ (n-1)
+ (Oparenthesiss(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_oparenth %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_oparenth %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_dq ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Doublequote as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Doublequotes 0) :: tl ->
+ loop (Doublequote::accu) n (Doublequote::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Doublequote as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Doublequotes 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Doublequote::tl
+ else
+ loop (Doublequote::accu) (n-1) (Doublequote::tl)
+ | Doublequotes x :: tl ->
+ if n = 0 then
+ List.rev accu, Doublequotes(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Doublequote::accu -> Doublequotes(0)::accu
+ | Doublequotes x::accu -> Doublequotes(x+1)::accu
+ | _ -> Doublequote::accu)
+ (n-1)
+ (Doublequotes(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_dq %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_dq %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_q ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Quote as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Quotes 0) :: tl ->
+ loop (Quote::accu) n (Quote::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Quote as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Quotes 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Quote::tl
+ else
+ loop (Quote::accu) (n-1) (Quote::tl)
+ | Quotes x :: tl ->
+ if n = 0 then
+ List.rev accu, Quotes(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Quote::accu -> Quotes(0)::accu
+ | Quotes x::accu -> Quotes(x+1)::accu
+ | _ -> Quote::accu)
+ (n-1)
+ (Quotes(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_q %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_q %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_obracket ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Obracket as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Obrackets 0) :: tl ->
+ loop (Obracket::accu) n (Obracket::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Obracket as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Obrackets 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Obracket::tl
+ else
+ loop (Obracket::accu) (n-1) (Obracket::tl)
+ | Obrackets x :: tl ->
+ if n = 0 then
+ List.rev accu, Obrackets(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Obracket::accu -> Obrackets(0)::accu
+ | Obrackets x::accu -> Obrackets(x+1)::accu
+ | _ -> Obracket::accu)
+ (n-1)
+ (Obrackets(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_obracket %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_obracket %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_cbracket ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Cbracket as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Cbrackets 0) :: tl ->
+ loop (Cbracket::accu) n (Cbracket::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl
+ | Backslash :: (Obracket as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Obrackets 0) :: tl ->
+ loop (Obracket::accu) n (Obracket::tl)
+ | Obracket as e :: tl ->
+ loop (e::accu) (n+1) tl
+ | Obrackets x as e :: tl ->
+ loop (e::accu) (n+x+2) tl
+ | Cbracket as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Cbrackets 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Cbracket::tl
+ else
+ loop (Cbracket::accu) (n-1) (Cbracket::tl)
+ | Cbrackets x :: tl ->
+ if n = 0 then
+ List.rev accu, Cbrackets(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Cbracket::accu -> Cbrackets(0)::accu
+ | Cbrackets x::accu -> Cbrackets(x+1)::accu
+ | _ -> Cbracket::accu)
+ (n-1)
+ (Cbrackets(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_cbracket %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_cbracket %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+
+let read_until_space ?(bq=false) ?(no_nl=false) l =
+ assert_well_formed l;
+ let rec loop accu n = function
+ | Backslash :: (Space as b) :: tl ->
+ loop (b::accu) n tl
+ | Backslash :: (Spaces 0) :: tl ->
+ loop (Space::accu) n (Space::tl)
+ | Backslashs 0 :: tl ->
+ loop (Backslash::accu) n tl
+ | Backslashs 1 :: tl ->
+ loop (Backslash::accu) n (Backslash::tl)
+ | Backslashs 2 :: tl ->
+ loop (Backslashs 0::accu) n tl
+ | (Backslashs x) :: tl ->
+ if x mod 2 = 0 then
+ loop (Backslashs(x/2-1)::accu) n tl
+ else
+ loop (Backslashs(x/2-1)::accu) n (Backslash::tl)
+ | (Backquote|Backquotes _ as e)::tl as l ->
+ if bq then
+ match bcode [] [] l with
+ | None -> loop (e::accu) n tl
+ | Some (r, _, tl) ->
+ loop (* not very pretty kind of hack *)
+ (List.rev(L.lex(Omd_backend.markdown_of_md r))@accu)
+ n
+ tl
+ else
+ loop (e::accu) n tl | Space as e :: tl ->
+ if n = 0 then
+ List.rev accu, tl
+ else
+ loop (e::accu) (n-1) tl
+ | Spaces 0 :: tl ->
+ if n = 0 then
+ List.rev accu, Space::tl
+ else
+ loop (Space::accu) (n-1) (Space::tl)
+ | Spaces x :: tl ->
+ if n = 0 then
+ List.rev accu, Spaces(x-1)::tl
+ else
+ loop
+ (match accu with
+ | Space::accu -> Spaces(0)::accu
+ | Spaces x::accu -> Spaces(x+1)::accu
+ | _ -> Space::accu)
+ (n-1)
+ (Spaces(x-1)::tl)
+ | (Newline|Newlines _ as e)::tl ->
+ if no_nl then
+ raise NL_exception
+ else
+ loop (e::accu) n tl
+ | e::tl ->
+ loop (e::accu) n tl
+ | [] ->
+ raise Premature_ending
+ in
+ if debug then
+ eprintf "Omd_parser.read_until_space %S bq=%b no_nl=%b\n%!" (L.string_of_tokens l) bq no_nl;
+ let res = loop [] 0 l in
+ if debug then
+ eprintf "Omd_parser.read_until_space %S bq=%b no_nl=%b => %S\n%!" (L.string_of_tokens l) bq no_nl (L.string_of_tokens (fst res));
+ res
+ (* /end generated part *)
+
+ let read_until_newline l =
+ assert_well_formed l;
+ let rec loop accu n =
+ function
+ | ((Backslash as a)) :: ((Newline as b)) :: tl ->
+ loop (b :: a :: accu) n tl
+ | Backslash :: Newlines 0 :: tl ->
+ loop (Newline :: Backslash :: accu) n (Newline :: tl)
+ | ((Backslashs 0 as e)) :: tl -> loop (e :: accu) n tl
+ | ((Backslashs x as e)) :: tl ->
+ if (x mod 2) = 0
+ then loop (e :: accu) n tl
+ else loop ((Backslashs (x - 1)) :: accu) n (Backslash :: tl)
+ | ((Newline as e)) :: tl ->
+ if n = 0 then ((List.rev accu), tl) else loop (e :: accu) (n - 1) tl
+ | Newlines 0 :: tl ->
+ if n = 0
+ then ((List.rev accu), (Newline :: tl))
+ else loop (Newline :: accu) (n - 1) (Newline :: tl)
+ | Newlines n :: tl -> ((List.rev accu), ((Newlines (n - 1)) :: tl))
+ | e :: tl -> loop (e :: accu) n tl
+ | [] -> raise Premature_ending
+ in loop [] 0 l
+
+ (* H1, H2, H3, ... *)
+ let read_title (main_loop:main_loop) n r _previous lexemes =
+ let title, rest =
+ let rec loop accu = function
+ | Backslash::Hash::tl ->
+ loop (Hash::Backslash::accu) tl
+ | Backslashs(n)::Hash::tl when n mod 2 = 1 ->
+ loop (Hash::Backslashs(n-1)::accu) tl
+ | Backslash::Hashs(h)::tl ->
+ begin match tl with
+ | []
+ | (Space|Spaces _)::(Newline|Newlines _)::_
+ | (Newline|Newlines _)::_ ->
+ loop (Hash::Backslash::accu)
+ ((if h = 0 then Hash else Hashs(h-1))::tl)
+ | _ ->
+ loop (Hashs(h)::Backslash::accu) tl
+ end
+ | Backslashs(n)::Hashs(h)::tl when n mod 2 = 1 ->
+ begin match tl with
+ | []
+ | (Space|Spaces _)::(Newline|Newlines _)::_
+ | (Newline|Newlines _)::_ ->
+ loop (Hash::Backslashs(n)::accu)
+ ((if h = 0 then Hash else Hashs(h-1))::tl)
+ | _ ->
+ loop (Hashs(h)::Backslashs(n)::accu) tl
+ end
+ | (Hash|Hashs _) :: ((Newline|Newlines _) :: _ as l)
+ | (Hash|Hashs _) :: (Space|Spaces _) :: ((Newline|Newlines _)::_ as l)
+ | ((Newline|Newlines _) :: _ as l)
+ | ([] as l)
+ | (Space|Spaces _) :: (Hash|Hashs _) :: ((Newline|Newlines _) :: _ as l)
+ | (Space|Spaces _) :: (Hash|Hashs _) :: (Space|Spaces _)
+ :: ((Newline|Newlines _)::_ as l)
+ | (Space|Spaces _) :: ((Newline|Newlines _) :: _ as l)
+ | (Space|Spaces _) :: ([] as l) ->
+ main_loop [] [] (List.rev accu), l
+ | [Hash|Hashs _]
+ | [(Space|Spaces _); Hash|Hashs _]
+ | [(Space|Spaces _); (Hash|Hashs _); (Space|Spaces _)] ->
+ main_loop [] [] (List.rev accu), []
+ | x::tl ->
+ loop (x::accu) tl
+ in
+ loop [] lexemes
+ in
+ match n with
+ | 1 -> Some(H1 title :: r, [Newline], rest)
+ | 2 -> Some(H2 title :: r, [Newline], rest)
+ | 3 -> Some(H3 title :: r, [Newline], rest)
+ | 4 -> Some(H4 title :: r, [Newline], rest)
+ | 5 -> Some(H5 title :: r, [Newline], rest)
+ | 6 -> Some(H6 title :: r, [Newline], rest)
+ | _ -> None
+
+ let maybe_extension extensions r p l =
+ match extensions with
+ | [] -> None
+ | _ ->
+ List.fold_left
+ (function
+ | None ->
+ (fun f -> f#parser_extension r p l)
+ | Some(nr, np, nl) as e ->
+ (fun f -> match f#parser_extension nr np nl with
+ | None -> e
+ | Some _ as k -> k)
+ )
+ None
+ extensions
+
+ (* blockquotes *)
+ let emailstyle_quoting (main_loop:main_loop) r _p lexemes =
+ assert_well_formed lexemes;
+ let rec loop block cl =
+ function
+ | Newline::Greaterthan::(Newline::_ as tl) ->
+ loop (Newline::cl@block) [] tl
+ | Newline::Greaterthan::Space::tl ->
+ loop (Newline::cl@block) [] tl
+ | Newline::Greaterthan::Spaces 0::tl ->
+ loop (Newline::cl@block) [Space] tl
+ | Newline::Greaterthan::Spaces n::tl ->
+ assert(n>0);
+ loop (Newline::cl@block) [Spaces(n-1)] tl
+
+ (* multi paragraph blockquotes with empty lines *)
+ | Newlines 0::Greaterthan::Space::tl ->
+ loop (Newlines 0::cl@block) [] tl
+ | Newlines 0::Greaterthan::Spaces 0::tl ->
+ loop (Newlines 0::cl@block) [Space] tl
+ | Newlines 0::Greaterthan::Spaces n::tl ->
+ assert(n>0);
+ loop (Newlines 0::cl@block) [Spaces(n-1)] tl
+
+ | (Newlines _::_ as l) | ([] as l) -> fix(List.rev(cl@block)), l
+ | e::tl -> loop block (e::cl) tl
+ in
+ match loop [] [] lexemes with
+ | (Newline|Newlines _)::block, tl ->
+ if debug then
+ eprintf "(OMD) Omd_parser.emailstyle_quoting %S\n%!"
+ (L.string_of_tokens block);
+ Some((Blockquote(main_loop [] [] block)::r), [Newline], tl)
+ | _ ->
+ None
+
+
+ (* maybe a reference *)
+ let maybe_reference (main_loop:main_loop) rc r _p l =
+ assert_well_formed l;
+ (* this function is called when we know it's not a link although
+ it started with a '[' *)
+ (* So it could be a reference or a link definition. *)
+ let maybe_ref l =
+ let text, remains = read_until_cbracket ~bq:true l in
+ (* check that there is no ill-placed open bracket *)
+ if (try ignore(read_until_obracket ~bq:true text); true
+ with Premature_ending -> false) then
+ raise Premature_ending; (* <-- ill-placed open bracket *)
+ let blank, remains = read_until_obracket ~bq:true remains in
+ (* check that there are no unwanted characters between CB and OB. *)
+ if eat (let flag = ref true in
+ function (* allow only a space, multiple spaces, or a newline *)
+ | Newline -> !flag && (flag := false; true)
+ | (Space|Spaces _) -> !flag && (flag := false; true)
+ | _ -> false) blank <> [] then
+ raise Premature_ending (* <-- not a regular reference *)
+ else
+ match read_until_cbracket ~bq:true remains with
+ | [], remains ->
+ let fallback = extract_fallback main_loop remains (Obracket::l) in
+ let id = L.string_of_tokens text in (* implicit anchor *)
+ Some(((Ref(rc, id, id, fallback))::r), [Cbracket], remains)
+ | id, remains ->
+ let fallback = extract_fallback main_loop remains (Obracket::l) in
+ Some(((Ref(rc, L.string_of_tokens id,
+ L.string_of_tokens text, fallback))::r),
+ [Cbracket], remains)
+ in
+ let maybe_nonregular_ref l =
+ let text, remains = read_until_cbracket ~bq:true l in
+ (* check that there is no ill-placed open bracket *)
+ if (try ignore(read_until_obracket ~bq:true text); true
+ with Premature_ending -> false) then
+ raise Premature_ending; (* <-- ill-placed open bracket *)
+ let fallback = extract_fallback main_loop remains (Obracket::l) in
+ let id = L.string_of_tokens text in (* implicit anchor *)
+ Some(((Ref(rc, id, id, fallback))::r), [Cbracket], remains)
+ in
+ let maybe_def l =
+ match read_until_cbracket ~bq:true l with
+ | _, [] -> raise Premature_ending
+ | id, (Colon::(Space|Spaces _)::remains)
+ | id, (Colon::remains) ->
+ begin
+ match
+ fsplit
+ ~f:(function
+ | (Space|Spaces _|Newline|Newlines _):: _ as l -> Split([], l)
+ | _::_ -> Continue
+ | [] -> Split([],[]))
+ remains
+ with
+ | None | Some([], _) -> raise Premature_ending
+ | Some(url, remains) ->
+ let title, remains =
+ match
+ eat
+ (function | (Space|Spaces _|Newline|Newlines _) -> true
+ | _ -> false)
+ remains
+ with
+ | Doublequotes(0)::tl -> [], tl
+ | Doublequote::tl -> read_until_dq ~bq:true tl
+ | Quotes(0)::tl -> [], tl
+ | Quote::tl -> read_until_q ~bq:true tl
+ | Oparenthesis::tl-> read_until_cparenth ~bq:true tl
+ | l -> [], l
+ in
+ let url =
+ let url = L.string_of_tokens url in
+ if String.length url > 2 && url.[0] = '<'
+ && url.[String.length url - 1] = '>' then
+ String.sub url 1 (String.length url - 2)
+ else
+ url
+ in
+ rc#add_ref (L.string_of_tokens id) (L.string_of_tokens title) url;
+ Some(r, [Newline], remains)
+ end
+ | _ -> raise Premature_ending
+ in
+ try
+ maybe_ref l
+ with | Premature_ending | NL_exception ->
+ try
+ maybe_def l
+ with
+ | Premature_ending | NL_exception ->
+ try
+ maybe_nonregular_ref l
+ with
+ | Premature_ending | NL_exception ->
+ None
+
+
+ (** maybe a link *)
+ let maybe_link (main_loop:main_loop) r _p l =
+ if debug then eprintf "(OMD) # maybe_link\n";
+ assert_well_formed l;
+ let read_url name l =
+ if debug then
+ eprintf "(OMD) # maybe_link>read_url %S\n" (L.string_of_tokens l);
+ try
+ let l_cp, r_cp =
+ read_until_cparenth ~no_nl:true ~bq:false l
+ in
+ if debug then eprintf "(OMD) maybe_link >> l_cp=%S r_cp=%S\n%!"
+ (L.string_of_tokens l_cp)
+ (L.string_of_tokens r_cp);
+ try
+ let l_dq, r_dq =
+ read_until_dq ~no_nl:true ~bq:false l
+ in
+ if debug then eprintf "(OMD) maybe_link >> l_dq=%S r_dq=%S\n%!"
+ (L.string_of_tokens l_dq)
+ (L.string_of_tokens r_dq);
+ (* maybe title *)
+ if List.length l_cp > List.length l_dq then (* title *)
+ begin
+ if debug then eprintf "(OMD) maybe_link >> title\n%!";
+ let url =
+ match List.rev l_dq with
+ | (Newline|Space|Spaces _)::(Newline|Space|Spaces _)::tl
+ | (Newline|Space|Spaces _)::tl ->
+ L.string_of_tokens (List.rev tl)
+ | _ ->
+ L.string_of_tokens l_dq
+ in
+ let title, rest = read_until_dq ~no_nl:false ~bq:false r_dq in
+ let rest = snd(read_until_cparenth rest) in
+ let title = L.string_of_tokens title in
+ Some(Url(url, name, title) :: r, [Cparenthesis], rest)
+ end
+ else (* no title *)
+ raise Premature_ending
+ with NL_exception | Premature_ending -> (* no title *)
+ begin
+ if debug then eprintf "(OMD) maybe_link >> no title\n%!";
+ let url = match List.rev l_cp with
+ | (Newline|Space|Spaces _)::(Newline|Space|Spaces _)::tl
+ | (Newline|Space|Spaces _)::tl -> List.rev tl
+ | _ -> l_cp
+ in
+ let title, rest = [], r_cp in
+ let url = L.string_of_tokens url in
+ let title = L.string_of_tokens title in
+ Some(Url(url, name, title) :: r, [Cparenthesis], rest)
+ end
+ with NL_exception | Premature_ending ->
+ None
+ in
+ let read_name l =
+ (* it's not really the "name" of a URL but what
+ corresponds to the inner HTML of an HTML 'A' tag *)
+ if debug then eprintf "(OMD) # maybe_link> read_name\n";
+ try
+ match read_until_cbracket ~bq:true l with
+ | name, (Oparenthesis::tl) ->
+ read_url (main_loop [] [Obracket] name) (eat_blank tl)
+ | name, (Oparenthesiss 0::tl) ->
+ read_url (main_loop [] [Obracket] name) (Oparenthesis::tl)
+ | name, (Oparenthesiss n::tl) ->
+ read_url (main_loop [] [Obracket] name) (Oparenthesiss(n-1)::tl)
+ | _ ->
+ None
+ with Premature_ending | NL_exception -> None
+ in
+ read_name l
+
+
+ let has_paragraphs l =
+ (* Has at least 2 consecutive newlines. *)
+ List.exists (function Newlines _ -> true | _ -> false) l
+
+ let parse_list (main_loop:main_loop) r _p l =
+ assert_well_formed l;
+ if debug then begin
+ eprintf "(OMD) parse_list r=(%s) p=(%s) l=(%s)\n%!"
+ "" (* (Omd_backend.sexpr_of_md (List.rev r)) *)
+ "" (* (destring_of_tl p) *)
+ (L.destring_of_tokens ~limit:40 l);
+ end;
+ let module UO = struct type ordered = O | U end in
+ let open UO in
+ if debug then
+ eprintf "(OMD) parse_list: l=(%s)\n%!" (L.destring_of_tokens l);
+ let end_of_item (indent:int) l : tok split_action = match l with
+ | [] ->
+ Split([],[])
+ | Newlines 0 :: ((Spaces n) :: Greaterthan :: (Space | Spaces _) :: _
+ as s) ->
+ assert(n>=0);
+ if n+2 = indent+4 then (* blockquote *)
+ match unindent (n+2) (Newline::s) with
+ | Newline::block, rest ->
+ Continue_with(List.rev(Newlines(1)::block), rest)
+ | Newlines n::block, rest ->
+ Continue_with(List.rev(Newlines(n+2)::block), rest)
+ | block, rest ->
+ Continue_with(Newlines 0::block, rest)
+ else if n+2 >= indent+8 then (* code inside item *)
+ match unindent (indent+4) (Newline::s) with
+ | Newline::block, rest ->
+ Continue_with(List.rev(Newlines(1)::block), rest)
+ | Newlines n::block, rest ->
+ Continue_with(List.rev(Newlines(n+2)::block), rest)
+ | block, rest ->
+ Continue_with(Newlines 0::block, rest)
+ else
+ Split([], l)
+ | Newlines 0 :: (Spaces n :: _ as s) ->
+ assert(n>=0);
+ if n+2 >= indent+8 then (* code inside item *)
+ match unindent (indent+4) (Newline::s) with
+ | Newline::block, rest ->
+ Continue_with(List.rev(Newlines(0)::block), rest)
+ | Newlines n::block, rest ->
+ Continue_with(List.rev(Newlines(n+1)::block), rest)
+ | block, rest ->
+ Continue_with(Newline::block, rest)
+ else if n+2 >= indent+4 then (* new paragraph inside item *)
+ match unindent (indent+4) (Newline::s) with
+ | Newline::block, rest ->
+ Continue_with(List.rev(Newlines(1)::block), rest)
+ | Newlines n::block, rest ->
+ Continue_with(List.rev(Newlines(n+2)::block), rest)
+ | block, rest ->
+ Continue_with(Newlines 0::block, rest)
+ else
+ Split([], l)
+ | (Newlines _) :: _ -> (* n > 0 *)
+ (* End of item, stop *)
+ Split([], l)
+ | Newline ::
+ (
+ ((Space|Spaces _) :: (Star|Minus|Plus) :: (Space|Spaces _):: _)
+ | ((Space|Spaces _) :: Number _ :: Dot :: (Space|Spaces _) :: _)
+ | ((Star|Minus|Plus) :: (Space|Spaces _):: _)
+ | (Number _ :: Dot :: (Space|Spaces _) :: _)
+ as tl) ->
+ Split([Newline], tl)
+ | Newline :: (Space | Spaces _) :: Newline :: tl ->
+ (* A line with spaces shouldn't interfere here,
+ which is about exactly 2 consecutive newlines,
+ so we rewrite the head of the lexing stream. *)
+ Continue_with([], Newlines 0 :: tl)
+ | Newline :: (Space | Spaces _) :: (Newlines _) :: _ ->
+ (* A line with spaces shouldn't interfere here,
+ which is about at least 3 consecutive newlines,
+ so we stop. *)
+ Split([], l)
+ | Newline :: (Spaces _ as s) :: tl ->
+ Continue_with
+ ([s;
+ Tag("parse_list/remember spaces",
+ object
+ method parser_extension r p =
+ function Spaces _::tl -> Some(r,p,Space::tl)
+ | _ -> None
+ method to_string = ""
+ end);
+ Newline],
+ tl)
+ | Newline :: (Space as s) :: tl ->
+ Continue_with
+ ([s;
+ Tag("parse_list/remember space",
+ object
+ method parser_extension r p =
+ function (Space|Spaces _)::tl -> Some(r,p,Space::tl)
+ | _ -> None
+ method to_string = ""
+ end);
+ Newline],
+ tl)
+ | _::_ ->
+ Continue
+ in
+ let rev_to_t l =
+ assert_well_formed l;
+ (* Newlines at the end of items have no meaning (except to end the
+ item which is expressed by the constructor already). *)
+ let l = match l with (Newline | Newlines _) :: tl -> tl | _ -> l in
+ main_loop [] [Newline] (List.rev l)
+ in
+ let add (sublist:element) items =
+ if debug then eprintf "(OMD) add\n%!";
+ match items with
+ | [] -> assert false
+ | (O,indents,item)::tl ->
+ (O,indents,(item@[sublist]))::tl
+ | (U,indents,item)::tl ->
+ (U,indents,(item@[sublist]))::tl
+ in
+ let make_up ~p items : Omd_representation.element =
+ if debug then eprintf "(OMD) make_up p=%b\n%!" p;
+ let items = List.rev items in
+ match items with
+ | (U,_,_item)::_ ->
+ if p then
+ Ulp(List.map (fun (_,_,i) -> i) items)
+ else
+ Ul(List.map (fun (_,_,i) -> i) items)
+ | (O,_,_item)::_ ->
+ if p then
+ Olp(List.map (fun (_,_,i) -> i) items)
+ else
+ Ol(List.map (fun (_,_,i) -> i) items)
+ | [] ->
+ failwith "make_up called with []" (* assert false *)
+ in
+ let rec list_items ~p indents items l =
+ if debug then eprintf "(OMD) list_items: p=%b l=(%s)\n%!"
+ p (L.destring_of_tokens l);
+ match l with
+ (* no more list items *)
+ | [] ->
+ make_up ~p items, l
+ (* more list items *)
+ (* new unordered items *)
+ | (Star|Minus|Plus)::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item 0) tl with
+ | None ->
+ make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ if debug then
+ eprintf "(OMD) (2346) new_item=%S\n%!"
+ (L.destring_of_tokens new_item);
+ match indents with
+ | [] ->
+ assert(items = []);
+ list_items ~p [0] ((U,[0], rev_to_t new_item)::items) rest
+ | 0::_ ->
+ list_items ~p indents ((U,indents,rev_to_t new_item)::items) rest
+ | _::_ ->
+ make_up ~p items, l
+ end
+ | Space::(Star|Minus|Plus)::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item 1) tl with
+ | None -> make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ match indents with
+ | [] ->
+ assert(items = []);
+ list_items ~p [1] ((U,[1],rev_to_t new_item)::items) rest
+ | 1::_ ->
+ list_items ~p indents ((U,indents,rev_to_t new_item)::items) rest
+ | i::_ ->
+ if i > 1 then
+ make_up ~p items, l
+ else (* i < 1 : new sub list*)
+ let sublist, remains =
+ list_items ~p (1::indents)
+ [(U,1::indents,rev_to_t new_item)] rest
+ in
+ list_items ~p indents (add sublist items) remains
+ end
+ | Spaces n::(Star|Minus|Plus)::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item (n+2)) tl with
+ | None ->
+ make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ match indents with
+ | [] ->
+ if debug then
+ eprintf "(OMD) spaces[] l=(%S)\n%!" (L.string_of_tokens l);
+ assert(items = []); (* a�e... listes mal form�es ?! *)
+ list_items ~p [n+2] ((U,[n+2],rev_to_t new_item)::items) rest
+ | i::_ ->
+ if debug then eprintf "(OMD) spaces(%d::_) n=%d l=(%S)\n%!"
+ i n (L.string_of_tokens l);
+ if i = n + 2 then
+ let items = (U,indents,rev_to_t new_item) :: items in
+ list_items ~p indents items rest
+ else if i < n + 2 then
+ let sublist, remains =
+ list_items ~p ((n+2)::indents)
+ [(U,(n+2)::indents,rev_to_t new_item)]
+ rest
+ in
+ list_items ~p indents (add sublist items) remains
+ else (* i > n + 2 *)
+ make_up ~p items, l
+ end
+ (* new ordered items *)
+ | Number _::Dot::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item 0) tl with
+ | None ->
+ make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ assert_well_formed new_item;
+ match indents with
+ | [] ->
+ assert(items = []);
+ list_items ~p [0] ((O,[0],rev_to_t new_item)::items) rest
+ | 0::_ ->
+ list_items ~p indents ((O,indents,rev_to_t new_item)::items) rest
+ | _::_ ->
+ make_up ~p items, l
+ end
+ | Space::Number _::Dot::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item 1) tl with
+ | None -> make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ match indents with
+ | [] ->
+ assert(items = []);
+ list_items ~p [1] ((O,[1],rev_to_t new_item)::items) rest
+ | 1::_ ->
+ list_items ~p indents ((O,indents,rev_to_t new_item)::items) rest
+ | i::_ ->
+ if i > 1 then
+ make_up ~p items, l
+ else (* i < 1 : new sub list*)
+ let sublist, remains =
+ list_items ~p (1::indents)
+ [(O,1::indents,rev_to_t new_item)] rest
+ in
+ list_items ~p:p indents (add sublist items) remains
+ end
+ | Spaces n::Number _::Dot::(Space|Spaces _)::tl ->
+ begin
+ match fsplit_rev ~f:(end_of_item (n+2)) tl with
+ | None ->
+ make_up ~p items, l
+ | Some(new_item, rest) ->
+ let p = p || has_paragraphs new_item in
+ match indents with
+ | [] ->
+ if debug then eprintf "(OMD) spaces[] l=(%S)\n%!"
+ (L.string_of_tokens l);
+ assert(items = []); (* a�e... listes mal form�es ?! *)
+ list_items ~p [n+2] ((O,[n+2],rev_to_t new_item)::items) rest
+ | i::_ ->
+ if debug then eprintf "(OMD) spaces(%d::_) n=%d l=(%S)\n%!"
+ i n (L.string_of_tokens l);
+ if i = n + 2 then
+ list_items ~p indents ((O,indents,rev_to_t new_item)::items)
+ rest
+ else if i < n + 2 then
+ let sublist, remains =
+ list_items ~p
+ ((n+2)::indents)
+ [(O,(n+2)::indents,rev_to_t new_item)]
+ rest
+ in
+ list_items ~p:p indents (add sublist items) remains
+ else (* i > n + 2 *)
+ make_up ~p items, l
+ end
+ (* *)
+ | Newlines 0::((Star|Minus|Plus)::(Space|Spaces _)::_ as l)
+ | Newlines 0::(Number _::Dot::(Space|Spaces _)::_ as l)
+ | Newlines 0::((Space|Spaces _)::Star::(Space|Spaces _)::_ as l)
+ | Newlines 0::((Space|Spaces _)::Number _::Dot::(Space|Spaces _)::_ as l)
+ ->
+ list_items ~p:true indents items l
+ | _ ->
+ if debug then
+ begin
+ let rec string_of_items items =
+ match items with
+ | [] -> ""
+ | (O,indent::_,item)::tl ->
+ sprintf "(O,i=%d,%S)" (indent) (Omd_backend.html_of_md item)
+ ^ string_of_items tl
+ | (U,indent::_,item)::tl ->
+ sprintf "(U,i=%d,%S)" (indent) (Omd_backend.html_of_md item)
+ ^ string_of_items tl
+ | _ -> "(weird)"
+ in
+ eprintf "(OMD) NALI parse_list: l=(%S) items=%s\n%!"
+ (L.string_of_tokens l) (string_of_items items)
+ end;
+ (* not a list item *)
+ make_up ~p items, l
+ in
+ match list_items ~p:false [] [] l with
+ | rp, l ->
+ rp::r, [Newline], l
+
+
+
+ let icode ?(default_lang=default_lang) r _p l =
+ assert_well_formed l;
+ (* indented code: returns (r,p,l) where r is the result, p is the
+ last thing read, l is the remains *)
+ let dummy_tag = Tag("dummy_tag",
+ object
+ method to_string = ""
+ method parser_extension = fun _r _p _l -> None
+ end) in
+ let accu = Buffer.create 64 in
+ let rec loop s tl = match s, tl with
+ | (Newline|Newlines _ as p), (Space|Spaces(0|1))::_ ->
+ (* 1, 2 or 3 spaces. *)
+ (* -> Return what's been found as code because what follows isn't. *)
+ Code_block(default_lang, Buffer.contents accu) :: r, [p], tl
+ | (Newline|Newlines _ as p), Spaces(n)::tl ->
+ assert(n>0);
+ (* At least 4 spaces, it's still code. *)
+ Buffer.add_string accu (L.string_of_token p);
+ loop
+ (if n >= 4 then Spaces(n-4) else if n = 3 then Space else dummy_tag)
+ tl
+ | (Newline|Newlines _ as p), (_not_spaces::_ as tl) -> (* stop *)
+ Code_block(default_lang, Buffer.contents accu) :: r, [p], tl
+ (* -> Return what's been found as code because it's no more code. *)
+ | p, e::tl ->
+ Buffer.add_string accu (L.string_of_token p);
+ (* html entities are to be converted later! *)
+ loop e tl
+ | p, [] ->
+ Buffer.add_string accu (L.string_of_token p);
+ Code_block(default_lang, Buffer.contents accu)::r, [p], []
+ in
+ match l with
+ | Spaces n::tl ->
+ if n >= 4 then
+ Some(loop (Spaces(n-4)) tl)
+ else if n = 3 then
+ Some(loop Space tl)
+ else Some(loop dummy_tag tl)
+ | _ -> assert false
+
+
+ (* Returns [(r,p,l)] where [r] is the result, [p] is the last thing
+ read, and [l] is what remains. *)
+ let spaces_at_beginning_of_line main_loop default_lang n r previous lexemes =
+ assert_well_formed lexemes;
+ assert (n > 0);
+ if n <= 3 then (
+ match lexemes with
+ | (Star|Minus|Plus) :: (Space|Spaces _) :: _ ->
+ (* unordered list *)
+ parse_list main_loop r [] (L.make_space n::lexemes)
+ | (Number _)::Dot::(Space|Spaces _)::_tl ->
+ (* ordered list *)
+ parse_list main_loop r [] (L.make_space n::lexemes)
+ | []
+ | (Newline|Newlines _) :: _ -> (* blank line, skip spaces *)
+ r, previous, lexemes
+ | _::_ ->
+ Text (" ")::r, previous, lexemes
+ )
+ else ( (* n>=4, blank line or indented code *)
+ match lexemes with
+ | [] | (Newline|Newlines _) :: _ -> r, previous, lexemes
+ | _ ->
+ match
+ icode ~default_lang r [Newline] (L.make_space n :: lexemes)
+ with
+ | Some(r,p,l) -> r,p,l
+ | None ->
+ if debug then
+ eprintf "(OMD) Omd_parser.icode or \
+ Omd_parser.main_loop is broken\n%!";
+ assert false
+ )
+
+ let spaces_not_at_beginning_of_line ?(html=false) n r lexemes =
+ assert_well_formed lexemes;
+ assert (n > 0);
+ if n = 1 then
+ (Text " "::r), [Space], lexemes
+ else (
+ match lexemes with
+ | Newline :: tl when not html ->
+ if debug then
+ eprintf
+ "(OMD) 2 or more spaces before a newline, eat the newline\n%!";
+ Br::r, [Spaces(n-2)], tl
+ | Newlines k :: tl when not html ->
+ if debug then
+ eprintf
+ "(OMD) 2 or more spaces before a newline, eat 1 newline";
+ let newlines = if k = 0 then Newline else Newlines(k-1) in
+ Br::r, [Spaces(n-2)], newlines :: tl
+ | _ ->
+ assert (n>1);
+ (Text (String.make n ' ')::r), [Spaces(n-2)], lexemes
+ )
+
+
+ let maybe_autoemail r _p l =
+ assert_well_formed l;
+ match l with
+ | Lessthan::tl ->
+ begin
+ match
+ fsplit ~excl:(function (Newline|Newlines _|Space|Spaces _) :: _-> true
+ | [] -> true
+ | _ -> false)
+ ~f:(function At::tl -> Split([],tl) | _ -> Continue)
+ tl
+ with
+ | None -> None
+ | Some(left, right) ->
+ match
+ fsplit
+ ~excl:(function
+ | (Newline|Newlines _|Space|Spaces _) :: _-> true
+ | [] -> true
+ | _ -> false)
+ ~f:(function Greaterthan::tl -> Split([],tl)
+ | Greaterthans 0::tl -> Split([],Greaterthan::tl)
+ | Greaterthans n::tl -> Split([],Greaterthans(n-1)::tl)
+ | _ -> Continue)
+ right
+ with
+ | None -> None
+ | Some(domain, tl) ->
+ let email = L.string_of_tokens left
+ ^ "@" ^ L.string_of_tokens domain in
+ Some(Url("mailto:"^email,[Text email],"")::r,[Greaterthan],tl)
+ end
+ | _ -> failwith "Omd_parser.maybe_autoemail: wrong use of the function."
+
+ let is_hex s =
+ String.length s > 1
+ && (s.[0] = 'X' || s.[0] = 'x')
+ && (let rec loop i =
+ i = String.length s
+ ||
+ (match s.[i] with
+ | '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ->
+ loop (succ i)
+ | _ -> false)
+ in loop 1)
+
+ let mediatypetextomd : string list ref = ref []
+
+ let filter_text_omd_rev l =
+ let rec loop b r = function
+ | [] -> if b then r else l
+ | ("media:type", Some "text/omd")::tl ->
+ loop true r tl
+ | e::tl ->
+ loop b (e::r) tl
+ in
+ loop false [] l
+
+ exception Orphan_closing of string * l * l
+
+ let rec main_impl_rev ~html (r:r) (previous:p) (lexemes:l) =
+ (* if debug then eprintf "(OMD) main_impl_rev html=%b\n%!" html; *)
+ assert_well_formed lexemes;
+ if debug then
+ eprintf "(OMD) main_impl_rev html=%b r=%s p=(%s) l=(%s)\n%!"
+ html
+ (Omd_backend.sexpr_of_md (List.rev r))
+ (L.destring_of_tokens previous)
+ (L.destring_of_tokens lexemes);
+ match previous, lexemes with
+ (* no more to process *)
+ | _, [] ->
+ (* return the result (/!\ it has to be reversed as some point) *)
+ r
+
+ (* Tag: tag system $\cup$ high-priority extension mechanism *)
+ | _, Tag(_name, e) :: tl ->
+ begin match e#parser_extension r previous tl with
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ | None ->
+ main_impl_rev ~html r previous tl
+ end
+
+ (* HTML comments *)
+ | _, (Lessthan as t)::(Exclamation::Minuss 0::_c as tl) ->
+ begin
+ let f = function
+ | (Minuss _ as m)::(Greaterthan|Greaterthans _ as g)::tl ->
+ Split([g;m], tl)
+ | _ ->
+ Continue
+ in
+ match fsplit ~f:f lexemes with
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ | Some (comments, new_tl) ->
+ let r = Html_comment(L.string_of_tokens comments) :: r in
+ main_impl_rev ~html r [Newline] new_tl
+ end
+
+ (* email-style quoting / blockquote *)
+ | ([]|[Newline|Newlines _]), Greaterthan::(Space|Spaces _)::_ ->
+ begin
+ match
+ emailstyle_quoting main_loop r previous (Newline::lexemes)
+ with
+ | Some(r,p,l) -> main_impl_rev ~html r p l
+ | None ->
+ if debug then
+ eprintf "(OMD) Omd_parser.emailstyle_quoting or \
+ Omd_parser.main_loop is broken\n%!";
+ assert false
+ end
+
+ (* email-style quoting, with lines starting with spaces! *)
+ | ([]|[Newline|Newlines _]), (Space|Spaces(0|1) as s)
+ :: Greaterthan :: (Space|Spaces _)::_ ->
+ (* It's 1, 2 or 3 spaces, not more because it wouldn't mean
+ quoting anymore but code. *)
+ begin
+ let new_r, _p, rest =
+ let foo, rest =
+ match unindent (L.length s) (Newline::lexemes) with
+ | (Newline|Newlines _)::foo, rest -> foo, rest
+ | res -> res
+ in
+ match
+ emailstyle_quoting main_loop [] previous (Newline::foo)
+ with
+ | Some(new_r, p, []) -> new_r, p, rest
+ | _ ->
+ if debug then
+ eprintf "(OMD) Omd_parser.emailstyle_quoting or \
+ Omd_parser.main_loop is broken\n%!";
+ assert false
+ in
+ main_impl_rev ~html (new_r@r) [Newline] rest
+ end
+
+ (* minus *)
+ | ([]|[Newline|Newlines _]),
+ (Minus|Minuss _ as t) :: ((Space|Spaces _)::_ as tl) ->
+ (* maybe hr *)
+ begin match hr_m lexemes with
+ | None -> (* no hr, so it could be a list *)
+ begin match t with
+ | Minus -> (* it's a list *)
+ let md, new_p, new_l =
+ parse_list main_loop r [] lexemes
+ in
+ main_impl_rev ~html md new_p new_l
+ | _ -> (* not a list *)
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ end
+ | Some l -> (* hr *)
+ main_impl_rev ~html (Hr::r) [Newline] l
+ end
+ | ([]|[Newline|Newlines _]), (Minus|Minuss _ as t)::tl ->
+ begin match hr_m lexemes with
+ | None -> (* no hr, and it's not a list either
+ because it's not followed by spaces *)
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ | Some l -> (* hr *)
+ main_impl_rev ~html (Hr::r) [Newline] l
+ end
+
+ (* hashes *)
+ | ([]|[(Newline|Newlines _)]),
+ (Hashs n as t) :: ((Space|Spaces _) :: ttl as tl)
+ | ([]|[(Newline|Newlines _)]),
+ (Hashs n as t) :: (ttl as tl) -> (* hash titles *)
+ if n <= 4 then
+ match read_title main_loop (n+2) r previous ttl with
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ | None ->
+ if debug then
+ eprintf "(OMD) Omd_parser.read_title or \
+ Omd_parser.main_loop is broken\n%!";
+ assert false
+ else
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ | ([]|[(Newline|Newlines _)]), Hash :: (Space|Spaces _) :: tl
+ | ([]|[(Newline|Newlines _)]), Hash :: tl -> (* hash titles *)
+ begin match read_title main_loop 1 r previous tl with
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ | None ->
+ if debug then
+ eprintf "(OMD) Omd_parser.read_title or \
+ Omd_parser.main_loop is broken\n%!";
+ assert false
+ end
+ | _, (Hash|Hashs _ as t) :: tl -> (* hash -- no title *)
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+
+ (* spaces after a newline: could lead to hr *)
+ | ([]|[Newline|Newlines _]), ((Space|Spaces _) as sp) :: tl ->
+ begin match hr tl with
+ | None ->
+ (* No [Hr], but maybe [Ul], [Ol], code,... *)
+ let n = L.length sp in
+ let r, p, l =
+ spaces_at_beginning_of_line main_loop default_lang n r previous tl in
+ main_impl_rev ~html r p l
+ | Some tl ->
+ main_impl_rev ~html (Hr::r) [Newline] tl
+ end
+
+ (* spaces anywhere *)
+ | _, ((Space|Spaces _) as t) :: tl ->
+ (* too many cases to be handled here *)
+ let n = L.length t in
+ let r, p, l = spaces_not_at_beginning_of_line ~html n r tl in
+ main_impl_rev ~html r p l
+
+ (* underscores *)
+ | _, (Underscore as t) :: tl -> (* one "orphan" underscore, or emph *)
+ (match uemph_or_bold 1 tl with
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ | Some(x, new_tl) ->
+ main_impl_rev ~html (Emph(main_impl ~html [] [t] x) :: r) [t] new_tl
+ )
+ | _, (Underscores((0|1) as n) as t) :: tl ->
+ (* 2 or 3 "orphan" underscores, or emph/bold *)
+ (match uemph_or_bold (n+2) tl with
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ | Some(x, new_tl) ->
+ if n = 0 then (* 1 underscore *)
+ main_impl_rev ~html (Bold(main_impl ~html [] [t] x) :: r) [t] new_tl
+ else (* 2 underscores *)
+ main_impl_rev ~html (Emph([Bold(main_impl ~html [] [t] x)]) :: r) [t] new_tl
+ )
+
+ (* enumerated lists *)
+ | ([]|[Newline|Newlines _]), (Number _) :: Dot :: (Space|Spaces _) :: _tl ->
+ let md, new_p, new_l =
+ parse_list main_loop r [] lexemes
+ in
+ main_impl_rev ~html md new_p new_l
+
+ (* plus *)
+ | ([]|[(Newline|Newlines _)]), Plus :: (Space|Spaces _) :: _ ->
+ let md, new_p, new_l =
+ parse_list main_loop r [] lexemes
+ in
+ main_impl_rev ~html md new_p new_l
+
+ (* stars *)
+ | ([]|[(Newline|Newlines _)]), Star :: (Space|Spaces _) :: _ ->
+ (* maybe hr or new list *)
+ begin match hr_s lexemes with
+ | Some l ->
+ main_impl_rev ~html (Hr::r) [Newline] l
+ | None ->
+ let md, new_p, new_l =
+ parse_list main_loop r [] lexemes
+ in
+ main_impl_rev ~html md new_p new_l
+ end
+ | ([]|[(Newline|Newlines _)]), Stars _ :: _ when hr_s lexemes <> None ->
+ (* hr *)
+ (match hr_s lexemes with
+ | Some l -> main_impl_rev ~html (Hr::r) [Newline] l
+ | None -> assert false
+ )
+ | ([]|[(Newline|Newlines _)]), (Star as t) :: tl -> (* maybe hr *)
+ begin match hr_s lexemes with
+ | Some l ->
+ main_impl_rev ~html (Hr::r) [Newline] l
+ | None ->
+ (match semph_or_bold 1 tl with
+ | Some(x, new_tl) ->
+ main_impl_rev ~html (Emph(main_impl ~html [] [t] x) :: r) [t] new_tl
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ )
+ end
+ | _, (Star as t) :: tl -> (* one "orphan" star, or emph // can't be hr *)
+ (match semph_or_bold 1 tl with
+ | Some(x, new_tl) ->
+ main_impl_rev ~html (Emph(main_impl ~html [] [t] x) :: r) [t] new_tl
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+ | _, (Stars((0|1) as n) as t) :: tl ->
+ (* 2 or 3 "orphan" stars, or emph/bold *)
+ (match semph_or_bold (n+2) tl with
+ | Some(x, new_tl) ->
+ if n = 0 then
+ main_impl_rev ~html (Bold(main_impl ~html [] [t] x) :: r) [t] new_tl
+ else
+ main_impl_rev ~html (Emph([Bold(main_impl ~html [] [t] x)]) :: r) [t] new_tl
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+
+ (* backslashes *)
+ | _, Backslash :: (Newline as t) :: tl -> (* \\n *)
+ main_impl_rev ~html (Br :: r) [t] tl
+ | _, Backslash :: Newlines 0 :: tl -> (* \\n\n\n\n... *)
+ main_impl_rev ~html (Br :: r) [Backslash; Newline] (Newline :: tl)
+ | _, Backslash :: Newlines n :: tl -> assert (n >= 0); (* \\n\n\n\n... *)
+ main_impl_rev ~html (Br :: r) [Backslash; Newline]
+ (Newlines (n-1) :: tl)
+ | _, Backslash :: (Backquote as t) :: tl -> (* \` *)
+ main_impl_rev ~html (Text ("`") :: r) [t] tl
+ | _, Backslash :: Backquotes 0 :: tl -> (* \````... *)
+ main_impl_rev ~html (Text ("`") :: r) [Backslash; Backquote] (Backquote :: tl)
+ | _, Backslash :: Backquotes n :: tl -> assert (n >= 0); (* \````... *)
+ main_impl_rev ~html (Text ("`") :: r) [Backslash; Backquote]
+ (Backquotes (n-1) :: tl)
+ | _, Backslash :: (Star as t) :: tl -> (* \* *)
+ main_impl_rev ~html (Text ("*") :: r) [t] tl
+ | _, Backslash :: Stars 0 :: tl -> (* \****... *)
+ main_impl_rev ~html (Text ("*") :: r) [Backslash; Star] (Star :: tl)
+ | _, Backslash :: Stars n :: tl -> assert (n >= 0); (* \****... *)
+ main_impl_rev ~html (Text ("*") :: r) [Backslash; Star] (Stars (n-1) :: tl)
+ | _, Backslash :: (Underscore as t) :: tl -> (* \_ *)
+ main_impl_rev ~html (Text ("_") :: r) [t] tl
+ | _, Backslash :: Underscores 0 :: tl -> (* \___... *)
+ main_impl_rev ~html (Text ("_") :: r) [Backslash; Underscore] (Underscore :: tl)
+ | _, Backslash :: Underscores n :: tl -> assert (n >= 0); (* \___... *)
+ main_impl_rev ~html (Text ("_") :: r) [Backslash; Underscore]
+ (Underscores (n-1) :: tl)
+ | _, Backslash :: (Obrace as t) :: tl -> (* \{ *)
+ main_impl_rev ~html (Text ("{") :: r) [t] tl
+ | _, Backslash :: Obraces 0 :: tl -> (* \{{{... *)
+ main_impl_rev ~html (Text ("{") :: r) [Backslash; Obrace] (Obrace :: tl)
+ | _, Backslash :: Obraces n :: tl -> assert (n >= 0); (* \{{{... *)
+ main_impl_rev ~html (Text ("{") :: r) [Backslash; Obrace] (Obraces (n-1) :: tl)
+ | _, Backslash :: (Cbrace as t) :: tl -> (* \} *)
+ main_impl_rev ~html (Text ("}") :: r) [t] tl
+ | _, Backslash :: Cbraces 0 :: tl -> (* \}}}... *)
+ main_impl_rev ~html (Text ("}") :: r) [Backslash; Cbrace] (Cbrace :: tl)
+ | _, Backslash :: Cbraces n :: tl -> assert (n >= 0); (* \}}}... *)
+ main_impl_rev ~html (Text ("}") :: r) [Backslash; Cbrace] (Cbraces (n-1) :: tl)
+ | _, Backslash :: (Obracket as t) :: tl -> (* \[ *)
+ main_impl_rev ~html (Text ("[") :: r) [t] tl
+ | _, Backslash :: Obrackets 0 :: tl -> (* \[[[... *)
+ main_impl_rev ~html (Text ("[") :: r) [Backslash; Obracket] (Obracket :: tl)
+ | _, Backslash :: Obrackets n :: tl -> assert (n >= 0); (* \[[[... *)
+ main_impl_rev ~html (Text ("[") :: r) [Backslash; Obracket] (Obrackets (n-1) :: tl)
+ | _, Backslash :: (Cbracket as t) :: tl -> (* \} *)
+ main_impl_rev ~html (Text ("]") :: r) [t] tl
+ | _, Backslash :: Cbrackets 0 :: tl -> (* \}}}... *)
+ main_impl_rev ~html (Text ("]") :: r) [Backslash; Cbracket] (Cbracket :: tl)
+ | _, Backslash :: Cbrackets n :: tl -> assert (n >= 0); (* \}}}... *)
+ main_impl_rev ~html (Text ("]") :: r) [Backslash; Cbracket] (Cbrackets (n-1) :: tl)
+ | _, Backslash :: (Oparenthesis as t) :: tl -> (* \( *)
+ main_impl_rev ~html (Text ("(") :: r) [t] tl
+ | _, Backslash :: Oparenthesiss 0 :: tl -> (* \(((... *)
+ main_impl_rev ~html (Text ("(") :: r) [Backslash; Oparenthesis] (Oparenthesis :: tl)
+ | _, Backslash :: Oparenthesiss n :: tl -> assert (n >= 0); (* \(((... *)
+ main_impl_rev ~html (Text ("(") :: r) [Backslash; Oparenthesis]
+ (Oparenthesiss (n-1) :: tl)
+ | _, Backslash :: (Cparenthesis as t) :: tl -> (* \) *)
+ main_impl_rev ~html (Text (")") :: r) [t] tl
+ | _, Backslash :: Cparenthesiss 0 :: tl -> (* \)))... *)
+ main_impl_rev ~html (Text (")") :: r) [Backslash; Cparenthesis]
+ (Cparenthesis :: tl)
+ | _, Backslash :: Cparenthesiss n :: tl -> assert (n >= 0); (* \)))... *)
+ main_impl_rev ~html (Text (")") :: r) [Backslash; Cparenthesis]
+ (Cparenthesiss (n-1) :: tl)
+ | _, Backslash :: (Plus as t) :: tl -> (* \+ *)
+ main_impl_rev ~html (Text ("+") :: r) [t] tl
+ | _, Backslash :: Pluss 0 :: tl -> (* \+++... *)
+ main_impl_rev ~html (Text ("+") :: r) [Backslash; Plus] (Plus :: tl)
+ | _, Backslash :: Pluss n :: tl -> assert (n >= 0); (* \+++... *)
+ main_impl_rev ~html (Text ("+") :: r) [Backslash; Plus] (Pluss (n-1) :: tl)
+ | _, Backslash :: (Minus as t) :: tl -> (* \- *)
+ main_impl_rev ~html (Text ("-") :: r) [t] tl
+ | _, Backslash :: Minuss 0 :: tl -> (* \---... *)
+ main_impl_rev ~html (Text ("-") :: r) [Backslash; Minus] (Minus :: tl)
+ | _, Backslash :: Minuss n :: tl -> assert (n >= 0); (* \---... *)
+ main_impl_rev ~html (Text ("-") :: r) [Backslash; Minus] (Minuss (n-1) :: tl)
+ | _, Backslash :: (Dot as t) :: tl -> (* \. *)
+ main_impl_rev ~html (Text (".") :: r) [t] tl
+ | _, Backslash :: Dots 0 :: tl -> (* \....... *)
+ main_impl_rev ~html (Text (".") :: r) [Backslash; Dot] (Dot :: tl)
+ | _, Backslash :: Dots n :: tl -> assert (n >= 0); (* \....... *)
+ main_impl_rev ~html (Text (".") :: r) [Backslash; Dot] (Dots (n-1) :: tl)
+ | _, Backslash :: (Exclamation as t) :: tl -> (* \! *)
+ main_impl_rev ~html (Text ("!") :: r) [t] tl
+ | _, Backslash :: Exclamations 0 :: tl -> (* \!!!... *)
+ main_impl_rev ~html (Text ("!") :: r) [Backslash; Exclamation] (Exclamation :: tl)
+ | _, Backslash :: Exclamations n :: tl -> assert (n >= 0); (* \!!!... *)
+ main_impl_rev ~html (Text ("!") :: r) [Backslash; Exclamation]
+ (Exclamations (n-1) :: tl)
+ | _, Backslash :: (Hash as t) :: tl -> (* \# *)
+ main_impl_rev ~html (Text ("#") :: r) [t] tl
+ | _, Backslash :: Hashs 0 :: tl -> (* \###... *)
+ main_impl_rev ~html (Text ("#") :: r) [Backslash; Hash] (Hash :: tl)
+ | _, Backslash :: Hashs n :: tl -> assert (n >= 0); (* \###... *)
+ main_impl_rev ~html (Text ("#") :: r) [Backslash; Hash] (Hashs (n-1) :: tl)
+ | _, Backslash :: (Greaterthan as t) :: tl -> (* \> *)
+ main_impl_rev ~html (Text (">") :: r) [t] tl
+ | _, Backslash :: Greaterthans 0 :: tl -> (* \>>>... *)
+ main_impl_rev ~html (Text (">") :: r) [Backslash; Greaterthan] (Greaterthan :: tl)
+ | _, Backslash :: Greaterthans n :: tl -> assert (n >= 0); (* \>>>... *)
+ main_impl_rev ~html (Text (">") :: r) [Backslash; Greaterthan]
+ (Greaterthans (n-1) :: tl)
+ | _, Backslash :: (Lessthan as t) :: tl -> (* \< *)
+ main_impl_rev ~html (Text ("<") :: r) [t] tl
+ | _, Backslash :: Lessthans 0 :: tl -> (* \<<<... *)
+ main_impl_rev ~html (Text ("<") :: r) [Backslash; Lessthan] (Lessthan :: tl)
+ | _, Backslash :: Lessthans n :: tl -> assert (n >= 0); (* \<<<... *)
+ main_impl_rev ~html (Text ("<") :: r) [Backslash; Lessthan]
+ (Lessthans (n-1) :: tl)
+ | _, (Backslashs 0 as t) :: tl -> (* \\\\... *)
+ main_impl_rev ~html (Text ("\\") :: r) [t] tl
+ | _, (Backslashs n as t) :: tl -> (* \\\\... *)
+ if n mod 2 = 0 then
+ main_impl_rev ~html (Text(String.make ((n+2)/2) '\\') :: r) [t] tl
+ else
+ main_impl_rev ~html (Text(String.make ((n+2)/2) '\\') :: r) [t] (Backslash :: tl)
+ | _, Backslash::[] ->
+ main_impl_rev ~html (Text "\\" :: r) [] []
+ | _, Backslash::tl ->
+ main_impl_rev ~html (Text "\\" :: r) [Backslash] tl
+
+ (* < *)
+ | _, (Lessthan|Lessthans _ as t)
+ :: (Word("http"|"https"|"ftp"|"ftps"|"ssh"|"afp"|"imap") as w)
+ :: Colon::Slashs(n)::tl ->
+ (* "semi-automatic" URLs *)
+ let rec read_url accu = function
+ | (Newline|Newlines _)::_tl ->
+ None
+ | Greaterthan::tl ->
+ let url =
+ (L.string_of_token w) ^ "://"
+ ^ (if n = 0 then "" else String.make (n-1) '/')
+ ^ L.string_of_tokens (List.rev accu)
+ in Some(url, tl)
+ | x::tl ->
+ read_url (x::accu) tl
+ | [] ->
+ None
+ in
+ begin match read_url [] tl with
+ | Some(url, new_tl) ->
+ let r =
+ match t with
+ | Lessthans 0 -> Text "<" :: r
+ | Lessthans n -> Text(String.make (n+1) '<') :: r
+ | _ -> r
+ in
+ main_impl_rev ~html (Url(url,[Text url],"")::r) [] new_tl
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ end
+
+
+ (* Word(w) *)
+ | _, Word w::tl ->
+ main_impl_rev ~html (Text w :: r) [Word w] tl
+
+ (* newline at the end *)
+ | _, [Newline] ->
+ NL::r
+
+ (* named html entity *)
+ | _, Ampersand::((Word w::((Semicolon|Semicolons _) as s)::tl) as tl2) ->
+ if StringSet.mem w htmlcodes_set then
+ begin match s with
+ | Semicolon ->
+ main_impl_rev ~html (Raw("&"^w^";")::r) [s] tl
+ | Semicolons 0 ->
+ main_impl_rev ~html (Raw("&"^w^";")::r) [s] (Semicolon::tl)
+ | Semicolons n ->
+ main_impl_rev ~html (Raw("&"^w^";")::r) [s] (Semicolons(n-1)::tl)
+ | _ -> assert false
+ end
+ else
+ main_impl_rev ~html (Raw("&")::r) [] tl2
+
+ (* digit-coded html entity *)
+ | _, Ampersand::((Hash::Number w::((Semicolon|Semicolons _) as s)::tl)
+ as tl2) ->
+ if String.length w <= 4 then
+ begin match s with
+ | Semicolon ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] tl
+ | Semicolons 0 ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] (Semicolon::tl)
+ | Semicolons n ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] (Semicolons(n-1)::tl)
+ | _ -> assert false
+ end
+ else
+ main_impl_rev ~html (Raw("&")::r) [] tl2
+
+ (* maybe hex digit-coded html entity *)
+ | _, Ampersand::((Hash::Word w::((Semicolon|Semicolons _) as s)::tl)
+ as tl2) when is_hex w ->
+ if String.length w <= 4 then
+ begin match s with
+ | Semicolon ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] tl
+ | Semicolons 0 ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] (Semicolon::tl)
+ | Semicolons n ->
+ main_impl_rev ~html (Raw("&#"^w^";")::r) [s] (Semicolons(n-1)::tl)
+ | _ -> assert false
+ end
+ else
+ main_impl_rev ~html (Raw("&")::r) [] tl2
+
+
+ (* Ampersand *)
+ | _, Ampersand::tl ->
+ main_impl_rev ~html (Raw("&")::r) [Ampersand] tl
+
+ (* 2 Ampersands *)
+ | _, Ampersands(0)::tl ->
+ main_impl_rev ~html (Raw("&")::r) [] (Ampersand::tl)
+
+ (* Several Ampersands (more than 2) *)
+ | _, Ampersands(n)::tl ->
+ main_impl_rev ~html (Raw("&")::r) [] (Ampersands(n-1)::tl)
+
+ (* backquotes *)
+ | _, (Backquote|Backquotes _ as t)::tl ->
+ begin match bcode ~default_lang r previous lexemes with
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ end
+
+ (* HTML *)
+ (*
and
with or without space(s) *)
+ | _, (Lessthan::Word("br"|"hr" as w)::Slash
+ ::(Greaterthan|Greaterthans _ as g)::tl)
+ | _, (Lessthan::Word("br"|"hr" as w)::(Space|Spaces _)::Slash
+ ::(Greaterthan|Greaterthans _ as g)::tl) ->
+ begin match g with
+ | Greaterthans 0 ->
+ main_impl_rev ~html (Raw("<"^w^" />")::r) [Greaterthan] (Greaterthan::tl)
+ | Greaterthans n ->
+ main_impl_rev ~html (Raw("<"^w^" />")::r) [Greaterthan]
+ (Greaterthans(n-1)::tl)
+ | _ ->
+ main_impl_rev ~html (Raw("<"^w^" />")::r) [Greaterthan] tl
+ end
+
+ (* awaited orphan html closing tag *)
+ | _, Lessthan::Slash::Word(w)::(Greaterthan|Greaterthans _ as g)::tl
+ when !mediatypetextomd <> [] ->
+ raise (Orphan_closing(w,
+ lexemes,
+ (match g with
+ | Greaterthans 0 -> Greaterthan::tl
+ | Greaterthans n -> Greaterthans(n-1)::tl
+ | _ -> tl)))
+
+ (* block html *)
+ | ([] | [Newline|Newlines _|Tag("HTMLBLOCK", _)]),
+ (Lessthan as t)
+ ::((Word(tagnametop) as w)
+ ::((Space|Spaces _|Greaterthan|Greaterthans _)
+ ::_ as html_stuff) as tlx) ->
+ if StringSet.mem tagnametop inline_htmltags_set then
+ main_impl_rev ~html r [Word ""] lexemes
+ else if not (blind_html || StringSet.mem tagnametop htmltags_set) then
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tlx
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ else
+ let read_html() =
+ let module T = struct
+ type t =
+ | Awaiting of string
+ | Open of string
+ type interm =
+ | HTML of string * (string * string option) list * interm list
+ | FTOKENS of L.t
+ | RTOKENS of L.t
+ | MD of Omd_representation.t
+ let rec md_of_interm_list html l =
+ let md_of_interm_list ?(html=html) l =
+ md_of_interm_list html l
+ in
+ match l with
+ | [] -> []
+ | HTML(t, a, c)::tl ->
+ (
+ let f_a = filter_text_omd_rev a in
+ if f_a != a then
+ Html_block
+ (t,
+ f_a,
+ make_paragraphs
+ (md_of_interm_list ~html:false (List.rev c)))
+ :: md_of_interm_list tl
+ else
+ Html_block
+ (t, f_a, md_of_interm_list ~html:true (List.rev c))
+ :: md_of_interm_list tl
+ )
+ | MD md::tl ->
+ md@md_of_interm_list tl
+ | RTOKENS t1::FTOKENS t2::tl ->
+ md_of_interm_list (FTOKENS(List.rev_append t1 t2)::tl)
+ | RTOKENS t1::RTOKENS t2::tl ->
+ md_of_interm_list
+ (FTOKENS(List.rev_append t1 (List.rev t2))::tl)
+ | FTOKENS t1::FTOKENS t2::tl ->
+ md_of_interm_list (FTOKENS(t1@t2)::tl)
+ | FTOKENS t :: tl ->
+ if html then
+ Raw(L.string_of_tokens t) :: md_of_interm_list tl
+ else
+ main_loop ~html [] [Word ""] t
+ @ md_of_interm_list tl
+ | RTOKENS t :: tl ->
+ md_of_interm_list (FTOKENS(List.rev t) :: tl)
+ let md_of_interm_list l = md_of_interm_list true l
+ let string_of_tagstatus tagstatus =
+ let b = Buffer.create 64 in
+ List.iter (function
+ | Open t -> bprintf b "{B/Open %s}" t
+ | Awaiting t -> bprintf b "{B/Awaiting %s}" t
+ ) tagstatus;
+ Buffer.contents b
+ end in
+ let add_token_to_body x body =
+ match body with
+ | T.RTOKENS r :: body -> T.RTOKENS(x::r)::body
+ | _ -> T.RTOKENS[x] :: body
+ in
+ let rec loop (body:T.interm list) attrs tagstatus tokens =
+ if debug then
+ eprintf "(OMD) 3333 BHTML loop body=%S tagstatus=%S %S\n%!"
+ (Omd_backend.sexpr_of_md(T.md_of_interm_list body))
+ (T.string_of_tagstatus tagstatus)
+ (L.destring_of_tokens tokens);
+ match tokens with
+ | [] ->
+ begin
+ match tagstatus with
+ | [] -> Some(body, tokens)
+ | T.Open t :: _ when StringSet.mem t html_void_elements ->
+ Some(body, tokens)
+ | _ ->
+ if debug then
+ eprintf "(OMD) 3401 BHTML Not enough to read\n%!";
+ None
+ end
+ | Lessthans n::tokens ->
+ begin match tagstatus with
+ | T.Awaiting _ :: _ -> None
+ | _ ->
+ if debug then eprintf "(OMD) 3408 BHTML loop\n%!";
+ loop
+ (add_token_to_body
+ (if n = 0 then Lessthan else Lessthans(n-1))
+ body)
+ attrs tagstatus (Lessthan::tokens)
+ end
+ (* self-closing tags *)
+ | Slash::Greaterthan::tokens ->
+ begin match tagstatus with
+ | T.Awaiting(tagname) :: tagstatus
+ when StringSet.mem tagname html_void_elements ->
+ loop [T.HTML(tagname, attrs, [])] [] tagstatus tokens
+ | _ ->
+ if debug then eprintf "(OMD) 3419 BHTML loop\n%!";
+ loop
+ (add_token_to_body
+ Slash
+ (add_token_to_body
+ Greaterthan
+ body))
+ attrs tagstatus tokens
+ end
+ (* closing the tag opener *)
+ | Lessthan::Slash::(Word(tagname) as w)
+ ::(Greaterthan|Greaterthans _ as g)::tokens ->
+ begin match tagstatus with
+ | T.Open t :: _ when t = tagname ->
+ if debug then
+ eprintf "(OMD) 3375 BHTML properly closing %S\n%!" t;
+ Some(body,
+ (match g with
+ | Greaterthans 0 -> Greaterthan :: tokens
+ | Greaterthans n -> Greaterthans(n-1) :: tokens
+ | _ -> tokens))
+ | T.Open t :: _ ->
+ if debug then
+ eprintf "(OMD) 3379 BHTML wrongly closing %S with %S 1\n%!"
+ t tagname;
+ loop (T.RTOKENS[g;w;Slash;Lessthan]::body)
+ [] tagstatus tokens
+ | T.Awaiting t :: _ ->
+ if debug then
+ eprintf "(OMD) 3383 BHTML wrongly closing %S with %S 2\n%!"
+ t tagname;
+ if !mediatypetextomd <> [] then
+ raise
+ (Orphan_closing(t,
+ lexemes,
+ (match g with
+ | Greaterthans 0 ->
+ Greaterthan::tokens
+ | Greaterthans n ->
+ Greaterthans(n-1)::tokens
+ | _ -> tokens)))
+ else
+ None
+ | [] ->
+ if debug then
+ eprintf "(OMD) BHTML wrongly closing %S 3\n%!" tagname;
+ None
+ end
+ (* tag *)
+ | Lessthan::(Word(tagname) as word)::tokens
+ when
+ blind_html
+ || StringSet.mem tagname htmltags_set
+ ->
+ if debug then
+ eprintf "(OMD) 3489 BHTML tagname && StringSet.mem t html_void_elements ->
+ None
+ | T.Awaiting _ :: _ -> None
+ | _ ->
+ if attrs <> [] then
+ begin
+ if debug then
+ eprintf "(OMD) 3496 BHTML tag %S but attrs <> []\n%!"
+ tagname;
+ None
+ end
+ else
+ begin
+ if debug then
+ eprintf "(OMD) 3421 BHTML tag %S, tagstatus=%S, \
+ attrs=[], tokens=%S\n%!"
+ tagname (T.string_of_tagstatus tagstatus)
+ (L.destring_of_tokens tokens);
+ match
+ loop [] [] (T.Awaiting tagname::tagstatus) tokens
+ with
+ | None ->
+ if debug then eprintf "(OMD) 3489 BHTML loop\n%!";
+ loop
+ (add_token_to_body
+ word
+ (add_token_to_body
+ Lessthan
+ body))
+ attrs tagstatus tokens
+ | Some(b, tokens) ->
+ if debug then begin
+ eprintf "(OMD) 3433 BHTML tagstatus=%S tokens=%S\n%!"
+ (T.string_of_tagstatus tagstatus)
+ (L.string_of_tokens tokens)
+ end;
+ Some(b@body, tokens)
+ end
+ end
+ (* end of opening tag *)
+ | Greaterthan::tokens ->
+ begin match tagstatus with
+ | T.Awaiting t :: tagstatus ->
+ if List.mem ("media:type", Some "text/omd") attrs then
+ (
+ mediatypetextomd := t :: !mediatypetextomd;
+ try
+ ignore(main_impl_rev ~html [] [] tokens);
+ if debug then
+ eprintf "(OMD) 3524 BHTML closing tag not found \
+ in %S\n%!" (L.destring_of_tokens tokens);
+ warn
+ (sprintf
+ "Closing tag `%s' not found for text/omd zone."
+ t);
+ mediatypetextomd := List.tl !mediatypetextomd;
+ None
+ with Orphan_closing(tagname, delimiter, after) ->
+ let before =
+ let rec f r = function
+ | Lessthans n as e :: tl ->
+ begin match delimiter with
+ | Lessthan::_ ->
+ if Lessthan::tl = delimiter then
+ List.rev
+ (if n = 0 then
+ Lessthan::r
+ else
+ Lessthans(n-1)::r)
+ else
+ f (e::r) tl
+ | _ ->
+ if tl == delimiter || tl = delimiter then
+ List.rev r
+ else
+ f (e::r) tl
+ end
+ | e::tl as l ->
+ if l == delimiter || l = delimiter then
+ List.rev r
+ else if tl == delimiter || tl = delimiter then
+ List.rev (e::r)
+ else
+ f (e::r) tl
+ | [] -> List.rev r
+ in
+ f [] tokens
+ in
+ if debug then
+ eprintf "(OMD) 3552 BHTML tokens=%s delimiter=%s \
+ after=%s before=%s (tagname=t)=%b\n%!"
+ (L.destring_of_tokens tokens)
+ (L.destring_of_tokens delimiter)
+ (L.destring_of_tokens after)
+ (L.destring_of_tokens before)
+ (tagname = t);
+ (match !mediatypetextomd with
+ | _ :: tl -> mediatypetextomd := tl
+ | [] -> assert false);
+ if tagname = t then
+ loop
+ [T.HTML
+ (t,
+ attrs,
+ [T.MD
+ (main_impl ~html [] []
+ (tag_setext main_loop before))])]
+ []
+ tagstatus
+ after
+ else
+ None
+ )
+ else
+ begin
+ if debug then eprintf "(OMD) 3571 BHTML loop\n%!";
+ match loop body [] (T.Open t::tagstatus) tokens with
+ | None ->
+ if debug then
+ eprintf "(OMD) 3519 BHTML \
+ Couldn't find an closing tag for %S\n%!"
+ t;
+ None
+ | Some(body, l) ->
+ if debug then
+ eprintf "(OMD) 3498 BHTML Found a closing tag %s\n%!" t;
+ match tagstatus with
+ | _ :: _ ->
+ loop [T.HTML(t, attrs, body)] [] tagstatus l
+ | [] ->
+ Some([T.HTML(t, attrs, body)], l)
+ end
+ | T.Open _t :: _ ->
+ if debug then
+ eprintf
+ "(OMD) 3591 BHTML Some `>` isn't for an opening tag\n%!";
+ loop (add_token_to_body Greaterthan body)
+ attrs tagstatus tokens
+ | [] ->
+ if debug then
+ eprintf "(OMD) 3542 BHTML tagstatus=[]\n%!";
+ None
+ end
+
+ (* maybe attribute *)
+ | (Colon|Colons _|Underscore|Underscores _|Word _ as t)::tokens
+ | (Space|Spaces _)
+ ::(Colon|Colons _|Underscore|Underscores _|Word _ as t)
+ ::tokens
+ when (match tagstatus with
+ | T.Awaiting _ :: _ -> true
+ | _ -> false) ->
+ begin
+ let module Attribute_value = struct
+ type t = Empty of name | Named of name | Void
+ and name = string
+ end in
+ let open Attribute_value in
+ let rec extract_attribute accu = function
+ | (Space | Spaces _ | Newline) :: tokens->
+ Empty(L.string_of_tokens(List.rev accu)), tokens
+ | (Greaterthan|Greaterthans _) :: _ as tokens->
+ Empty(L.string_of_tokens(List.rev accu)), tokens
+ | Equal :: tokens ->
+ Named(L.string_of_tokens(List.rev accu)), tokens
+ | Colon | Colons _ | Underscore | Underscores _ | Word _
+ | Number _ | Minus | Minuss _ | Dot | Dots _ as t :: tokens ->
+ extract_attribute (t::accu) tokens
+ | tokens -> Void, tokens
+ in
+ match extract_attribute [t] tokens with
+ | Empty attributename, tokens ->
+ (* attribute with no explicit value *)
+ if debug then eprintf "(OMD) 3628 BHTML loop\n%!";
+ loop body ((attributename, None)::attrs) tagstatus tokens
+ | Named attributename, tokens ->
+ begin match tokens with
+ | Quotes 0 :: tokens ->
+ if debug then
+ eprintf "(OMD) 3661 BHTML empty attribute 1 %S\n%!"
+ (L.string_of_tokens tokens);
+ loop body ((attributename, Some "")::attrs)
+ tagstatus tokens
+ | Quote :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) 3668 BHTML non empty attribute 1 %S\n%!"
+ (L.string_of_tokens tokens);
+ match
+ fsplit
+ ~excl:(function
+ | Quotes _ :: _ -> true
+ | _ -> false)
+ ~f:(function
+ | Quote::tl -> Split([], tl)
+ | _ -> Continue)
+ tokens
+ with
+ | None -> None
+ | Some(at_val, tokens) ->
+ if debug then eprintf "(OMD) 3654 BHTML loop\n%!";
+ loop body ((attributename,
+ Some(L.string_of_tokens at_val))
+ ::attrs) tagstatus tokens
+ end
+ | Doublequotes 0 :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) 3690 BHTML empty attribute 2 %S\n%!"
+ (L.string_of_tokens tokens);
+ loop body ((attributename, Some "")::attrs)
+ tagstatus tokens
+ end
+ | Doublequote :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) 3698 BHTML non empty attribute 2 %S\n%!"
+ (L.string_of_tokens tokens);
+ match fsplit
+ ~excl:(function
+ | Doublequotes _ :: _ -> true
+ | _ -> false)
+ ~f:(function
+ | Doublequote::tl -> Split([], tl)
+ | _ -> Continue)
+ tokens
+ with
+ | None -> None
+ | Some(at_val, tokens) ->
+ if debug then
+ eprintf "(OMD) 3622 BHTML %s=%S %s\n%!"
+ attributename
+ (L.string_of_tokens at_val)
+ (L.destring_of_tokens tokens);
+ loop body ((attributename,
+ Some(L.string_of_tokens at_val))
+ ::attrs) tagstatus tokens
+ end
+ | _ -> None
+ end
+ | Void, _ -> None
+ end
+
+ | x::tokens as dgts
+ when (match tagstatus with T.Open _ :: _ -> true | _ -> false) ->
+ begin
+ if debug then
+ eprintf "(OMD) 3620 BHTML general %S\n%!"
+ (L.string_of_tokens dgts);
+ loop (add_token_to_body x body) attrs tagstatus tokens
+ end
+ | (Newline | Space | Spaces _) :: tokens
+ when
+ (match tagstatus with T.Awaiting _ :: _ -> true | _ -> false) ->
+ begin
+ if debug then eprintf "(OMD) 3737 BHTML spaces\n%!";
+ loop body attrs tagstatus tokens
+ end
+ | (Newlines _ as x) :: tokens
+ when
+ (match tagstatus with T.Awaiting _ :: _ -> true | _ -> false) ->
+ begin
+ if debug then eprintf "(OMD) 3827 BHTML newlines\n%!";
+ warn "there are empty lines in what may be an HTML block";
+ loop (add_token_to_body x body) attrs tagstatus tokens
+ end
+ | _ ->
+ if debug then
+ eprintf "(OMD) 3742 BHTML fallback with \
+ tokens=%s and tagstatus=%s\n%!"
+ (L.destring_of_tokens tokens)
+ (match tagstatus with
+ | [] -> "None"
+ | T.Awaiting _ :: _ -> "Awaiting"
+ | T.Open _ :: _ -> "Open (can't be)");
+ (match tagstatus with
+ | [] -> Some(body, tokens)
+ | T.Awaiting tag :: _ ->
+ warn (sprintf "expected to read an open HTML tag (%s), \
+ but found nothing" tag);
+ None
+ | T.Open tag :: _ ->
+ warn (sprintf "expected to find the closing HTML tag for %s, \
+ but found nothing" tag);
+ None)
+ in
+ if debug then eprintf "(OMD) 3408 BHTML loop\n%!";
+ match loop [] [] [] lexemes with
+ | Some(h, rest) ->
+ Some(T.md_of_interm_list h, rest)
+ | None -> None
+ in
+ begin match read_html() with
+ | Some(h, rest) ->
+ main_impl_rev ~html (h@r) [Tag("HTMLBLOCK", empty_extension)] rest
+ | None ->
+ let text = L.string_of_token t in
+ main_impl_rev ~html (Text(text ^ tagnametop)::r) [w] html_stuff
+ end
+ (* / end of block HTML. *)
+
+
+ (* inline HTML *)
+ | _,
+ (Lessthan as t)
+ ::((Word(tagnametop) as w)
+ ::((Space|Spaces _|Greaterthan|Greaterthans _)
+ ::_ as html_stuff) as tlx) ->
+ if (strict_html && not(StringSet.mem tagnametop inline_htmltags_set))
+ || not(blind_html || StringSet.mem tagnametop htmltags_set)
+ then
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tlx
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ else
+ let read_html() =
+ let module T = struct
+ type t =
+ | Awaiting of string
+ | Open of string
+ type interm =
+ | HTML of string * (string * string option) list * interm list
+ | TOKENS of L.t
+ | MD of Omd_representation.t
+ let rec md_of_interm_list = function
+ | [] -> []
+ | HTML(t, a, c)::tl ->
+ Html(t, a, md_of_interm_list(List.rev c))::md_of_interm_list tl
+ | MD md::tl -> md @ md_of_interm_list tl
+ | TOKENS t1::TOKENS t2::tl ->
+ md_of_interm_list (TOKENS(t1@t2)::tl)
+ | TOKENS t :: tl ->
+ main_impl ~html [] [Word ""] (t)
+ @ md_of_interm_list tl
+ let string_of_tagstatus tagstatus =
+ let b = Buffer.create 64 in
+ List.iter (function
+ | Open t -> bprintf b "{I/Open %s}" t
+ | Awaiting t -> bprintf b "{I/Awaiting %s}" t
+ ) tagstatus;
+ Buffer.contents b
+ end in
+ let add_token_to_body x body =
+ T.TOKENS[x]::body
+ in
+ let rec loop (body:T.interm list) attrs tagstatus tokens =
+ if debug then
+ eprintf "(OMD) 3718 loop tagstatus=(%s) %s\n%!"
+ (* eprintf "(OMD) 3718 loop tagstatus=(%s) body=(%s) %s\n%!" *)
+ (T.string_of_tagstatus tagstatus)
+ (* (Omd_backend.sexpr_of_md(T.md_of_interm_list body)) *)
+ (L.destring_of_tokens tokens);
+ match tokens with
+ | [] ->
+ begin
+ match tagstatus with
+ | [] -> Some(body, tokens)
+ | T.Open(t)::_ when StringSet.mem t html_void_elements ->
+ Some(body, tokens)
+ | _ ->
+ if debug then
+ eprintf "(OMD) Not enough to read for inline HTML\n%!";
+ None
+ end
+ | Lessthans n::tokens ->
+ begin match tagstatus with
+ | T.Awaiting _ :: _ -> None
+ | _ ->
+ loop
+ (add_token_to_body
+ (if n = 0 then Lessthan else Lessthans(n-1))
+ body)
+ attrs tagstatus (Lessthan::tokens)
+ end
+ (* self-closing tags *)
+ | Slash::Greaterthan::tokens ->
+ begin match tagstatus with
+ | T.Awaiting(tagname)::tagstatus
+ when StringSet.mem tagname html_void_elements ->
+ loop [T.HTML(tagname, attrs, [])] [] tagstatus tokens
+ | _ ->
+ loop (T.TOKENS[Greaterthan;Slash]::body)
+ attrs tagstatus tokens
+ end
+ (* multiple newlines are not to be seen in inline HTML *)
+ | Newlines _ :: _ ->
+ if debug then eprintf "(OMD) Multiple lines in inline HTML\n%!";
+ (match tagstatus with
+ | [] -> Some(body, tokens)
+ | _ -> warn "multiple newlines in inline HTML"; None)
+ (* maybe code *)
+ | (Backquote | Backquotes _ as b)::tl ->
+ begin match tagstatus with
+ | T.Awaiting _ :: _ ->
+ if debug then
+ eprintf "(OMD) maybe code in inline HTML: no code\n%!";
+ None
+ | [] ->
+ if debug then
+ eprintf "(OMD) maybe code in inline HTML: none\n%!";
+ None
+ | T.Open _ :: _ ->
+ if debug then
+ eprintf "(OMD) maybe code in inline HTML: let's try\n%!";
+ begin match bcode [] [Space] tokens with
+ | Some (((Code _::_) as c), _p, l) ->
+ if debug then
+ eprintf "(OMD) maybe code in inline HTML: \
+ confirmed\n%!";
+ loop (T.MD c::body) [] tagstatus l
+ | _ ->
+ if debug then
+ eprintf "(OMD) maybe code in inline HTML: failed\n%!";
+ loop (T.TOKENS[b]::body) [] tagstatus tl
+ end
+ end
+ (* closing the tag *)
+ | Lessthan::Slash::(Word(tagname) as w)
+ ::(Greaterthan|Greaterthans _ as g)::tokens ->
+ begin match tagstatus with
+ | T.Open t :: _ when t = tagname ->
+ if debug then
+ eprintf "(OMD) 4136 properly closing %S tokens=%s\n%!"
+ t (L.string_of_tokens tokens);
+ Some(body,
+ (match g with
+ | Greaterthans 0 -> Greaterthan :: tokens
+ | Greaterthans n -> Greaterthans(n-1) :: tokens
+ | _ -> tokens))
+ | T.Open t :: _ ->
+ if debug then
+ eprintf "(OMD) 4144 \
+ wrongly closing %S with %S 1\n%!" t tagname;
+ loop (T.TOKENS[g;w;Slash;Lessthan]::body) [] tagstatus tokens
+ | T.Awaiting t :: _ ->
+ if debug then
+ eprintf "(OMD) 4149 \
+ wrongly closing %S with %S 2\n%!" t tagname;
+ None
+ | [] ->
+ if debug then
+ eprintf "(OMD) 4154 \
+ wrongly closing nothing with %S 3\n%!"
+ tagname;
+ None
+ end
+ (* tag *)
+ | Lessthan::(Word(tagname) as word)::tokens
+ when
+ blind_html
+ || (strict_html && StringSet.mem tagname inline_htmltags_set)
+ || (not strict_html && StringSet.mem tagname htmltags_set)
+ ->
+ if debug then eprintf "(OMD) <%s...\n%!" tagname;
+ begin match tagstatus with
+ | T.Open(t) :: _
+ when t <> tagname && StringSet.mem t html_void_elements ->
+ None
+ | T.Awaiting _ :: _ -> None
+ | _ ->
+ begin
+ if debug then
+ eprintf "(OMD) 3796 tag %s, attrs=[]\n%!" tagname;
+ match loop [] [] (T.Awaiting tagname::tagstatus) tokens
+ with
+ | None ->
+ loop (T.TOKENS[word;Lessthan]::body)
+ attrs tagstatus tokens
+ | Some(b,tokens) ->
+ Some(b@body, tokens)
+ end
+ end
+ (* end of opening tag *)
+ | Greaterthan::tokens ->
+ if debug then
+ eprintf "(OMD) 4185 end of opening tag tokens=%s \
+ tagstatus=%s\n%!"
+ (L.string_of_tokens tokens)
+ (T.string_of_tagstatus tagstatus);
+ begin match tagstatus with
+ | T.Awaiting t :: tagstatus as ts ->
+ begin match loop body [] (T.Open t::tagstatus) tokens with
+ | None ->
+ if debug then
+ eprintf "(OMD) 4186 \
+ Couldn't find an closing tag for %S\n%!"
+ t;
+ None
+ | Some(b, tokens) ->
+ if debug then
+ eprintf
+ "(OMD) 4192 Found a closing tag %s ts=%s \
+ tokens=%s\n%!"
+ t
+ (T.string_of_tagstatus ts)
+ (L.string_of_tokens tokens);
+ match tagstatus with
+ | [] ->
+ Some(T.HTML(t, attrs, b)::body, tokens)
+ | _ ->
+ (* Note: we don't care about the value of
+ [attrs] here because in we have a
+ [tagstatus] matches [T.Open _ :: _] and
+ there's a corresponding filter that will
+ take care of attrs that will take care of
+ it. *)
+ loop (T.HTML(t, attrs, b)::body) [] tagstatus tokens
+ end
+ | T.Open _t :: _ ->
+ if debug then
+ eprintf
+ "(OMD) Turns out an `>` isn't for an opening tag\n%!";
+ loop (T.TOKENS[Greaterthan]::body) attrs tagstatus tokens
+ | [] ->
+ if debug then
+ eprintf "(OMD) 4202 tagstatus=[]\n%!";
+ None
+ end
+
+ (* maybe attribute *)
+ | (Colon|Colons _|Underscore|Underscores _|Word _ as t)::tokens
+ | (Space|Spaces _)
+ ::(Colon|Colons _|Underscore|Underscores _|Word _ as t)
+ ::tokens
+ when (match tagstatus with
+ | T.Awaiting _ :: _ -> true
+ | _ -> false) ->
+ begin
+ let module Attribute_value = struct
+ type t = Empty of name | Named of name | Void
+ and name = string
+ end in
+ let open Attribute_value in
+ let rec extract_attribute accu = function
+ | (Space | Spaces _ | Newline) :: tokens->
+ Empty(L.string_of_tokens(List.rev accu)), tokens
+ | (Greaterthan|Greaterthans _) :: _ as tokens->
+ Empty(L.string_of_tokens(List.rev accu)), tokens
+ | Equal :: tokens ->
+ Named(L.string_of_tokens(List.rev accu)), tokens
+ | Colon | Colons _ | Underscore | Underscores _ | Word _
+ | Number _ | Minus | Minuss _ | Dot | Dots _ as t :: tokens ->
+ extract_attribute (t::accu) tokens
+ | tokens -> Void, tokens
+ in
+ match extract_attribute [t] tokens with
+ | Empty attributename, tokens ->
+ (* attribute with no explicit value *)
+ loop body ((attributename, None)::attrs) tagstatus tokens
+ | Named attributename, tokens ->
+ begin match tokens with
+ | Quotes 0 :: tokens ->
+ if debug then
+ eprintf "(OMD) (IHTML) empty attribute 1 %S\n%!"
+ (L.string_of_tokens tokens);
+ loop body ((attributename, Some "")::attrs) tagstatus tokens
+ | Quote :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) (IHTML) non empty attribute 1 %S\n%!"
+ (L.string_of_tokens tokens);
+ match
+ fsplit
+ ~excl:(function
+ | Quotes _ :: _ -> true
+ | _ -> false)
+ ~f:(function
+ | Quote::tl -> Split([], tl)
+ | _ -> Continue)
+ tokens
+ with
+ | None -> None
+ | Some(at_val, tokens) ->
+ loop body ((attributename,
+ Some(L.string_of_tokens at_val))
+ ::attrs) tagstatus tokens
+ end
+ | Doublequotes 0 :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) (IHTML) empty attribute 2 %S\n%!"
+ (L.string_of_tokens tokens);
+ loop body ((attributename, Some "")::attrs) tagstatus tokens
+ end
+ | Doublequote :: tokens ->
+ begin
+ if debug then
+ eprintf "(OMD) (IHTML) non empty attribute 2 %S\n%!"
+ (L.string_of_tokens tokens);
+ match fsplit
+ ~excl:(function
+ | Doublequotes _ :: _ -> true
+ | _ -> false)
+ ~f:(function
+ | Doublequote::tl -> Split([], tl)
+ | _ -> Continue)
+ tokens
+ with
+ | None -> None
+ | Some(at_val, tokens) ->
+ if debug then
+ eprintf "(OMD) (3957) %s=%S %s\n%!" attributename
+ (L.string_of_tokens at_val)
+ (L.destring_of_tokens tokens);
+ loop body ((attributename,
+ Some(L.string_of_tokens at_val))
+ ::attrs) tagstatus tokens
+ end
+ | _ -> None
+ end
+ | Void, _ -> None
+ end
+
+ | Backslash::x::tokens
+ when (match tagstatus with T.Open _ :: _ -> true | _ -> false) ->
+ loop (T.TOKENS[Backslash;x]::body) attrs tagstatus tokens
+ | Backslashs(n)::x::tokens
+ when (match tagstatus with T.Open _ :: _ -> true | _ -> false)
+ && n mod 2 = 1 ->
+ loop (T.TOKENS[Backslashs(n);x]::body) attrs tagstatus tokens
+
+ | x::tokens
+ when (match tagstatus with T.Open _ :: _ -> true | _ -> false) ->
+ begin
+ if debug then
+ eprintf "(OMD) (4161) general %S\n%!"
+ (L.string_of_tokens (x::tokens));
+ loop (T.TOKENS[x]::body) attrs tagstatus tokens
+ end
+ | (Newline | Space | Spaces _) :: tokens
+ when
+ (match tagstatus with T.Awaiting _ :: _ -> true | _ -> false) ->
+ begin
+ if debug then eprintf "(OMD) (4289) spaces\n%!";
+ loop body attrs tagstatus tokens
+ end
+ | _ ->
+ if debug then
+ eprintf "(OMD) (4294) \
+ fallback with tokens=%s and tagstatus=%s\n%!"
+ (L.destring_of_tokens tokens)
+ (T.string_of_tagstatus tagstatus);
+ (match tagstatus with
+ | [] -> Some(body, tokens)
+ | T.Awaiting tag :: _ ->
+ warn (sprintf "expected to read an open HTML tag (%s), \
+ but found nothing" tag);
+ None
+ | T.Open tag :: _ ->
+ warn (sprintf "expected to find the closing HTML tag for %s, \
+ but found nothing" tag);
+ None)
+ in match loop [] [] [] lexemes with
+ | Some(html, rest) ->
+ Some(T.md_of_interm_list html, rest)
+ | None -> None
+ in
+ begin match read_html() with
+ | Some(h, rest) ->
+ main_impl_rev ~html (h@r) [Greaterthan] rest
+ | None ->
+ let text = L.string_of_token t in
+ main_impl_rev ~html (Text(text ^ tagnametop)::r) [w] html_stuff
+ end
+ (* / end of inline HTML. *)
+
+ (* < : emails *)
+ | _, (Lessthan as t)::tl ->
+ begin match maybe_autoemail r previous lexemes with
+ | Some(r,p,l) -> main_impl_rev ~html r p l
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ end
+
+ (* line breaks *)
+ | _, Newline::tl ->
+ main_impl_rev ~html (NL::r) [Newline] tl
+ | _, Newlines _::tl ->
+ main_impl_rev ~html (NL::NL::r) [Newline] tl
+
+ (* [ *)
+ | _, (Obracket as t)::tl ->
+ begin match maybe_link main_loop r previous tl with
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ | None ->
+ match maybe_reference main_loop rc r previous tl with
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ | None ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ end
+
+ (* img *)
+ | _, (Exclamation|Exclamations _ as t)
+ ::Obracket::Cbracket::Oparenthesis::tl ->
+ (* image insertion with no "alt" *)
+ (*  *)
+ (try
+ begin
+ let b, tl = read_until_cparenth ~bq:true ~no_nl:false tl in
+ (* new lines there are allowed *)
+ let r (* updated result *) = match t with
+ | Exclamations 0 -> Text "!" :: r
+ | Exclamations n -> Text(String.make (n+1) '!') :: r
+ | _ -> r in
+ match
+ try Some(read_until_space ~bq:false ~no_nl:true b)
+ with Premature_ending -> None
+ with
+ | Some(url, tls) ->
+ let title, _should_be_empty_list =
+ read_until_dq ~bq:true (snd (read_until_dq ~bq:true tls)) in
+ let url = L.string_of_tokens url in
+ let title = L.string_of_tokens title in
+ main_impl_rev ~html (Img("", url, title) :: r) [Cparenthesis] tl
+ | None ->
+ let url = L.string_of_tokens b in
+ main_impl_rev ~html (Img("", url, "") :: r) [Cparenthesis] tl
+ end
+ with
+ | NL_exception ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+
+ (* img ref *)
+ | _, (Exclamation as t)
+ ::Obracket::Cbracket::Obracket::tl ->
+ (* ref image insertion with no "alt" *)
+ (* ![][ref] *)
+ (try
+ let id, tl = read_until_cbracket ~bq:true ~no_nl:true tl in
+ let fallback = extract_fallback main_loop tl lexemes in
+ let id = L.string_of_tokens id in
+ main_impl_rev ~html (Img_ref(rc, id, "", fallback) :: r) [Cbracket] tl
+ with NL_exception ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+
+
+ (* img *)
+ | _, (Exclamation|Exclamations _ as t)::Obracket::tl ->
+ (* image insertion with "alt" *)
+ (*  *)
+ (try
+ match read_until_cbracket ~bq:true tl with
+ | alt, Oparenthesis::ntl ->
+ (try
+ let alt = L.string_of_tokens alt in
+ let path_title, rest =
+ read_until_cparenth ~bq:true ~no_nl:false ntl in
+ let path, title =
+ try
+ read_until_space ~bq:true ~no_nl:true path_title
+ with Premature_ending -> path_title, [] in
+ let title, nothing =
+ if title <> [] then
+ read_until_dq ~bq:true (snd(read_until_dq ~bq:true title))
+ else [], [] in
+ if nothing <> [] then
+ raise NL_exception; (* caught right below *)
+ let r =
+ match t with
+ | Exclamations 0 -> Text "!" :: r
+ | Exclamations n -> Text(String.make (n+1) '!') :: r
+ | _ -> r in
+ let path = L.string_of_tokens path in
+ let title = L.string_of_tokens title in
+ main_impl_rev ~html (Img(alt, path, title) :: r) [Cparenthesis] rest
+ with
+ | NL_exception
+ (* if NL_exception was raised, then fall back to "text" *)
+ | Premature_ending ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+ )
+ | alt, Obracket::Word(id)::Cbracket::ntl
+ | alt, Obracket::(Space|Spaces _)::Word(id)::Cbracket::ntl
+ | alt, Obracket::(Space|Spaces _)::Word(id)::(Space|Spaces _)
+ ::Cbracket::ntl
+ | alt, Obracket::Word(id)::(Space|Spaces _)::Cbracket::ntl ->
+ let fallback = extract_fallback main_loop ntl lexemes in
+ let alt = L.string_of_tokens alt in
+ main_impl_rev ~html (Img_ref(rc, id, alt, fallback)::r) [Cbracket] ntl
+ | alt, Obracket::((Newline|Space|Spaces _|Word _|Number _)::_
+ as ntl) ->
+ (try
+ match read_until_cbracket ~bq:true ~no_nl:false ntl with
+ | [], _rest -> raise Premature_ending
+ | id, rest ->
+ let fallback = extract_fallback main_loop rest lexemes in
+ let id = L.string_of_tokens id in
+ let alt = L.string_of_tokens alt in
+ main_impl_rev ~html (Img_ref(rc, id, alt, fallback)::r)
+ [Cbracket]
+ rest
+ with
+ | Premature_ending
+ | NL_exception ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+ | _ ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ with
+ | Premature_ending ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ )
+
+ | _,
+ (At|Bar|Caret|Cbrace|Colon|Comma|Cparenthesis|Cbracket|Dollar
+ |Dot|Doublequote|Exclamation|Equal|Minus|Obrace|Oparenthesis
+ |Percent|Plus|Question|Quote|Semicolon|Slash|Tab|Tilde
+ |Greaterthan as t)::tl
+ ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+ | _, (Number _ as t):: tl ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None -> main_impl_rev ~html (Text(L.string_of_token t)::r) [t] tl
+ | Some(r, p, l) -> main_impl_rev ~html r p l
+ end
+
+ | _, (Ats _ | Bars _ | Carets _ | Cbraces _ | Cbrackets _ | Colons _
+ | Commas _ | Cparenthesiss _ | Dollars _ | Dots _ | Doublequotes _
+ | Equals _ | Exclamations _ | Greaterthans _ | Lessthans _
+ | Minuss _ | Obraces _ | Obrackets _ | Oparenthesiss _
+ | Percents _ | Pluss _ | Questions _ | Quotes _ | Semicolons _
+ | Slashs _ | Stars _ | Tabs _ | Tildes _ | Underscores _ as tk)
+ :: tl ->
+ begin match maybe_extension extensions r previous lexemes with
+ | None ->
+ let tk0, tks = L.split_first tk in
+ let text = L.string_of_token tk0 in
+ main_impl_rev ~html (Text text :: r) [tk0] (tks :: tl)
+ | Some(r, p, l) ->
+ main_impl_rev ~html r p l
+ end
+
+
+ and main_impl ~html (r:r) (previous:p) (lexemes:l) =
+ (* if debug then eprintf "(OMD) main_impl html=%b\n%!" html; *)
+ assert_well_formed lexemes;
+ List.rev (main_loop_rev ~html r previous lexemes)
+
+ and main_loop ?(html=false) (r:r) (previous:p) (lexemes:l) =
+ main_impl ~html r previous lexemes
+
+ and main_loop_rev ?(html=false) (r:r) (previous:p) (lexemes:l) =
+ main_impl_rev ~html r previous lexemes
+
+
+ let main_parse lexemes =
+ main_loop [] [] (tag_setext main_loop lexemes)
+
+ let parse lexemes =
+ main_parse lexemes
+
+end
+
+let default_parse ?(extensions=[]) ?(default_lang="") lexemes =
+ let e = extensions and d = default_lang in
+ let module E = Default_env(Unit) in
+ let module M =
+ Make(struct
+ include E
+ let extensions = e
+ let default_lang = d
+ end)
+ in
+ M.main_parse lexemes
+
diff --git a/analysis/src/vendor/omd/omd_parser.mli b/analysis/src/vendor/omd/omd_parser.mli
new file mode 100644
index 000000000..e8174bb48
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_parser.mli
@@ -0,0 +1,379 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+(** Beware: the functions in this module may raise exceptions! If you
+ use them, you should be careful. *)
+
+
+type r = Omd_representation.t
+(** accumulator (beware, reversed tokens) *)
+
+and p = Omd_representation.tok list
+(** context information: previous elements *)
+
+and l = Omd_representation.tok list
+(** tokens to parse *)
+
+and main_loop =
+ ?html:bool ->
+ r -> (* accumulator (beware, reversed tokens) *)
+ p -> (* info: previous elements *)
+ l -> (* tokens to parse *)
+ Omd_representation.t (* final result *)
+(** most important loop, which has to be given as an argument *)
+
+
+val default_parse :
+ ?extensions:Omd_representation.extensions -> ?default_lang:string -> l
+ -> Omd_representation.t
+(** Translate tokens to Markdown representation.
+
+ @param lang language for blocks of code where it was not specified.
+ Default: [""].
+*)
+
+module type Env =
+sig
+ val rc: Omd_representation.ref_container
+ (** reference container *)
+ val extensions : Omd_representation.extensions
+ (** list of parser extensions *)
+ val default_lang : string
+ (** default language for code blocks *)
+ val gh_uemph_or_bold_style : bool
+ (** flag: bold/emph using using underscores is by default
+ github-style, which means that underscores inside words are
+ left as underscore, rather than special characters, because
+ it's more convenient. However it is also less expressive
+ because then you can't bold/emph a part of a word. You might
+ want to set this flag to false. *)
+ val blind_html : bool
+ (** flag: if true, will not check whether a used HTML tag actually
+ exists in HTML. *)
+ val strict_html : bool
+ (** flag: if true, will only accept known inline HTML tags in inline HTML. *)
+ val warning : bool
+ (** flag: if true, will output warnings *)
+ val warn_error : bool
+ (** flag: if true, will convert warnings to errors *)
+end
+
+module Default_env : functor (Unit: sig end) -> Env
+
+module Make : functor (Env : Env) ->
+sig
+
+ val rc: Omd_representation.ref_container
+ (** reference container *)
+ val extensions : Omd_representation.extensions
+ (** list of parser extensions *)
+ val default_lang : string
+ (** default language for code blocks *)
+ val gh_uemph_or_bold_style : bool
+ (** flag: bold/emph using using underscores is by default
+ github-style, which means that underscores inside words are
+ left as underscore, rather than special characters, because
+ it's more convenient. However it is also less expressive
+ because then you can't bold/emph a part of a word. You might
+ want to set this flag to false. *)
+ val blind_html : bool
+ (** flag: if true, will not check whether a used HTML tag actually
+ exists in HTML. *)
+ val strict_html : bool
+ (** flag: if true, will only accept known inline HTML tags in inline HTML. *)
+
+
+ val htmlcodes_set : Omd_utils.StringSet.t
+ (** set of known HTML codes *)
+
+ val inline_htmltags_set : Omd_utils.StringSet.t
+ (** set of known inline HTML tags *)
+
+ val htmltags_set : Omd_utils.StringSet.t
+ (** All known HTML tags *)
+
+ val unindent_rev :
+ int ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ (** [unindent_rev n l] returns the same couple as [unindent n l]
+ except that the first element (which is a list) is reversed.
+ This function is used for lists. *)
+
+ val unindent :
+ int ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ (** [unindent n l] returns [(unindented, rest)] where [unindented] is
+ the consecutive lines of [l] that are indented with at least [n]
+ spaces, and de-indented by [n] spaces. If [l] starts with a line
+ that is indented by less than [n] spaces, then it returns [([], l)].
+
+
+ (* This function is used for lists, so it does not require [n] *)
+ (* spaces on every single line, but only on some specific ones of them. *)
+
+ This function is used for lists and blockquotes.
+
+ *)
+
+ (* val unindent_strict_rev : *)
+ (* int -> *)
+ (* Omd_representation.tok list -> *)
+ (* Omd_representation.tok list * Omd_representation.tok list *)
+ (* (\** [unindent_strict_rev n l] returns the same couple as [unindent n l] *)
+ (* except that the first element (which is a list) is reversed. *)
+ (* This function is used for blockquotes. *\) *)
+
+ (* val unindent_strict : *)
+ (* int -> *)
+ (* Omd_representation.tok list -> *)
+ (* Omd_representation.tok list * Omd_representation.tok list *)
+ (* (\** [unindent_strict n l] returns [(unindented, rest)] where [unindented] is *)
+ (* the consecutive lines of [l] that are indented with at least [n] *)
+ (* spaces, and de-indented by [n] spaces. If [l] starts with a line *)
+ (* that is indented by less than [n] spaces, then it returns [([], l)]. *)
+ (* This function is used for blockquotes. *)
+ (* *\) *)
+
+
+
+ val is_blank : Omd_representation.tok list -> bool
+ (** [is_blank l] returns [true] if [l] only contains blanks, which are
+ spaces and newlines. *)
+
+ val semph_or_bold :
+ int ->
+ Omd_representation.tok list ->
+ (Omd_representation.tok list * Omd_representation.tok list) option
+ (** [semph_or_bold n l] returns [None] if [l] doesn't start with
+ a bold/emph phrase (marked using stars), else it returns [Some(x,y)]
+ where [x] is the emph and/or bold phrase at the beginning of [l]
+ and [y] is the rest of [l]. *)
+
+ val sm_uemph_or_bold :
+ int ->
+ Omd_representation.tok list ->
+ (Omd_representation.tok list * Omd_representation.tok list) option
+ (** [sm_uemph_or_bold n l] returns [None] if [l] doesn't start with
+ a bold/emph phrase (marked using underscores), else it returns [Some(x,y)]
+ where [x] is the emph and/or bold phrase at the beginning of [l]
+ and [y] is the rest of [l]. *)
+
+ val gh_uemph_or_bold :
+ int ->
+ Omd_representation.tok list ->
+ (Omd_representation.tok list * Omd_representation.tok list) option
+ (** [gh_uemph_or_bold n l] returns [None] if [l] doesn't start with
+ a bold/emph phrase (marked using underscores), else it returns [Some(x,y)]
+ where [x] is the emph and/or bold phrase at the beginning of [l]
+ and [y] is the rest of [l]. *)
+
+ val uemph_or_bold :
+ int ->
+ Omd_representation.tok list ->
+ (Omd_representation.tok list * Omd_representation.tok list) option
+ (** [uemph_or_bold n l] returns [None] if [l] doesn't start with a
+ bold/emph phrase (marked using underscores), else it returns
+ [Some(x,y)] where [x] is the emph and/or bold phrase at the
+ beginning of [l] and [y] is the rest of [l]. N.B. if
+ [!gh_uemph_or_bold_style] then in Github style (i.e., underscores
+ inside words are considered as underscores). *)
+
+ val eat_blank : Omd_representation.tok list -> Omd_representation.tok list
+ (** [eat_blank l] returns [l] where all blanks at the beginning of the
+ list have been removed (it stops removing as soon as it meets an element
+ that is not a blank). Blanks are spaces and newlines only. *)
+
+ val tag__maybe_h1 : main_loop -> Omd_representation.tok
+ (** [tag__maybe_h1 main_loop] is a tag that is injected everywhere that
+ might preceed a H1 title. It needs [main_loop] as argument because
+ it is used to parse the contents of the titles. *)
+
+ val tag__maybe_h2 : main_loop -> Omd_representation.tok
+ (** [tag__maybe_h2 main_loop] is the same as [tag__maybe_h1 main_loop]
+ but for H2. *)
+
+ val tag__md : Omd_representation.t -> Omd_representation.tok
+ (** [tag__md md] encapsulates [md] to make it a value of type [tok].
+ Its purpose is to inject some pre-parsed markdown (i.e., [md] of type [t])
+ in a yet-to-parse token stream of type [tok]. *)
+
+ val tag_setext :
+ main_loop -> Omd_representation.tok list -> Omd_representation.tok list
+ (** Tag used for the lines that *might* be titles using setext-style. *)
+
+
+ val hr_m : l -> l option
+ (** [hr_m l] returns [Some nl] where [nl] is the remaining of [l] if [l]
+ contains a horizontal rule "drawn" with dashes. If there's no HR, then
+ returns [None].*)
+
+ val hr_s : l -> l option
+ (** [hr_s l] is the same as [hr_m l] but for horizontal rules
+ "drawn" with stars instead. *)
+
+ exception NL_exception
+ exception Premature_ending
+
+ val read_until_gt :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_lt :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_cparenth :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_oparenth :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_dq :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_q :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_obracket :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_cbracket :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_space :
+ ?bq:bool ->
+ ?no_nl:bool ->
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ val read_until_newline :
+ Omd_representation.tok list ->
+ Omd_representation.tok list * Omd_representation.tok list
+ (** [read_until_...] are functions that read from a token list
+ and return two token lists: the first one is the tokens read
+ until a specific token is met, and the second one is the remainder.
+ The particularity of these functions is that they do consider
+ backslash-escaped characters and closing characters.
+ For instance, [read_until_gt "1 < 2 > 3 > 4"] returns
+ ["1 < 2 > 3 ", " 4"]: note that the ">" before " 4" has disappeared
+ and that [read_until_gt] takes a [tok list] (not a string) and
+ returns a couple of [tok list] (not a couple of strings), the
+ string notation is used here for concision.
+
+ Until otherwise noted, those functions do *not* consider
+ backquote-trapped sections.
+ For instance, [read_until_gt "1 < 2 > 3 `>` 4"]
+ returns ["1 < 2 > 3 `", "` 4"].
+ If you use these functions, you should make sure that they
+ do what you think they do (i.e., do look at the code).
+
+ If the expected characters are not found, the exception
+ [Premature_ending] is raised. For instance,
+ [read_until_gt "1 < > 3"] raises [Premature_ending].
+
+ If [no_nl] is [true] (default value for [no_nl] is [false])
+ and ['\n'] occurs before the splitting character,
+ then [NL_exception] is raised.
+ *)
+
+
+ val read_title : main_loop -> int -> r -> p -> l -> (r * p * l) option
+ (** [read_title main_loop n r p l] returns [Some(r,p,l)]
+ if it succeeds, [None] otherwise.
+
+ [read_title main_loop n r p l] expects to read a [n]-level
+ hash-declared title from [l], where the hashes have *already*
+ been *removed*. If [n] is not between 1 and 6 (included), then
+ it returns [None].
+
+ [main_loop] is used to parse the contents of the title.
+
+ [r] and [p] are the classical "result" and "previous" parameters.
+ *)
+
+ val maybe_extension :
+ Omd_representation.extensions ->
+ r -> p -> l -> (r * p * l) option
+ (** [maybe_extension e r p l] returns [None] if there is no extension or
+ if extensions haven't had any effect, returns [Some(nr, np, nl)] if
+ at least one extension has applied successfully. *)
+
+ val emailstyle_quoting : main_loop -> r -> p -> l -> (r * p * l) option
+ (** [emailstyle_quoting main_loop r p l] returns [Some(r,p,l)] with
+ [r] being the updated result, [p] being the last parsed token
+ and [l] being the remaining tokens to parse. If [emailstyle_quoting]
+ fails, then it returns [None], in which case its user is advise
+ to investigate why it returns [None] because there's possibly a
+ real problem. *)
+
+ val maybe_reference :
+ main_loop ->
+ Omd_representation.ref_container -> r -> p -> l -> (r * p * l) option
+ (** [maybe_reference] tries to parse a reference, a reference definition or
+ a github-style short reference (e.g., [foo] as a shortcut for [foo][]),
+ and returns [Some(r,p,l)] if it succeeds, [None] otherwise. *)
+
+ val maybe_link : main_loop -> r -> p -> l -> (r * p * l) option
+ (** [maybe_link] tries to parse a link,
+ and returns [Some(r,p,l)] if it succeeds, [None] otherwise. *)
+
+
+ val parse_list : main_loop -> r -> p -> l -> r * p * l
+ (** [parse_list main_loop r p l] parses a list from [l].
+
+ ***Important property***
+ It is considered in Omd that a sub-list is always more indented than
+ the item that contains it (so, 2 items with different indentations cannot
+ have the direct same parent).
+ *)
+
+ val make_paragraphs : Omd_representation.t -> Omd_representation.t
+ (** Since [Omd_parser.parse] doesn't build paragraphs, if you want
+ Markdown-style paragraphs, you need to apply this function to
+ the result of [Omd_parser.parse]. *)
+
+
+ val bcode :
+ ?default_lang:Omd_representation.name ->
+ r -> p -> l -> (r * p * l) option
+ (** [bcode default_lang r p l]
+ tries to parse some code that's delimited by backquotes,
+ and returns [Some(r,p,l)] if it succeeds, [None] otherwise.
+ *)
+
+ val icode :
+ ?default_lang:Omd_representation.name ->
+ r -> p -> l -> (r * p * l) option
+ (** [icode default_lang r p l]
+ tries to parse some code that's delimited by space indentation.
+ It should always return [Some(r,p,l)], if it returns [None]
+ it means that it's been misused or there's a bug.
+ *)
+
+
+ val main_loop_rev : ?html:bool -> r -> p -> l -> r
+ val main_loop : ?html:bool -> r -> p -> l -> Omd_representation.t
+ val main_parse : Omd_representation.tok list -> Omd_representation.t
+ val parse : Omd_representation.tok list -> Omd_representation.t
+
+end
+
diff --git a/analysis/src/vendor/omd/omd_representation.ml b/analysis/src/vendor/omd/omd_representation.ml
new file mode 100644
index 000000000..be4e795de
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_representation.ml
@@ -0,0 +1,491 @@
+open Omd_utils
+open Printf
+
+(** references, instances created in [Omd_parser.main_parse] and
+ accessed in the [Omd_backend] module. *)
+module R = Map.Make(String)
+class ref_container : object
+ val mutable c : (string * string) R.t
+ method add_ref : R.key -> string -> string -> unit
+ method get_ref : R.key -> (string * string) option
+ method get_all : (string * (string * string)) list
+ end = object
+ val mutable c = R.empty
+ val mutable c2 = R.empty
+
+ method get_all = R.bindings c
+
+ method add_ref name title url =
+ c <- R.add name (url, title) c;
+ let ln = String.lowercase_ascii name in
+ if ln <> name then c2 <- R.add ln (url, title) c2
+
+ method get_ref name =
+ try
+ let r =
+ try R.find name c
+ with Not_found ->
+ let ln = String.lowercase_ascii name in
+ try R.find ln c
+ with Not_found ->
+ R.find ln c2
+ in Some r
+ with Not_found ->
+ None
+end
+
+type element =
+ | H1 of t
+ | H2 of t
+ | H3 of t
+ | H4 of t
+ | H5 of t
+ | H6 of t
+ | Paragraph of t
+ | Text of string
+ | Emph of t
+ | Bold of t
+ | Ul of t list
+ | Ol of t list
+ | Ulp of t list
+ | Olp of t list
+ | Code of name * string
+ | Code_block of name * string
+ | Br
+ | Hr
+ | NL
+ | Url of href * t * title
+ | Ref of ref_container * name * string * fallback
+ | Img_ref of ref_container * name * alt * fallback
+ | Html of name * (string * string option) list * t
+ | Html_block of name * (string * string option) list * t
+ | Html_comment of string
+ | Raw of string
+ | Raw_block of string
+ | Blockquote of t
+ | Img of alt * src * title
+ | X of
+ < name : string;
+ to_html : ?indent:int -> (t -> string) -> t -> string option;
+ to_sexpr : (t -> string) -> t -> string option;
+ to_t : t -> t option >
+and fallback = < to_string : string ; to_t : t >
+and name = string
+and alt = string
+and src = string
+and href = string
+and title = string
+and t = element list
+
+
+let rec loose_compare t1 t2 = match t1,t2 with
+ | H1 e1::tl1, H1 e2::tl2
+ | H2 e1::tl1, H2 e2::tl2
+ | H3 e1::tl1, H3 e2::tl2
+ | H4 e1::tl1, H4 e2::tl2
+ | H5 e1::tl1, H5 e2::tl2
+ | H6 e1::tl1, H6 e2::tl2
+ | Emph e1::tl1, Emph e2::tl2
+ | Bold e1::tl1, Bold e2::tl2
+ | Blockquote e1::tl1, Blockquote e2::tl2
+ | Paragraph e1::tl1, Paragraph e2::tl2
+ ->
+ (match loose_compare e1 e2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+
+ | Ul e1::tl1, Ul e2::tl2
+ | Ol e1::tl1, Ol e2::tl2
+ | Ulp e1::tl1, Ulp e2::tl2
+ | Olp e1::tl1, Olp e2::tl2
+ ->
+ (match loose_compare_lists e1 e2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+
+ | (Code _ as e1)::tl1, (Code _ as e2)::tl2
+ | (Br as e1)::tl1, (Br as e2)::tl2
+ | (Hr as e1)::tl1, (Hr as e2)::tl2
+ | (NL as e1)::tl1, (NL as e2)::tl2
+ | (Html _ as e1)::tl1, (Html _ as e2)::tl2
+ | (Html_block _ as e1)::tl1, (Html_block _ as e2)::tl2
+ | (Raw _ as e1)::tl1, (Raw _ as e2)::tl2
+ | (Raw_block _ as e1)::tl1, (Raw_block _ as e2)::tl2
+ | (Html_comment _ as e1)::tl1, (Html_comment _ as e2)::tl2
+ | (Img _ as e1)::tl1, (Img _ as e2)::tl2
+ | (Text _ as e1)::tl1, (Text _ as e2)::tl2
+ ->
+ (match compare e1 e2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+
+ | Code_block(l1,c1)::tl1, Code_block(l2,c2)::tl2
+ ->
+ (match compare l1 l2, String.length c1 - String.length c2 with
+ | 0, 0 ->
+ (match compare c1 c2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+ | 0, 1 ->
+ (match compare c1 (c2^"\n") with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+ | 0, -1 ->
+ (match compare (c1^"\n") c2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+ | i, _ -> i
+ )
+
+ | Url (href1, t1, title1)::tl1, Url (href2, t2, title2)::tl2
+ ->
+ (match compare href1 href2 with
+ | 0 -> (match loose_compare t1 t2 with
+ | 0 -> (match compare title1 title2 with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+ | i -> i)
+ | i -> i)
+
+ | Ref (ref_container1, name1, x1, fallback1)::tl1,
+ Ref (ref_container2, name2, x2, fallback2)::tl2
+ | Img_ref (ref_container1, name1, x1, fallback1)::tl1,
+ Img_ref (ref_container2, name2, x2, fallback2)::tl2
+ ->
+ (match compare (name1, x1) (name2, x2) with
+ | 0 ->
+ let cff =
+ if fallback1#to_string = fallback2#to_string then
+ 0
+ else
+ loose_compare (fallback1#to_t) (fallback2#to_t)
+ in
+ if cff = 0 then
+ match
+ compare (ref_container1#get_all) (ref_container2#get_all)
+ with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i
+ else
+ cff
+ | i -> i)
+
+ | X e1::tl1, X e2::tl2 ->
+ (match compare (e1#name) (e2#name) with
+ | 0 -> (match compare (e1#to_t) (e2#to_t) with
+ | 0 -> loose_compare tl1 tl2
+ | i -> i)
+ | i -> i)
+ | X _::_, _ -> 1
+ | _, X _::_ -> -1
+ | _ -> compare t1 t2
+
+and loose_compare_lists l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | e1::tl1, e2::tl2 ->
+ (match loose_compare e1 e2 with
+ | 0 -> loose_compare_lists tl1 tl2
+ | i -> i)
+ | _, [] -> 1
+ | _ -> -1
+
+
+type tok = (* Cs(n) means (n+2) times C *)
+| Ampersand
+| Ampersands of int
+| At
+| Ats of int
+| Backquote
+| Backquotes of int
+| Backslash
+| Backslashs of int
+| Bar
+| Bars of int
+| Caret
+| Carets of int
+| Cbrace
+| Cbraces of int
+| Colon
+| Colons of int
+| Comma
+| Commas of int
+| Cparenthesis
+| Cparenthesiss of int
+| Cbracket
+| Cbrackets of int
+| Dollar
+| Dollars of int
+| Dot
+| Dots of int
+| Doublequote
+| Doublequotes of int
+| Exclamation
+| Exclamations of int
+| Equal
+| Equals of int
+| Greaterthan
+| Greaterthans of int
+| Hash
+| Hashs of int
+| Lessthan
+| Lessthans of int
+| Minus
+| Minuss of int
+| Newline
+| Newlines of int
+| Number of string
+| Obrace
+| Obraces of int
+| Oparenthesis
+| Oparenthesiss of int
+| Obracket
+| Obrackets of int
+| Percent
+| Percents of int
+| Plus
+| Pluss of int
+| Question
+| Questions of int
+| Quote
+| Quotes of int
+| Semicolon
+| Semicolons of int
+| Slash
+| Slashs of int
+| Space
+| Spaces of int
+| Star
+| Stars of int
+| Tab
+| Tabs of int
+| Tilde
+| Tildes of int
+| Underscore
+| Underscores of int
+| Word of string
+| Tag of name * extension
+
+and extension = <
+ parser_extension :
+ t -> tok list -> tok list -> ((t * tok list * tok list) option);
+ to_string : string
+>
+
+type extensions = extension list
+
+let empty_extension = object
+ method parser_extension _r _p _l = None
+ method to_string = ""
+end
+
+let rec normalise_md l =
+ if debug then
+ eprintf "(OMD) normalise_md\n%!";
+ let rec loop = function
+ | [NL;NL;NL;NL;NL;NL;NL;]
+ | [NL;NL;NL;NL;NL;NL;]
+ | [NL;NL;NL;NL;NL;]
+ | [NL;NL;NL;NL;]
+ | [NL;NL;NL;]
+ | [NL;NL]
+ | [NL] -> []
+ | [] -> []
+ | NL::NL::NL::tl -> loop (NL::NL::tl)
+ | Text t1::Text t2::tl -> loop (Text(t1^t2)::tl)
+ | NL::(((Paragraph _|H1 _|H2 _|H3 _|H4 _|H5 _|H6 _
+ |Code_block _|Ol _|Ul _|Olp _|Ulp _)::_) as tl) -> loop tl
+ | Paragraph[Text " "]::tl -> loop tl
+ | Paragraph[]::tl -> loop tl
+ | Paragraph(p)::tl -> Paragraph(loop p)::loop tl
+ | H1 v::tl -> H1(loop v)::loop tl
+ | H2 v::tl -> H2(loop v)::loop tl
+ | H3 v::tl -> H3(loop v)::loop tl
+ | H4 v::tl -> H4(loop v)::loop tl
+ | H5 v::tl -> H5(loop v)::loop tl
+ | H6 v::tl -> H6(loop v)::loop tl
+ | Emph v::tl -> Emph(loop v)::loop tl
+ | Bold v::tl -> Bold(loop v)::loop tl
+ | Ul v::tl -> Ul(List.map loop v)::loop tl
+ | Ol v::tl -> Ol(List.map loop v)::loop tl
+ | Ulp v::tl -> Ulp(List.map loop v)::loop tl
+ | Olp v::tl -> Olp(List.map loop v)::loop tl
+ | Blockquote v::tl -> Blockquote(loop v)::loop tl
+ | Url(href,v,title)::tl -> Url(href,(loop v),title)::loop tl
+ | Text _
+ | Code _
+ | Code_block _
+ | Br
+ | Hr
+ | NL
+ | Ref _
+ | Img_ref _
+ | Html _
+ | Html_block _
+ | Html_comment _
+ | Raw _
+ | Raw_block _
+ | Img _
+ | X _ as v::tl -> v::loop tl
+ in
+ let a = loop l in
+ let b = loop a in
+ if a = b then
+ a
+ else
+ normalise_md b
+
+let rec visit f = function
+ | [] -> []
+ | Paragraph v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Paragraph(visit f v)::visit f tl
+ end
+ | H1 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H1(visit f v)::visit f tl
+ end
+ | H2 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H2(visit f v)::visit f tl
+ end
+ | H3 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H3(visit f v)::visit f tl
+ end
+ | H4 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H4(visit f v)::visit f tl
+ end
+ | H5 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H5(visit f v)::visit f tl
+ end
+ | H6 v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> H6(visit f v)::visit f tl
+ end
+ | Emph v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Emph(visit f v)::visit f tl
+ end
+ | Bold v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Bold(visit f v)::visit f tl
+ end
+ | Ul v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Ul(List.map (visit f) v)::visit f tl
+ end
+ | Ol v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Ol(List.map (visit f) v)::visit f tl
+ end
+ | Ulp v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Ulp(List.map (visit f) v)::visit f tl
+ end
+ | Olp v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Olp(List.map (visit f) v)::visit f tl
+ end
+ | Blockquote v as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Blockquote(visit f v)::visit f tl
+ end
+ | Url(href,v,title) as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Url(href,visit f v,title)::visit f tl
+ end
+ | Text _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Code _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Code_block _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Ref _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Img_ref _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Html _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Html_block _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Html_comment _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Raw _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Raw_block _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Img _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | X _ as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> e::visit f tl
+ end
+ | Br as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Br::visit f tl
+ end
+ | Hr as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> Hr::visit f tl
+ end
+ | NL as e::tl ->
+ begin match f e with
+ | Some(l) -> l@visit f tl
+ | None -> NL::visit f tl
+ end
+
+
diff --git a/analysis/src/vendor/omd/omd_representation.mli b/analysis/src/vendor/omd/omd_representation.mli
new file mode 100644
index 000000000..6f0474e92
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_representation.mli
@@ -0,0 +1,188 @@
+
+module R : Map.S with type key = string
+
+class ref_container :
+ object
+ val mutable c : (string * string) R.t
+ method add_ref : R.key -> string -> string -> unit
+ method get_ref : R.key -> (string * string) option
+ method get_all : (string * (string * string)) list
+ end
+type element =
+ | H1 of t
+ | H2 of t
+ | H3 of t
+ | H4 of t
+ | H5 of t
+ | H6 of t
+ | Paragraph of t
+ | Text of string
+ | Emph of t
+ | Bold of t
+ | Ul of t list
+ | Ol of t list
+ | Ulp of t list
+ | Olp of t list
+ | Code of name * string
+ | Code_block of name * string
+ | Br
+ | Hr
+ | NL
+ | Url of href * t * title
+ | Ref of ref_container * name * string * fallback
+ | Img_ref of ref_container * name * alt * fallback
+ | Html of name * (string * string option) list * t
+ | Html_block of name * (string * string option) list * t
+ | Html_comment of string
+ | Raw of string
+ | Raw_block of string
+ | Blockquote of t
+ | Img of alt * src * title
+ | X of
+ < name : string;
+ to_html : ?indent:int -> (t -> string) -> t -> string option;
+ to_sexpr : (t -> string) -> t -> string option;
+ to_t : t -> t option >
+and fallback = < to_string : string ; to_t : t >
+and name = string
+and alt = string
+and src = string
+and href = string
+and title = string
+and t = element list
+
+type tok =
+ Ampersand (* one & *)
+ | Ampersands of int (* [Ampersands(n)] is (n+2) consecutive occurrences of & *)
+ | At (* @ *)
+ | Ats of int (* @@.. *)
+ | Backquote (* ` *)
+ | Backquotes of int (* ``.. *)
+ | Backslash (* \\ *)
+ | Backslashs of int (* \\\\.. *)
+ | Bar (* | *)
+ | Bars of int (* ||.. *)
+ | Caret (* ^ *)
+ | Carets of int (* ^^.. *)
+ | Cbrace (* } *)
+ | Cbraces of int (* }}.. *)
+ | Colon (* : *)
+ | Colons of int (* ::.. *)
+ | Comma (* , *)
+ | Commas of int (* ,,.. *)
+ | Cparenthesis (* ) *)
+ | Cparenthesiss of int (* )).. *)
+ | Cbracket (* ] *)
+ | Cbrackets of int (* ]].. *)
+ | Dollar (* $ *)
+ | Dollars of int (* $$.. *)
+ | Dot (* . *)
+ | Dots of int (* .... *)
+ | Doublequote (* \034 *)
+ | Doublequotes of int (* \034\034.. *)
+ | Exclamation (* ! *)
+ | Exclamations of int (* !!.. *)
+ | Equal (* = *)
+ | Equals of int (* ==.. *)
+ | Greaterthan (* > *)
+ | Greaterthans of int (* >>.. *)
+ | Hash (* # *)
+ | Hashs of int (* ##.. *)
+ | Lessthan (* < *)
+ | Lessthans of int (* <<.. *)
+ | Minus (* - *)
+ | Minuss of int (* --.. *)
+ | Newline (* \n *)
+ | Newlines of int (* \n\n.. *)
+ | Number of string
+ | Obrace (* { *)
+ | Obraces of int (* {{.. *)
+ | Oparenthesis (* ( *)
+ | Oparenthesiss of int (* ((.. *)
+ | Obracket (* [ *)
+ | Obrackets of int (* [[.. *)
+ | Percent (* % *)
+ | Percents of int (* %%.. *)
+ | Plus (* + *)
+ | Pluss of int (* ++.. *)
+ | Question (* ? *)
+ | Questions of int (* ??.. *)
+ | Quote (* ' *)
+ | Quotes of int (* ''.. *)
+ | Semicolon (* ; *)
+ | Semicolons of int (* ;;.. *)
+ | Slash (* / *)
+ | Slashs of int (* //.. *)
+ | Space (* *)
+ | Spaces of int (* .. *)
+ | Star (* * *)
+ | Stars of int (* **.. *)
+ | Tab (* \t *)
+ | Tabs of int (* \t\t.. *)
+ | Tilde (* ~ *)
+ | Tildes of int (* ~~.. *)
+ | Underscore (* _ *)
+ | Underscores of int (* __.. *)
+ | Word of string
+ | Tag of name * extension
+(** Lexer's tokens. If you want to use the parser with an extended
+ lexer, you may use the constructor [Tag] to implement
+ the parser's extension. In the parser, [Tag] is used (at least)
+ 3 times in order to represent metadata or to store data.
+
+ The integers carried by constructors means that the represented
+ character appears (n+2) times. So, [Ampersand(0)] is "&&".
+ Notably, this allows to use the property that in the match
+ case [Ampersand _ ->], we know there are at least 2 ampersands.
+ This is particularly useful for some characters, such as newlines
+ and spaces. It's not useful for all of them indeed but it has
+ been designed this way for the sake of uniformity (one doesn't
+ want to know by heart which constructor have that "at least 2"
+ property and which haven't).
+*)
+
+and extension = <
+ parser_extension : t -> tok list -> tok list -> ((t * tok list * tok list) option);
+ to_string : string
+>
+(** - [parser_extension] is a method that takes the current state of the
+ parser's data and returns None if nothing has been changed,
+ otherwise it returns the new state. The current state of the
+ parser's data is [(r, p, l)] where [r] is the result so far, [p]
+ is the list of the previous tokens (it's typically empty or
+ contains information on how many newlines we've just seen), and
+ [l] is the remaining tokens to parse.
+ - and [to_string] is a method that returns directly a string
+ representation of the object (it's normal if it returns the
+ empty string). *)
+
+type extensions = extension list
+(** One must use this type to extend the parser. It's a list of
+ functions of type [extension]. They are processed in order (the
+ head is applied first), so be careful about it. If you use it
+ wrong, it will behave wrong. *)
+
+val empty_extension : extension
+(** An empty extension *)
+
+val loose_compare : t -> t -> int
+(** [loose_compare t1 t2] returns [0] if [t1] and [t2]
+ are equivalent, otherwise it returns another number. *)
+
+val normalise_md : t -> t
+(** [normalise_md md] returns a copy of [md] where some elements
+ have been factorized. *)
+
+val visit : (element -> t option) -> t -> t
+(** visitor for structures of type t: [visit f md] will return a new
+ potentially altered copy of [md] that has been created by the
+ visit of [md] by [f].
+
+ The function [f] takes each [element] (from [md]) and returns
+ [Some t] if it has effectively been applied to [element], and
+ [None] otherwise. When it returns [Some t], [t] replaces [element]
+ in the copy of [md], and when it returns [None], either [element]
+ is copied as it is in the copy of [md] or a visited version is
+ copied instead (well, that depends on if [element] has elements
+ inside of it or not).
+*)
diff --git a/analysis/src/vendor/omd/omd_types.ml b/analysis/src/vendor/omd/omd_types.ml
new file mode 100644
index 000000000..40582dcfa
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_types.ml
@@ -0,0 +1,44 @@
+
+type name = string
+type url = string
+type title = string
+type alt = string
+
+type 'a el =
+ [ `Text of string
+ | `Br
+ | `Emph of 'a
+ | `Bold of 'a
+ | `Url of url * 'a * title
+ | `Img of url * alt * title
+ | `Code of name * string
+ | `Html of string
+ | `Comment of string
+ ]
+
+type phrasing_no_NL = phrasing_no_NL el list
+
+type phrasing = [phrasing el | `NL] list
+
+type reference
+
+type flow =
+ [ phrasing el
+ | `H1 of phrasing_no_NL
+ | `H2 of phrasing_no_NL
+ | `H3 of phrasing_no_NL
+ | `H4 of phrasing_no_NL
+ | `H5 of phrasing_no_NL
+ | `H6 of phrasing_no_NL
+ | `Hr
+ | `Paragraph of phrasing
+ | `Code_block of name * string
+ | `Html_block of string
+ | `Ul of t
+ | `Ol of t
+ | `Quote of t
+ | `Ref of reference
+ | `Img_ref of reference
+ ]
+
+and t = flow list
diff --git a/analysis/src/vendor/omd/omd_utils.ml b/analysis/src/vendor/omd/omd_utils.ml
new file mode 100644
index 000000000..3919fd4d7
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_utils.ml
@@ -0,0 +1,310 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013/2014 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+open Printf
+
+let debug =
+ let _DEBUG =
+ try
+ Some(Sys.getenv "DEBUG")
+ with _ -> None
+ and _OMD_DEBUG =
+ try
+ Some(Sys.getenv "OMD_DEBUG")
+ with _ -> None
+ in
+ match _DEBUG, _OMD_DEBUG with
+ | _, Some "false" ->
+ false
+ | Some _, None ->
+ eprintf "omd: debug mode activated because DEBUG is set, \
+ you can deactivate the mode by unsetting DEBUG \
+ or by setting OMD_DEBUG to the string \"false\".\n%!";
+ true
+ | None, None ->
+ false
+ | _, Some _ ->
+ eprintf "omd: debug mode activated because OMD_DEBUG is set
+ to a value that isn't the string \"false\".\n%!";
+ true
+
+exception Error of string
+
+let warn ?(we=false) msg =
+ if we then
+ raise (Error msg)
+ else
+ eprintf "(OMD) Warning: %s\n%!" msg
+
+
+let trackfix =
+ try
+ ignore(Sys.getenv "OMD_FIX");
+ eprintf "omd: tracking mode activated: token list are very often checked, \
+ it might take a *very* long time if your input is large.\n%!";
+ true
+ with Not_found ->
+ false
+
+let _ = if debug then Printexc.record_backtrace true
+
+let raise =
+ if debug then
+ (fun e ->
+ eprintf "(OMD) Exception raised: %s\n%!" (Printexc.to_string e);
+ raise e)
+ else
+ Pervasives.raise
+
+module StringSet : sig
+ include Set.S with type elt = string
+ val of_list : elt list -> t
+end = struct
+ include Set.Make(String)
+ let of_list l = List.fold_left (fun r e -> add e r) empty l
+end
+
+
+type 'a split = 'a list -> 'a split_action
+and 'a split_action =
+ | Continue
+ | Continue_with of 'a list * 'a list
+ | Split of 'a list * 'a list
+
+
+let fsplit_rev ?(excl=(fun _ -> false)) ~(f:'a split) l
+ : ('a list * 'a list) option =
+ let rec loop accu = function
+ | [] ->
+ begin
+ match f [] with
+ | Split(left, right) -> Some(left@accu, right)
+ | Continue_with(left, tl) -> loop (left@accu) tl
+ | Continue -> None
+ end
+ | e::tl as l ->
+ if excl l then
+ None
+ else match f l with
+ | Split(left, right) -> Some(left@accu, right)
+ | Continue_with(left, tl) -> loop (left@accu) tl
+ | Continue -> loop (e::accu) tl
+ in loop [] l
+
+let fsplit ?(excl=(fun _ -> false)) ~f l =
+ match fsplit_rev ~excl:excl ~f:f l with
+ | None -> None
+ | Some(rev, l) -> Some(List.rev rev, l)
+
+let id_of_string ids s =
+ let n = String.length s in
+ let out = Buffer.create 0 in
+ (* Put [s] into [b], replacing non-alphanumeric characters with dashes. *)
+ let rec loop started i =
+ if i = n then ()
+ else
+ match s.[i] with
+ | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' as c ->
+ Buffer.add_char out c ;
+ loop true (i + 1)
+ (* Don't want to start with dashes. *)
+ | _ when not started ->
+ loop false (i + 1)
+ | _ ->
+ Buffer.add_char out '-' ;
+ loop false (i + 1)
+ in
+ loop false 0 ;
+ let s' = Buffer.contents out in
+ if s' = "" then ""
+ else
+ (* Find out the index of the last character in [s'] that isn't a dash. *)
+ let last_trailing =
+ let rec loop i =
+ if i < 0 || s'.[i] <> '-' then i
+ else loop (i - 1)
+ in
+ loop (String.length s' - 1)
+ in
+ (* Trim trailing dashes. *)
+ ids#mangle @@ String.sub s' 0 (last_trailing + 1)
+
+(* only convert when "necessary" *)
+let htmlentities ?(md=false) s =
+ let module Break = struct exception Break end in
+ let b = Buffer.create 64 in
+ let rec loop i =
+ if i = String.length s then
+ ()
+ else
+ let () =
+ match s.[i] with
+ | ( '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' ) as c -> Buffer.add_char b c
+ | '"' -> Buffer.add_string b """
+ | '\'' -> Buffer.add_string b "'"
+ | '&' ->
+ if md then
+ begin
+ try
+ let () = match s.[i+1] with
+ | '#' ->
+ let rec ff j =
+ match s.[j] with
+ | '0' .. '9' -> ff (succ j)
+ | ';' -> ()
+ | _ -> raise Break.Break
+ in
+ ff (i+2)
+ | 'A' .. 'Z' | 'a' .. 'z' ->
+ let rec ff j =
+ match s.[j] with
+ | 'A' .. 'Z' | 'a' .. 'z' -> ff (succ j)
+ | ';' -> ()
+ | _ -> raise Break.Break
+ in
+ ff (i+2)
+ | _ -> raise Break.Break
+ in
+ Buffer.add_string b "&"
+ with _ -> Buffer.add_string b "&"
+ end
+ else
+ Buffer.add_string b "&"
+ | '<' -> Buffer.add_string b "<"
+ | '>' -> Buffer.add_string b ">"
+ | c -> Buffer.add_char b c
+ in loop (succ i)
+ in
+ loop 0;
+ Buffer.contents b
+
+
+let minimalize_blanks s =
+ let l = String.length s in
+ let b = Buffer.create l in
+ let rec loop f i =
+ if i = l then
+ Buffer.contents b
+ else
+ match s.[i] with
+ | ' ' | '\t' | '\n' ->
+ loop true (succ i)
+ | _c ->
+ if Buffer.length b > 0 && f then
+ Buffer.add_char b ' ';
+ loop false (succ i)
+ in loop false 0
+
+let rec eat f = function
+ | [] -> []
+ | e::tl as l -> if f e then eat f tl else l
+
+
+let rec extract_html_attributes (html:string) =
+ let cut_on_char_from s i c =
+ match String.index_from s i c with
+ | 0 -> "", String.sub s 1 (String.length s - 1)
+ | j -> String.sub s i (j-i), String.sub s (j+1) (String.length s - (j+1))
+ in
+ let remove_prefix_spaces s =
+ if s = "" then
+ s
+ else if s.[0] <> ' ' then
+ s
+ else
+ let rec loop i =
+ if i = String.length s then
+ String.sub s i (String.length s - i)
+ else
+ match s.[i] with
+ | ' ' -> loop (i+1)
+ | _ -> String.sub s i (String.length s - i)
+ in loop 1
+ in
+ let remove_suffix_spaces s =
+ if s = "" then
+ s
+ else if s.[String.length s - 1] <> ' ' then
+ s
+ else
+ let rec loop i =
+ match s.[i] with
+ | ' ' -> loop (i-1)
+ | _ -> String.sub s 0 (i+1)
+ in loop (String.length s - 1)
+ in
+ let rec loop s res i =
+ if i = String.length s then
+ res
+ else
+ match
+ try
+ Some (take_attribute s i)
+ with Not_found -> None
+ with
+ | Some (((_,_) as a), new_s) ->
+ loop new_s (a::res) 0
+ | None -> res
+ and take_attribute s i =
+ let name, after_eq = cut_on_char_from s i '=' in
+ let name = remove_suffix_spaces name in
+ let after_eq = remove_prefix_spaces after_eq in
+ let value, rest = cut_on_char_from after_eq 1 after_eq.[0] in
+ (name,value), remove_prefix_spaces rest
+ in
+ if (* Has it at least one attribute? *)
+ try String.index html '>' < String.index html ' '
+ with Not_found -> true
+ then
+ []
+ else
+ match html.[1] with
+ | '<' | ' ' ->
+ extract_html_attributes
+ (remove_prefix_spaces (String.sub html 1 (String.length html - 1)))
+ | _ ->
+ try
+ let html = snd (cut_on_char_from html 0 ' ') in
+ loop (String.sub html 0 (String.index html '>')) [] 0
+ with Not_found -> []
+
+let extract_inner_html (html:string) =
+ let cut_on_char_from s i c =
+ match String.index_from s i c with
+ | 0 -> "", String.sub s 1 (String.length s - 1)
+ | j -> String.sub s i (j-i), String.sub s (j+1) (String.length s - (j+1))
+ in
+ let rcut_on_char_from s i c =
+ match String.rindex_from s i c with
+ | 0 -> "", String.sub s 1 (String.length s - 1)
+ | j -> String.sub s 0 j, String.sub s (j+1) (String.length s - (j+1))
+ in
+ let _, p = cut_on_char_from html 0 '>' in
+ let r, _ = rcut_on_char_from p (String.length p - 1) '<' in
+ r
+
+
+let html_void_elements = StringSet.of_list [
+ "img";
+ "input";
+ "link";
+ "meta";
+ "br";
+ "hr";
+ "source";
+ "wbr";
+ "param";
+ "embed";
+ "base";
+ "area";
+ "col";
+ "track";
+ "keygen";
+]
+
+let ( @ ) l1 l2 =
+ List.rev_append (List.rev l1) l2
diff --git a/analysis/src/vendor/omd/omd_utils.mli b/analysis/src/vendor/omd/omd_utils.mli
new file mode 100644
index 000000000..7c36c3d03
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_utils.mli
@@ -0,0 +1,118 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013/2014 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+val debug : bool
+(** Equals [true] if the environment variable DEBUG is set,
+ or if the environment variable OMD_DEBUG is set to a string
+ that is not ["false"]. *)
+
+val trackfix : bool
+
+exception Error of string
+
+val raise : exn -> 'a
+(** Same as [Pervasives.raise] except if [debug] equals true,
+ in which case it prints a trace on stderr before raising the exception. *)
+
+val warn : ?we:bool -> string -> unit
+(** [warn we x] prints a warning with the message [x] if [we] is true,
+ else raises [Omd_utils.Error x]. *)
+
+module StringSet :
+ sig
+ include Set.S with type elt = string
+ val of_list : elt list -> t
+ end
+(** Set of [string]. Cf. documentation of {!Set.S} *)
+
+type 'a split = 'a list -> 'a split_action
+(** Type of a split function *)
+
+and 'a split_action =
+ (** Don't split yet *)
+ | Continue
+
+ (** Don't split yet but continue with those two lists instead of default *)
+ | Continue_with of 'a list * 'a list
+
+ (** Do split with this split scheme *)
+ | Split of 'a list * 'a list
+(** Type of a split action *)
+
+
+val fsplit_rev :
+ ?excl:('a list -> bool) ->
+ f:'a split -> 'a list -> ('a list * 'a list) option
+(** [fsplit_rev ?excl ~f l] returns [Some(x,y)] where [x] is the
+ **reversed** list of the consecutive elements of [l] that obey the
+ split function [f].
+ Note that [f] is applied to a list of elements and not just an
+ element, so that [f] can look farther in the list when applied.
+ [f l] returns [Continue] if there're more elements to consume,
+ [Continue_with(left,right)] if there's more elements to consume
+ but we want to choose what goes to the left part and what remains
+ to process (right part), and returns [Split(left,right)] if
+ the splitting is decided.
+ When [f] is applied to an empty list, if it returns [Continue]
+ then the result will be [None].
+
+ If [excl] is given, then [excl] is applied before [f] is, to check
+ if the splitting should be stopped right away. When the split
+ fails, it returns [None]. *)
+
+
+val fsplit :
+ ?excl:('a list -> bool) ->
+ f:'a split -> 'a list -> ('a list * 'a list) option
+(** [fsplit ?excl ~f l] returns [Some(List.rev x, y)]
+ if [fsplit ?excl ~f l] returns [Some(x,y)], else it returns [None]. *)
+
+val id_of_string : < mangle : string -> string; .. > -> string -> string
+(** [id_of_string ids id] returns a mangled version of [id], using the
+ method [ids#mangle]. If you don't need mangling, you may use
+ [object method mangle x = x end] for [ids]. However, the name
+ [ids] also means that your object should have knowledge of all IDs
+ it has issued, in order to avoid collision. This is why
+ [id_of_string] asks for an object rather than "just a
+ function". *)
+
+val htmlentities : ?md:bool -> string -> string
+(** [htmlentities s] returns a new string in which html-significant
+ characters have been converted to html entities. For instance,
+ "" is converted to "<Foo&Bar>". *)
+
+val minimalize_blanks : string -> string
+(** [minimalize_blanks s] returns a copy of [s] in which the first and last
+ characters are never blank, and two consecutive blanks never happen. *)
+
+
+val eat : ('a -> bool) -> 'a list -> 'a list
+(** [eat f l] returns [l] where elements satisfying [f] have been removed,
+ but it stops removing as soon as one element doesn't satisfy [f]. *)
+
+
+val extract_html_attributes : string -> (string * string) list
+(** Takes some HTML and returns the list of attributes of the first
+ HTML tag.
+ Notes:
+ * Doesn't check the validity of HTML tags or attributes.
+ * Doesn't support backslash escaping.
+ * Attribute names are delimited by the space and equal characters.
+ * Attribute values are either delimited by the double quote
+ or the simple quote character.
+*)
+
+val extract_inner_html : string -> string
+(** Takes an HTML node and returns the contents of the node.
+ If it's not given a node, it returns something rubbish.
+*)
+
+val html_void_elements : StringSet.t
+(** HTML void elements *)
+
+val ( @ ) : 'a list -> 'a list -> 'a list
+(** Tail-recursive version of [Pervasives.(@)]. *)
diff --git a/analysis/src/vendor/omd/omd_xtxt.ml b/analysis/src/vendor/omd/omd_xtxt.ml
new file mode 100644
index 000000000..68b49f66a
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_xtxt.ml
@@ -0,0 +1,28 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+(* xtxt = eXTernal eXTension *)
+
+(* let extensions = ref [] *)
+
+(* let get () = *)
+(* !extensions *)
+
+(* let register e = *)
+(* extensions := e :: !extensions *)
+
+(* let set es = extensions := es *)
+
+(* let activate ... *)
+
+(* (\* let deactivate ... *\) *)
+
+(* priority (integer?) *)
+(* pre-extension *)
+(* post-extension *)
+
+
diff --git a/analysis/src/vendor/omd/omd_xtxt.mli b/analysis/src/vendor/omd/omd_xtxt.mli
new file mode 100644
index 000000000..9c1d8749b
--- /dev/null
+++ b/analysis/src/vendor/omd/omd_xtxt.mli
@@ -0,0 +1,9 @@
+(***********************************************************************)
+(* omd: Markdown frontend in OCaml *)
+(* (c) 2013 by Philippe Wang *)
+(* Licence : ISC *)
+(* http://www.isc.org/downloads/software-support-policy/isc-license/ *)
+(***********************************************************************)
+
+(** xtxt = eXTernal eXTension *)
+
diff --git a/analysis/src/vendor/res_outcome_printer/res_comment.ml b/analysis/src/vendor/res_outcome_printer/res_comment.ml
new file mode 100644
index 000000000..bdcd7e563
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_comment.ml
@@ -0,0 +1,72 @@
+type style =
+ | SingleLine
+ | MultiLine
+
+let styleToString s = match s with
+ | SingleLine -> "SingleLine"
+ | MultiLine -> "MultiLine"
+
+type t = {
+ txt: string;
+ style: style;
+ loc: Location.t;
+ mutable prevTokEndPos: Lexing.position;
+}
+
+let loc t = t.loc
+let txt t = t.txt
+let prevTokEndPos t = t.prevTokEndPos
+
+let setPrevTokEndPos t pos =
+ t.prevTokEndPos <- pos
+
+let isSingleLineComment t = match t.style with
+ | SingleLine -> true
+ | MultiLine -> false
+
+let toString t =
+ Format.sprintf
+ "(txt: %s\nstyle: %s\nlines: %d-%d)"
+ t.txt
+ (styleToString t.style)
+ t.loc.loc_start.pos_lnum
+ t.loc.loc_end.pos_lnum
+
+let makeSingleLineComment ~loc txt = {
+ txt;
+ loc;
+ style = SingleLine;
+ prevTokEndPos = Lexing.dummy_pos;
+}
+
+let makeMultiLineComment ~loc txt = {
+ txt;
+ loc;
+ style = MultiLine;
+ prevTokEndPos = Lexing.dummy_pos;
+}
+
+let fromOcamlComment ~loc ~txt ~prevTokEndPos = {
+ txt;
+ loc;
+ style = MultiLine;
+ prevTokEndPos = prevTokEndPos
+}
+
+let trimSpaces s =
+ let len = String.length s in
+ if len = 0 then s
+ else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then (
+ let i = ref 0 in
+ while !i < len && (String.unsafe_get s !i) = ' ' do
+ incr i
+ done;
+ let j = ref (len - 1) in
+ while !j >= !i && (String.unsafe_get s !j) = ' ' do
+ decr j
+ done;
+ if !j >= !i then
+ (String.sub [@doesNotRaise]) s !i (!j - !i + 1)
+ else
+ ""
+ ) else s
\ No newline at end of file
diff --git a/analysis/src/vendor/res_outcome_printer/res_comment.mli b/analysis/src/vendor/res_outcome_printer/res_comment.mli
new file mode 100644
index 000000000..7fdaa0459
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_comment.mli
@@ -0,0 +1,17 @@
+type t
+
+val toString: t -> string
+
+val loc: t -> Location.t
+val txt: t -> string
+val prevTokEndPos: t -> Lexing.position
+
+val setPrevTokEndPos: t -> Lexing.position -> unit
+
+val isSingleLineComment: t -> bool
+
+val makeSingleLineComment: loc:Location.t -> string -> t
+val makeMultiLineComment: loc:Location.t -> string -> t
+val fromOcamlComment:
+ loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t
+val trimSpaces: string -> string
\ No newline at end of file
diff --git a/analysis/src/vendor/res_outcome_printer/res_doc.ml b/analysis/src/vendor/res_outcome_printer/res_doc.ml
new file mode 100644
index 000000000..63a9a731c
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_doc.ml
@@ -0,0 +1,356 @@
+module MiniBuffer = Res_minibuffer
+
+type mode = Break | Flat
+
+type lineStyle =
+ | Classic (* fits? -> replace with space *)
+ | Soft (* fits? -> replaced with nothing *)
+ | Hard (* always included, forces breaks in parents *)
+ (* always included, forces breaks in parents, but doesn't increase indentation
+ use case: template literals, multiline string content *)
+ | Literal
+
+type t =
+ | Nil
+ | Text of string
+ | Concat of t list
+ | Indent of t
+ | IfBreaks of {yes: t; no: t; mutable broken: bool} (* when broken is true, treat as the yes branch *)
+ | LineSuffix of t
+ | LineBreak of lineStyle
+ | Group of {mutable shouldBreak: bool; doc: t}
+ | CustomLayout of t list
+ | BreakParent
+
+let nil = Nil
+let line = LineBreak Classic
+let hardLine = LineBreak Hard
+let softLine = LineBreak Soft
+let literalLine = LineBreak Literal
+let text s = Text s
+
+(* Optimization. We eagerly collapse and reduce whatever allocation we can *)
+let rec _concat acc l =
+ match l with
+ | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest
+ | Nil :: rest -> _concat acc rest
+ | Concat l2 :: rest -> _concat (_concat acc rest) l2 (* notice the order here *)
+ | x :: rest ->
+ let rest1 = _concat acc rest in
+ if rest1 == rest then l else x :: rest1
+ | [] -> acc
+
+let concat l = Concat(_concat [] l)
+
+let indent d = Indent d
+let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false}
+let lineSuffix d = LineSuffix d
+let group d = Group {shouldBreak = false; doc = d}
+let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d}
+let customLayout gs = CustomLayout gs
+let breakParent = BreakParent
+
+let space = Text " "
+let comma = Text ","
+let dot = Text "."
+let dotdot = Text ".."
+let dotdotdot = Text "..."
+let lessThan = Text "<"
+let greaterThan = Text ">"
+let lbrace = Text "{"
+let rbrace = Text "}"
+let lparen = Text "("
+let rparen = Text ")"
+let lbracket = Text "["
+let rbracket = Text "]"
+let question = Text "?"
+let tilde = Text "~"
+let equal = Text "="
+let trailingComma = ifBreaks comma nil
+let doubleQuote = Text "\""
+
+let propagateForcedBreaks doc =
+ let rec walk doc = match doc with
+ | Text _ | Nil | LineSuffix _ ->
+ false
+ | BreakParent ->
+ true
+ | LineBreak (Hard | Literal) ->
+ true
+ | LineBreak (Classic | Soft) ->
+ false
+ | Indent children ->
+ let childForcesBreak = walk children in
+ childForcesBreak
+ | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) ->
+ let falseForceBreak = walk falseDoc in
+ if falseForceBreak then
+ let _ = walk trueDoc in
+ ib.broken <- true;
+ true
+ else
+ let forceBreak = walk trueDoc in
+ forceBreak
+ | Group ({shouldBreak = forceBreak; doc = children} as gr) ->
+ let childForcesBreak = walk children in
+ let shouldBreak = forceBreak || childForcesBreak in
+ gr.shouldBreak <- shouldBreak;
+ shouldBreak
+ | Concat children ->
+ List.fold_left (fun forceBreak child ->
+ let childForcesBreak = walk child in
+ forceBreak || childForcesBreak
+ ) false children
+ | CustomLayout children ->
+ (* When using CustomLayout, we don't want to propagate forced breaks
+ * from the children up. By definition it picks the first layout that fits
+ * otherwise it takes the last of the list.
+ * However we do want to propagate forced breaks in the sublayouts. They
+ * might need to be broken. We just don't propagate them any higher here *)
+ let _ = walk (Concat children) in
+ false
+ in
+ let _ = walk doc in
+ ()
+
+(* See documentation in interface file *)
+let rec willBreak doc = match doc with
+ | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> true
+ | Group {doc} | Indent doc | CustomLayout (doc::_) -> willBreak doc
+ | Concat docs -> List.exists willBreak docs
+ | IfBreaks {yes; no} -> willBreak yes || willBreak no
+ | _ -> false
+
+let join ~sep docs =
+ let rec loop acc sep docs =
+ match docs with
+ | [] -> List.rev acc
+ | [x] -> List.rev (x::acc)
+ | x::xs -> loop (sep::x::acc) sep xs
+ in
+ concat(loop [] sep docs)
+
+let fits w stack =
+ let width = ref w in
+ let result = ref None in
+
+ let rec calculate indent mode doc =
+ match mode, doc with
+ | _ when result.contents != None -> ()
+ | _ when width.contents < 0 -> result := Some false
+ | _, Nil
+ | _, LineSuffix _
+ | _, BreakParent -> ()
+ | _, Text txt -> width := width.contents - (String.length txt)
+ | _, Indent doc -> calculate (indent + 2) mode doc
+ | Flat, LineBreak Hard
+ | Flat, LineBreak Literal -> result := Some true
+ | Flat, LineBreak Classic -> width := width.contents - 1
+ | Flat, LineBreak Soft -> ()
+ | Break, LineBreak _ -> result := Some true
+ | _, Group {shouldBreak = true; doc} -> calculate indent Break doc
+ | _, Group {doc} -> calculate indent mode doc
+ | _, IfBreaks {yes = breakDoc; broken = true} -> calculate indent mode breakDoc
+ | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc
+ | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc
+ | _, Concat docs -> calculateConcat indent mode docs
+ | _, CustomLayout (hd::_) ->
+ (* TODO: if we have nested custom layouts, what we should do here? *)
+ calculate indent mode hd
+ | _, CustomLayout [] -> ()
+ and calculateConcat indent mode docs =
+ if result.contents == None then (
+ match docs with
+ | [] -> ()
+ | doc::rest ->
+ calculate indent mode doc;
+ calculateConcat indent mode rest
+ )
+ in
+ let rec calculateAll stack =
+ match result.contents, stack with
+ | Some r, _ -> r
+ | None, [] -> !width >= 0
+ | None, (indent, mode, doc)::rest ->
+ calculate indent mode doc;
+ calculateAll rest
+ in
+ calculateAll stack
+
+let toString ~width doc =
+ propagateForcedBreaks doc;
+ let buffer = MiniBuffer.create 1000 in
+
+ let rec process ~pos lineSuffices stack =
+ match stack with
+ | ((ind, mode, doc) as cmd)::rest ->
+ begin match doc with
+ | Nil | BreakParent ->
+ process ~pos lineSuffices rest
+ | Text txt ->
+ MiniBuffer.add_string buffer txt;
+ process ~pos:(String.length txt + pos) lineSuffices rest
+ | LineSuffix doc ->
+ process ~pos ((ind, mode, doc)::lineSuffices) rest
+ | Concat docs ->
+ let ops = List.map (fun doc -> (ind, mode, doc)) docs in
+ process ~pos lineSuffices (List.append ops rest)
+ | Indent doc ->
+ process ~pos lineSuffices ((ind + 2, mode, doc)::rest)
+ | IfBreaks {yes = breakDoc; broken = true} ->
+ process ~pos lineSuffices ((ind, mode, breakDoc)::rest)
+ | IfBreaks {yes = breakDoc; no = flatDoc} ->
+ if mode = Break then
+ process ~pos lineSuffices ((ind, mode, breakDoc)::rest)
+ else
+ process ~pos lineSuffices ((ind, mode, flatDoc)::rest)
+ | LineBreak lineStyle ->
+ if mode = Break then (
+ begin match lineSuffices with
+ | [] ->
+ if lineStyle = Literal then (
+ MiniBuffer.add_char buffer '\n';
+ process ~pos:0 [] rest
+ ) else (
+ MiniBuffer.flush_newline buffer;
+ MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]);
+ process ~pos:ind [] rest
+ )
+ | _docs ->
+ process ~pos:ind [] (List.concat [List.rev lineSuffices; cmd::rest])
+ end
+ ) else (* mode = Flat *) (
+ let pos = match lineStyle with
+ | Classic -> MiniBuffer.add_string buffer " "; pos + 1
+ | Hard -> MiniBuffer.flush_newline buffer; 0
+ | Literal -> MiniBuffer.add_char buffer '\n'; 0
+ | Soft -> pos
+ in
+ process ~pos lineSuffices rest
+ )
+ | Group {shouldBreak; doc} ->
+ if shouldBreak || not (fits (width - pos) ((ind, Flat, doc)::rest)) then
+ process ~pos lineSuffices ((ind, Break, doc)::rest)
+ else
+ process ~pos lineSuffices ((ind, Flat, doc)::rest)
+ | CustomLayout docs ->
+ let rec findGroupThatFits groups = match groups with
+ | [] -> Nil
+ | [lastGroup] -> lastGroup
+ | doc::docs ->
+ if (fits (width - pos) ((ind, Flat, doc)::rest)) then
+ doc
+ else
+ findGroupThatFits docs
+ in
+ let doc = findGroupThatFits docs in
+ process ~pos lineSuffices ((ind, Flat, doc)::rest)
+ end
+ | [] ->
+ begin match lineSuffices with
+ | [] -> ()
+ | suffices ->
+ process ~pos:0 [] (List.rev suffices)
+ end
+ in
+ process ~pos:0 [] [(0, Flat, doc)];
+ MiniBuffer.contents buffer
+
+
+let debug t =
+ let rec toDoc = function
+ | Nil -> text "nil"
+ | BreakParent -> text "breakparent"
+ | Text txt -> text ("text(\"" ^ txt ^ "\")")
+ | LineSuffix doc -> group(
+ concat [
+ text "linesuffix(";
+ indent (
+ concat [line; toDoc doc]
+ );
+ line;
+ text ")"
+ ]
+ )
+ | Concat [] -> text "concat()"
+ | Concat docs -> group(
+ concat [
+ text "concat(";
+ indent (
+ concat [
+ line;
+ join ~sep:(concat [text ","; line])
+ (List.map toDoc docs) ;
+ ]
+ );
+ line;
+ text ")"
+ ]
+ )
+ | CustomLayout docs -> group(
+ concat [
+ text "customLayout(";
+ indent (
+ concat [
+ line;
+ join ~sep:(concat [text ","; line])
+ (List.map toDoc docs) ;
+ ]
+ );
+ line;
+ text ")"
+ ]
+ )
+ | Indent doc ->
+ concat [
+ text "indent(";
+ softLine;
+ toDoc doc;
+ softLine;
+ text ")";
+ ]
+ | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc
+ | IfBreaks {yes = trueDoc; no = falseDoc} ->
+ group(
+ concat [
+ text "ifBreaks(";
+ indent (
+ concat [
+ line;
+ toDoc trueDoc;
+ concat [text ","; line];
+ toDoc falseDoc;
+ ]
+ );
+ line;
+ text ")"
+ ]
+ )
+ | LineBreak break ->
+ let breakTxt = match break with
+ | Classic -> "Classic"
+ | Soft -> "Soft"
+ | Hard -> "Hard"
+ | Literal -> "Liteal"
+ in
+ text ("LineBreak(" ^ breakTxt ^ ")")
+ | Group {shouldBreak; doc} ->
+ group(
+ concat [
+ text "Group(";
+ indent (
+ concat [
+ line;
+ text ("{shouldBreak: " ^ (string_of_bool shouldBreak) ^ "}");
+ concat [text ","; line];
+ toDoc doc;
+ ]
+ );
+ line;
+ text ")"
+ ]
+ )
+ in
+ let doc = toDoc t in
+ toString ~width:10 doc |> print_endline
+ [@@live]
diff --git a/analysis/src/vendor/res_outcome_printer/res_doc.mli b/analysis/src/vendor/res_outcome_printer/res_doc.mli
new file mode 100644
index 000000000..031afbaf6
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_doc.mli
@@ -0,0 +1,63 @@
+type t
+
+val nil: t
+val line: t
+val hardLine: t
+val softLine: t
+val literalLine: t
+val text: string -> t
+val concat: t list -> t
+val indent: t -> t
+val ifBreaks: t -> t -> t
+val lineSuffix: t -> t
+val group: t -> t
+val breakableGroup: forceBreak : bool -> t -> t
+(* `customLayout docs` will pick the layout that fits from `docs`.
+ * This is a very expensive computation as every layout from the list
+ * will be checked until one fits. *)
+val customLayout: t list -> t
+val breakParent: t
+val join: sep: t -> t list -> t
+
+val space: t
+val comma: t
+val dot: t
+val dotdot: t
+val dotdotdot: t
+val lessThan: t
+val greaterThan: t
+val lbrace: t
+val rbrace: t
+val lparen: t
+val rparen: t
+val lbracket: t
+val rbracket: t
+val question: t
+val tilde: t
+val equal: t
+val trailingComma: t
+val doubleQuote: t [@@live]
+
+(*
+ * `willBreak doc` checks whether `doc` contains forced line breaks.
+ * This is more or less a "workaround" to make the parent of a `customLayout` break.
+ * Forced breaks are not propagated through `customLayout`; otherwise we would always
+ * get the last layout the algorithm tries…
+ * This might result into some weird layouts:
+ * [fn(x => {
+ * let _ = x
+ * }), fn(y => {
+ * let _ = y
+ * }), fn(z => {
+ * let _ = z
+ * })]
+ * The `[` and `]` would be a lot better broken out.
+ * Although the layout of `fn(x => {...})` is correct, we need to break its parent (the array).
+ * `willBreak` can be used in this scenario to check if the `fn…` contains any forced breaks.
+ * The consumer can then manually insert a `breakParent` doc, to manually propagate the
+ * force breaks from bottom to top.
+ *)
+val willBreak: t -> bool
+
+val toString: width: int -> t -> string
+val debug: t -> unit [@@live]
diff --git a/analysis/src/vendor/res_outcome_printer/res_minibuffer.ml b/analysis/src/vendor/res_outcome_printer/res_minibuffer.ml
new file mode 100644
index 000000000..174b5ec6a
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_minibuffer.ml
@@ -0,0 +1,50 @@
+type t = {
+ mutable buffer : bytes;
+ mutable position : int;
+ mutable length : int;
+}
+
+let create n =
+ let n = if n < 1 then 1 else n in
+ let s = (Bytes.create [@doesNotRaise]) n in
+ {buffer = s; position = 0; length = n}
+
+let contents b = (Bytes.sub_string [@doesNotRaise]) b.buffer 0 b.position
+
+(* Can't be called directly, don't add to the interface *)
+let resize_internal b more =
+ let len = b.length in
+ let new_len = ref len in
+ while b.position + more > !new_len do new_len := 2 * !new_len done;
+ if !new_len > Sys.max_string_length then begin
+ if b.position + more <= Sys.max_string_length
+ then new_len := Sys.max_string_length
+ end;
+ let new_buffer = (Bytes.create [@doesNotRaise]) !new_len in
+ (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in
+ this tricky function that is slow anyway. *)
+ Bytes.blit b.buffer 0 new_buffer 0 b.position [@doesNotRaise];
+ b.buffer <- new_buffer;
+ b.length <- !new_len
+
+let add_char b c =
+ let pos = b.position in
+ if pos >= b.length then resize_internal b 1;
+ Bytes.unsafe_set b.buffer pos c;
+ b.position <- pos + 1
+
+let add_string b s =
+ let len = String.length s in
+ let new_position = b.position + len in
+ if new_position > b.length then resize_internal b len;
+ Bytes.blit_string s 0 b.buffer b.position len [@doesNotRaise];
+ b.position <- new_position
+
+(* adds newline and trims all preceding whitespace *)
+let flush_newline b =
+ let position = ref (b.position) in
+ while (Bytes.unsafe_get b.buffer (!position - 1)) = ' ' && !position >= 0 do
+ position := !position - 1;
+ done;
+ b.position <- !position;
+ add_char b '\n'
diff --git a/analysis/src/vendor/res_outcome_printer/res_minibuffer.mli b/analysis/src/vendor/res_outcome_printer/res_minibuffer.mli
new file mode 100644
index 000000000..0a2bffa53
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_minibuffer.mli
@@ -0,0 +1,6 @@
+type t
+val add_char : t -> char -> unit
+val add_string : t -> string -> unit
+val contents : t -> string
+val create : int -> t
+val flush_newline : t -> unit
diff --git a/analysis/src/vendor/res_outcome_printer/res_outcome_printer.ml b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.ml
new file mode 100644
index 000000000..7300bef4e
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_outcome_printer.ml
@@ -0,0 +1,1148 @@
+(* For the curious: the outcome printer is a printer to print data
+ * from the outcometree.mli file in the ocaml compiler.
+ * The outcome tree is used by:
+ * - ocaml's toplevel/repl, print results/errors
+ * - super errors, print nice errors
+ * - editor tooling, e.g. show type on hover
+ *
+ * In general it represent messages to show results or errors to the user. *)
+
+module Doc = Res_doc
+module Token = Res_token
+
+(* checks if ident contains "arity", like in "arity1", "arity2", "arity3" etc. *)
+let isArityIdent ident =
+ if String.length ident >= 6 then
+ (String.sub [@doesNotRaise]) ident 0 5 = "arity"
+ else
+ false
+
+type identifierStyle =
+ | ExoticIdent
+ | NormalIdent
+
+let classifyIdentContent ~allowUident txt =
+ let len = String.length txt in
+ let rec go i =
+ if i == len then NormalIdent
+ else
+ let c = String.unsafe_get txt i in
+ if i == 0 && not (
+ (allowUident && (c >= 'A' && c <= 'Z')) ||
+ (c >= 'a' && c <= 'z') || c = '_') then
+ ExoticIdent
+ else if not (
+ (c >= 'a' && c <= 'z')
+ || (c >= 'A' && c <= 'Z')
+ || c = '\''
+ || c = '_'
+ || (c >= '0' && c <= '9'))
+ then
+ ExoticIdent
+ else
+ go (i + 1)
+ in
+ if Token.isKeywordTxt txt then
+ ExoticIdent
+ else
+ go 0
+
+let printIdentLike ~allowUident txt =
+ match classifyIdentContent ~allowUident txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\\\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+let printPolyVarIdent txt =
+ match classifyIdentContent ~allowUident:true txt with
+ | ExoticIdent -> Doc.concat [
+ Doc.text "\"";
+ Doc.text txt;
+ Doc.text"\""
+ ]
+ | NormalIdent -> Doc.text txt
+
+ (* ReScript doesn't have parenthesized identifiers.
+ * We don't support custom operators. *)
+ let parenthesized_ident _name = true
+
+ (* TODO: better allocation strategy for the buffer *)
+ let escapeStringContents s =
+ let len = String.length s in
+ let b = Buffer.create len in
+ for i = 0 to len - 1 do
+ let c = (String.get [@doesNotRaise]) s i in
+ if c = '\008' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b 'b';
+ ) else if c = '\009' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b 't';
+ ) else if c = '\010' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b 'n';
+ ) else if c = '\013' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b 'r';
+ ) else if c = '\034' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b '"';
+ ) else if c = '\092' then (
+ Buffer.add_char b '\\';
+ Buffer.add_char b '\\';
+ ) else (
+ Buffer.add_char b c;
+ );
+ done;
+ Buffer.contents b
+
+ (* let rec print_ident fmt ident = match ident with
+ | Outcometree.Oide_ident s -> Format.pp_print_string fmt s
+ | Oide_dot (id, s) ->
+ print_ident fmt id;
+ Format.pp_print_char fmt '.';
+ Format.pp_print_string fmt s
+ | Oide_apply (id1, id2) ->
+ print_ident fmt id1;
+ Format.pp_print_char fmt '(';
+ print_ident fmt id2;
+ Format.pp_print_char fmt ')' *)
+
+ let rec printOutIdentDoc ?(allowUident=true) (ident : Outcometree.out_ident) =
+ match ident with
+ | Oide_ident s -> printIdentLike ~allowUident s
+ | Oide_dot (ident, s) -> Doc.concat [
+ printOutIdentDoc ident;
+ Doc.dot;
+ Doc.text s;
+ ]
+ | Oide_apply (call, arg) ->Doc.concat [
+ printOutIdentDoc call;
+ Doc.lparen;
+ printOutIdentDoc arg;
+ Doc.rparen;
+ ]
+
+ let printOutAttributeDoc (outAttribute: Outcometree.out_attribute) =
+ Doc.concat [
+ Doc.text "@";
+ Doc.text outAttribute.oattr_name;
+ ]
+
+ let printOutAttributesDoc (attrs: Outcometree.out_attribute list) =
+ match attrs with
+ | [] -> Doc.nil
+ | attrs ->
+ Doc.concat [
+ Doc.group (
+ Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)
+ );
+ Doc.line;
+ ]
+
+ let rec collectArrowArgs (outType: Outcometree.out_type) args =
+ match outType with
+ | Otyp_arrow (label, argType, returnType) ->
+ let arg = (label, argType) in
+ collectArrowArgs returnType (arg::args)
+ | _ as returnType ->
+ (List.rev args, returnType)
+
+ let rec collectFunctorArgs (outModuleType: Outcometree.out_module_type) args =
+ match outModuleType with
+ | Omty_functor (lbl, optModType, returnModType) ->
+ let arg = (lbl, optModType) in
+ collectFunctorArgs returnModType (arg::args)
+ | _ ->
+ (List.rev args, outModuleType)
+
+ let rec printOutTypeDoc (outType: Outcometree.out_type) =
+ match outType with
+ | Otyp_abstract | Otyp_open -> Doc.nil
+ | Otyp_variant (nonGen, outVariant, closed, labels) ->
+ (* bool * out_variant * bool * (string list) option *)
+ let opening = match (closed, labels) with
+ | (true, None) -> (* [#A | #B] *) Doc.softLine
+ | (false, None) ->
+ (* [> #A | #B] *)
+ Doc.concat [Doc.greaterThan; Doc.line]
+ | (true, Some []) ->
+ (* [< #A | #B] *)
+ Doc.concat [Doc.lessThan; Doc.line]
+ | (true, Some _) ->
+ (* [< #A | #B > #X #Y ] *)
+ Doc.concat [Doc.lessThan; Doc.line]
+ | (false, Some _) ->
+ (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *)
+ Doc.concat [Doc.text "?"; Doc.line]
+ in
+ Doc.group (
+ Doc.concat [
+ if nonGen then Doc.text "_" else Doc.nil;
+ Doc.lbracket;
+ Doc.indent (
+ Doc.concat [
+ opening;
+ printOutVariant outVariant
+ ]
+ );
+ begin match labels with
+ | None | Some [] -> Doc.nil
+ | Some tags ->
+ Doc.group (
+ Doc.concat [
+ Doc.space;
+ Doc.join ~sep:Doc.space (
+ List.map (fun lbl -> printIdentLike ~allowUident:true lbl) tags
+ )
+ ]
+ )
+ end;
+ Doc.softLine;
+ Doc.rbracket;
+ ]
+ )
+ | Otyp_alias (typ, aliasTxt) ->
+ Doc.concat [
+ printOutTypeDoc typ;
+ Doc.text " as '";
+ Doc.text aliasTxt
+ ]
+ | Otyp_constr (
+ Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , "arity0"), (* Js.Fn.arity0 *)
+ [Otyp_constr (Oide_ident ident, [])] (* int or unit or string *)
+ ) ->
+ (* Js.Fn.arity0 -> (.) => int*)
+ Doc.concat [
+ Doc.text "(.) => ";
+ Doc.text ident;
+ ]
+ | Otyp_constr (
+ Oide_dot (Oide_dot (Oide_ident "Js", "Fn") , ident), (* Js.Fn.arity2 *)
+ [(Otyp_arrow _) as arrowType] (* (int, int) => int *)
+ ) when isArityIdent ident ->
+ (* Js.Fn.arity2<(int, int) => int> -> (. int, int) => int*)
+ printOutArrowType ~uncurried:true arrowType
+ | Otyp_constr (outIdent, []) ->
+ printOutIdentDoc ~allowUident:false outIdent
+ | Otyp_manifest (typ1, typ2) ->
+ Doc.concat [
+ printOutTypeDoc typ1;
+ Doc.text " = ";
+ printOutTypeDoc typ2;
+ ]
+ | Otyp_record record ->
+ printRecordDeclarationDoc ~inline:true record
+ | Otyp_stuff txt -> Doc.text txt
+ | Otyp_var (ng, s) -> Doc.concat [
+ Doc.text ("'" ^ (if ng then "_" else ""));
+ Doc.text s
+ ]
+ | Otyp_object (fields, rest) -> printObjectFields fields rest
+ | Otyp_class _ -> Doc.nil
+ | Otyp_attribute (typ, attribute) ->
+ Doc.group (
+ Doc.concat [
+ printOutAttributeDoc attribute;
+ Doc.line;
+ printOutTypeDoc typ;
+ ]
+ )
+ (* example: Red | Blue | Green | CustomColour(float, float, float) *)
+ | Otyp_sum constructors ->
+ printOutConstructorsDoc constructors
+
+ (* example: {"name": string, "age": int} *)
+ | Otyp_constr (
+ (Oide_dot ((Oide_ident "Js"), "t")),
+ [Otyp_object (fields, rest)]
+ ) -> printObjectFields fields rest
+
+ (* example: node *)
+ | Otyp_constr (outIdent, args) ->
+ let argsDoc = match args with
+ | [] -> Doc.nil
+ | args ->
+ Doc.concat [
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutTypeDoc args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.greaterThan;
+ ]
+ in
+ Doc.group (
+ Doc.concat [
+ printOutIdentDoc outIdent;
+ argsDoc;
+ ]
+ )
+ | Otyp_tuple tupleArgs ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutTypeDoc tupleArgs
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ | Otyp_poly (vars, outType) ->
+ Doc.group (
+ Doc.concat [
+ Doc.join ~sep:Doc.space (
+ List.map (fun var -> Doc.text ("'" ^ var)) vars
+ );
+ Doc.dot;
+ Doc.space;
+ printOutTypeDoc outType;
+ ]
+ )
+ | Otyp_arrow _ as typ ->
+ printOutArrowType ~uncurried:false typ
+ | Otyp_module (_modName, _stringList, _outTypes) ->
+ Doc.nil
+
+ and printOutArrowType ~uncurried typ =
+ let (typArgs, typ) = collectArrowArgs typ [] in
+ let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (lbl, typ) ->
+ if lbl = "" then
+ printOutTypeDoc typ
+ else
+ Doc.group (
+ Doc.concat [
+ Doc.text ("~" ^ lbl ^ ": ");
+ printOutTypeDoc typ
+ ]
+ )
+ ) typArgs
+ ) in
+ let argsDoc =
+ let needsParens = match typArgs with
+ | _ when uncurried -> true
+ | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true
+ (* single argument should not be wrapped *)
+ | ["", _] -> false
+ | _ -> true
+ in
+ if needsParens then
+ Doc.group (
+ Doc.concat [
+ if uncurried then Doc.text "(. " else Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ args;
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ else args
+ in
+ Doc.concat [
+ argsDoc;
+ Doc.text " => ";
+ printOutTypeDoc typ;
+ ]
+
+
+ and printOutVariant variant = match variant with
+ | Ovar_fields fields -> (* (string * bool * out_type list) list *)
+ Doc.join ~sep:Doc.line (
+ (*
+ * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand
+ * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand
+ *)
+ List.mapi (fun i (name, ampersand, types) ->
+ let needsParens = match types with
+ | [(Outcometree.Otyp_tuple _)] -> false
+ | _ -> true
+ in
+ Doc.concat [
+ if i > 0 then
+ Doc.text "| "
+ else
+ Doc.ifBreaks (Doc.text "| ") Doc.nil;
+ Doc.group (
+ Doc.concat [
+ Doc.text "#";
+ printPolyVarIdent name;
+ match types with
+ | [] -> Doc.nil
+ | types ->
+ Doc.concat [
+ if ampersand then Doc.text " & " else Doc.nil;
+ Doc.indent (
+ Doc.concat [
+ Doc.join ~sep:(Doc.concat [Doc.text " &"; Doc.line])
+ (List.map (fun typ ->
+ let outTypeDoc = printOutTypeDoc typ in
+ if needsParens then
+ Doc.concat [Doc.lparen; outTypeDoc; Doc.rparen]
+ else
+ outTypeDoc
+ ) types)
+ ];
+ );
+ ]
+ ]
+ )
+ ]
+ ) fields
+ )
+ | Ovar_typ typ -> printOutTypeDoc typ
+
+ and printObjectFields fields rest =
+ let dots = match rest with
+ | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..")
+ | None -> Doc.nil
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.lbrace;
+ dots;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (lbl, outType) -> Doc.group (
+ Doc.concat [
+ Doc.text ("\"" ^ lbl ^ "\": ");
+ printOutTypeDoc outType;
+ ]
+ )) fields
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+
+
+ and printOutConstructorsDoc constructors =
+ Doc.group (
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ Doc.join ~sep:Doc.line (
+ List.mapi (fun i constructor ->
+ Doc.concat [
+ if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil;
+ printOutConstructorDoc constructor;
+ ]
+ ) constructors
+ )
+ ]
+ )
+ )
+
+ and printOutConstructorDoc (name, args, gadt) =
+ let gadtDoc = match gadt with
+ | Some outType ->
+ Doc.concat [
+ Doc.text ": ";
+ printOutTypeDoc outType
+ ]
+ | None -> Doc.nil
+ in
+ let argsDoc = match args with
+ | [] -> Doc.nil
+ | [Otyp_record record] ->
+ (* inline records
+ * | Root({
+ * mutable value: 'value,
+ * mutable updatedTime: float,
+ * })
+ *)
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ printRecordDeclarationDoc ~inline:true record;
+ );
+ Doc.rparen;
+ ]
+ | _types ->
+ Doc.indent (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutTypeDoc args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.text name;
+ argsDoc;
+ gadtDoc
+ ]
+ )
+
+ and printRecordDeclRowDoc (name, mut, arg) =
+ Doc.group (
+ Doc.concat [
+ if mut then Doc.text "mutable " else Doc.nil;
+ printIdentLike ~allowUident:false name;
+ Doc.text ": ";
+ printOutTypeDoc arg;
+ ]
+ )
+
+ and printRecordDeclarationDoc ~inline rows =
+ let content = Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printRecordDeclRowDoc rows
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbrace;
+ ] in
+ if not inline then
+ Doc.group content
+ else content
+
+ let printOutType fmt outType =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutTypeDoc outType))
+
+ let printTypeParameterDoc (typ, (co, cn)) =
+ Doc.concat [
+ if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil;
+ if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)
+ ]
+
+
+ let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) =
+ match outSigItem with
+ | Osig_class _ | Osig_class_type _ -> Doc.nil
+ | Osig_ellipsis -> Doc.dotdotdot
+ | Osig_value valueDecl ->
+ Doc.group (
+ Doc.concat [
+ printOutAttributesDoc valueDecl.oval_attributes;
+ Doc.text (
+ match valueDecl.oval_prims with | [] -> "let " | _ -> "external "
+ );
+ Doc.text valueDecl.oval_name;
+ Doc.text ":";
+ Doc.space;
+ printOutTypeDoc valueDecl.oval_type;
+ match valueDecl.oval_prims with
+ | [] -> Doc.nil
+ | primitives -> Doc.indent (
+ Doc.concat [
+ Doc.text " =";
+ Doc.line;
+ Doc.group (
+ Doc.join ~sep:Doc.line (List.map (fun prim -> Doc.text ("\"" ^ prim ^ "\"")) primitives)
+ )
+ ]
+ )
+ ]
+ )
+ | Osig_typext (outExtensionConstructor, _outExtStatus) ->
+ printOutExtensionConstructorDoc outExtensionConstructor
+ | Osig_modtype (modName, Omty_signature []) ->
+ Doc.concat [
+ Doc.text "module type ";
+ Doc.text modName;
+ ]
+ | Osig_modtype (modName, outModuleType) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "module type ";
+ Doc.text modName;
+ Doc.text " = ";
+ printOutModuleTypeDoc outModuleType;
+ ]
+ )
+ | Osig_module (modName, Omty_alias ident, _) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "module ";
+ Doc.text modName;
+ Doc.text " =";
+ Doc.line;
+ printOutIdentDoc ident;
+ ]
+ )
+ | Osig_module (modName, outModType, outRecStatus) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text (
+ match outRecStatus with
+ | Orec_not -> "module "
+ | Orec_first -> "module rec "
+ | Orec_next -> "and"
+ );
+ Doc.text modName;
+ Doc.text " = ";
+ printOutModuleTypeDoc outModType;
+ ]
+ )
+ | Osig_type (outTypeDecl, outRecStatus) ->
+ (* TODO: manifest ? *)
+ let attrs = match outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed with
+ | false, false -> Doc.nil
+ | true, false ->
+ Doc.concat [Doc.text "@immediate"; Doc.line]
+ | false, true ->
+ Doc.concat [Doc.text "@unboxed"; Doc.line]
+ | true, true ->
+ Doc.concat [Doc.text "@immediate @unboxed"; Doc.line]
+ in
+ let kw = Doc.text (
+ match outRecStatus with
+ | Orec_not -> "type "
+ | Orec_first -> "type rec "
+ | Orec_next -> "and "
+ ) in
+ let typeParams = match outTypeDecl.otype_params with
+ | [] -> Doc.nil
+ | _params -> Doc.group (
+ Doc.concat [
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printTypeParameterDoc outTypeDecl.otype_params
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.greaterThan;
+ ]
+ )
+ in
+ let privateDoc = match outTypeDecl.otype_private with
+ | Asttypes.Private -> Doc.text "private "
+ | Public -> Doc.nil
+ in
+ let kind = match outTypeDecl.otype_type with
+ | Otyp_open -> Doc.concat [
+ Doc.text " = ";
+ privateDoc;
+ Doc.text "..";
+ ]
+ | Otyp_abstract -> Doc.nil
+ | Otyp_record record -> Doc.concat [
+ Doc.text " = ";
+ privateDoc;
+ printRecordDeclarationDoc ~inline:false record;
+ ]
+ | typ -> Doc.concat [
+ Doc.text " = ";
+ printOutTypeDoc typ
+ ]
+ in
+ let constraints = match outTypeDecl.otype_cstrs with
+ | [] -> Doc.nil
+ | _ -> Doc.group (
+ Doc.indent (
+ Doc.concat [
+ Doc.hardLine;
+ Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "constraint ";
+ printOutTypeDoc typ1;
+ Doc.text " =";
+ Doc.space;
+ printOutTypeDoc typ2;
+ ]
+ )
+ ) outTypeDecl.otype_cstrs)
+ ]
+ )
+ ) in
+ Doc.group (
+ Doc.concat [
+ attrs;
+ Doc.group (
+ Doc.concat [
+ attrs;
+ kw;
+ printIdentLike ~allowUident:false outTypeDecl.otype_name;
+ typeParams;
+ kind
+ ]
+ );
+ constraints
+ ]
+ )
+
+ and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) =
+ match outModType with
+ | Omty_abstract -> Doc.nil
+ | Omty_ident ident -> printOutIdentDoc ident
+ (* example: module Increment = (M: X_int) => X_int *)
+ | Omty_functor _ ->
+ let (args, returnModType) = collectFunctorArgs outModType [] in
+ let argsDoc = match args with
+ | [_, None] -> Doc.text "()"
+ | args ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (lbl, optModType) -> Doc.group (
+ Doc.concat [
+ Doc.text lbl;
+ match optModType with
+ | None -> Doc.nil
+ | Some modType -> Doc.concat [
+ Doc.text ": ";
+ printOutModuleTypeDoc modType;
+ ]
+ ]
+ )) args
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ in
+ Doc.group (
+ Doc.concat [
+ argsDoc;
+ Doc.text " => ";
+ printOutModuleTypeDoc returnModType
+ ]
+ )
+ | Omty_signature [] -> Doc.nil
+ | Omty_signature signature ->
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.concat [
+ Doc.lbrace;
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printOutSignatureDoc signature;
+ ]
+ );
+ Doc.softLine;
+ Doc.rbrace;
+ ]
+ )
+ | Omty_alias _ident -> Doc.nil
+
+ and printOutSignatureDoc (signature : Outcometree.out_sig_item list) =
+ let rec loop signature acc =
+ match signature with
+ | [] -> List.rev acc
+ | Outcometree.Osig_typext(ext, Oext_first) :: items ->
+ (* Gather together the extension constructors *)
+ let rec gather_extensions acc items =
+ match items with
+ Outcometree.Osig_typext(ext, Oext_next) :: items ->
+ gather_extensions
+ ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc)
+ items
+ | _ -> (List.rev acc, items)
+ in
+ let exts, items =
+ gather_extensions
+ [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+ items
+ in
+ let te =
+ { Outcometree.otyext_name = ext.oext_type_name;
+ otyext_params = ext.oext_type_params;
+ otyext_constructors = exts;
+ otyext_private = ext.oext_private }
+ in
+ let doc = printOutTypeExtensionDoc te in
+ loop items (doc::acc)
+ | item::items ->
+ let doc = printOutSigItemDoc item in
+ loop items (doc::acc)
+ in
+ match loop signature [] with
+ | [doc] -> doc
+ | docs ->
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.join ~sep:Doc.line docs
+ )
+
+ and printOutExtensionConstructorDoc (outExt : Outcometree.out_extension_constructor) =
+ let typeParams = match outExt.oext_type_params with
+ | [] -> Doc.nil
+ | params ->
+ Doc.group(
+ Doc.concat [
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map
+ (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty))
+ params
+
+ )
+ ]
+ );
+ Doc.softLine;
+ Doc.greaterThan;
+ ]
+ )
+
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.text "type ";
+ printIdentLike ~allowUident:false outExt.oext_type_name;
+ typeParams;
+ Doc.text " += ";
+ Doc.line;
+ if outExt.oext_private = Asttypes.Private then
+ Doc.text "private "
+ else
+ Doc.nil;
+ printOutConstructorDoc
+ (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type)
+ ]
+ )
+
+ and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) =
+ let typeParams = match typeExtension.otyext_params with
+ | [] -> Doc.nil
+ | params ->
+ Doc.group(
+ Doc.concat [
+ Doc.lessThan;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map
+ (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty))
+ params
+
+ )
+ ]
+ );
+ Doc.softLine;
+ Doc.greaterThan;
+ ]
+ )
+
+ in
+ Doc.group (
+ Doc.concat [
+ Doc.text "type ";
+ printIdentLike ~allowUident:false typeExtension.otyext_name;
+ typeParams;
+ Doc.text " += ";
+ if typeExtension.otyext_private = Asttypes.Private then
+ Doc.text "private "
+ else
+ Doc.nil;
+ printOutConstructorsDoc typeExtension.otyext_constructors;
+ ]
+ )
+
+ let printOutSigItem fmt outSigItem =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutSigItemDoc outSigItem))
+
+ let printOutSignature fmt signature =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutSignatureDoc signature))
+
+ let validFloatLexeme s =
+ let l = String.length s in
+ let rec loop i =
+ if i >= l then s ^ "." else
+ match (s.[i] [@doesNotRaise]) with
+ | '0' .. '9' | '-' -> loop (i+1)
+ | _ -> s
+ in loop 0
+
+ let floatRepres f =
+ match classify_float f with
+ | FP_nan -> "nan"
+ | FP_infinite ->
+ if f < 0.0 then "neg_infinity" else "infinity"
+ | _ ->
+ let float_val =
+ let s1 = Printf.sprintf "%.12g" f in
+ if f = (float_of_string [@doesNotRaise]) s1 then s1 else
+ let s2 = Printf.sprintf "%.15g" f in
+ if f = (float_of_string [@doesNotRaise]) s2 then s2 else
+ Printf.sprintf "%.18g" f
+ in validFloatLexeme float_val
+
+ let rec printOutValueDoc (outValue : Outcometree.out_value) =
+ match outValue with
+ | Oval_array outValues ->
+ Doc.group (
+ Doc.concat [
+ Doc.lbracket;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutValueDoc outValues
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbracket;
+ ]
+ )
+ | Oval_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'")
+ | Oval_constr (outIdent, outValues) ->
+ Doc.group (
+ Doc.concat [
+ printOutIdentDoc outIdent;
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutValueDoc outValues
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ | Oval_ellipsis -> Doc.text "..."
+ | Oval_int i -> Doc.text (Format.sprintf "%i" i)
+ | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i)
+ | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i)
+ | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i)
+ | Oval_float f -> Doc.text (floatRepres f)
+ | Oval_list outValues ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "list[";
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutValueDoc outValues
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rbracket;
+ ]
+ )
+ | Oval_printer fn ->
+ let fmt = Format.str_formatter in
+ fn fmt;
+ let str = Format.flush_str_formatter () in
+ Doc.text str
+ | Oval_record rows ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map (fun (outIdent, outValue) -> Doc.group (
+ Doc.concat [
+ printOutIdentDoc outIdent;
+ Doc.text ": ";
+ printOutValueDoc outValue;
+ ]
+ )
+ ) rows
+ );
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ | Oval_string (txt, _sizeToPrint, _kind) ->
+ Doc.text (escapeStringContents txt)
+ | Oval_stuff txt -> Doc.text txt
+ | Oval_tuple outValues ->
+ Doc.group (
+ Doc.concat [
+ Doc.lparen;
+ Doc.indent (
+ Doc.concat [
+ Doc.softLine;
+ Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (
+ List.map printOutValueDoc outValues
+ )
+ ]
+ );
+ Doc.trailingComma;
+ Doc.softLine;
+ Doc.rparen;
+ ]
+ )
+ (* Not supported by ReScript *)
+ | Oval_variant _ -> Doc.nil
+
+ let printOutExceptionDoc exc outValue =
+ match exc with
+ | Sys.Break -> Doc.text "Interrupted."
+ | Out_of_memory -> Doc.text "Out of memory during evaluation."
+ | Stack_overflow ->
+ Doc.text "Stack overflow during evaluation (looping recursion?)."
+ | _ ->
+ Doc.group (
+ Doc.indent(
+ Doc.concat [
+ Doc.text "Exception:";
+ Doc.line;
+ printOutValueDoc outValue;
+ ]
+ )
+ )
+
+ let printOutPhraseSignature signature =
+ let rec loop signature acc =
+ match signature with
+ | [] -> List.rev acc
+ | (Outcometree.Osig_typext(ext, Oext_first), None)::signature ->
+ (* Gather together extension constructors *)
+ let rec gather_extensions acc items =
+ match items with
+ | (Outcometree.Osig_typext(ext, Oext_next), None)::items ->
+ gather_extensions
+ ((ext.oext_name, ext.oext_args, ext.oext_ret_type)::acc)
+ items
+ | _ -> (List.rev acc, items)
+ in
+ let exts, signature =
+ gather_extensions
+ [(ext.oext_name, ext.oext_args, ext.oext_ret_type)]
+ signature
+ in
+ let te =
+ { Outcometree.otyext_name = ext.oext_type_name;
+ otyext_params = ext.oext_type_params;
+ otyext_constructors = exts;
+ otyext_private = ext.oext_private }
+ in
+ let doc = printOutTypeExtensionDoc te in
+ loop signature (doc::acc)
+ | (sigItem, optOutValue)::signature ->
+ let doc = match optOutValue with
+ | None ->
+ printOutSigItemDoc sigItem
+ | Some outValue ->
+ Doc.group (
+ Doc.concat [
+ printOutSigItemDoc sigItem;
+ Doc.text " = ";
+ printOutValueDoc outValue;
+ ]
+ )
+ in
+ loop signature (doc::acc)
+ in
+ Doc.breakableGroup ~forceBreak:true (
+ Doc.join ~sep:Doc.line (loop signature [])
+ )
+
+ let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) =
+ match outPhrase with
+ | Ophr_eval (outValue, outType) ->
+ Doc.group (
+ Doc.concat [
+ Doc.text "- : ";
+ printOutTypeDoc outType;
+ Doc.text " =";
+ Doc.indent (
+ Doc.concat [
+ Doc.line;
+ printOutValueDoc outValue;
+ ]
+ )
+ ]
+ )
+ | Ophr_signature [] -> Doc.nil
+ | Ophr_signature signature -> printOutPhraseSignature signature
+ | Ophr_exception (exc, outValue) ->
+ printOutExceptionDoc exc outValue
+
+ let printOutPhrase fmt outPhrase =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutPhraseDoc outPhrase))
+
+ let printOutModuleType fmt outModuleType =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType))
+
+ let printOutTypeExtension fmt typeExtension =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension))
+
+ let printOutValue fmt outValue =
+ Format.pp_print_string fmt
+ (Doc.toString ~width:80 (printOutValueDoc outValue))
+
+
+
+
+
+(* Not supported in ReScript *)
+(* Oprint.out_class_type *)
+ let setup = lazy begin
+ Oprint.out_value := printOutValue;
+ Oprint.out_type := printOutType;
+ Oprint.out_module_type := printOutModuleType;
+ Oprint.out_sig_item := printOutSigItem;
+ Oprint.out_signature := printOutSignature;
+ Oprint.out_type_extension := printOutTypeExtension;
+ Oprint.out_phrase := printOutPhrase
+ end
+
diff --git a/analysis/src/vendor/res_outcome_printer/res_token.ml b/analysis/src/vendor/res_outcome_printer/res_token.ml
new file mode 100644
index 000000000..a14491dd6
--- /dev/null
+++ b/analysis/src/vendor/res_outcome_printer/res_token.ml
@@ -0,0 +1,213 @@
+module Comment = Res_comment
+
+type t =
+ | Open
+ | True | False
+ | Character of char
+ | Int of {i: string; suffix: char option}
+ | Float of {f: string; suffix: char option}
+ | String of string
+ | Lident of string
+ | Uident of string
+ | As
+ | Dot | DotDot | DotDotDot
+ | Bang
+ | Semicolon
+ | Let
+ | And
+ | Rec
+ | Underscore
+ | SingleQuote
+ | Equal | EqualEqual | EqualEqualEqual
+ | Bar
+ | Lparen
+ | Rparen
+ | Lbracket
+ | Rbracket
+ | Lbrace
+ | Rbrace
+ | Colon
+ | Comma
+ | Eof
+ | Exception
+ | Backslash [@live]
+ | Forwardslash | ForwardslashDot
+ | Asterisk | AsteriskDot | Exponentiation
+ | Minus | MinusDot
+ | Plus | PlusDot | PlusPlus | PlusEqual
+ | ColonGreaterThan
+ | GreaterThan
+ | LessThan
+ | LessThanSlash
+ | Hash | HashEqual
+ | Assert
+ | Lazy
+ | Tilde
+ | Question
+ | If | Else | For | In | While | Switch
+ | When
+ | EqualGreater | MinusGreater
+ | External
+ | Typ
+ | Private
+ | Mutable
+ | Constraint
+ | Include
+ | Module
+ | Of
+ | Land | Lor
+ | Band (* Bitwise and: & *)
+ | BangEqual | BangEqualEqual
+ | LessEqual | GreaterEqual
+ | ColonEqual
+ | At | AtAt
+ | Percent | PercentPercent
+ | Comment of Comment.t
+ | List
+ | TemplateTail of string
+ | TemplatePart of string
+ | Backtick
+ | BarGreater
+ | Try
+ | Import
+ | Export
+
+let precedence = function
+ | HashEqual | ColonEqual -> 1
+ | Lor -> 2
+ | Land -> 3
+ | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan
+ | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4
+ | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5
+ | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6
+ | Exponentiation -> 7
+ | MinusGreater -> 8
+ | Dot -> 9
+ | _ -> 0
+
+let toString = function
+ | Open -> "open"
+ | True -> "true" | False -> "false"
+ | Character c -> "character '" ^ (Char.escaped c) ^ "'"
+ | String s -> "string \"" ^ s ^ "\""
+ | Lident str -> str
+ | Uident str -> str
+ | Dot -> "." | DotDot -> ".." | DotDotDot -> "..."
+ | Int {i} -> "int " ^ i
+ | Float {f} -> "Float: " ^ f
+ | Bang -> "!"
+ | Semicolon -> ";"
+ | Let -> "let"
+ | And -> "and"
+ | Rec -> "rec"
+ | Underscore -> "_"
+ | SingleQuote -> "'"
+ | Equal -> "=" | EqualEqual -> "==" | EqualEqualEqual -> "==="
+ | Eof -> "eof"
+ | Bar -> "|"
+ | As -> "as"
+ | Lparen -> "(" | Rparen -> ")"
+ | Lbracket -> "[" | Rbracket -> "]"
+ | Lbrace -> "{" | Rbrace -> "}"
+ | ColonGreaterThan -> ":>"
+ | Colon -> ":"
+ | Comma -> ","
+ | Minus -> "-" | MinusDot -> "-."
+ | Plus -> "+" | PlusDot -> "+." | PlusPlus -> "++" | PlusEqual -> "+="
+ | Backslash -> "\\"
+ | Forwardslash -> "/" | ForwardslashDot -> "/."
+ | Exception -> "exception"
+ | Hash -> "#" | HashEqual -> "#="
+ | GreaterThan -> ">"
+ | LessThan -> "<"
+ | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**"
+ | Assert -> "assert"
+ | Lazy -> "lazy"
+ | Tilde -> "tilde"
+ | Question -> "?"
+ | If -> "if"
+ | Else -> "else"
+ | For -> "for"
+ | In -> "in"
+ | While -> "while"
+ | Switch -> "switch"
+ | When -> "when"
+ | EqualGreater -> "=>" | MinusGreater -> "->"
+ | External -> "external"
+ | Typ -> "type"
+ | Private -> "private"
+ | Constraint -> "constraint"
+ | Mutable -> "mutable"
+ | Include -> "include"
+ | Module -> "module"
+ | Of -> "of"
+ | Lor -> "||"
+ | Band -> "&" | Land -> "&&"
+ | BangEqual -> "!=" | BangEqualEqual -> "!=="
+ | GreaterEqual -> ">=" | LessEqual -> "<="
+ | ColonEqual -> ":="
+ | At -> "@" | AtAt -> "@@"
+ | Percent -> "%" | PercentPercent -> "%%"
+ | Comment c -> "Comment" ^ (Comment.toString c)
+ | List -> "list{"
+ | TemplatePart text -> text ^ "${"
+ | TemplateTail text -> "TemplateTail(" ^ text ^ ")"
+ | Backtick -> "`"
+ | BarGreater -> "|>"
+ | Try -> "try"
+ | Import -> "import"
+ | Export -> "export"
+
+let keywordTable = function
+| "and" -> And
+| "as" -> As
+| "assert" -> Assert
+| "constraint" -> Constraint
+| "else" -> Else
+| "exception" -> Exception
+| "export" -> Export
+| "external" -> External
+| "false" -> False
+| "for" -> For
+| "if" -> If
+| "import" -> Import
+| "in" -> In
+| "include" -> Include
+| "lazy" -> Lazy
+| "let" -> Let
+| "list{" -> List
+| "module" -> Module
+| "mutable" -> Mutable
+| "of" -> Of
+| "open" -> Open
+| "private" -> Private
+| "rec" -> Rec
+| "switch" -> Switch
+| "true" -> True
+| "try" -> Try
+| "type" -> Typ
+| "when" -> When
+| "while" -> While
+| _ -> raise Not_found
+[@@raises Not_found]
+
+let isKeyword = function
+ | And | As | Assert | Constraint | Else | Exception | Export
+ | External | False | For | If | Import | In | Include | Land | Lazy
+ | Let | List | Lor | Module | Mutable | Of | Open | Private | Rec
+ | Switch | True | Try | Typ | When | While -> true
+ | _ -> false
+
+let lookupKeyword str =
+ try keywordTable str with
+ | Not_found ->
+ match str.[0] [@doesNotRaise] with
+ | 'A'..'Z' -> Uident str
+ | _ -> Lident str
+
+let isKeywordTxt str =
+ try let _ = keywordTable str in true with
+ | Not_found -> false
+
+let catch = Lident "catch"
diff --git a/analysis/test.sh b/analysis/test.sh
new file mode 100755
index 000000000..5a2fa163e
--- /dev/null
+++ b/analysis/test.sh
@@ -0,0 +1,19 @@
+function exp {
+ echo "$(dirname $1)/expected/$(basename $1).txt"
+}
+
+for file in tests/src/*.res; do
+ ../server/analysis_binaries/current-platform.exe test $file &> $(exp $file)
+done
+
+warningYellow='\033[0;33m'
+successGreen='\033[0;32m'
+reset='\033[0m'
+
+diff=$(git ls-files --modified tests/src/expected)
+if [[ $diff = "" ]]; then
+ printf "${successGreen}✅ No unstaged tests difference.${reset}\n"
+else
+ printf "${warningYellow}⚠️ There are unstaged differences in tests/! Did you break a test?\n${diff}\n${reset}"
+ exit 1
+fi
diff --git a/analysis/tests/bsconfig.json b/analysis/tests/bsconfig.json
new file mode 100644
index 000000000..a65991b94
--- /dev/null
+++ b/analysis/tests/bsconfig.json
@@ -0,0 +1,6 @@
+{
+ "name": "test",
+ "sources": "src",
+ "bs-dependencies": ["reason-react"],
+ "reason": { "react-jsx": 3 }
+}
diff --git a/analysis/tests/package-lock.json b/analysis/tests/package-lock.json
new file mode 100644
index 000000000..223207d01
--- /dev/null
+++ b/analysis/tests/package-lock.json
@@ -0,0 +1,47 @@
+{
+ "name": "tests",
+ "lockfileVersion": 2,
+ "requires": true,
+ "packages": {
+ "": {
+ "dependencies": {
+ "reason-react": "^0.9.1"
+ },
+ "devDependencies": {
+ "rescript": "9.1.1"
+ }
+ },
+ "node_modules/reason-react": {
+ "version": "0.9.1",
+ "license": "MIT",
+ "peerDependencies": {
+ "bs-platform": "^7.1.1",
+ "react": "^16.8.1",
+ "react-dom": "^16.8.1"
+ }
+ },
+ "node_modules/rescript": {
+ "version": "9.1.1",
+ "dev": true,
+ "hasInstallScript": true,
+ "license": "SEE LICENSE IN LICENSE",
+ "bin": {
+ "bsb": "bsb",
+ "bsc": "bsc",
+ "bsrefmt": "bsrefmt",
+ "bstracing": "lib/bstracing",
+ "rescript": "rescript"
+ }
+ }
+ },
+ "dependencies": {
+ "reason-react": {
+ "version": "0.9.1",
+ "requires": {}
+ },
+ "rescript": {
+ "version": "9.1.1",
+ "dev": true
+ }
+ }
+}
diff --git a/analysis/tests/package.json b/analysis/tests/package.json
new file mode 100644
index 000000000..79294d08b
--- /dev/null
+++ b/analysis/tests/package.json
@@ -0,0 +1,13 @@
+{
+ "dependencies": {
+ "reason-react": "^0.9.1"
+ },
+ "devDependencies": {
+ "rescript": "9.1.1"
+ },
+ "scripts": {
+ "build": "bsb -make-world",
+ "start": "bsb -make-world -w",
+ "clean": "bsb -clean"
+ }
+}
diff --git a/analysis/tests/src/Auto.res b/analysis/tests/src/Auto.res
new file mode 100644
index 000000000..c33d1614b
--- /dev/null
+++ b/analysis/tests/src/Auto.res
@@ -0,0 +1,4 @@
+open! Belt
+
+let m = List.map
+// ^hov
\ No newline at end of file
diff --git a/analysis/tests/src/Complete.res b/analysis/tests/src/Complete.res
new file mode 100644
index 000000000..8b3bd744f
--- /dev/null
+++ b/analysis/tests/src/Complete.res
@@ -0,0 +1,57 @@
+module MyList = Belt.List
+//^com MyList.m
+//^com Array.
+//^com Array.m
+
+
+module Dep: {
+ @ocaml.doc("Some doc comment") @deprecated("Use customDouble instead")
+ let customDouble: int => int
+} = {
+ let customDouble = foo => foo * 2
+}
+
+//^com let cc = Dep.c
+
+module Lib = {
+ let foo = (~age, ~name) => name ++ string_of_int(age)
+ let next = (~number=0, ~year) => number + year
+}
+
+//^com let x = foo(~
+
+//^com [1,2,3]->m
+
+//^com "abc"->toU
+
+let op = Some(3)
+
+//^com op->e
+
+module ForAuto = {
+ type t = int
+ let abc = (x:t, _y:int) => x
+ let abd = (x:t, _y:int) => x
+}
+
+let fa:ForAuto.t = 34
+//^com fa->
+
+//^com "hello"->Js.Dict.u
+
+module O = {
+ module Comp = {
+ @react.component
+ let make = (~first="", ~zoo=3, ~second) =>
+ React.string(first ++ second ++ string_of_int(zoo))
+ }
+}
+
+let zzz = 11
+
+//^com let comp = int
+} = {
+ let customDouble = foo => foo * 2
+}
+
+module D = Dep
+// ^hov
+
+let cd = D.customDouble
+// ^hov
+
+module HoverInsideModuleWithComponent = {
+ let x = 2 // check that hover on x works
+// ^hov
+ @react.component
+ let make = () => React.null
+}
+
+@ocaml.doc("Doc comment for functionWithTypeAnnotation")
+let functionWithTypeAnnotation : unit => int = () => 1
+// ^hov
+
+@react.component
+let make = (~name) => React.string(name)
+// ^hov
+
+@react.component
+let make2 = (~name:string) => React.string(name)
+// ^hov
\ No newline at end of file
diff --git a/analysis/tests/src/Jsx.res b/analysis/tests/src/Jsx.res
new file mode 100644
index 000000000..d28ce76ec
--- /dev/null
+++ b/analysis/tests/src/Jsx.res
@@ -0,0 +1,12 @@
+module M = {
+ @react.component
+ let make = (~first, ~fun="", ~second="") => React.string(first ++ fun++ second)
+}
+
+let d = , 'a => 'b) => Belt.List.t<'b>\n```\n\n`map xs f`\n\nreturn the list obtained by applying `f` to each element of `xs`\n\n```ml\nmap [1;2] (fun x-> x + 1) = [3;4]\n```\n"}
+
diff --git a/analysis/tests/src/expected/Complete.res.txt b/analysis/tests/src/expected/Complete.res.txt
new file mode 100644
index 000000000..355e25ab0
--- /dev/null
+++ b/analysis/tests/src/expected/Complete.res.txt
@@ -0,0 +1,456 @@
+Complete tests/src/Complete.res 0:2
+[{
+ "label": "mapReverse",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, 'a => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "`mapReverse xs f`\n\nEquivalent to `reverse (map xs f)`\n\n```ml\nmapReverse [3;4;5] (fun x -> x * x) = [25;16;9];;\n```\n\n\n\nbelt_List.mli:299"}
+ }, {
+ "label": "makeBy",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, int => 'a) => t<'a>",
+ "documentation": {"kind": "markdown", "value": "`makeBy n f`\n\n- return a list of length `n` with element `i` initialized with `f i`\n\n\n- return the empty list if `n` is negative\n\n\n\n```ml\nmakeBy 5 (fun i -> i) = [0;1;2;3;4];;\nmakeBy 5 (fun i -> i * i) = [0;1;4;9;16];;\n```\n\n\n\nbelt_List.mli:127"}
+ }, {
+ "label": "make",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, 'a) => t<'a>",
+ "documentation": {"kind": "markdown", "value": "`make n v`\n\n- return a list of length `n` with each element filled with value `v`\n\n\n- return the empty list if `n` is negative\n\n\n\n```ml\nmake 3 1 = [1;1;1]\n```\n\n\n\nbelt_List.mli:115"}
+ }, {
+ "label": "mapReverse2U",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, t<'b>, (. 'a, 'b) => 'c) => t<'c>",
+ "documentation": {"kind": "markdown", "value": "\nbelt_List.mli:391"}
+ }, {
+ "label": "map",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, 'a => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "`map xs f`\n\nreturn the list obtained by applying `f` to each element of `xs`\n\n```ml\nmap [1;2] (fun x-> x + 1) = [3;4]\n```\n\n\n\nbelt_List.mli:222"}
+ }, {
+ "label": "mapWithIndexU",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, (. int, 'a) => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "\nbelt_List.mli:258"}
+ }, {
+ "label": "mapU",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, (. 'a) => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "\nbelt_List.mli:221"}
+ }, {
+ "label": "makeByU",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, (. int) => 'a) => t<'a>",
+ "documentation": {"kind": "markdown", "value": "\nbelt_List.mli:126"}
+ }, {
+ "label": "mapReverse2",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, t<'b>, ('a, 'b) => 'c) => t<'c>",
+ "documentation": {"kind": "markdown", "value": "`mapReverse2 xs ys f`\n\nequivalent to `reverse (zipBy xs ys f)`\n\n```ml\nmapReverse2 [1;2;3] [1;2] (+) = [4;2]\n```\n\n\n\nbelt_List.mli:392"}
+ }, {
+ "label": "mapWithIndex",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, (int, 'a) => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "`mapWithIndex xs f` applies `f` to each element of `xs`. Function `f` takes two arguments: the index starting from 0 and the element from `xs`.\n\n```ml\nmapWithIndex [1;2;3] (fun i x -> i + x) =\n[0 + 1; 1 + 2; 2 + 3 ]\n```\n\n\n\nbelt_List.mli:259"}
+ }, {
+ "label": "mapReverseU",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, (. 'a) => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "\nbelt_List.mli:298"}
+ }]
+
+Complete tests/src/Complete.res 1:2
+[{
+ "label": "Floatarray",
+ "kind": 9,
+ "tags": [],
+ "detail": "module",
+ "documentation": {"kind": "markdown", "value": "\narray.mli:267"}
+ }, {
+ "label": "fold_left",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'b) => 'a, 'a, array<'b>) => 'a",
+ "documentation": {"kind": "markdown", "value": "`Array.fold_left f x a` computes `f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)`, where `n` is the length of the array `a`.\n\n\n\n\narray.mli:160"}
+ }, {
+ "label": "concat",
+ "kind": 12,
+ "tags": [],
+ "detail": "list> => array<'a>",
+ "documentation": {"kind": "markdown", "value": "Same as append, but concatenates a list of arrays.\n\n\n\n\narray.mli:95"}
+ }, {
+ "label": "mapi",
+ "kind": 12,
+ "tags": [],
+ "detail": "((int, 'a) => 'b, array<'a>) => array<'b>",
+ "documentation": {"kind": "markdown", "value": "Same as map, but the function is applied to the index of the element as first argument, and the element itself as second argument.\n\n\n\n\narray.mli:155"}
+ }, {
+ "label": "exists",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a => bool, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "`Array.exists p [|a1; ...; an|]` checks if at least one element of the array satisfies the predicate `p`. That is, it returns `(p a1) || (p a2) || ... || (p an)`.\n\nSince: 4.03.0\n\n\narray.mli:197"}
+ }, {
+ "label": "for_all",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a => bool, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "`Array.for_all p [|a1; ...; an|]` checks if all elements of the array satisfy the predicate `p`. That is, it returns `(p a1) && (p a2) && ... && (p an)`.\n\nSince: 4.03.0\n\n\narray.mli:191"}
+ }, {
+ "label": "copy",
+ "kind": 12,
+ "tags": [],
+ "detail": "array<'a> => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.copy a` returns a copy of `a`, that is, a fresh array containing the same elements as `a`.\n\n\n\n\narray.mli:107"}
+ }, {
+ "label": "iter2",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'b) => unit, array<'a>, array<'b>) => unit",
+ "documentation": {"kind": "markdown", "value": "`Array.iter2 f a b` applies function `f` to all the elements of `a` and `b`. Raise `Invalid_argument` if the arrays are not the same size.\n\nSince: 4.03.0\n\n\narray.mli:174"}
+ }, {
+ "label": "to_list",
+ "kind": 12,
+ "tags": [],
+ "detail": "array<'a> => list<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.to_list a` returns the list of all the elements of `a`.\n\n\n\n\narray.mli:129"}
+ }, {
+ "label": "stable_sort",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'a) => int, array<'a>) => unit",
+ "documentation": {"kind": "markdown", "value": "Same as sort, but the sorting algorithm is stable \\(i.e. elements that compare equal are kept in their original order\\) and not guaranteed to run in constant heap space.\n\nThe current implementation uses Merge Sort. It uses `n/2` words of heap space, where `n` is the length of the array. It is usually faster than the current implementation of sort.\n\n\n\n\narray.mli:243"}
+ }, {
+ "label": "iteri",
+ "kind": 12,
+ "tags": [],
+ "detail": "((int, 'a) => unit, array<'a>) => unit",
+ "documentation": {"kind": "markdown", "value": "Same as iter, but the function is applied with the index of the element as first argument, and the element itself as second argument.\n\n\n\n\narray.mli:145"}
+ }, {
+ "label": "memq",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "Same as mem, but uses physical equality instead of structural equality to compare array elements.\n\nSince: 4.03.0\n\n\narray.mli:208"}
+ }, {
+ "label": "map2",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'b) => 'c, array<'a>, array<'b>) => array<'c>",
+ "documentation": {"kind": "markdown", "value": "`Array.map2 f a b` applies function `f` to all the elements of `a` and `b`, and builds an array with the results returned by `f`: `[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]`. Raise `Invalid_argument` if the arrays are not the same size.\n\nSince: 4.03.0\n\n\narray.mli:180"}
+ }, {
+ "label": "set",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int, 'a) => unit",
+ "documentation": {"kind": "markdown", "value": "`Array.set a n x` modifies array `a` in place, replacing element number `n` with `x`. You can also write `a.(n) <- x` instead of `Array.set a n x`.\n\nRaise `Invalid_argument \"index out of bounds\"` if `n` is outside the range 0 to `Array.length a - 1`.\n\n\n\n\narray.mli:30"}
+ }, {
+ "label": "make",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, 'a) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.make n x` returns a fresh array of length `n`, initialized with `x`. All the elements of this new array are initially physically equal to `x` \\(in the sense of the `==` predicate\\). Consequently, if `x` is mutable, it is shared among all elements of the array, and modifying `x` through one of the array entries will modify all other entries at the same time.\n\nRaise `Invalid_argument` if `n < 0` or `n > Sys.max_array_length`. If the value of `x` is a floating-point number, then the maximum size is only `Sys.max_array_length / 2`.\n\n\n\n\narray.mli:38"}
+ }, {
+ "label": "make_float",
+ "kind": 12,
+ "tags": [],
+ "detail": "int => array",
+ "documentation": {"kind": "markdown", "value": "Deprecated: `Array.make_float` is an alias for create_float.\n\n\n\n\n\n\narray.mli:60"}
+ }, {
+ "label": "fold_right",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('b, 'a) => 'a, array<'b>, 'a) => 'a",
+ "documentation": {"kind": "markdown", "value": "`Array.fold_right f a x` computes `f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))`, where `n` is the length of the array `a`.\n\n\n\n\narray.mli:165"}
+ }, {
+ "label": "sort",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'a) => int, array<'a>) => unit",
+ "documentation": {"kind": "markdown", "value": "Sort an array in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller \\(see below for a complete specification\\). For example, compare is a suitable comparison function, provided there are no floating-point NaN values in the data. After calling `Array.sort`, the array is sorted in place in increasing order. `Array.sort` is guaranteed to run in constant heap space and \\(at most\\) logarithmic stack space.\n\nThe current implementation uses Heap Sort. It runs in constant stack space.\n\nSpecification of the comparison function: Let `a` be the array and `cmp` the comparison function. The following must be true for all x, y, z in a :\n\n- `cmp x y` \\> 0 if and only if `cmp y x` < 0\n\n\n- if `cmp x y` \\>= 0 and `cmp y z` \\>= 0 then `cmp x z` \\>= 0\n\n\n\nWhen `Array.sort` returns, `a` contains the same elements as before, reordered in such a way that for all i and j valid indices of `a` :\n\n- `cmp a.(i) a.(j)` \\>= 0 if and only if i \\>= j\n\n\n\n\n\n\narray.mli:217"}
+ }, {
+ "label": "length",
+ "kind": 12,
+ "tags": [],
+ "detail": "array<'a> => int",
+ "documentation": {"kind": "markdown", "value": "Return the length \\(number of elements\\) of the given array.\n\n\n\n\narray.mli:18"}
+ }, {
+ "label": "sub",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int, int) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.sub a start len` returns a fresh array of length `len`, containing the elements number `start` to `start + len - 1` of array `a`.\n\nRaise `Invalid_argument \"Array.sub\"` if `start` and `len` do not designate a valid subarray of `a`; that is, if `start < 0`, or `len < 0`, or `start + len > Array.length a`.\n\n\n\n\narray.mli:98"}
+ }, {
+ "label": "of_list",
+ "kind": 12,
+ "tags": [],
+ "detail": "list<'a> => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.of_list l` returns a fresh array containing the elements of `l`.\n\n\n\n\narray.mli:132"}
+ }, {
+ "label": "iter",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a => unit, array<'a>) => unit",
+ "documentation": {"kind": "markdown", "value": "`Array.iter f a` applies function `f` in turn to all the elements of `a`. It is equivalent to `f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()`.\n\n\n\n\narray.mli:140"}
+ }, {
+ "label": "map",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a => 'b, array<'a>) => array<'b>",
+ "documentation": {"kind": "markdown", "value": "`Array.map f a` applies function `f` to all the elements of `a`, and builds an array with the results returned by `f`: `[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]`.\n\n\n\n\narray.mli:150"}
+ }, {
+ "label": "unsafe_get",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int) => 'a",
+ "documentation": {"kind": "markdown", "value": "\narray.mli:264"}
+ }, {
+ "label": "make_matrix",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, int, 'a) => array>",
+ "documentation": {"kind": "markdown", "value": "`Array.make_matrix dimx dimy e` returns a two-dimensional array \\(an array of arrays\\) with first dimension `dimx` and second dimension `dimy`. All the elements of this new matrix are initially physically equal to `e`. The element \\(`x,y`\\) of a matrix `m` is accessed with the notation `m.(x).(y)`.\n\nRaise `Invalid_argument` if `dimx` or `dimy` is negative or greater than max_array_length. If the value of `e` is a floating-point number, then the maximum size is only `Sys.max_array_length / 2`.\n\n\n\n\narray.mli:74"}
+ }, {
+ "label": "mem",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "`mem a l` is true if and only if `a` is equal to an element of `l`.\n\nSince: 4.03.0\n\n\narray.mli:203"}
+ }, {
+ "label": "get",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int) => 'a",
+ "documentation": {"kind": "markdown", "value": "`Array.get a n` returns the element number `n` of array `a`. The first element has number 0. The last element has number `Array.length a - 1`. You can also write `a.(n)` instead of `Array.get a n`.\n\nRaise `Invalid_argument \"index out of bounds\"` if `n` is outside the range 0 to `(Array.length a - 1)`.\n\n\n\n\narray.mli:21"}
+ }, {
+ "label": "append",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, array<'a>) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.append v1 v2` returns a fresh array containing the concatenation of the arrays `v1` and `v2`.\n\n\n\n\narray.mli:91"}
+ }, {
+ "label": "unsafe_set",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int, 'a) => unit",
+ "documentation": {"kind": "markdown", "value": "\narray.mli:265"}
+ }, {
+ "label": "create_matrix",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, int, 'a) => array>",
+ "documentation": {"kind": "markdown", "value": "Deprecated: `Array.create_matrix` is an alias for make_matrix.\n\n\n\n\n\n\narray.mli:87"}
+ }, {
+ "label": "create_float",
+ "kind": 12,
+ "tags": [],
+ "detail": "int => array",
+ "documentation": {"kind": "markdown", "value": "`Array.create_float n` returns a fresh float array of length `n`, with uninitialized data.\n\nSince: 4.03\n\n\narray.mli:55"}
+ }, {
+ "label": "create",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, 'a) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "Deprecated: `Array.create` is an alias for make.\n\n\n\n\n\n\narray.mli:51"}
+ }, {
+ "label": "init",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, int => 'a) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.init n f` returns a fresh array of length `n`, with element number `i` initialized to the result of `f i`. In other terms, `Array.init n f` tabulates the results of `f` applied to the integers `0` to `n-1`.\n\nRaise `Invalid_argument` if `n < 0` or `n > Sys.max_array_length`. If the return type of `f` is `float`, then the maximum size is only `Sys.max_array_length / 2`.\n\n\n\n\narray.mli:64"}
+ }, {
+ "label": "fast_sort",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'a) => int, array<'a>) => unit",
+ "documentation": {"kind": "markdown", "value": "Same as sort or stable_sort, whichever is faster on typical input.\n\n\n\n\narray.mli:253"}
+ }, {
+ "label": "fill",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int, int, 'a) => unit",
+ "documentation": {"kind": "markdown", "value": "`Array.fill a ofs len x` modifies the array `a` in place, storing `x` in elements number `ofs` to `ofs + len - 1`.\n\nRaise `Invalid_argument \"Array.fill\"` if `ofs` and `len` do not designate a valid subarray of `a`.\n\n\n\n\narray.mli:111"}
+ }, {
+ "label": "blit",
+ "kind": 12,
+ "tags": [],
+ "detail": "(array<'a>, int, array<'a>, int, int) => unit",
+ "documentation": {"kind": "markdown", "value": "`Array.blit v1 o1 v2 o2 len` copies `len` elements from array `v1`, starting at element number `o1`, to array `v2`, starting at element number `o2`. It works correctly even if `v1` and `v2` are the same array, and the source and destination chunks overlap.\n\nRaise `Invalid_argument \"Array.blit\"` if `o1` and `len` do not designate a valid subarray of `v1`, or if `o2` and `len` do not designate a valid subarray of `v2`.\n\n\n\n\narray.mli:118"}
+ }]
+
+Complete tests/src/Complete.res 2:2
+[{
+ "label": "mapi",
+ "kind": 12,
+ "tags": [],
+ "detail": "((int, 'a) => 'b, array<'a>) => array<'b>",
+ "documentation": {"kind": "markdown", "value": "Same as map, but the function is applied to the index of the element as first argument, and the element itself as second argument.\n\n\n\n\narray.mli:155"}
+ }, {
+ "label": "memq",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "Same as mem, but uses physical equality instead of structural equality to compare array elements.\n\nSince: 4.03.0\n\n\narray.mli:208"}
+ }, {
+ "label": "map2",
+ "kind": 12,
+ "tags": [],
+ "detail": "(('a, 'b) => 'c, array<'a>, array<'b>) => array<'c>",
+ "documentation": {"kind": "markdown", "value": "`Array.map2 f a b` applies function `f` to all the elements of `a` and `b`, and builds an array with the results returned by `f`: `[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]`. Raise `Invalid_argument` if the arrays are not the same size.\n\nSince: 4.03.0\n\n\narray.mli:180"}
+ }, {
+ "label": "make",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, 'a) => array<'a>",
+ "documentation": {"kind": "markdown", "value": "`Array.make n x` returns a fresh array of length `n`, initialized with `x`. All the elements of this new array are initially physically equal to `x` \\(in the sense of the `==` predicate\\). Consequently, if `x` is mutable, it is shared among all elements of the array, and modifying `x` through one of the array entries will modify all other entries at the same time.\n\nRaise `Invalid_argument` if `n < 0` or `n > Sys.max_array_length`. If the value of `x` is a floating-point number, then the maximum size is only `Sys.max_array_length / 2`.\n\n\n\n\narray.mli:38"}
+ }, {
+ "label": "make_float",
+ "kind": 12,
+ "tags": [],
+ "detail": "int => array",
+ "documentation": {"kind": "markdown", "value": "Deprecated: `Array.make_float` is an alias for create_float.\n\n\n\n\n\n\narray.mli:60"}
+ }, {
+ "label": "map",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a => 'b, array<'a>) => array<'b>",
+ "documentation": {"kind": "markdown", "value": "`Array.map f a` applies function `f` to all the elements of `a`, and builds an array with the results returned by `f`: `[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]`.\n\n\n\n\narray.mli:150"}
+ }, {
+ "label": "make_matrix",
+ "kind": 12,
+ "tags": [],
+ "detail": "(int, int, 'a) => array>",
+ "documentation": {"kind": "markdown", "value": "`Array.make_matrix dimx dimy e` returns a two-dimensional array \\(an array of arrays\\) with first dimension `dimx` and second dimension `dimy`. All the elements of this new matrix are initially physically equal to `e`. The element \\(`x,y`\\) of a matrix `m` is accessed with the notation `m.(x).(y)`.\n\nRaise `Invalid_argument` if `dimx` or `dimy` is negative or greater than max_array_length. If the value of `e` is a floating-point number, then the maximum size is only `Sys.max_array_length / 2`.\n\n\n\n\narray.mli:74"}
+ }, {
+ "label": "mem",
+ "kind": 12,
+ "tags": [],
+ "detail": "('a, array<'a>) => bool",
+ "documentation": {"kind": "markdown", "value": "`mem a l` is true if and only if `a` is equal to an element of `l`.\n\nSince: 4.03.0\n\n\narray.mli:203"}
+ }]
+
+Complete tests/src/Complete.res 12:2
+[{
+ "label": "customDouble",
+ "kind": 12,
+ "tags": [1],
+ "detail": "int => int",
+ "documentation": {"kind": "markdown", "value": "Deprecated: Use customDouble instead\n\nSome doc comment\n\n\nComplete.res:1"}
+ }]
+
+Complete tests/src/Complete.res 19:2
+[{
+ "label": "age",
+ "kind": 4,
+ "tags": [],
+ "detail": "int",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:20"}
+ }, {
+ "label": "name",
+ "kind": 4,
+ "tags": [],
+ "detail": "string",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:20"}
+ }]
+
+Complete tests/src/Complete.res 21:2
+[{
+ "label": "Js.Array2.mapi",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, ('a, int) => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "\njs_array2.ml:127"}
+ }, {
+ "label": "Js.Array2.map",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, 'a => 'b) => t<'b>",
+ "documentation": {"kind": "markdown", "value": "\njs_array2.ml:126"}
+ }]
+
+Complete tests/src/Complete.res 23:2
+[{
+ "label": "Js.String2.toUpperCase",
+ "kind": 12,
+ "tags": [],
+ "detail": "t => t",
+ "documentation": {"kind": "markdown", "value": "`toUpperCase str` converts `str` to upper case using the locale-insensitive case mappings in the Unicode Character Database. Notice that the conversion can expand the number of letters in the result; for example the German `\195\159` capitalizes to two `S`es in a row.\n\n```ml\ntoUpperCase \"abc\" = \"ABC\";;\ntoUpperCase {js|Stra\195\159e|js} = {js|STRASSE|js};;\ntoLowerCase {js|\207\128\207\130|js} = {js|\206\160\206\163|js};;\n```\n\n\n\njs_string2.ml:601"}
+ }]
+
+Complete tests/src/Complete.res 27:2
+[{
+ "label": "Belt.Option.eqU",
+ "kind": 12,
+ "tags": [],
+ "detail": "(option<'a>, option<'b>, (. 'a, 'b) => bool) => bool",
+ "documentation": {"kind": "markdown", "value": "Uncurried version of `eq`\n\n\n\n\nbelt_Option.mli:154"}
+ }, {
+ "label": "Belt.Option.eq",
+ "kind": 12,
+ "tags": [],
+ "detail": "(option<'a>, option<'b>, ('a, 'b) => bool) => bool",
+ "documentation": {"kind": "markdown", "value": "`eq optValue1 optvalue2 predicate`\n\nEvaluates two optional values for equality with respect to a predicate function.\n\nIf both `optValue1` and `optValue2` are `None`, returns `true`.\n\nIf one of the arguments is `Some value` and the other is `None`, returns `false`\n\nIf arguments are `Some value1` and `Some value2`, returns the result of `predicate value1 value2`; the `predicate` function must return a `bool`\n\n```ml\nlet clockEqual = (fun a b -> a mod 12 = b mod 12);;\neq (Some 3) (Some 15) clockEqual = true;;\neq (Some 3) None clockEqual = false;;\neq None (Some 3) clockEqual = false;;\neq None None clockEqual = true;;\n```\n\n\n\nbelt_Option.mli:159"}
+ }]
+
+Complete tests/src/Complete.res 36:2
+[{
+ "label": "ForAuto.abc",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t, int) => t",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:33"}
+ }, {
+ "label": "ForAuto.abd",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t, int) => t",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:34"}
+ }]
+
+Complete tests/src/Complete.res 38:2
+[{
+ "label": "unsafeGet",
+ "kind": 12,
+ "tags": [],
+ "detail": "(t<'a>, key) => 'a",
+ "documentation": {"kind": "markdown", "value": "`unsafeGet dict key` return the value if the `key` exists, otherwise an **undefined** value is returned. Must be used only when the existence of a key is certain. \\(i.e. when having called `keys` function previously.\n\n```ml\nArray.iter (fun key -> Js.log (Js_dict.unsafeGet dic key)) (Js_dict.keys dict) \n```\n\n\n\njs_dict.mli:42"}
+ }, {
+ "label": "unsafeDeleteKey",
+ "kind": 12,
+ "tags": [],
+ "detail": "(. t, string) => unit",
+ "documentation": {"kind": "markdown", "value": "Experimental internal function\n\n\n\n\njs_dict.mli:63"}
+ }]
+
+Complete tests/src/Complete.res 50:2
+[{
+ "label": "zzz",
+ "kind": 12,
+ "tags": [],
+ "detail": "int",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:50"}
+ }]
+
+Complete tests/src/Complete.res 52:2
+[{
+ "label": "key",
+ "kind": 4,
+ "tags": [],
+ "detail": "string",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:53"}
+ }, {
+ "label": "zoo",
+ "kind": 4,
+ "tags": [],
+ "detail": "option",
+ "documentation": {"kind": "markdown", "value": "\nComplete.res:53"}
+ }]
+
diff --git a/analysis/tests/src/expected/Definition.res.txt b/analysis/tests/src/expected/Definition.res.txt
new file mode 100644
index 000000000..61c640fb5
--- /dev/null
+++ b/analysis/tests/src/expected/Definition.res.txt
@@ -0,0 +1,12 @@
+Definition tests/src/Definition.res 2:8
+{"uri": "Definition.res", "range": {"start": {"line": 0, "character": 4}, "end": {"line": 0, "character": 6}}}
+
+Definition tests/src/Definition.res 10:23
+{"uri": "Definition.res", "range": {"start": {"line": 6, "character": 7}, "end": {"line": 6, "character": 13}}}
+
+Hover tests/src/Definition.res 14:14
+{"contents": "```rescript\n('a => 'b, list<'a>) => list<'b>\n```\n\n`List.map f [a1; ...; an]` applies function `f` to `a1, ..., an`, and builds the list `[f a1; ...; f an]` with the results returned by `f`. Not tail-recursive.\n\n"}
+
+Hover tests/src/Definition.res 18:14
+{"contents": "```rescript\n(Belt.List.t<'a>, 'a => 'b) => Belt.List.t<'b>\n```\n\n`map xs f`\n\nreturn the list obtained by applying `f` to each element of `xs`\n\n```ml\nmap [1;2] (fun x-> x + 1) = [3;4]\n```\n"}
+
diff --git a/analysis/tests/src/expected/Hover.res.txt b/analysis/tests/src/expected/Hover.res.txt
new file mode 100644
index 000000000..8c36cff4e
--- /dev/null
+++ b/analysis/tests/src/expected/Hover.res.txt
@@ -0,0 +1,27 @@
+Hover tests/src/Hover.res 0:4
+{"contents": "```rescript\nint\n```"}
+
+Hover tests/src/Hover.res 3:5
+{"contents": "```rescript\ntype t = (int, float)\n```"}
+
+Hover tests/src/Hover.res 6:7
+{"contents": "```rescript\nmodule Id = {\n type x = int\n}\n```"}
+
+Hover tests/src/Hover.res 19:11
+{"contents": "\nThis module is commented\n```rescript\nmodule Dep = {\n let customDouble: int => int\n}\n```"}
+
+Hover tests/src/Hover.res 22:11
+{"contents": "```rescript\nint => int\n```\n\nSome doc comment"}
+
+Hover tests/src/Hover.res 26:6
+{"contents": "```rescript\nint\n```"}
+
+Hover tests/src/Hover.res 33:4
+{"contents": "```rescript\nunit => int\n```\n\nDoc comment for functionWithTypeAnnotation"}
+
+Hover tests/src/Hover.res 37:13
+{"contents": "```rescript\nstring\n```"}
+
+Hover tests/src/Hover.res 41:13
+{"contents": "```rescript\nstring\n```"}
+
diff --git a/analysis/tests/src/expected/Jsx.res.txt b/analysis/tests/src/expected/Jsx.res.txt
new file mode 100644
index 000000000..3dc179a82
--- /dev/null
+++ b/analysis/tests/src/expected/Jsx.res.txt
@@ -0,0 +1,27 @@
+Definition tests/src/Jsx.res 5:9
+{"uri": "Jsx.res", "range": {"start": {"line": 2, "character": 6}, "end": {"line": 2, "character": 10}}}
+
+Complete tests/src/Jsx.res 7:2
+[]
+
+Complete tests/src/Jsx.res 10:2
+[{
+ "label": "key",
+ "kind": 4,
+ "tags": [],
+ "detail": "string",
+ "documentation": {"kind": "markdown", "value": "\nJsx.res:11"}
+ }, {
+ "label": "first",
+ "kind": 4,
+ "tags": [],
+ "detail": "string",
+ "documentation": {"kind": "markdown", "value": "\nJsx.res:11"}
+ }, {
+ "label": "fun",
+ "kind": 4,
+ "tags": [],
+ "detail": "option",
+ "documentation": {"kind": "markdown", "value": "\nJsx.res:11"}
+ }]
+
diff --git a/package-lock.json b/package-lock.json
index 87517e67b..1a67d568e 100644
--- a/package-lock.json
+++ b/package-lock.json
@@ -18,6 +18,7 @@
"@typescript-eslint/parser": "^2.3.0",
"eslint": "^6.4.0",
"mocha": "^8.0.1",
+ "reanalyze": "^2.15.0",
"typescript": "^3.9.4"
},
"engines": {
@@ -1838,6 +1839,16 @@
"node": ">=8.10.0"
}
},
+ "node_modules/reanalyze": {
+ "version": "2.15.0",
+ "resolved": "https://registry.npmjs.org/reanalyze/-/reanalyze-2.15.0.tgz",
+ "integrity": "sha512-FUN/pqgTKs5i+kzi9Mje5deahZHKniOQDyig5UseozDiK81eW77A4iRyN+3UsnontG6K6mAdUcXCU9NpEqZFug==",
+ "dev": true,
+ "hasInstallScript": true,
+ "bin": {
+ "reanalyze": "reanalyze.exe"
+ }
+ },
"node_modules/regexpp": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/regexpp/-/regexpp-2.0.1.tgz",
@@ -3943,6 +3954,12 @@
"picomatch": "^2.2.1"
}
},
+ "reanalyze": {
+ "version": "2.15.0",
+ "resolved": "https://registry.npmjs.org/reanalyze/-/reanalyze-2.15.0.tgz",
+ "integrity": "sha512-FUN/pqgTKs5i+kzi9Mje5deahZHKniOQDyig5UseozDiK81eW77A4iRyN+3UsnontG6K6mAdUcXCU9NpEqZFug==",
+ "dev": true
+ },
"regexpp": {
"version": "2.0.1",
"resolved": "https://registry.npmjs.org/regexpp/-/regexpp-2.0.1.tgz",
diff --git a/package.json b/package.json
index a749949c6..ecf26b44a 100644
--- a/package.json
+++ b/package.json
@@ -112,6 +112,7 @@
"@typescript-eslint/parser": "^2.3.0",
"eslint": "^6.4.0",
"mocha": "^8.0.1",
+ "reanalyze": "^2.15.0",
"typescript": "^3.9.4"
},
"dependencies": {
diff --git a/server/analysis_binaries/README.md b/server/analysis_binaries/README.md
new file mode 100644
index 000000000..2927b24db
--- /dev/null
+++ b/server/analysis_binaries/README.md
@@ -0,0 +1,2 @@
+We store the analysis binaries here.
+
diff --git a/server/src/RescriptEditorSupport.ts b/server/src/RescriptEditorSupport.ts
index 0259ff055..1a54c88a0 100644
--- a/server/src/RescriptEditorSupport.ts
+++ b/server/src/RescriptEditorSupport.ts
@@ -1,101 +1,156 @@
import { fileURLToPath } from "url";
import { RequestMessage } from "vscode-languageserver";
-import { CompletionItem } from "vscode-languageserver-protocol";
+import { CompletionItem, Hover, Location } from "vscode-languageserver-protocol";
import * as utils from "./utils";
import * as path from "path";
import { execFileSync } from "child_process";
import fs from "fs";
-let binaryPath = path.join(
+let binariesFolder = path.join(
path.dirname(__dirname),
- process.platform,
- "rescript-editor-support.exe"
+ "analysis_binaries"
+)
+
+// For local development and CI tests
+let currentPlatformBinaryPath = path.join(
+ binariesFolder,
+ "current-platform.exe"
+);
+// Platform-specific production binaries manually downloaded from CI
+let productionBinaryPath = path.join(
+ binariesFolder,
+ process.platform + ".exe"
);
-export let binaryExists = fs.existsSync(binaryPath);
+let findBinary = () => {
+ if (fs.existsSync(currentPlatformBinaryPath)) {
+ return currentPlatformBinaryPath
+ } else if (fs.existsSync(productionBinaryPath)) {
+ return productionBinaryPath
+ } else {
+ return null
+ }
+}
+
+// export let binaryExists = fs.existsSync(binaryPath);
+
+// let findExecutable = (uri: string) => {
+// let filePath = fileURLToPath(uri);
+// let projectRootPath = utils.findProjectRootOfFile(filePath);
+// if (projectRootPath == null || !binaryExists) {
+// return null;
+// } else {
+// return {
+// binaryPath: binaryPath,
+// filePath: filePath,
+// cwd: projectRootPath,
+// };
+// }
+// };
+
+// type dumpCommandResult = {
+// hover?: string;
+// definition?: { uri?: string; range: any };
+// };
+// export function runDumpCommand(msg: RequestMessage): dumpCommandResult | null {
+// let executable = findExecutable(msg.params.textDocument.uri);
+// if (executable == null) {
+// return null;
+// }
+
+// let command =
+// executable.filePath +
+// ":" +
+// msg.params.position.line +
+// ":" +
+// msg.params.position.character;
+
+// try {
+// let stdout = execFileSync(executable.binaryPath, ["dump", command], {
+// cwd: executable.cwd,
+// });
+// let parsed = JSON.parse(stdout.toString());
+// if (parsed && parsed[0]) {
+// return parsed[0];
+// } else {
+// return null;
+// }
+// } catch (error) {
+// // TODO: @cristianoc any exception possible?
+// return null;
+// }
+// }
-let findExecutable = (uri: string) => {
- let filePath = fileURLToPath(uri);
+export function runCompletionCommand(
+ msg: RequestMessage,
+ code: string
+): CompletionItem[] | null {
+ let filePath = fileURLToPath(msg.params.textDocument.uri)
let projectRootPath = utils.findProjectRootOfFile(filePath);
- if (projectRootPath == null || !binaryExists) {
+ let binaryPath = findBinary();
+ if (binaryPath == null || projectRootPath == null) {
return null;
- } else {
- return {
- binaryPath: binaryPath,
- filePath: filePath,
- cwd: projectRootPath,
- };
}
-};
+ let tmpname = utils.createFileInTempDir();
+ fs.writeFileSync(tmpname, code, { encoding: "utf-8" });
-type dumpCommandResult = {
- hover?: string;
- definition?: { uri?: string; range: any };
-};
-export function runDumpCommand(msg: RequestMessage): dumpCommandResult | null {
- let executable = findExecutable(msg.params.textDocument.uri);
- if (executable == null) {
+ try {
+ let stdout = execFileSync(
+ binaryPath,
+ ["complete", filePath, msg.params.position.line, msg.params.position.character, tmpname],
+ { cwd: projectRootPath }
+ );
+ return JSON.parse(stdout.toString());
+ } catch (error) {
+ // TODO: @cristianoc any exception possible?
return null;
+ } finally {
+ fs.unlink(tmpname, () => null);
}
+}
- let command =
- executable.filePath +
- ":" +
- msg.params.position.line +
- ":" +
- msg.params.position.character;
+export function runHoverCommand(
+ msg: RequestMessage,
+): Hover | null {
+ let filePath = fileURLToPath(msg.params.textDocument.uri)
+ let projectRootPath = utils.findProjectRootOfFile(filePath);
+ let binaryPath = findBinary();
+ if (binaryPath == null || projectRootPath == null) {
+ return null;
+ }
try {
- let stdout = execFileSync(executable.binaryPath, ["dump", command], {
- cwd: executable.cwd,
- });
- let parsed = JSON.parse(stdout.toString());
- if (parsed && parsed[0]) {
- return parsed[0];
- } else {
- return null;
- }
+ let stdout = execFileSync(
+ binaryPath,
+ ["hover", filePath, msg.params.position.line, msg.params.position.character],
+ { cwd: projectRootPath }
+ );
+ return JSON.parse(stdout.toString());
} catch (error) {
// TODO: @cristianoc any exception possible?
return null;
}
}
-// TODO: the result will never be null soon when the updated binary syncs
-export function runCompletionCommand(
+export function runDefinitionCommand(
msg: RequestMessage,
- code: string
-): CompletionItem[] | null {
- let executable = findExecutable(msg.params.textDocument.uri);
- if (executable == null) {
+): Location | null {
+ let filePath = fileURLToPath(msg.params.textDocument.uri)
+ let projectRootPath = utils.findProjectRootOfFile(filePath);
+ let binaryPath = findBinary();
+ if (binaryPath == null || projectRootPath == null) {
return null;
}
- let tmpname = utils.createFileInTempDir();
- fs.writeFileSync(tmpname, code, { encoding: "utf-8" });
-
- let command =
- executable.filePath +
- ":" +
- msg.params.position.line +
- ":" +
- msg.params.position.character;
try {
let stdout = execFileSync(
- executable.binaryPath,
- ["complete", command, tmpname],
- { cwd: executable.cwd }
+ binaryPath,
+ ["definition", filePath, msg.params.position.line, msg.params.position.character],
+ { cwd: projectRootPath }
);
- let parsed = JSON.parse(stdout.toString());
- if (parsed && parsed[0]) {
- return parsed;
- } else {
- return null;
- }
+ return JSON.parse(stdout.toString());
} catch (error) {
// TODO: @cristianoc any exception possible?
return null;
- } finally {
- fs.unlink(tmpname, () => null);
}
}
diff --git a/server/src/server.ts b/server/src/server.ts
index 6407da2e8..6cd7b5d8f 100644
--- a/server/src/server.ts
+++ b/server/src/server.ts
@@ -10,6 +10,7 @@ import {
DidOpenTextDocumentNotification,
DidChangeTextDocumentNotification,
DidCloseTextDocumentNotification,
+ Location,
} from "vscode-languageserver-protocol";
import * as utils from "./utils";
import * as c from "./constants";
@@ -18,9 +19,7 @@ import { assert } from "console";
import { fileURLToPath } from "url";
import { ChildProcess } from "child_process";
import {
- binaryExists,
- runDumpCommand,
- runCompletionCommand,
+ runCompletionCommand, runDefinitionCommand, runHoverCommand,
} from "./RescriptEditorSupport";
// https://microsoft.github.io/language-server-protocol/specification#initialize
@@ -296,11 +295,9 @@ function onMessage(msg: m.Message) {
// TODO: incremental sync?
textDocumentSync: v.TextDocumentSyncKind.Full,
documentFormattingProvider: true,
- hoverProvider: binaryExists,
- definitionProvider: binaryExists,
- completionProvider: binaryExists
- ? { triggerCharacters: [".", ">", "@", "~"] }
- : undefined,
+ hoverProvider: true,
+ definitionProvider: true,
+ completionProvider: { triggerCharacters: [".", ">", "@", "~"] },
},
};
let response: m.ResponseMessage = {
@@ -351,11 +348,11 @@ function onMessage(msg: m.Message) {
// type Hover = {contents: MarkedString | MarkedString[] | MarkupContent, range?: Range}
result: null,
};
- let result = runDumpCommand(msg);
- if (result !== null && result.hover != null) {
+ let result = runHoverCommand(msg);
+ if (result !== null) {
let hoverResponse: m.ResponseMessage = {
...emptyHoverResponse,
- result: { contents: result.hover },
+ result,
};
send(hoverResponse);
} else {
@@ -371,14 +368,11 @@ function onMessage(msg: m.Message) {
// error: code and message set in case an exception happens during the definition request.
};
- let result = runDumpCommand(msg);
- if (result !== null && result.definition != null) {
+ let result = runDefinitionCommand(msg);
+ if (result !== null) {
let definitionResponse: m.ResponseMessage = {
...emptyDefinitionResponse,
- result: {
- uri: result.definition.uri || msg.params.textDocument.uri,
- range: result.definition.range,
- },
+ result: result,
};
send(definitionResponse);
} else {