{
(* 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 Jrme 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)

}