1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160

(** Copyright 2026, Dmitrii Kuznetsov *)

(** SPDX-License-Identifier: LGPL-3.0-or-later *)

open Common

module STATEERROR = struct
  type ('st, 'a) t = 'st -> 'st * ('a, error) Result.t

  let return : 'a -> ('st, 'a) t = fun x st -> st, Result.Ok x
  let fail e st = st, Result.Error e

  let ( >>= ) : ('st, 'a) t -> ('a -> ('st, 'b) t) -> ('st, 'b) t =
    fun x f st ->
    let st, x = x st in
    match x with
    | Result.Ok x -> f x st
    | Result.Error e -> fail e st
  ;;

  let ( let* ) = ( >>= )
  let ( *> ) : ('st, 'a) t -> ('st, 'b) t -> ('st, 'b) t = fun x1 x2 -> x1 >>= fun _ -> x2

  let ( <|> ) : ('st, 'a) t -> ('st, 'a) t -> ('st, 'a) t =
    fun x1 x2 st ->
    let st, x = x1 st in
    match x with
    | Result.Ok x -> return x st
    | Result.Error _ -> x2 st
  ;;

  let ( >>| ) : ('st, 'a) t -> ('a -> 'b) -> ('st, 'b) t =
    fun x f st ->
    let st, x = x st in
    match x with
    | Result.Ok x -> return (f x) st
    | Result.Error e -> fail e st
  ;;

  let lift2 : ('a -> 'b -> 'c) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t =
    fun f a b -> a >>= fun r_a -> b >>= fun r_b -> return @@ f r_a r_b
  ;;

  let lift3
    : ('a -> 'b -> 'c -> 'd) -> ('st, 'a) t -> ('st, 'b) t -> ('st, 'c) t -> ('st, 'd) t
    =
    fun f a b c -> lift2 f a b >>= fun f -> c >>| f
  ;;

  let read : ('st, 'st) t = fun st -> return st st
  let write : 'st -> ('st, unit) t = fun new_st _ -> new_st, Result.Ok ()

  let map : ('a -> ('st, 'b) t) -> 'a list -> ('st, 'b list) t =
    fun f list ->
    let f acc el = acc >>= fun acc -> f el >>= fun el -> return (el :: acc) in
    List.fold_left f (return []) list >>| List.rev
  ;;

  let iter : ('a -> ('st, unit) t) -> 'a list -> ('st, unit) t =
    fun f list ->
    let f acc elem = acc *> f elem *> return () in
    List.fold_left f (return ()) list
  ;;

  (*('st, 'a) t -> 'st -> 'st * ('a, error) Result.t *)
  let run f = f
end

module TYPECHECK = struct
  open Ast
  open Common.TypeCheck
  include STATEERROR

  type 'a t = (TypeCheck.state, 'a) STATEERROR.t

  let return_with_fail = function
    | Some x -> return x
    | None -> fail (TCError OccursCheck)
  ;;

  let read_local : 'a IdMap.t t =
    read
    >>= function
    | _, l, _, _, _ -> return l
  ;;

  let read_local_el id f = read_local >>= fun l -> IdMap.find_opt id l |> f
  let read_local_el_opt id = read_local_el id return
  let read_local_el id = read_local_el id return_with_fail

  let write_local n_l =
    read
    >>= function
    | g, _, n, m, main -> write (g, n_l, n, m, main)
  ;;

  let write_local_el el_id el_ctx =
    read_local >>= fun l -> write_local (IdMap.add el_id el_ctx l)
  ;;

  let write_meth_type_opt t =
    read
    >>= function
    | g, l, n, _, main -> write (g, l, n, t, main)
  ;;

  let write_meth_type t = write_meth_type_opt (Some t)

  let read_global : 'a IdMap.t t =
    read
    >>= function
    | g, _, _, _, _ -> return g
  ;;

  let read_global_el id f = read_global >>= fun g -> IdMap.find_opt id g |> f
  let read_global_el_opt id = read_global_el id return
  let read_global_el id = read_global_el id return_with_fail

  let read_meth_type : _type option t =
    read
    >>= function
    | _, _, _, m_t, _ -> return m_t
  ;;

  let read_main_class : class_with_main option t =
    read
    >>= function
    | _, _, _, _, main -> return main
  ;;

  let write_main_class main =
    read
    >>= function
    | g, l, n, t, _ -> write (g, l, n, t, main)
  ;;

  let write_global n_g =
    read
    >>= function
    | _, l, n, m, main -> write (n_g, l, n, m, main)
  ;;

  let write_global_el el_id el_ctx =
    read_global >>= fun g -> write_global (IdMap.add el_id el_ctx g)
  ;;

  let get_curr_class_name : curr_class t =
    read
    >>= function
    | _, _, Some n, _, _ -> return n
    | _ ->
      fail (TCError (ImpossibleResult "Current class can be 'none' only before running"))
  ;;

  let write_curr_class_name n =
    read
    >>= function
    | g, l, _, t, main -> write (g, l, Some n, t, main)
  ;;
end