{
(* Ocsimore
* Copyright (C) 2008
* Laboratoire PPS - Université Paris Diderot - CNRS
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(**
Parser for Wikicreole
@author Jérôme Vouillon
@author Vincent Balat
*)
exception Eof
exception Unrecognized_char
type attribs = (string * string) list
type ('a, 'b, 'c) ext_kind =
| Block of 'a
| A_content of 'b
| Link_plugin of 'c
type ('flow, 'inline, 'a_content, 'param, 'sp) builder =
{ chars : string -> 'a_content;
strong_elem : attribs -> 'inline list -> 'a_content;
em_elem : attribs -> 'inline list -> 'a_content;
br_elem : attribs -> 'a_content;
img_elem : attribs -> string -> string -> 'a_content;
tt_elem : attribs -> 'inline list -> 'a_content;
monospace_elem : attribs -> 'inline list -> 'a_content;
underlined_elem : attribs -> 'inline list -> 'a_content;
linethrough_elem : attribs -> 'inline list -> 'a_content;
subscripted_elem : attribs -> 'inline list -> 'a_content;
superscripted_elem : attribs -> 'inline list -> 'a_content;
nbsp : 'a_content;
a_elem : attribs -> 'sp -> string -> 'a_content list -> 'inline;
make_href : 'sp -> string -> string;
p_elem : attribs -> 'inline list -> 'flow;
pre_elem : attribs -> string list -> 'flow;
h1_elem : attribs -> 'inline list -> 'flow;
h2_elem : attribs -> 'inline list -> 'flow;
h3_elem : attribs -> 'inline list -> 'flow;
h4_elem : attribs -> 'inline list -> 'flow;
h5_elem : attribs -> 'inline list -> 'flow;
h6_elem : attribs -> 'inline list -> 'flow;
ul_elem : attribs -> ('inline list * 'flow option * attribs) list -> 'flow;
ol_elem : attribs -> ('inline list * 'flow option * attribs) list -> 'flow;
dl_elem : attribs -> (bool * 'inline list * attribs) list -> 'flow;
hr_elem : attribs -> 'flow;
table_elem : attribs ->
((bool * attribs * 'inline list) list * attribs) list -> 'flow;
inline : 'a_content -> 'inline;
plugin :
string ->
(bool *
('param -> (string * string) list -> string option ->
(('flow, 'a_content, (string * attribs * 'a_content)) ext_kind)));
plugin_action :
string -> int -> int ->
'param -> (string * string) list -> string option -> unit;
error : string -> 'a_content;
}
type style =
Bold | Italic | Underlined | Linethrough |
Monospace | Superscripted | Subscripted
type list_kind = Unordered | Ordered
type ('inline, 'flow) stack =
Style of style * 'inline list * attribs * ('inline, 'flow) stack
| Link of string * attribs * ('inline, 'flow) stack
(* Not that we do not save anything in the case of links, as
links cannot be nested *)
| Paragraph of attribs
| Heading of int * attribs
| List_item of attribs * ('inline, 'flow) stack
| List of
list_kind * ('inline list * 'flow option * attribs) list
* attribs * ('inline, 'flow) stack
| Descr_def of attribs * ('inline, 'flow) stack
| Descr_title of attribs * ('inline, 'flow) stack
| Descr of attribs * ('inline, 'flow) stack
| Table of ((bool * attribs * 'inline list) list * attribs) list * attribs
| Row of (bool * attribs * 'inline list) list * attribs * ('inline, 'flow) stack
| Entry of bool * attribs * ('inline, 'flow) stack
type ('flow, 'inline, 'a_content, 'param, 'sp) ctx =
{ build : ('flow, 'inline, 'a_content, 'param, 'sp) builder;
param : 'param;
sp : 'sp;
mutable italic : bool;
mutable bold : bool;
mutable monospace : bool;
mutable underlined : bool;
mutable linethrough : bool;
mutable subscripted : bool;
mutable superscripted : bool;
mutable heading : bool;
mutable link : bool;
mutable list_level : int;
mutable inline_mix : 'inline list;
mutable link_content : 'a_content list;
mutable pre_content : string list;
mutable list : ('inline list * 'flow option * attribs) list;
mutable descr : (bool * 'inline list * attribs) list;
mutable flow : 'flow list;
mutable stack : ('inline, 'flow) stack }
let count c s =
let n = ref 0 in
for i = 0 to String.length s - 1 do if s.[i] = c then incr n done;
!n
let push c v =
match c.stack with
Link _ -> c.link_content <- v :: c.link_content
| _ -> c.inline_mix <- c.build.inline v :: c.inline_mix
let push_string c s =
push c (c.build.chars s)
let push_chars c lexbuf = push_string c (Lexing.lexeme lexbuf)
let read_attribs att parse_attribs c lexbuf =
try
if att = "@@"
then match parse_attribs 1 [] [] c lexbuf with
| [] -> []
| a::_ -> a
else []
with Eof -> [] (*VVV ??? *)
let read_list_attribs att parse_attribs c lexbuf =
try
if att = "@@"
then match parse_attribs 2 [] [] c lexbuf with
| [] -> ([], [])
| a::b::_ -> (b, a)
| [a] -> ([], a)
else ([], [])
with Eof -> ([], []) (*VVV ??? *)
let read_table_attribs att parse_attribs c lexbuf =
try
if att = "@@"
then match parse_attribs 3 [] [] c lexbuf with
| [] -> ([], [], [])
| a::b::c::_ -> (c, b, a)
| [a; b] -> ([], b, a)
| [a] -> ([], [], a)
else ([], [], [])
with Eof -> ([], [], []) (*VVV ??? *)
let get_style c style =
match style with
| Bold -> c.bold
| Italic -> c.italic
| Monospace -> c.monospace
| Underlined -> c.underlined
| Linethrough -> c.linethrough
| Subscripted -> c.subscripted
| Superscripted -> c.superscripted
let set_style c style v =
match style with
| Bold -> c.bold <- v
| Italic -> c.italic <- v
| Monospace -> c.monospace <- v
| Underlined -> c.underlined <- v
| Linethrough -> c.linethrough <- v
| Subscripted -> c.subscripted <- v
| Superscripted -> c.superscripted <- v
let pop_style c style inline attribs stack =
let elt =
match style with
| Bold -> c.build.strong_elem attribs
| Italic -> c.build.em_elem attribs
| Monospace -> c.build.monospace_elem attribs
| Underlined -> c.build.underlined_elem attribs
| Linethrough -> c.build.linethrough_elem attribs
| Subscripted -> c.build.subscripted_elem attribs
| Superscripted -> c.build.superscripted_elem attribs
in
let inline' = c.inline_mix in
c.stack <- stack;
c.inline_mix <- inline;
push c (elt (List.rev inline'));
set_style c style false
let style_change c style att parse_attribs lexbuf =
let atts = read_attribs att parse_attribs c lexbuf in
if get_style c style then begin
match c.stack with
Style (s, inline, attribs, stack) when s = style ->
pop_style c style inline attribs stack;
| _ ->
push_string c "**";
push_string c att
end else begin
c.stack <- Style (style, c.inline_mix, atts, c.stack);
c.inline_mix <- [];
set_style c style true
end
let pop_link c addr attribs stack =
c.stack <- stack;
c.inline_mix <-
c.build.a_elem attribs c.sp addr (List.rev c.link_content) :: c.inline_mix;
c.link_content <- [];
c.link <- false
let close_entry c =
match c.stack with
Entry (heading, attribs, Row (entries, row_attribs, stack)) ->
c.stack <- Row ((heading, attribs, List.rev c.inline_mix) :: entries,
row_attribs,
stack);
c.inline_mix <- [];
true
| Row _ | Table _ ->
true
| _ ->
false
let close_row c =
close_entry c &&
match c.stack with
Row (entries, row_attribs, Table (rows, table_attribs)) ->
c.stack <- Table (((List.rev entries, row_attribs) :: rows),
table_attribs);
true
| Table _ ->
true
| _ ->
assert false
let close_descr_entry c =
match c.stack with
| Descr_def (attribs, stack) ->
c.stack <- stack;
c.descr <- (false, List.rev c.inline_mix, attribs) :: c.descr;
c.inline_mix <- [];
true
| Descr_title (attribs, stack) ->
c.stack <- stack;
c.descr <- (true, List.rev c.inline_mix, attribs) :: c.descr;
c.inline_mix <- [];
true
| _ ->
false
let rec end_paragraph c lev =
match c.stack with
Style (style, inline, attribs, stack) ->
pop_style c style inline attribs stack;
end_paragraph c lev
| Link (addr, attribs, stack) ->
pop_link c addr attribs stack;
end_paragraph c lev
| Paragraph attribs ->
if c.inline_mix <> [] then begin
c.flow <- c.build.p_elem attribs (List.rev c.inline_mix) :: c.flow;
c.inline_mix <- []
end;
c.stack <- Paragraph []
| Heading (l, attribs) ->
let f =
match l with
| 1 -> c.build.h1_elem
| 2 -> c.build.h2_elem
| 3 -> c.build.h3_elem
| 4 -> c.build.h4_elem
| 5 -> c.build.h5_elem
| _ -> c.build.h6_elem
in
c.flow <- f attribs (List.rev c.inline_mix) :: c.flow;
c.inline_mix <- [];
c.heading <- false;
c.stack <- Paragraph []
| List_item (attribs, stack) ->
c.list <- (List.rev c.inline_mix, None, attribs) :: c.list;
c.stack <- stack;
c.inline_mix <- [];
end_paragraph c lev
| List (kind, lst, attribs, stack) ->
if lev < c.list_level then begin
c.list_level <- c.list_level - 1;
let elt =
match kind with
Unordered -> c.build.ul_elem
| Ordered -> c.build.ol_elem
in
let cur_lst = elt attribs (List.rev c.list) in
if c.list_level = 0 then
c.flow <- cur_lst :: c.flow
else begin
match lst with
(l, None, attribs) :: rem ->
c.list <- (l, Some cur_lst, attribs) :: rem;
| _ -> assert false
end;
c.stack <- stack;
end_paragraph c lev
end
| Descr_def (attribs, stack) ->
c.descr <- (false, List.rev c.inline_mix, attribs) :: c.descr;
c.stack <- stack;
c.inline_mix <- [];
end_paragraph c lev
| Descr_title (attribs, stack) ->
c.descr <- (true, List.rev c.inline_mix, attribs) :: c.descr;
c.stack <- stack;
c.inline_mix <- [];
end_paragraph c lev
| Descr (attribs, stack) ->
let lst = c.build.dl_elem attribs (List.rev c.descr) in
c.flow <- lst :: c.flow;
c.stack <- stack;
end_paragraph c lev
| Entry _ ->
ignore (close_row c);
end_paragraph c lev
| Row _ ->
assert false
| Table (rows, attribs) ->
c.flow <- c.build.table_elem attribs (List.rev rows) :: c.flow;
c.stack <- Paragraph []
let rec correct_kind_rec stack kind n =
match stack with
List_item (_, stack) ->
correct_kind_rec stack kind n
| List (k, _lst, _, stack) ->
if n = 0 then k = kind else
correct_kind_rec stack kind (n - 1)
| Style (_, _, _, stack) ->
correct_kind_rec stack kind n
| Link _ | Heading _ | Paragraph _ | Entry _ | Row _ | Table _
| Descr _ | Descr_title _ | Descr_def _ ->
assert false
let correct_kind c kind lev =
lev = c.list_level + 1
||
(lev <= c.list_level &&
correct_kind_rec c.stack kind (c.list_level - lev))
let start_list_item c kind lev att parse_attribs lexbuf =
let correct = correct_kind c kind lev in
if lev = 1 || correct then begin
(* If we have an item of a different kind at level 1, we close the
previous list and start a new one of the right kind *)
end_paragraph c (if correct then lev else 0);
let (list_attribs, item_attribs) =
read_list_attribs att parse_attribs c lexbuf
in
if lev = c.list_level then begin
c.stack <- List_item (item_attribs, c.stack)
end else (* if lev = c.list_level + 1 then *) begin
c.list_level <- lev;
c.stack <- List_item (item_attribs,
List (kind, c.list, list_attribs, c.stack));
c.list <- []
end;
true
end else
false
let start_table_row c heading (table_attribs, row_attribs, entry_attribs) =
if not (close_row c) then begin
end_paragraph c 0;
c.stack <- Table ([], table_attribs)
end;
c.stack <- Entry (heading,
entry_attribs,
Row ([], row_attribs, c.stack))
let build_extension lexbuf start name ext_info args c content =
let args = List.rev args in
c.build.plugin_action name start (Lexing.lexeme_end lexbuf)
c.param args content;
ext_info c.param args content
}
let line_break = '\n' | '\r' | "\r\n"
let white_space = [ ' ' '\t' ]
(* XXX Should we consider form feed and zero-width space as white
spaces as well ? *)
let not_line_break = [^ '\n' '\r']
let reserved_chars = [ '*' '/' '\\' '=' '[' ']' '{' '~' '|' 'h' 'f' '<' '-' '#' '_' '^' ',' ';' ':' ]
let punctuation = [ ',' '.' '?' '!' ':' ';' '"' '\'' ]
let first_char = (not_line_break # ['~' '|']) | ('=' +)
let next_chars = not_line_break # reserved_chars
rule parse_bol c =
parse
line_break {
end_paragraph c 0;
parse_bol c lexbuf
}
| white_space * ("=" | "==" | "===" | "====" | "=====" | "======")
(("@@" ?) as att) {
end_paragraph c 0;
assert (match c.stack with Paragraph _ -> true | _ -> false);
let l = count '=' (Lexing.lexeme lexbuf) in
c.stack <- Heading (l, read_attribs att parse_attribs c lexbuf);
c.heading <- true;
parse_rem c lexbuf
}
| white_space * "*" + (("@@" ?) as att) {
let lev = count '*' (Lexing.lexeme lexbuf) in
if not (start_list_item c Unordered lev att parse_attribs lexbuf)
then begin
let s = Lexing.lexeme lexbuf in
let l = String.index s '*' in
if l > 0 then push_string c (String.sub s 0 l);
for i = 1 to lev / 2 - 1 do
style_change c Bold "" parse_attribs lexbuf
done;
if lev land 1 = 1
then begin
style_change c Bold "" parse_attribs lexbuf;
push_string c "*";
push_string c att;
end
else
style_change c Bold att parse_attribs lexbuf
end;
parse_rem c lexbuf
}
| white_space * "#" + (("@@" ?) as att) {
let lev = count '#' (Lexing.lexeme lexbuf) in
if not (start_list_item c Ordered lev att parse_attribs lexbuf)
then begin
let s = Lexing.lexeme lexbuf in
let l = String.index s '#' in
if l > 0 then push_string c (String.sub s 0 l);
for i = 1 to lev / 2 - 1 do
style_change c Monospace "" parse_attribs lexbuf
done;
if lev land 1 = 1
then begin
style_change c Monospace "" parse_attribs lexbuf;
push_string c "#";
push_string c att;
end
else
style_change c Bold att parse_attribs lexbuf
end;
parse_rem c lexbuf
}
| white_space * ";" (("@@" ?) as att) {
let (list_attribs, item_attribs) =
read_list_attribs att parse_attribs c lexbuf
in
if close_descr_entry c
then c.stack <- Descr_title (item_attribs, c.stack)
else begin
end_paragraph c 0;
c.stack <- Descr_title (item_attribs, Descr (list_attribs, c.stack));
c.descr <- []
end;
parse_rem c lexbuf
}
| white_space * ":" (("@@" ?) as att) {
let (list_attribs, item_attribs) =
read_list_attribs att parse_attribs c lexbuf
in
if close_descr_entry c
then c.stack <- Descr_def (item_attribs, c.stack)
else begin
end_paragraph c 0;
c.stack <- Descr_def (item_attribs, Descr (list_attribs, c.stack));
c.descr <- []
end;
parse_rem c lexbuf
}
| white_space * "----" (("@@" ?) as att) white_space * (line_break | eof) {
end_paragraph c 0;
c.flow <- c.build.hr_elem
(read_attribs att parse_attribs c lexbuf) :: c.flow;
parse_bol c lexbuf
}
| white_space * "{{{" (("@@" ?) as att) (line_break | eof) {
end_paragraph c 0;
parse_nowiki c (read_attribs att parse_attribs c lexbuf) lexbuf
}
| white_space * "|" (("@@" ?) as att) {
start_table_row c false
(read_table_attribs att parse_attribs c lexbuf);
parse_rem c lexbuf
}
| white_space * "|=" (("@@" ?) as att) {
start_table_row c true
(read_table_attribs att parse_attribs c lexbuf);
parse_rem c lexbuf
}
| white_space * (("@@" ?) as att) {
let attribs = read_attribs att parse_attribs c lexbuf in
if attribs <> []
then
(match c.stack with
| Paragraph _ -> c.stack <- Paragraph attribs
| _ -> ());
parse_rem c lexbuf
}
| "" {
parse_rem c lexbuf
}
and parse_rem c =
parse
line_break {
(* Headings are single lines *)
if c.heading then
end_paragraph c 0
else
push_chars c lexbuf;
parse_bol c lexbuf
}
| "**" (("@@" ?) as att) {
style_change c Bold att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "//" (("@@" ?) as att) {
style_change c Italic att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "##" (("@@" ?) as att) {
style_change c Monospace att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "^^" (("@@" ?) as att) {
style_change c Superscripted att parse_attribs lexbuf;
parse_rem c lexbuf
}
| ",," (("@@" ?) as att) {
style_change c Subscripted att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "__" (("@@" ?) as att) {
style_change c Underlined att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "--" (("@@" ?) as att) {
style_change c Linethrough att parse_attribs lexbuf;
parse_rem c lexbuf
}
| "=" + white_space * (line_break | eof) {
if c.heading then
end_paragraph c 0
else
push_chars c lexbuf;
parse_bol c lexbuf
}
| "[[" (("@@" ?) as att)
{ parse_link c (read_attribs att parse_attribs c lexbuf) lexbuf }
| "]]" {
begin match c.stack with
Link (addr, attribs, stack) ->
pop_link c addr attribs stack
| _ ->
push_chars c lexbuf
end;
parse_rem c lexbuf
}
| ("http:" | "ftp:") (not_line_break # white_space) *
(not_line_break # white_space # punctuation) {
if c.link then
push_chars c lexbuf
else
let addr = Lexing.lexeme lexbuf in
c.inline_mix <-
c.build.a_elem [] c.sp addr [c.build.chars addr] :: c.inline_mix;
parse_rem c lexbuf
}
| "\\\\" (("@@" ?) as att) {
push c (c.build.br_elem (read_attribs att parse_attribs c lexbuf));
parse_rem c lexbuf
}
| "{{" (("@@" ?) as att)
{ parse_image c (read_attribs att parse_attribs c lexbuf) lexbuf }
| "<<" ((not_line_break # white_space) # ['|' '>']) * {
let s = Lexing.lexeme lexbuf in
let l = String.length s in
let name = String.sub s 2 (l - 2) in
let start = Lexing.lexeme_start lexbuf in
let (wiki_content, ext_info) = c.build.plugin name in
let content, args =
parse_extension start name wiki_content [] c lexbuf
in
match build_extension lexbuf start name ext_info args c content with
| A_content i ->
push c i;
parse_rem c lexbuf
| Link_plugin (addr, attribs, content) ->
c.link_content <- [ content ];
pop_link c addr attribs c.stack;
parse_rem c lexbuf
| Block b ->
end_paragraph c 0;
c.flow <- b :: c.flow;
parse_bol c lexbuf
}
| "{{{" (("@@" ?) as att)
{ parse_tt c (read_attribs att parse_attribs c lexbuf) lexbuf }
| '~' (not_line_break # white_space) {
let s = Lexing.lexeme lexbuf in
(* It amounts to the same to quote a UTF-8 char or its first byte *)
push_string c (String.sub s 1 1);
parse_rem c lexbuf
}
| "~ " {
push c c.build.nbsp;
parse_rem c lexbuf
}
| '|' white_space* (line_break | eof) {
if not (close_row c) then
push_chars c lexbuf;
parse_bol c lexbuf
}
| '|' (("@@" ?) as att) {
if close_entry c then
c.stack <- Entry (false,
read_attribs att parse_attribs c lexbuf,
c.stack)
else
push_chars c lexbuf;
parse_rem c lexbuf
}
| "|=" (("@@" ?) as att) {
if close_entry c then
c.stack <- Entry (true,
read_attribs att parse_attribs c lexbuf,
c.stack)
else
push_chars c lexbuf;
parse_rem c lexbuf
}
| first_char next_chars * | '~' {
push_chars c lexbuf;
parse_rem c lexbuf
}
| _ {
Js.alert
("Wikicreole: Unrecognized char "^(Lexing.lexeme lexbuf)^".");
raise Unrecognized_char
}
| eof {
end_paragraph c 0
}
and parse_link c attribs =
parse
(']' ? (not_line_break # [ ']' '|' ])) * "]]" {
if c.link then begin
push_string c "[["; (*VVV We loose attributes *)
push_chars c lexbuf
end
else
let s = Lexing.lexeme lexbuf in
let addr =
c.build.make_href c.sp (String.sub s 0 (String.length s - 2))
in
c.inline_mix <-
c.build.a_elem attribs c.sp addr [c.build.chars addr] :: c.inline_mix;
parse_rem c lexbuf
}
| (']' ? (not_line_break # [ ']' '|' ])) * "|" {
if c.link then begin
push_string c "[["; (*VVV We loose attributes *)
push_chars c lexbuf
end
else begin
let s = Lexing.lexeme lexbuf in
let addr = c.build.make_href c.sp (String.sub s 0 (String.length s - 1)) in
c.stack <- Link (addr, attribs, c.stack);
c.link <- true
end;
parse_rem c lexbuf
}
| "" {
push_string c "[["; (*VVV We loose attributes *)
parse_rem c lexbuf
}
and parse_image c attribs =
parse
(not_line_break # ['|' '{']) (not_line_break # '|') * '|'
('}' ? (not_line_break # '}')) * "}}" {
let s = Lexing.lexeme lexbuf in
let i = String.index s '|' in
let url = c.build.make_href c.sp (String.sub s 0 i) in
let alt = String.sub s (i + 1) (String.length s - i - 3) in
push c (c.build.img_elem attribs url alt);
parse_rem c lexbuf
}
| "" {
push_string c "{{"; (*VVV We loose attributes *)
parse_rem c lexbuf
}
and parse_tt c attribs =
parse
('}' ? '}' ? (not_line_break # '}')) * '}' * "}}}" {
let s = Lexing.lexeme lexbuf in
let txt = String.sub s 0 (String.length s - 3) in
push c (c.build.tt_elem attribs [c.build.inline (c.build.chars txt)]);
parse_rem c lexbuf
}
| "" {
push_string c "{{{"; (*VVV We loose attributes *)
parse_rem c lexbuf
}
and parse_nowiki c attribs =
parse
white_space + "}}}" (line_break | eof) {
let s = Lexing.lexeme lexbuf in
c.pre_content <- String.sub s 1 (String.length s - 1) :: c.pre_content;
parse_nowiki c attribs lexbuf
}
| ("}}}" (line_break | eof)) | eof {
c.flow <- c.build.pre_elem attribs (List.rev c.pre_content) :: c.flow;
c.pre_content <- [];
parse_bol c lexbuf
}
| not_line_break * (line_break | eof) {
c.pre_content <- Lexing.lexeme lexbuf :: c.pre_content;
parse_nowiki c attribs lexbuf
}
and parse_extension start name wiki_content args c =
parse
| '|' {
if wiki_content
then ((parse_extension_content_wiki start 0 false name "" c lexbuf),
args)
else ((parse_extension_content_nowiki start name "" c lexbuf), args)
}
| (">>" | eof) {
(None, args)
}
| ';'* | (white_space *) | (line_break *) {
parse_extension start name wiki_content args c lexbuf
}
| (not_line_break # white_space # '=' # '>') * '='
((white_space | line_break) *) (('\'' | '"') as quote) {
let s = Lexing.lexeme lexbuf in
let i = String.index s '=' in
let arg_name = String.sub s 0 i in
let arg_value = parse_arg_value quote "" c lexbuf in
parse_extension start name wiki_content
((arg_name, arg_value)::args) c lexbuf
}
| _ {
ignore (if wiki_content
then ((parse_extension_content_wiki
start 0 false name "" c lexbuf), args)
else ((parse_extension_content_nowiki
start name "" c lexbuf), args));
(Some ("Syntax error in extension "^name), args)
}
and parse_extension_content_wiki start lev nowiki name beg c =
parse
'~' (('<' | '>' | '~') as ch) {
parse_extension_content_wiki
start lev nowiki name (beg^"~"^(String.make 1 ch)) c lexbuf
}
| "<<" {
if nowiki
then
parse_extension_content_wiki
start lev nowiki name (beg^"<<") c lexbuf
else
parse_extension_content_wiki
start (lev+1) nowiki name (beg^"<<") c lexbuf
}
| "{{{" {
parse_extension_content_wiki
start lev true name (beg^"{{{") c lexbuf
}
| "}}}" {
(*VVV Warning: not quotable! *)
parse_extension_content_wiki
start lev false name (beg^"}}}") c lexbuf
}
| (">>" | eof) {
if nowiki
then
parse_extension_content_wiki
start lev nowiki name (beg^">>") c lexbuf
else
if lev>0
then
parse_extension_content_wiki
start (lev-1) nowiki name (beg^">>") c lexbuf
else Some beg
}
| [^ '~' '>' '<' '{' '}' ]+ {
let s = Lexing.lexeme lexbuf in
parse_extension_content_wiki start lev nowiki name (beg^s) c lexbuf
}
| [ '>' '<' '~' '{' '}' ] {
let s = Lexing.lexeme lexbuf in
parse_extension_content_wiki start lev nowiki name (beg^s) c lexbuf
}
| _ {
Js.alert
("Wikicreole: Unrecognized char in extension "^
(Lexing.lexeme lexbuf)^".");
raise Unrecognized_char
}
and parse_extension_content_nowiki start name beg c =
parse
| ("~>>" | eof) {
parse_extension_content_nowiki
start name (beg^">>") c lexbuf
}
| (">>" | eof) {
Some beg
}
| [^ '~' '>' ]+ {
let s = Lexing.lexeme lexbuf in
parse_extension_content_nowiki start name (beg^s) c lexbuf
}
| [ '>' '~' ] {
let s = Lexing.lexeme lexbuf in
parse_extension_content_nowiki start name (beg^s) c lexbuf
}
| _ {
Js.alert
("Wikicreole: Unrecognized char in extension "^
(Lexing.lexeme lexbuf)^".");
raise Unrecognized_char
}
and parse_arg_value quote beg c =
parse
eof | '~' eof {
raise Eof
}
| '~' ('\'' | '"' | '~' as ch) {
parse_arg_value quote (beg^(String.make 1 ch)) c lexbuf
}
| ('\'' | '"' | '~') as ch {
if ch = quote
then beg
else parse_arg_value quote (beg^(String.make 1 ch)) c lexbuf
}
| [^ '~' '\'' '"' ] * {
let s = Lexing.lexeme lexbuf in
parse_arg_value quote (beg^s) c lexbuf
}
and parse_attribs depth args oldargs c =
parse
"" {
args::oldargs
}
| ';'* | (white_space *) | (line_break *) {
parse_attribs depth args oldargs c lexbuf
}
| (not_line_break # white_space # '=' # '@') * '='
((white_space | line_break) *) (('\'' | '"') as quote) {
let s = Lexing.lexeme lexbuf in
let i = String.index s '=' in
let arg_name = String.sub s 0 i in
let arg_value = parse_arg_value quote "" c lexbuf in
parse_attribs depth ((arg_name, arg_value)::args) oldargs c lexbuf
}
| "@@" { args::oldargs }
| "@" {
if depth > 1
then parse_attribs (depth - 1) [] (args::oldargs) c lexbuf
else args::oldargs
}
| "@@@" { []::args::oldargs }
| "@@@@" { []::[]::args::oldargs }
| eof {
raise Eof
}
{
let context sp param b =
{ build = b;
param = param;
sp = sp;
italic = false;
bold = false;
monospace = false;
underlined = false;
linethrough = false;
subscripted = false;
superscripted = false;
heading = false;
link = false;
list_level = 0;
inline_mix = [];
link_content = [];
pre_content = [];
list = [];
descr = [];
flow = [];
stack = Paragraph [] }
let from_lexbuf sp param b lexbuf =
let c = context sp param b in
parse_bol c lexbuf;
List.rev c.flow
let from_string sp param b s = from_lexbuf sp param b (Lexing.from_string s)
}
