diff options
Diffstat (limited to 'lib/syntax/check.ml')
| -rw-r--r-- | lib/syntax/check.ml | 429 |
1 files changed, 0 insertions, 429 deletions
diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml deleted file mode 100644 index b642945..0000000 --- a/lib/syntax/check.ml +++ /dev/null @@ -1,429 +0,0 @@ -module Id = Type.Id - -(** The the Id module, wrap a value in an existencial type with a witness - associate with. *) -type result = R : { value : 'a; witness : 'a Id.t } -> result - -let get : type a. a Id.t -> result -> a option = - fun typeid (R { value; witness }) -> - match Id.provably_equal typeid witness with - | Some Type.Equal -> Some value - | None -> None - -type t = - | E : { - module_ : - (module S.Analyzer - with type Expression.t = 'a - and type Expression.t' = 'b - and type Instruction.t = 'c - and type Instruction.t' = 'd - and type Location.t = 'e - and type context = 'f); - expr_witness : 'a Id.t; - expr' : 'b Id.t; - instr_witness : 'c Id.t; - instr' : 'd Id.t; - location_witness : 'e Id.t; - context : 'f Id.t; - } - -> t - -let build : - (module S.Analyzer - with type Expression.t = _ - and type Expression.t' = _ - and type Instruction.t = _ - and type Instruction.t' = _ - and type Location.t = 'a - and type context = _) -> - 'a Id.t * t = - fun module_ -> - let expr_witness = Id.make () - and expr' = Id.make () - and instr_witness = Id.make () - and instr' = Id.make () - and location_witness = Id.make () - and context = Id.make () in - let t = - E - { - module_; - expr_witness; - expr'; - instr_witness; - instr'; - location_witness; - context; - } - in - (location_witness, t) - -let get_module : t -> (module S.Analyzer) = - fun (E { module_; _ }) -> (module_ :> (module S.Analyzer)) - -module type App = sig - val t : t array -end - -open StdLabels - -module Helper = struct - type 'a expr_list = { witness : 'a Id.t; values : 'a list } - - let expr_i : result array list -> 'a Id.t -> int -> 'a expr_list = - fun args witness i -> - let result = - List.fold_left args ~init:{ values = []; witness } - ~f:(fun (type a) ({ values; witness } : a expr_list) t : a expr_list -> - match get witness (Array.get t i) with - | None -> failwith "Does not match" - | Some value_1 -> { values = value_1 :: values; witness }) - in - { result with values = result.values } -end - -module Make (A : App) = struct - let identifier = "main_checker" - let description = "Internal module" - let is_global = false - let active = ref false - - type context = result Array.t - (** We associate each context from the differents test in an array. The - context for this module is a sort of context of contexts *) - - (** Initialize each test, and keep the result in the context. *) - let initialize : unit -> context = - fun () -> - Array.map A.t ~f:(fun (E { module_ = (module S); context; _ }) -> - let value = S.initialize () in - R { value; witness = context }) - - let finalize : result Array.t -> (string * Report.t) list = - fun context_array -> - let _, report = - Array.fold_left A.t ~init:(0, []) - ~f:(fun (i, acc) (E { module_ = (module S); context; _ }) -> - let result = Array.get context_array i in - let local_context = Option.get (get context result) in - let reports = S.finalize local_context in - (i + 1, List.rev_append reports acc)) - in - report - - (* Global variable for the whole module *) - let len = Array.length A.t - - module Expression : S.Expression with type t' = result array = struct - type t = result array - type t' = result array - - let literal : S.pos -> t T.literal list -> t = - fun pos values -> - Array.mapi A.t ~f:(fun i (E { module_ = (module S); expr_witness; _ }) -> - (* Map every values to the Checker *) - let values' = - List.map values - ~f: - (T.map_litteral ~f:(fun expr -> - Option.get (get expr_witness (Array.get expr i)))) - in - let value = S.Expression.literal pos values' in - R { value; witness = expr_witness }) - - let integer : S.pos -> string -> t = - fun pos value -> - Array.map A.t ~f:(fun (E { module_ = (module S); expr_witness; _ }) -> - let value = S.Expression.integer pos value in - R { value; witness = expr_witness }) - - (** Unary operator like [-123] or [+'Text']*) - let uoperator : S.pos -> T.uoperator -> t -> t = - fun pos op values -> - (* Evaluate the nested expression *) - let results = values in - - (* Now evaluate the remaining expression. - - Traverse both the module the apply, and the matching expression already - evaluated. - - It’s easer to use [map] and declare [report] as reference instead of - [fold_left2] and accumulate the report inside the closure, because I - don’t manage the order of the results. - *) - let results = - Array.map2 A.t results - ~f:(fun (E { module_ = (module S); expr_witness; _ }) value -> - match get expr_witness value with - | None -> failwith "Does not match" - | Some value -> - (* Evaluate the single expression *) - let value = S.Expression.uoperator pos op value in - R { witness = expr_witness; value }) - in - results - - (** Basically the same as uoperator, but operate over two operands instead - of a single one. *) - let boperator : S.pos -> T.boperator -> t -> t -> t = - fun pos op expr1 expr2 -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - match - ( get expr_witness (Array.get expr1 i), - get expr_witness (Array.get expr2 i) ) - with - | Some value_1, Some value_2 -> - let value = S.Expression.boperator pos op value_1 value_2 in - R { witness = expr_witness; value } - | _ -> failwith "Does not match") - - (** Call a function. The functions list is hardcoded in lib/lexer.mll *) - let function_ : S.pos -> T.function_ -> t list -> t = - fun pos func args -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - (* Extract the arguments for each module *) - let args_i = List.rev (Helper.expr_i args expr_witness i).values in - let value = S.Expression.function_ pos func args_i in - R { witness = expr_witness; value }) - - let ident : (S.pos, t) S.variable -> t = - fun { pos : S.pos; name : string; index : t option } -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in - - match index with - | None -> - (* Easest case, just return the plain ident *) - let value = S.Expression.ident { pos; name; index = None } in - R { witness = expr_witness; value } - | Some t -> ( - match get expr_witness (Array.get t i) with - | None -> failwith "Does not match" - | Some value_1 -> - let value = - S.Expression.ident { pos; name; index = Some value_1 } - in - R { witness = expr_witness; value })) - - (** Convert each internal represention for the expression into its external - representation *) - let v : t -> t' = - fun t -> - let result = - Array.map2 A.t t - ~f:(fun (E { module_ = (module S); expr_witness; expr'; _ }) result -> - match get expr_witness result with - | None -> failwith "Does not match" - | Some value -> - let value = S.Expression.v value in - R { witness = expr'; value }) - in - result - end - - module Instruction : - S.Instruction - with type expression = Expression.t' - and type t' = result array = struct - type expression = Expression.t' - type t = result array - type t' = result array - - let location : S.pos -> string -> t = - fun pos label -> - Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> - let value = S.Instruction.location pos label in - R { value; witness = instr_witness }) - - let comment : S.pos -> t = - fun pos -> - Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> - let value = S.Instruction.comment pos in - R { value; witness = instr_witness }) - - let expression : expression -> t = - fun expr -> - Array.map2 A.t expr - ~f:(fun (E { module_ = (module S); instr_witness; expr'; _ }) result -> - match get expr' result with - | None -> failwith "Does not match" - | Some value -> - (* The evaluate the instruction *) - let value = S.Instruction.expression value in - R { value; witness = instr_witness }) - - let call : S.pos -> T.keywords -> expression list -> t = - fun pos keyword args -> - (* The arguments are given like an array of array. Each expression is - actually the list of each expression in the differents modules. *) - Array.init len ~f:(fun i -> - let (E { module_ = (module S); expr'; instr_witness; _ }) = - Array.get A.t i - in - - let values = List.rev (Helper.expr_i args expr' i).values in - - let value = S.Instruction.call pos keyword values in - R { witness = instr_witness; value }) - - let act : S.pos -> label:expression -> t list -> t = - fun pos ~label instructions -> - Array.init len ~f:(fun i -> - let (E { module_ = (module S); instr_witness; expr'; _ }) = - Array.get A.t i - in - let values = - List.rev (Helper.expr_i instructions instr_witness i).values - in - - match get expr' (Array.get label i) with - | None -> failwith "Does not match" - | Some label_i -> - let value = S.Instruction.act pos ~label:label_i values in - R { witness = instr_witness; value }) - - (* I think it’s one of the longest module I’ve ever written in OCaml… *) - - let assign : - S.pos -> - (S.pos, expression) S.variable -> - T.assignation_operator -> - expression -> - t = - fun pos { pos = var_pos; name; index } op expression -> - Array.init len ~f:(fun i -> - let (E { module_ = (module A); instr_witness; expr'; _ }) = - Array.get A.t i - in - - let index_i = - Option.map - (fun expression -> - Option.get (get expr' (Array.get expression i))) - index - in - let variable = S.{ pos = var_pos; name; index = index_i } in - - match get expr' (Array.get expression i) with - | None -> failwith "Does not match" - | Some value -> - let value = A.Instruction.assign pos variable op value in - - R { value; witness = instr_witness }) - - let rebuild_clause : - type a b. - int -> - a Id.t -> - b Id.t -> - S.pos * result array * result array list -> - (b, a) S.clause = - fun i instr_witness expr' clause -> - let pos_clause, expr_clause, ts = clause in - match get expr' (Array.get expr_clause i) with - | None -> failwith "Does not match" - | Some value -> - let ts = Helper.expr_i ts instr_witness i in - let ts = List.rev ts.values in - let clause = (pos_clause, value, ts) in - clause - - 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_ -> - (* First, apply the report for all the instructions *) - let else_ = - match else_ with - | None -> None - | Some (pos, instructions) -> Some (pos, instructions) - in - Array.init len ~f:(fun i -> - let (E { module_ = (module A); instr_witness; expr'; _ }) = - Array.get A.t i - in - - let clause = rebuild_clause i instr_witness expr' clause - and elifs = List.map elifs ~f:(rebuild_clause i instr_witness expr') - and else_ = - match else_ with - | None -> None - | Some (pos, instructions) -> - let elses = Helper.expr_i instructions instr_witness i in - Some (pos, List.rev elses.values) - in - - let value = A.Instruction.if_ pos clause ~elifs ~else_ in - R { value; witness = instr_witness }) - - (** This code is almost a copy/paste from Expression.v but I did not found - a way to factorize it. *) - let v : t -> t' = - fun t -> - let result = - Array.map2 A.t t - ~f:(fun - (E { module_ = (module S); instr_witness; instr'; _ }) result -> - match get instr_witness result with - | None -> failwith "Does not match" - | Some value -> - let value = S.Instruction.v value in - R { witness = instr'; value }) - in - result - end - - module Location : - S.Location - with type t = result array - and type instruction = Instruction.t' - and type context := context = struct - type instruction = Instruction.t' - type t = result array - - let location : context -> S.pos -> instruction list -> t = - fun local_context pos args -> - ignore pos; - - let result = - Array.init len ~f:(fun i -> - let (E - { module_ = (module A); instr'; location_witness; context; _ }) - = - Array.get A.t i - in - - let local_context = - Option.get (get context (Array.get local_context i)) - in - - let instructions = List.rev (Helper.expr_i args instr' i).values in - let value = A.Location.location local_context pos instructions in - R { value; witness = location_witness }) - in - result - - let v : t -> Report.t list = - fun args -> - let report = ref [] in - let () = - Array.iteri args ~f:(fun i result -> - let (E { module_ = (module A); location_witness; _ }) = - Array.get A.t i - in - match get location_witness result with - | None -> failwith "Does not match" - | Some value -> - let re = A.Location.v value in - report := List.rev_append re !report) - in - !report - end -end |