(*********************************************************************************)
(*                Higlo                                                          *)
(*                                                                               *)
(*    Copyright (C) 2014-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    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 Library General Public License for more details.                       *)
(*                                                                               *)
(*    You should have received a copy of the GNU Lesser 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                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*                                                                               *)
(*********************************************************************************)

open Lang

let lexeme lb = Sedlexing.(Utf8.lexeme lb, lexeme_length lb);;
let sedlexeme = Sedlexing.Utf8.lexeme;;

let digit = [%sedlex.regexp? '0'..'9'|'_']
let hex = [%sedlex.regexp? digit | 'A'..'F' | 'a'..'f']
let integer = [%sedlex.regexp? Plus(digit)]
let decimal = [%sedlex.regexp? Star('0'..'9'), '.', Plus('0'..'9')]

let lf = [%sedlex.regexp? 0x000A]
let cr = [%sedlex.regexp? 0x000D]

let line_ending = [%sedlex.regexp? lf | (cr, Opt(lf))]

let space = [%sedlex.regexp? ' ']
let tab = [%sedlex.regexp? '\t']
let space_or_tab = [%sedlex.regexp? space | tab]
let star3_space = [%sedlex.regexp? Opt(space_or_tab),Opt(space_or_tab),Opt(space_or_tab)]

let thematic_break = [%sedlex.regexp? star3_space,
  (  (('_',Star(space_or_tab)),('_',Star(space_or_tab)),('_',Star(space_or_tab)),Star('_',Star(space_or_tab)))
   | (('-',Star(space_or_tab)),('-',Star(space_or_tab)),('-',Star(space_or_tab)),Star('-',Star(space_or_tab)))
   | (('*',Star(space_or_tab)),('*',Star(space_or_tab)),('*',Star(space_or_tab)),Star('*',Star(space_or_tab)))
  ), line_ending
]

let title = [%sedlex.regexp? star3_space,
  '#',Opt('#'),Opt('#'),Opt('#'),Opt('#'),Opt('#'), Plus(space_or_tab),
  Star(Compl(lf|cr|'#')),Opt(Plus(space_or_tab),Plus('#')),Opt(cr),lf]

let no_lf_cr = [%sedlex.regexp? 0x0000 .. 0x0009 | 0x000B | 0x000C | 0x000E .. 0xffff]

let setext_begin = [%sedlex.regexp? Compl(lf|cr|'>'|'+'|'-'|space_or_tab) ]
let setext_content = [%sedlex.regexp? Star(setext_begin | space_or_tab)]

let setext1 = [%sedlex.regexp?
  star3_space, setext_begin, setext_content, line_ending, star3_space, Plus('='),Star(space_or_tab),line_ending]
let setext2 = [%sedlex.regexp?
  star3_space, setext_begin, setext_content, line_ending, star3_space, Plus('-'),Star(space_or_tab),line_ending]

let indent = [%sedlex.regexp? space_or_tab, space_or_tab, space_or_tab, Plus(space_or_tab)]

let blank_line = [%sedlex.regexp? Star(space_or_tab), line_ending]
let code_line = [%sedlex.regexp? indent, Plus(no_lf_cr),line_ending]

let code_block = [%sedlex.regexp? Opt(blank_line), Plus(code_line), Opt(blank_line)]

let link_id = [%sedlex.regexp? '[',Plus(Compl(lf|cr|']')|"\\]"),']']
let link_url = [%sedlex.regexp? '(',Plus(Compl(lf|cr|')')|"\\)"),')']

let strong = [%sedlex.regexp?
  ( "**",Plus(Compl('*')),"**")
| ( "__",Plus(Compl('_')),"__")
]

let emph = [%sedlex.regexp?
  ( '*',Plus(Compl('*')),'*')
| ( '_',Plus(Compl('_')),'_')
]

let strikethrough = [%sedlex.regexp? ( "~~",Plus(Compl('~')),"~~")]


let rec fence_code_block lexbuf opening b len =
  match%sedlex lexbuf with
  | line_ending, star3_space,
    ( ("``",Plus('`')) | ("~~",Plus('~')) ) ->
      let str,n = lexeme lexbuf in
      let len = len + n in
      Buffer.add_string b str ;
      if Misc.is_prefix ~of_:opening (Misc.strip_string str) then
        [Symbol (1, (Buffer.contents b, len))]
      else
        fence_code_block lexbuf opening b len
  | eof -> [Symbol (1, (Buffer.contents b, len))]
  | any ->
      let (str, n) = lexeme lexbuf in
      Buffer.add_string b str;
      fence_code_block lexbuf opening b (len+n)
  | _ -> failwith "Invalid state"

and main lexbuf =
  match%sedlex lexbuf with
  | eof -> []
  | thematic_break -> [Symbol (4, lexeme lexbuf)]
  | title ->
      let (str, len) = lexeme lexbuf in
      let level =
        match Misc.split_string str [' '; '\t'] with
        | sharps :: _ -> String.length sharps
        | [] -> 0
      in
      [Title (level, (str, len))]
  | setext1 -> [Title (1, lexeme lexbuf)]
  | setext2 -> [Title (2, lexeme lexbuf)]
  | code_block -> [Symbol (1, lexeme lexbuf)]
  | star3_space, (("``",Plus('`')) | ("~~",Plus('~'))) ->
      let (opening, len) = lexeme lexbuf in
      let b = Buffer.create 256 in
      Buffer.add_string b opening ;
      fence_code_block lexbuf opening b len
  | link_id ->
      (
       let link_id = lexeme lexbuf in
       match%sedlex lexbuf with
       | link_url ->
           [ Id link_id ; Constant (lexeme lexbuf) ]
       | _ ->
           Sedlexing.rollback lexbuf;
           [ Id link_id ]
      )
  | strong -> [Symbol (5, lexeme lexbuf)]
  | emph -> [Symbol (6, lexeme lexbuf)]
  | strikethrough -> [Lcomment (lexeme lexbuf)]
  | any -> [Text (lexeme lexbuf)]
  | _ -> failwith "Invalid state"

let () = Lang.register_lang "commonmark" main;;
