Source file u.ml

(*********************************************************************************)
(*                OCaml-CSS                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    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, version 3 of the License.       *)
(*                                                                               *)
(*    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                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Utilities for parsing. *)

open Angstrom
open T

let remove_options : 'a option list -> 'a list = fun l ->
  List.fold_right
    (fun x acc ->
       match x with
       | None -> acc
       | Some x -> x :: acc)
    l []

let with_loc : ctx -> 'a Angstrom.t -> ('a * loc) Angstrom.t = fun ctx p ->
  ctx.get_pos >>= fun start ->
     p >>= fun v ->
       ctx.get_pos >>= fun stop ->
       return (v, (start, stop))

let is_hex = function
| '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true
| _ -> false

let is_digit = function '0'..'9' -> true | _ -> false

(** Parser failing with the given message where current position is added. *)
let fail_at ctx msg =
  let p =
    match Angstrom.Unbuffered.parse ctx.last_pos with
    | Done (_,p) -> Some p
    | Partial _ | Fail _ -> None
  in
  T.error (Parse_error (p, msg))

(** [parse_error ctx e] raises a {!T.Error} with a parse error [e]
  and last position of [ctx]. *)
let parse_error_at ctx e = ctx.last_pos >>= fun p ->
  T.error (Parse_error (Some p, e))

(**/**)
include Log
(**/**)


let string_of_char_list l =
  let a = Array.of_list l in
  String.init (Array.length a) (Array.get a)

(** {2 Util parsers} *)

(** [opt_ p] returns [None] if [p] fails, else return [Some r] where [r]
  is the result of [p]. *)
let opt_ p = option None (p >>| fun x -> Some x)

(** [take_char] is a parser returning [None] is there is no more char,
  else accept any character [c], {!Angstrom.advance} by 1 char and returns [Some c].*)
let take_char = peek_char >>= function
| None -> return None
| Some c -> advance 1 >>= (fun _ -> return (Some c))

(** [take_while_upto pred n] accepts at most [n] characters
  or as long a [pred] returns [true]. Returns accepted characters as a string.*)
let take_while_upto =
  let rec f pred acc n =
    if n <= 0 then
      return (String.concat "" (List.rev acc))
    else
      peek_char >>= function
      | Some c when pred c ->
          (advance 1 >>= function () ->
            f pred (String.make 1 c :: acc) (n-1))
      | _ -> return (String.concat "" (List.rev acc))
  in
  fun pred n -> f pred [] n

(** Same as {!take_while_upto} but fails if no character is available. *)
let take_while1_upto pred n =
  take_char >>= function
| None -> fail ""
| Some c ->
   take_while_upto pred n >>=
      fun s -> return (Printf.sprintf "%c%s" c s)

(** Accept a comment. *)
let comment ctx =
  ctx.get_pos >>= fun start_pos ->
    Angstrom.(string "/*" *>
     choice [
       ((many_till any_char (string "*/")) >>| string_of_char_list) ;
       (peek_char >>= fun _ -> T.(error (Parse_error (Some start_pos, Unterminated_comment))))
     ]
  ) <?> "comment"

let is_ws = function
| '\x20' | '\x0a' | '\x0d' | '\x09' -> true
| _ -> false

(*let is_ws c =
  prerr_endline (Printf.sprintf "is_ws %c" c);
  is_ws c
*)

(** [ws ctx] accepts any number of white spaces or comments. *)
let ws ctx : string Angstrom.t =
  many ((take_while1 is_ws) <|> comment ctx) >>| String.concat ""

(*let ws ctx = skip_many ((take_while1 is_ws >>| fun _ -> ()) <|> comment ctx) >>| fun _ -> ()*)

(** {2 Parser combinators} *)

let map_fst parser = (fun ctx -> Angstrom.map (parser ctx) ~f:fst)

(** [p1 &&& p2] returns a parser succeeding when [p1] and [p2] succeed, in any order. *)
let (&&&) p1 p2 = choice [
    (p1 >>= fun v1 -> p2 >>| fun v2 -> (v1, v2) ) ;
    (p2 >>= fun v2 -> p1 >>| fun v1 -> (v1, v2) ) ;
  ]

(** [p1 ||| p2] returns a parser accepting values for [p1] or [p2] or both. *)
let (|||) : 'a Angstrom.t -> 'b Angstrom.t -> ('a option * 'b option) Angstrom.t =
  fun p1 p2 -> choice [
      (p1 >>= fun v1 -> choice [
           (p2 >>| fun v2 -> (Some v1, Some v2)) ;
           return (Some v1, None)]) ;
      (p2 >>= fun v2 -> choice [
           (p1 >>| fun v1 -> (Some v1, Some v2)) ;
           return (None, Some v2)])
    ]

(** [alt_1_2 def1 p1 def2 p2] is the same as {!(|||)} but returns the provided
  default values for each parser. *)
let alt_1_2 : 'a -> 'a Angstrom.t -> 'b -> 'b Angstrom.t -> ('a * 'b) Angstrom.t =
  fun def1 p1 def2 p2 ->
    p1 ||| p2 >>| fun (x1, x2) ->
      (Option.value x1 ~default:def1, Option.value x2 ~default:def2)

(** {2 Predefined character parsers}

 All these parser accept a character after optional white spaces or comments.
*)

let lchar c ctx = ws ctx *> char c

let lbracket = lchar '['
let rbracket = lchar ']'
let lbrace = lchar '{'
let rbrace = lchar '}'
let lpar = lchar '('
let rpar = lchar ')'
let dot = lchar '.'
let colon = lchar ':'
let semicolon = lchar ';'
let ampersand = lchar '&'
let comma = lchar ','
let dquote = lchar '"'
let quote = lchar '\''
let plus = lchar '+'
let minus = lchar '-'
let pipe = lchar '|'
let sharp = lchar '#'
let slash = lchar '/'
let gt = lchar '>'
let tilde = lchar '~'



(** {2 Parsing integers and sign} *)

let sign ctx = choice [minus ctx ; plus ctx]

let integer ctx = (ws ctx *> option '+' (sign ctx) >>=
  fun sign -> take_while1 is_digit >>=
    fun n -> return (int_of_string (Printf.sprintf "%c%s" sign n))) <?> "integer"