path: root/syntax/type_of.ml

open StdLabels

type pos = Lexing.position * Lexing.position
(** Extract the type for expression *)

module Helper = struct
  type t = Integer | Bool | String | Any
  [@@deriving show { with_path = false }]

  type dyn_type = t -> t
  (** Dynamic type is a type unknown during the code.

      For example, the equality operator accept either Integer or String, but
      we expect that both sides of the equality uses the same type.*)

  (** Build a new dynamic type *)
  let dyn_type : unit -> dyn_type =
   fun () ->
    let stored = ref None in
    fun t ->
      match !stored with
      | None ->
          stored := Some t;
          t
      | Some t -> t

  (** Declare an argument for a function. 

 - Either we already know the type and we just have to compare.
 - Either the type shall constrained by another one 
 - Or we have a variable number of arguments. *)
  type argument = Fixed of t | Dynamic of dyn_type | Variable of argument

  let compare :
      ?level:Report.level -> t -> pos * t -> Report.t list -> Report.t list =
   fun ?(level = Report.Warn) expected actual report ->
    let equal =
      match (expected, snd actual) with
      | _, Any -> true
      | Any, _ -> true
      | String, String -> true
      | Integer, Integer -> true
      | Bool, Bool -> true
      | Bool, Integer -> true
      | Integer, Bool -> true
      | String, Integer -> true
      | String, Bool -> true
      | _, String -> false
    in
    if equal then report
    else
      let message =
        Format.asprintf "The type %a is expected but got %a" pp expected pp
          (snd actual)
      in
      Report.message level (fst actual) message :: report

  let rec compare_parameter :
      ?level:Report.level ->
      argument ->
      pos * t ->
      Report.t list ->
      Report.t list =
   fun ?(level = Report.Warn) expected param report ->
    match expected with
    | Fixed t -> compare ~level t param report
    | Dynamic d ->
        let type_ = d (snd param) in
        compare ~level type_ param report
    | Variable c -> compare_parameter ~level c param report

  (** Compare the arguments one by one *)
  let compare_args :
      ?level:Report.level ->
      pos ->
      argument list ->
      (pos * t) list ->
      Report.t list ->
      Report.t list =
   fun ?(level = Report.Warn) pos expected actuals report ->
    let tl, report =
      List.fold_left actuals ~init:(expected, report)
        ~f:(fun (expected, report) param ->
          match expected with
          | (Variable _ as hd) :: _ ->
              let check = compare_parameter ~level hd param report in
              (expected, check)
          | hd :: tl ->
              let check = compare_parameter ~level hd param report in
              (tl, check)
          | [] ->
              let msg = Report.error (fst param) "Unexpected argument" in
              ([], msg :: report))
    in
    match tl with
    | [] | Variable _ :: _ -> report
    | _ ->
        let msg = Report.error pos "Not enougth arguments given" in
        msg :: report
end

