(*
* F# Common Library
* Parsing.fs: parsing facilities
* (C) 2007-2021 Alvise Spano' @ Universita' Ca' Foscari di Venezia
*)

module FSharp.Common.Parsing

#nowarn "52"

open System
open FSharp.Text // if removed, any project using types such as Position and LexBuffer will not compile because of name clashing with homonimous types defined elsewhere within F# libs

let parse_float (s: string) =
    Double.Parse(s, Globalization.NumberStyles.Float, Globalization.CultureInfo.InvariantCulture)

// list of strings mappers
//

let mappen_strings_or_nothing f empty sep xs =
    match Seq.toList xs with
    | [] -> empty
    | [ x ] -> f x
    | x :: xs -> Seq.fold (fun r x -> r + sep + (f x)) (f x) xs

let flatten_strings_or_nothing empty = mappen_strings_or_nothing id empty

let flatten_strings sep = flatten_strings_or_nothing "" sep
let mappen_strings f = mappen_strings_or_nothing f ""

let mappen_stringables f = mappen_strings (f >> sprintf "%O")
let flatten_stringables sep = mappen_stringables id sep


(* error locating *)

// yacc/lex utilities
//

module LexYacc =
    exception ParseErrorContextException of obj
    let parse_error_rich = Some(fun ctx -> raise (ParseErrorContextException ctx))
    let newline (lexbuf: Lexing.LexBuffer<_>) = lexbuf.EndPos <- lexbuf.EndPos.NextLine
    let lexeme = Lexing.LexBuffer<_>.LexemeString


// FsYacc parser wrapper
//

let yparse syntax_error parser (tokenizer: Lexing.LexBuffer<_> -> 'tok) tokenTagToTokenId =
    let pretty_token_by_tags =
        let p n = sprintf "%A" (tokenTagToTokenId n) // do not change %A with %O: tokens do not define ToString(), thus only %A prints them
        let prefix = "TOKEN_" in

        fun ns ->
            let r =
                mappen_strings
                    (fun n ->
                        let s = p n in

                        sprintf
                            "<%s>"
                            (if s.StartsWith prefix then
                                 s.Remove(0, prefix.Length)
                             else
                                 s))
                    ", "
                    ns in

            if List.length ns > 1 then
                sprintf "one among %s" r
            else
                r

    let tokenizer lexbuf =
        let tok =
            try
                tokenizer lexbuf
            with
            | e -> raise (syntax_error (e.Message, lexbuf))
        //        L.debug Low "%s" (pretty_token tok)
        tok in

    fun (lexbuf: Lexing.LexBuffer<_>) ->
        try
            parser tokenizer lexbuf
        with
        | LexYacc.ParseErrorContextException ctx as e ->
            let ctx = ctx :?> Parsing.ParseErrorContext<'tok>

            let tok =
                match ctx.CurrentToken with
                | Some t -> sprintf "<%A>" t
                | None -> "unknown"

            let msg =
                sprintf
                    "encountered token %s but expected %s%s"
                    tok
                    (pretty_token_by_tags ctx.ShiftTokens)
                    (let l = ctx.ReduceTokens in

                     if l.IsEmpty then
                         ""
                     else
                         sprintf ", or alternatively %s" (pretty_token_by_tags l)) in

            raise (syntax_error (msg, lexbuf))

let init_lexbuf filename (start_line, start_col) (lexbuf: Lexing.LexBuffer<_>) =
    let r =
        { Lexing.Position.pos_bol = 0
          Lexing.Position.pos_fname = filename
          Lexing.Position.pos_cnum = start_col
          Lexing.Position.pos_lnum = start_line }

    lexbuf.StartPos <- r
    lexbuf.EndPos <- r

let parse_from_lexbuf syntax_error lexbuf filename (start_line, start_col) parser tokenizer tokenTagToTokenId =
    init_lexbuf filename (start_line, start_col) lexbuf
    yparse syntax_error parser tokenizer tokenTagToTokenId lexbuf

let parse_from_TextReader syntax_error trd =
    parse_from_lexbuf syntax_error (Lexing.LexBuffer<_>.FromTextReader trd)

let parse_from_string syntax_error s name =
    parse_from_lexbuf syntax_error (Lexing.LexBuffer<_>.FromString s) (sprintf "<%s>" name)
