qsp_parser/lib/syntax/locations.ml

open StdLabels

module IgnoreCaseString = struct
  type t = string

  let compare t1 t2 =
    String.compare (String.lowercase_ascii t1) (String.lowercase_ascii t2)

  let equal t1 t2 =
    String.equal (String.lowercase_ascii t1) (String.lowercase_ascii t2)
end

module LocationSet = Set.Make (IgnoreCaseString)
module LocationCalls = Map.Make (IgnoreCaseString)

let identifier = "locations"
let description = "Ensure every call points to an existing location"
let is_global = true
let active = ref true

type t = {
  locations : LocationSet.t;
  calls : (string * S.pos) list LocationCalls.t;
}

type context = t ref

let initialize () =
  ref { locations = LocationSet.empty; calls = LocationCalls.empty }

let finalize : context -> (string * Report.t) list =
 fun context ->
  LocationCalls.fold
    (fun location positions acc ->
      let message = Printf.sprintf "The location %s does not exists" location in

      List.fold_left ~init:acc (List.rev positions)
        ~f:(fun acc (loc, position) ->
          let report = Report.error position message in
          (loc, report) :: acc))
    !context.calls []

(** Register a new call to a defined location. *)
let registerCall : S.pos -> string -> t -> t =
 fun pos location t ->
  let file_name = (fst pos).Lexing.pos_fname in
  match
    IgnoreCaseString.equal location file_name
    || LocationSet.mem location t.locations
  with
  | true -> t
  | false ->
      (* The location is not yet defined, register the call for later *)
      let calls =
        LocationCalls.update location
          (function
            | None -> Some [ (file_name, pos) ]
            | Some poss ->
                Some
                  (let new_pos = (file_name, pos) in
                   new_pos :: poss))
          t.calls
      in
      { t with calls }

(** Add a new location in the list of all the collected elements *)
let registerLocation : string -> t -> t =
 fun location t ->
  let calls = LocationCalls.remove location t.calls
  and locations = LocationSet.add location t.locations in
  { calls; locations }

(** The module Expression is pretty simple, we are only interrested by the
    strings ( because only the first argument of [gt …] is read ). 

    If the string is too much complex, we just ignore it. *)
module Expression = struct
  type t = string option

  include Default.Expression (struct
    type nonrec t = t

    let default = None
  end)

  let v : t -> t' = Fun.id

  (* Extract the litteral if this is a simple text *)
  let literal : S.pos -> t' T.literal list -> t' =
   fun _ ll -> match ll with Text lit :: [] -> Some lit | _ -> None
end

module Instruction = struct
  type nonrec t = t -> t
  type t' = t

  let v : t -> t' = Fun.id

  (** Keep a track of every gt or gs instruction *)
  let call : S.pos -> T.keywords -> Expression.t' list -> t =
   fun pos fn args t ->
    match (fn, args) with
    | T.Goto, Some dest :: _ -> registerCall pos dest t
    | T.Gosub, Some dest :: _ -> registerCall pos dest t
    | _ -> t

  let location : S.pos -> string -> t = fun _ _ -> Fun.id
  let comment : S.pos -> t = fun _ -> Fun.id
  let expression : Expression.t' -> t = fun _ -> Fun.id

  let if_ :
      S.pos ->
      (Expression.t', t) S.clause ->
      elifs:(Expression.t', t) S.clause list ->
      else_:(S.pos * t list) option ->
      t =
   fun _ clause ~elifs ~else_ t ->
    let traverse_clause t clause =
      let _, _, block = clause in
      List.fold_left block ~init:t ~f:(fun t instruction -> instruction t)
    in

    let t = traverse_clause t clause in
    let t = List.fold_left ~init:t ~f:traverse_clause elifs in
    match else_ with
    | None -> t
    | Some (_, instructions) ->
        List.fold_left instructions ~init:t ~f:(fun t instruction ->
            instruction t)

  let act : S.pos -> label:Expression.t' -> t list -> t =
   fun _ ~label instructions t ->
    ignore label;
    List.fold_left instructions ~init:t ~f:(fun t instruction -> instruction t)

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

module Location = struct
  type t = unit

  let v : t -> Report.t list = fun () -> []

  let location : context -> S.pos -> Instruction.t list -> t =
   fun context pos instructions ->
    (* Register the location *)
    let file_name = (fst pos).Lexing.pos_fname in
    let c = registerLocation file_name !context in
    (* Then update the list of all the calls to the differents locations *)
    context :=
      List.fold_left instructions ~init:c ~f:(fun t instruction ->
          instruction t)
end