module Expression = struct
  type 'a obs

  type t = {
    result : Helper.t;
    report : Report.t list;
    pos : pos;
    empty : bool;
  }

  type repr = Report.t list -> t
  (** The type repr is a function accepting the report as a first argement.
      When the report is given, it will be reported into the tree and collected
      in bottom-top *)

  type variable = { pos : pos; name : string; index : repr option }

  let arg_of_repr : t -> pos * Helper.t =
   fun { result; report; pos; empty } ->
    ignore report;
    ignore empty;
    (pos, result)

  (** The variable has type string when starting with a '$' *)
  let ident : variable -> repr =
   fun var report ->
    let empty = false in
    match var.name.[0] with
    | '$' -> { result = String; report; pos = var.pos; empty }
    | _ -> { result = Integer; report; pos = var.pos; empty }

  let integer : pos -> string -> repr =
   fun pos value report ->
    let empty =
      match int_of_string_opt value with Some 0 -> true | _ -> false
    in

    { result = Integer; report; pos; empty }

  let literal : pos -> string -> repr =
   fun pos value report ->
    let empty = String.equal String.empty value in
    { result = String; report; pos; empty }

  let function_ : pos -> T.function_ -> repr list -> repr =
   fun pos function_ params _acc ->
    (* Accumulate the expressions and get the results, the report is given in
       the differents arguments, and we build a list with the type of the
       parameters. *)
    let types, report =
      List.fold_left params ~init:([], _acc) ~f:(fun (types, report) param ->
          let arg = arg_of_repr (param report) in
          (arg :: types, report))
    in
    let types = List.rev types
    and default = { result = Any; report; pos; empty = false } in

    match function_ with
    | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Func | Getobj
    | Instr | Isplay ->
        { default with result = Integer }
    | Desc' | Dyneval' | Func' | Getobj' -> { default with result = String }
    | Iif | Iif' ->
        let d = Helper.dyn_type () in
        let expected = Helper.[ Fixed Bool; Dynamic d; Dynamic d ] in
        let report = Helper.compare_args pos expected types report in
        (* Extract the type for the expression *)
        let result = d Helper.Bool in
        { result; report; pos; empty = false }
    | Input | Input' ->
        (* Input should check the result if the variable is a num and raise a
           message in this case.*)
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        { result = String; report; pos; empty = false }
    | Isnum ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        { result = Bool; report; pos; empty = false }
    | Lcase | Lcase' | Ucase | Ucase' ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        { result = String; report; pos; empty = false }
    | Len ->
        let expected = Helper.[ Fixed Any ] in
        let report = Helper.compare_args pos expected types report in
        { result = Integer; report; pos; empty = false }
    | Loc ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        { result = Bool; report; pos; empty = false }
    | Max | Max' | Min | Min' ->
        let d = Helper.dyn_type () in
        (* All the arguments must have the same type *)
        let expected = Helper.[ Variable (Dynamic d) ] in
        let report = Helper.compare_args pos expected types report in
        let result = d Helper.Bool in
        { result; report; pos; empty = false }
    | Mid | Mid' ->
        let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        { result = String; report; pos; empty = false }
    | Msecscount -> { result = Integer; report; pos; empty = false }
    | Rand ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        { result = Integer; report; pos; empty = false }
    | Replace -> { result = Integer; report; pos; empty = false }
    | Replace' -> { result = String; report; pos; empty = false }
    | Rgb -> { result = Integer; report; pos; empty = false }
    | Qspver | Qspver' | Rnd ->
        (* No arg *)
        let report = Helper.compare_args pos [] types report in
        { result = Integer; report; pos; empty = false }
    | Selact -> { result = Integer; report; pos; empty = false }
    | Stattxt -> { result = Integer; report; pos; empty = false }
    | Stattxt' -> { result = String; report; pos; empty = false }
    | Str | Str' ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        { default with result = String; report }
    | Strcomp -> { result = Integer; report; pos; empty = false }
    | Strfind -> { result = Integer; report; pos; empty = false }
    | Strfind' -> { result = String; report; pos; empty = false }
    | Strpos -> { result = Integer; report; pos; empty = false }
    | Trim -> { result = Integer; report; pos; empty = false }
    | Trim' -> { result = String; report; pos; empty = false }
    | Val ->
        let expected = Helper.[ Fixed Any ] in
        let report = Helper.compare_args pos expected types report in
        { result = Integer; report; pos; empty = false }

  (** Unary operator like [-123] or [+'Text']*)
  let uoperator : pos -> T.uoperator -> repr -> repr =
   fun pos operator t1 report ->
    let t = t1 report in
    match operator with
    | Add -> t
    | Neg | No ->
        let types = [ arg_of_repr t ] in
        let expected = Helper.[ Fixed Integer ] in
        let report = Helper.compare_args pos expected types report in
        { result = Integer; report; pos; empty = false }

  let boperator : pos -> T.boperator -> repr -> repr -> repr =
   fun pos operator t1 t2 report ->
    let types = [ arg_of_repr (t1 report); arg_of_repr (t2 report) ] in
    match operator with
    | T.Plus ->
        (* Operation over number *)
        let d = Helper.(Dynamic (dyn_type ())) in
        let expected = [ d; d ] in
        let report = Helper.compare_args pos expected types report in
        { result = Bool; report; pos; empty = false }
    | T.Eq | T.Neq | Lt | Gte | Lte | Gt ->
        let d = Helper.(Dynamic (dyn_type ())) in
        let expected = [ d; d ] in
        let report = Helper.compare_args pos expected types report in
        { result = Bool; report; pos; empty = false }
    | T.Mod | T.Minus | T.Product | T.Div ->
        (* Operation over number *)
        let expected = Helper.[ Fixed Integer; Fixed Integer ] in
        let report = Helper.compare_args pos expected types report in
        { result = Integer; report; pos; empty = false }
    | T.And | T.Or ->
        (* Operation over booleans *)
        let expected = Helper.[ Fixed Bool; Fixed Bool ] in
        let report = Helper.compare_args pos expected types report in
        { result = Bool; report; pos; empty = false }
end

module Instruction = struct
  type repr = Report.t list -> Report.t list
  type expression = Expression.repr
  type variable = Expression.variable

  (** Call for an instruction like [GT] or [*CLR] *)
  let call : pos -> string -> expression list -> repr =
   fun _pos _ _ report -> report

  let location : pos -> string -> repr = fun _pos _ report -> report

  (** Comment *)
  let comment : pos -> repr = fun _pos report -> report

  (** Raw expression *)
  let expression : expression -> repr =
   fun expression report -> (expression report).report

  type clause = pos * expression * repr list

  let if_ : pos -> clause -> elifs:clause list -> else_:repr list -> repr =
   fun _pos clause ~elifs ~else_ report ->
    (* Helper function *)
    let fold_clause report (_pos, expr, instructions) : Report.t list =
      let result = expr report in
      let report =
        Helper.compare Helper.Bool
          (Expression.arg_of_repr result)
          result.Expression.report
      in
      List.fold_left instructions ~init:report ~f:(fun report instruction ->
          instruction report)
    in

    (* Traverse the whole block recursively *)
    let report = fold_clause report clause in
    let report = List.fold_left elifs ~f:fold_clause ~init:report in
    List.fold_left else_ ~init:report ~f:(fun report instruction ->
        instruction report)

  let act : pos -> label:expression -> repr list -> repr =
   fun _pos ~label instructions report ->
    let result = label report in
    let report =
      Helper.compare Helper.String
        (Expression.arg_of_repr result)
        result.Expression.report
    in
    List.fold_left instructions ~init:report ~f:(fun report instruction ->
        instruction report)

  let assign : pos -> variable -> T.assignation_operator -> expression -> repr =
   fun pos variable _ expression report ->
    let right_expression = expression report in
    match right_expression.empty with
    | true -> report
    | false ->
        let op1 = Expression.arg_of_repr (Expression.ident variable report) in
        let report = right_expression.Expression.report in
        let op2 = Expression.arg_of_repr right_expression in

        let d = Helper.dyn_type () in
        (* Every part of the assignation should be the same type *)
        let expected = Helper.[ Dynamic d; Dynamic d ] in
        Helper.compare_args ~level:Report.Debug pos expected [ op1; op2 ] report
end

module Location = struct
  type repr = Instruction.repr
  type instruction = Instruction.repr

  let location : pos -> instruction list -> repr =
   fun _pos instructions report ->
    List.fold_left instructions ~init:report ~f:(fun report instruction ->
        instruction report)
end