Source file errors.ml

open UtilsLib.Error

module Lexing_o = Lexing

module Syntax_l =
  struct
    type t =
      | UnexpectedEOI
      | TrailingChars
      | SyntaxError of int

    let kind = "Script syntax"

    let get_menhir_error_message state =
      match ParserMessages.message state with
      | message -> message
      | exception Not_found -> "Unknown syntax error"

    let pp fmt err =
      match err with
      | UnexpectedEOI -> Format.fprintf fmt "Unexpected@ end@ of@ input"
      | TrailingChars -> Format.fprintf fmt "Trailing@ chars"
      | SyntaxError s -> Format.fprintf fmt "%a" UtilsLib.Error.pp_text (String.trim (get_menhir_error_message s))
  end

module SyntaxErrors = ErrorManager(Syntax_l)

module Lexing_l =
  struct
    type t =
      | Unclosed of string
      | UnterminatedComment
      | UnstartedComment
      | BadChar of string
      | Malformed

    let kind = "Script lexing"

    let pp fmt err =
      match err with
      | Unclosed tok -> Format.fprintf fmt "Unclosed@ \'%s\'" tok
      | UnterminatedComment -> Format.fprintf fmt "Unterminated@ comment"
      | UnstartedComment -> Format.fprintf fmt "Unstarted@ comment"
      | BadChar tok -> Format.fprintf fmt "Bad@ character@ \'%s\'" tok
      | Malformed -> Format.fprintf fmt "Malformed@ UTF-8@ input"
  end

module LexingErrors = ErrorManager(Lexing_l)

module Type_l =
  struct
    type t =
      | Variable of string * string * string * string * string
      | Literal of string * string * string * string
      | DefaultValue of string * string * string * string
      | Other

    let kind = "Script type"

    let pp fmt err =
      match err with
      | Variable (f, p, v, t_exp, t_act) ->
        Format.fprintf fmt "Expecting@ %s@ for@ paramater@ \"%s\"@ of@ function@ \"%s\",@ but@ got@ %s.@ The@ type@ of@ variable@ \"%s\"@ was@ inferred@ to@ %s" t_exp p f t_act v t_act
      | Literal (f, p, t_exp, t_act) -> Format.fprintf fmt "Expecting@ %s@ for@ parameter@ \"%s\"@ of@ function@ \"%s\",@ but@ got@ %s" t_exp p f t_act
      | DefaultValue (f, p, t_exp, t_act) -> Format.fprintf fmt "Expecting@ %s@ for@ the@ default@ value@ of@ parameter@ \"%s\"@ of@ function@ \"%s\",@ but@ got@ %s.@ The@ type@ of@ variable@ \"%s\"@ was@ inferred@ to@ %s" t_exp p f t_act p t_exp
      | Other -> Format.fprintf fmt "Unknown@ error"
  end

module TypeErrors = ErrorManager(Type_l)

module Script_l =
  struct
    type t =
      | NoSignatureType of string
      | NoSignatureTerm
      | WrongSignature of string * string
      | OnlyLexicon of string
      | ArgumentMissing of string * string
      | DifferentSig of string * (AcgData.Signature.Data_Signature.t * AcgData.Signature.Data_Signature.t) option
      | AlreadyExistingFun of string
      | UnusedVariable of string
      | UnknownFunction of string
      | UnknownParameter of string * string
      | ParameterRepeated of string * string
      | TooMuchArgs of string
      | NoLastValue
      | InvalidSpecialFuncCall of string
      | MissingFuncTermList of string
      | TermListNotAllowed of string
      | EmptyPipe of string
      | EmptyHelp of string
      | AbsSigMismatch of AcgData.Acg_lexicon.Data_Lexicon.(t * t)
      | Other

    let kind = "Script"

    let pp fmt err =
      match err with
      | NoSignatureType t -> Format.fprintf fmt "No@ signature@ to@ interpret@ type@ \"%s\"" t
      | NoSignatureTerm -> Format.fprintf fmt "No@ signature@ to@ interpret@ the@ resulting@ term"
      | WrongSignature (sig1, sig2) -> Format.fprintf fmt "This@ term@ is@ in@ the@ signature@ \"%s\"@ but@ is@ used@ with@ an@ other@ signature@ (\"%s\")" sig1 sig2
      | OnlyLexicon s -> Format.fprintf fmt "This@ function@ only@ accepts@ a@ lexicon.@ \"%s\"@ is@ a@ signature" s
      | ArgumentMissing (a, f) -> Format.fprintf fmt "No@ value@ given@ for@ parameter@ \"%s\"@ of@ function@ \"%s\"" a f
      | DifferentSig (v, Some (sig1, sig2)) -> Format.fprintf fmt "Different@ signatures@ used@ for@ the@ type@ variable@ \"%s\"@ (\"%s\"@ and@ \"%s\")" v (fst (AcgData.Signature.Data_Signature.name sig1)) (fst (AcgData.Signature.Data_Signature.name sig2))
      | DifferentSig (v, None) -> Format.fprintf fmt "Different@ signatures@ used@ for@ the@ type@ variable@ \"%s\"" v
      | AlreadyExistingFun f -> Format.fprintf fmt "The@ function@ \"%s\"@ already@ exists@ in@ the@ environment" f
      | UnusedVariable v -> Format.fprintf fmt "Unused@ variable@ \"%s\"" v
      | UnknownFunction f -> Format.fprintf fmt "Unknown@ function@ \"%s\"" f
      | UnknownParameter (f, p) -> Format.fprintf fmt "Unknown@ parameter@ \"%s\"@ for@ the@ function@ \"%s\"" p f
      | ParameterRepeated (f, p) -> Format.fprintf fmt "Parameter@ \"%s\"@ of@ function@ \"%s\"@ given@ twice" p f
      | TooMuchArgs f -> Format.fprintf fmt "Too@ many@ arguments@ for@ function@ \"%s\"" f
      | NoLastValue -> Format.fprintf fmt "No@ last@ value@ in@ the@ current@ environment"
      | InvalidSpecialFuncCall f -> Format.fprintf fmt "The@ function@ \"%s\"@ can@ only@ be@ called@ alone@ in@ a@ command" f
      | MissingFuncTermList f -> Format.fprintf fmt "The@ function@ \"%s\"@ requires@ terms@ as@ input" f
      | TermListNotAllowed f -> Format.fprintf fmt "The@ function@ \"%s\"@ must@ be@ called@ without@ terms@ as@ input" f
      | EmptyPipe f -> Format.fprintf fmt "The@ pipe@ before@ the@ function@ \"%s\"@ is@ invalid,@ because@ the@ previous@ function@ does@ not@ output@ terms" f
      | EmptyHelp f_pattern -> Format.fprintf fmt "No@ functions@ starting@ with@ \"%s\"@ found" f_pattern
      | AbsSigMismatch (lex1, lex2) ->
         Format.fprintf
           fmt
           "The@ abstract@ signature@ of lexicon@ %a@ is@ not@ \
            the@ same@ as@ the@ abstract@ signature@ of@ lexicon@ \
            %a.@ The@ %a@ function@ requires@ all@ the@ lexicons@ \
            to@ share@ the@ same@ abstract@ signature"
           AcgData.Acg_lexicon.Data_Lexicon.short_pp
           lex2
           AcgData.Acg_lexicon.Data_Lexicon.short_pp
           lex1
           UtilsLib.PPUtils.fun_pp
           "realize"
    
      | Other -> Format.fprintf fmt "Unknown@ error"
  end

module ScriptErrors = ErrorManager(Script_l)