qsp_parser/lib/syntax/dead_end.ml

open StdLabels

let identifier = "dead_end"
let description = "Check for dead end in the code"
let is_global = false
let active = ref false

type context = unit

let initialize = Fun.id
let finalize () = []

module Expression = struct
  type t = unit

  include Default.Expression (struct
    type nonrec t = t

    let default = ()
  end)

  let v : t -> t' = fun () -> ()
end

module Instruction = struct
  type cause = Missing_else | Unchecked_path

  type state = {
    block_pos : S.pos;
    has_gt : bool;
    is_gt : bool;
    pos : (cause * S.pos) option;
  }

  type t = state
  type t' = state

  (** For each instruction, return thoses two informations :

      - the intruction contains at [gt] 
      - the last instruction is a [gt]

    *)
  let v : t -> t' = fun t -> t

  let default =
    {
      block_pos = (Lexing.dummy_pos, Lexing.dummy_pos);
      has_gt = false;
      is_gt = false;
      pos = None;
    }

  (** Call for an instruction like [GT] or [*CLR] *)
  let call : S.pos -> T.keywords -> Expression.t' list -> t =
   fun pos f _ ->
    ignore pos;
    match f with
    | T.Goto | T.XGoto ->
        { block_pos = pos; has_gt = true; is_gt = true; pos = None }
    | T.Gosub -> { block_pos = pos; has_gt = false; is_gt = true; pos = None }
    | _ -> default

  (** Label for a loop *)
  let location : S.pos -> string -> t = fun _ _ -> default

  (** Comment *)
  let comment : S.pos -> t = fun _ -> default

  (** Raw expression *)
  let expression : Expression.t' -> t = fun _ -> default

  (** The content of a block is very linear, I only need to check the last element *)
  let check_block : S.pos -> t list -> t =
   fun pos instructions ->
    let last_element =
      List.fold_left instructions ~init:default ~f:(fun t instruction ->
          let result = instruction in
          let has_gt = result.has_gt || t.has_gt in
          let is_gt = result.is_gt || t.is_gt in
          { result with block_pos = pos; is_gt; has_gt })
    in
    last_element

  let if_ :
      S.pos ->
      (Expression.t', t) S.clause ->
      elifs:(Expression.t', t) S.clause list ->
      else_:(S.pos * t list) option ->
      t =
   fun pos clause ~elifs ~else_ ->
    (* For each block, evaluate the instructions *)
    let res, has_gt, is_gt =
      List.fold_left ~init:([], false, false) (clause :: elifs)
        ~f:(fun (acc, has_gt, is_gt) clause ->
          let pos, _, instructions = clause in
          let clause_t = check_block pos instructions in
          let has_gt = has_gt || clause_t.has_gt
          and is_gt = is_gt || clause_t.is_gt in

          ((clause_t, pos) :: acc, has_gt, is_gt))
    in

    let else_pos, else_block =
      match else_ with
      | Some (pos, instructions) ->
          let block = check_block pos instructions in
          (pos, block)
      | None -> (pos, default)
    in
    let has_gt = has_gt || else_block.has_gt
    and is_gt = is_gt || else_block.is_gt in

    let blocks = (else_block, else_pos) :: res in

    (* Check if one of the clauses already holds a dead end*)
    match List.find_opt res ~f:(fun (res, _) -> res.pos != None) with
    | Some (v, _) -> v
    | None -> (
        match (is_gt, has_gt) with
        | _, true -> (
            (* There is gt intruction in one of the branch, we need to checks
               the others *)
            match List.find_opt blocks ~f:(fun (f, _) -> not f.is_gt) with
            | None ->
                (* Every branch in the if is covered. It’s ok. *)
                { default with block_pos = pos; is_gt; has_gt }
            | Some (_, pos) ->
                (* TODO check if [pos] is the whole block *)
                let cause =
                  match else_ with None -> Missing_else | _ -> Unchecked_path
                in
                { default with block_pos = pos; pos = Some (cause, pos) })
        | _, _ -> { default with block_pos = pos; has_gt; is_gt })

  let act : S.pos -> label:Expression.t' -> t list -> t =
   fun pos ~label expressions ->
    ignore label;
    check_block pos expressions

  let assign :
      S.pos ->
      (S.pos, Expression.t') S.variable ->
      T.assignation_operator ->
      Expression.t' ->
      t =
   fun _ _ _ _ -> default

  let for_ :
      S.pos ->
      (S.pos, Expression.t') S.variable ->
      start:Expression.t' ->
      to_:Expression.t' ->
      step:Expression.t' option ->
      t list ->
      t =
   fun pos variable ~start ~to_ ~step statements ->
    ignore variable;
    ignore start;
    ignore to_;
    ignore step;
    check_block pos statements
end

module Location = struct
  type t = Report.t list

  let v = Fun.id

  let location : unit -> S.pos -> Instruction.t' list -> t =
   fun () _pos instructions ->
    List.fold_left instructions ~init:[] ~f:(fun report t ->
        match (t.Instruction.is_gt, t.Instruction.pos) with
        | false, Some (cause, value) ->
            ignore cause;
            if t.Instruction.block_pos != value then
              match cause with
              | Missing_else ->
                  Report.debug value "Possible dead end (no else fallback)"
                  :: report
              | Unchecked_path ->
                  Report.warn value "Possible dead end (unmatched path)"
                  :: report
            else report
        | _ -> report)
end