index : configuration.git	master
	Fichiers de configuration	Sébastien Dailly

aboutsummaryrefslogtreecommitdiff

log msg author committer range

path: root/rxvt/.urxvt/ext

Age	Commit message (Collapse)	Author
2021-10-24	rxvt script for copy/paste	Sébastien Dailly
2017-02-25	First commit	Sébastien Dailly

generated by cgit v1.2.3 (git 2.46.0) at 2026-10-09 14:21:09 +0000

open StdLabels

let identifier = "type_check"
let description = "Ensure all the expression are correctly typed"
let active = ref true

module Helper = struct
  type argument_repr = { pos : S.pos; t : Get_type.t }

  module DynType = struct
    type nonrec t = Get_type.t -> Get_type.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 t : unit -> t =
     fun () ->
      let stored = ref None in
      fun t ->
        match !stored with
        | None ->
            stored := Some t;
            t
        | Some t -> t
  end

  (** 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 Get_type.type_of
    | Dynamic of DynType.t
    | Variable of argument

  let compare :
      ?strict:bool ->
      ?level:Report.level ->
      Get_type.type_of ->
      argument_repr ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(level = Report.Warn) expected actual report ->
    let equal =
      match (expected, actual.t) with
      (* Strict equality for this ones, always true *)
      | String, Variable String
      | String, Raw String
      | String, Raw NumericString
      | String, Variable NumericString
      | Integer, Variable Integer
      | Integer, Raw Integer
      | NumericString, Raw NumericString
      | NumericString, Variable NumericString
      | Bool, Raw Bool
      | Bool, Variable Bool
      (* Also include the conversion between bool and integer *)
      | Integer, Raw Bool
      | Integer, Variable Bool
      (* The type NumericString can be used as a generic type in input *)
      | _, Variable NumericString
      | NumericString, Raw String
      | NumericString, Variable String
      | NumericString, Raw Integer
      | NumericString, Variable Integer
      (* A numeric type can be used at any place *)
      | String, Raw Integer ->
          true
      | Bool, Variable Integer when not strict -> true
      | Bool, Raw Integer when not strict -> true
      | String, Variable Integer when not strict -> true
      | String, Raw Bool when not strict -> true
      | String, Variable Bool when not strict -> true
      | Integer, Variable String when not strict -> true
      (* Explicit rejected cases  *)
      | Integer, Raw NumericString when not strict -> true
      | Integer, Raw String -> false
      | _, _ -> false
    in
    if equal then report
    else
      let result_type = match actual.t with Variable v -> v | Raw r -> r in
      let message =
        Format.asprintf "The type %a is expected but got %a" Get_type.pp_type_of
          expected Get_type.pp_type_of result_type
      in
      Report.message level actual.pos message :: report

  let rec compare_parameter :
      ?strict:bool ->
      ?level:Report.level ->
      argument ->
      argument_repr ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(level = Report.Warn) expected param report ->
    match expected with
    | Fixed t -> compare ~level t param report
    | Dynamic d ->
        let type_ = match d param.t with Raw r -> r | Variable v -> v in
        compare ~strict ~level type_ param report
    | Variable c -> compare_parameter ~level c param report

  (** Compare the arguments one by one *)
  let compare_args :
      ?strict:bool ->
      ?level:Report.level ->
      S.pos ->
      argument list ->
      argument_repr list ->
      Report.t list ->
      Report.t list =
   fun ?(strict = false) ?(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 ~strict ~level hd param report in
              (expected, check)
          | hd :: tl ->
              let check = compare_parameter ~strict ~level hd param report in
              (tl, check)
          | [] ->
              let msg = Report.error param.pos "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 TypeBuilder = Compose.Expression (Get_type)

type t' = { result : Get_type.t Lazy.t; pos : S.pos; empty : bool }

let arg_of_repr : Get_type.t Lazy.t -> S.pos -> Helper.argument_repr =
 fun type_of pos -> { pos; t = Lazy.force type_of }

module TypedExpression = struct
  type nonrec t' = t' * Report.t list
  type state = { pos : S.pos; empty : bool }
  type t = state * Report.t list

  let v : Get_type.t Lazy.t * t -> t' =
   fun (type_of, (t, r)) ->
    ({ result = type_of; pos = t.pos; empty = t.empty }, r)

  (** The variable has type string when starting with a '$' *)
  let ident :
      (S.pos, Get_type.t Lazy.t * t) S.variable -> Get_type.t Lazy.t -> t =
   fun var _type_of ->
    let empty = false in

    (* Extract the error from the index *)
    let report =
      match var.index with
      | None -> []
      | Some (_, expr) ->
          let _, r = expr in
          r
    in
    ({ pos = var.pos; empty }, report)

  let integer : S.pos -> string -> Get_type.t Lazy.t -> t =
   fun pos value _type_of ->
    let int_value = int_of_string_opt value in

    let empty, report =
      match int_value with
      | Some 0 -> (true, [])
      | Some _ -> (false, [])
      | None -> (false, Report.error pos "Invalid integer value" :: [])
    in

    ({ pos; empty }, report)

  let literal :
      S.pos -> (Get_type.t Lazy.t * t) T.literal list -> Get_type.t Lazy.t -> t
      =
   fun pos values type_of ->
    ignore type_of;
    let init = ({ pos; empty = true }, []) in
    let result =
      List.fold_left values ~init ~f:(fun (_, report) -> function
        | T.Text t ->
            let empty = String.equal t String.empty in
            ({ pos; empty }, report)
        | T.Expression t -> snd t)
    in

    result

  let function_ :
      S.pos ->
      T.function_ ->
      (Get_type.t Lazy.t * t) list ->
      Get_type.t Lazy.t ->
      t =
   fun pos function_ params _type_of ->
    (* 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:([], [])
        ~f:(fun (types, report) (type_of, param) ->
          ignore type_of;
          let t, r = param in
          let arg = arg_of_repr type_of t.pos in
          (arg :: types, r @ report))
    in
    let types = List.rev types and default = { pos; empty = false } in

    match function_ with
    | Arrcomp | Arrpos | Arrsize | Countobj | Desc | Dyneval | Getobj | Instr
    | Isplay ->
        (default, report)
    | Desc' | Dyneval' | Getobj' -> (default, report)
    | Func | Func' -> (default, report)
    | Iif | Iif' ->
        let d = Helper.DynType.t () 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 *)
        ({ pos; empty = false }, report)
    | 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
        (default, report)
    | Isnum ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Lcase | Lcase' | Ucase | Ucase' ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Len ->
        let expected = Helper.[ Fixed NumericString ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Loc ->
        let expected = Helper.[ Fixed String ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Max | Max' | Min | Min' ->
        let d = Helper.DynType.t () 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
        ({ pos; empty = false }, report)
    | Mid | Mid' ->
        let expected = Helper.[ Fixed String; Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Msecscount -> (default, report)
    | Rand ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Replace -> (default, report)
    | Replace' -> (default, report)
    | Rgb -> (default, report)
    | Rnd ->
        (* No arg *)
        let report = Helper.compare_args pos [] types report in
        (default, report)
    | Selact -> (default, report)
    | Str | Str' ->
        let expected = Helper.[ Variable (Fixed Integer) ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)
    | Strcomp -> (default, report)
    | Strfind -> (default, report)
    | Strfind' -> (default, report)
    | Strpos -> (default, report)
    | Trim -> (default, report)
    | Trim' -> (default, report)
    | Val ->
        let expected = Helper.[ Fixed NumericString ] in
        let report = Helper.compare_args pos expected types report in
        (default, report)

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

  let boperator :
      S.pos ->
      T.boperator ->
      Get_type.t Lazy.t * t ->
      Get_type.t Lazy.t * t ->
      Get_type.t Lazy.t ->
      t =
   fun pos operator (type_1, t1) (type_2, t2) type_of ->
    ignore type_of;
    let t1, report1 = t1 in
    let t2, report2 = t2 in

    let report = report1 @ report2 in

    let types = [ arg_of_repr type_1 t1.pos; arg_of_repr type_2 t2.pos ] in

    match operator with
    | T.Plus ->
        let d = Helper.DynType.t () in
        (* Remove the empty elements *)
        let types =
          List.filter_map
            [ (type_1, t1); (type_2, t2) ]
            ~f:(fun (type_of, t) ->
              (* TODO could be added in the logs *)
              match t.empty with
              | true -> None
              | false -> Some (arg_of_repr type_of t.pos))
        in
        let expected = List.map types ~f:(fun _ -> Helper.Dynamic d) in

        let report = Helper.compare_args pos expected types report in
        ({ pos; empty = false }, report)
    | T.Eq | T.Neq ->
        (* If the expression is '' or 0, we accept the comparaison as if
            instead of raising a warning *)
        if t1.empty || t2.empty then ({ pos; empty = false }, report)
        else
          let d = Helper.(Dynamic (DynType.t ())) in
          let expected = [ d; d ] in
          let report =
            Helper.compare_args ~strict:true pos expected (List.rev types)
              report
          in
          ({ pos; empty = false }, report)
    | Lt | Gte | Lte | Gt ->
        let d = Helper.(Dynamic (DynType.t ())) in
        let expected = [ d; d ] in
        let report = Helper.compare_args pos expected types report in
        ({ pos; empty = false }, report)
    | 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
        ({ pos; empty = false }, report)
    | 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
        ({ pos; empty = false }, report)
end

module Expression = TypeBuilder.Make (TypedExpression)

module Instruction = struct
  type t = Report.t list
  type t' = Report.t list

  let v : t -> t' = fun local_report -> local_report

  type expression = Expression.t'

  (** Call for an instruction like [GT] or [*CLR] *)
  let call : S.pos -> T.keywords -> expression list -> t =
   fun _pos _ expressions ->
    List.fold_left expressions ~init:[] ~f:(fun acc a ->
        let _, report = a in
        (List.rev_append report) acc)

  let location : S.pos -> string -> t = fun _pos _ -> []

  (** Comment *)
  let comment : S.pos -> t = fun _pos -> []

  (** Raw expression *)
  let expression : expression -> t = fun expression -> snd expression

  (** Helper function used in the [if_] function. *)
  let fold_clause : t -> (expression, t) S.clause -> t =
   fun report (_pos, expr, instructions) ->
    let result, r = expr in

    let r2 =
      Helper.compare Get_type.Bool (arg_of_repr result.result result.pos) []
    in

    List.fold_left instructions
      ~init:(r @ r2 @ report)
      ~f:(fun acc a ->
        let report = a in
        (List.rev_append report) acc)

  let if_ :
      S.pos ->
      (expression, t) S.clause ->
      elifs:(expression, t) S.clause list ->
      else_:(S.pos * t list) option ->
      t =
   fun _pos clause ~elifs ~else_ ->
    (* Traverse the whole block recursively *)
    let report = fold_clause [] clause in
    let report = List.fold_left elifs ~f:fold_clause ~init:report in

    match else_ with
    | None -> report
    | Some (_, instructions) ->
        List.fold_left instructions ~init:report ~f:(fun acc a ->
            let report = a in
            (List.rev_append report) acc)

  let act : S.pos -> label:expression -> t list -> t =
   fun _pos ~label instructions ->
    let result, report = label in
    let report =
      Helper.compare Get_type.String
        (arg_of_repr result.result result.pos)
        report
    in

    List.fold_left instructions ~init:report ~f:(fun acc a ->
        let report = a in
        (List.rev_append report) acc)

  let assign :
      S.pos ->
      (S.pos, expression) S.variable ->
      T.assignation_operator ->
      expression ->
      t =
   fun pos variable _ expression ->
    let right_expression, report = expression in

    let report' = Option.map snd variable.index |> Option.value ~default:[] in

    let report = List.rev_append report' report in
    match right_expression.empty with
    | true -> report
    | false -> (
        let var_type = Lazy.from_val (Get_type.ident variable) in
        let op1 = arg_of_repr var_type variable.pos in
        let op2 = arg_of_repr right_expression.result right_expression.pos in

        let d = Helper.DynType.t () in
        (* Every part of the assignation should be the same type *)
        let expected = Helper.[ Dynamic d; Dynamic d ] in

        match
          Helper.compare_args ~strict:false ~level:Report.Error pos expected
            [ op1; op2 ] []
        with
        | [] ->
            Helper.compare_args ~strict:true ~level:Report.Warn pos expected
              [ op1; op2 ] report
        | reports -> reports @ report)
end

module Location = struct
  type t = Report.t list
  type instruction = Instruction.t'

  let v = Fun.id

  let location : S.pos -> instruction list -> t =
   fun _pos instructions ->
    let report =
      List.fold_left instructions ~init:[] ~f:(fun report instruction ->
          let report' = instruction in
          report' @ report)
    in
    report
end