diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/qparser/analyzer.ml | 1 | ||||
| -rw-r--r-- | lib/qparser/parser.mly | 15 | ||||
| -rw-r--r-- | lib/qparser/qsp_instruction.mly | 14 | ||||
| -rw-r--r-- | lib/syntax/S.ml | 70 | ||||
| -rw-r--r-- | lib/syntax/check.ml | 396 | ||||
| -rw-r--r-- | lib/syntax/dead_end.ml | 91 | ||||
| -rw-r--r-- | lib/syntax/tree.ml | 65 | ||||
| -rw-r--r-- | lib/syntax/type_of.ml | 71 | 
8 files changed, 267 insertions, 456 deletions
| diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml index 06960f6..58a117f 100644 --- a/lib/qparser/analyzer.ml +++ b/lib/qparser/analyzer.ml @@ -36,7 +36,6 @@ let parse :      in      evaluation -    |> Result.map (fun e -> e [])      |> Result.map_error (fun e ->             let message =               match e.IncrementalParser.code with diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly index d84e534..81b630a 100644 --- a/lib/qparser/parser.mly +++ b/lib/qparser/parser.mly @@ -5,21 +5,20 @@      type action_block =          { loc : Qsp_syntax.S.pos          ; expression :  -          Analyzer.Expression.t' * Qsp_syntax.Report.t list  -        ; body : Analyzer.Instruction.t Qsp_syntax.S.repr list +          Analyzer.Expression.t' +        ; body : Analyzer.Instruction.t list          ; pos : Qsp_syntax.S.pos          ; clauses : (              ( (Analyzer.Instruction.expression, Analyzer.Instruction.t) Qsp_syntax.S.clause list  -            * (Qsp_syntax.S.pos *Analyzer.Instruction.t Qsp_syntax.S.repr list) option +            * (Qsp_syntax.S.pos * Analyzer.Instruction.t list) option              ) option )          }      module Helper = Qsp_syntax.S.Helper(Analyzer.Expression) -    module HelperI = Qsp_syntax.S.Helper(Analyzer.Instruction)  %}  %parameter<Analyzer: Qsp_syntax.S.Analyzer> -%start <(Analyzer.Location.t * Qsp_syntax.Report.t list) Qsp_syntax.S.repr>main +%start <(Analyzer.Location.t * Qsp_syntax.Report.t list)>main  %on_error_reduce expression instruction unary_operator assignation_operator  %%  @@ -31,7 +30,7 @@ main:        instructions = line_statement*        LOCATION_END      {  -        let instructions = List.map instructions ~f:(HelperI.v) in +        let instructions = List.map instructions ~f:(Analyzer.Instruction.v) in          Analyzer.Location.location $loc instructions      } @@ -75,7 +74,7 @@ line_statement:        END TOKEN?        line_sep        {  -        let expression = Helper.v' e in +        let expression = Analyzer.Expression.v e in          let clauses = match b with          | None -> None          | Some (elifs, clauses) ->  @@ -84,7 +83,7 @@ line_statement:              | _ ->                 List.map elifs                ~f:(fun ((pos:Qsp_syntax.S.pos), e, instructions) ->  -                let e = Helper.v' e in +                let e = Analyzer.Expression.v e in                  (pos, e, instructions)                ) diff --git a/lib/qparser/qsp_instruction.mly b/lib/qparser/qsp_instruction.mly index e8f5a77..b7d2558 100644 --- a/lib/qparser/qsp_instruction.mly +++ b/lib/qparser/qsp_instruction.mly @@ -18,7 +18,7 @@ argument(X):  %public inline_action:      | a = onliner(ACT)        { let loc, label, statements, _, _ = a in  -        let label = Helper.v' label in +        let label = Analyzer.Expression.v label in          Analyzer.Instruction.act loc ~label statements        }      | a = onliner(IF) @@ -30,7 +30,7 @@ argument(X):            | Some instructions -> Some ($loc(else_opt), [ instructions ]) in          Analyzer.Instruction.if_              loc  -            (loc_s, Helper.v' expr, statements)  +            (loc_s, Analyzer.Expression.v expr, statements)               ~elifs              ~else_        } @@ -42,21 +42,21 @@ argument(X):          Analyzer.Instruction.if_              loc  -            (loc_s, Helper.v' expr, statements)  +            (loc_s, Analyzer.Expression.v expr, statements)               ~elifs              ~else_        }  single_instruction:      | expr = expression      {  -        let expr = Helper.v' expr in +        let expr = Analyzer.Expression.v expr in          Analyzer.Instruction.expression expr      }      | e = let_assignation   { e }      | k = keyword        args = argument(expression)      { -        let args = List.map args ~f:(Helper.v') in +        let args = List.map args ~f:(Analyzer.Expression.v) in          Analyzer.Instruction.call $loc k args      } @@ -69,8 +69,8 @@ let_assignation:        op = assignation_operator        value = expression       {  -        let variable = Helper.variable' variable -        and value = Helper.v' value in +        let variable = Helper.variable variable +        and value = Analyzer.Expression.v value in          Analyzer.Instruction.assign $loc variable op value      } diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml index b52365d..4a6b3e2 100644 --- a/lib/syntax/S.ml +++ b/lib/syntax/S.ml @@ -13,8 +13,6 @@   *) -type 'a repr = Report.t list -> 'a -  type pos = Lexing.position * Lexing.position  (** Starting and ending position for the given location *) @@ -24,7 +22,7 @@ type ('a, 'b) variable = { pos : 'a; name : string; index : 'b option }      If missing, the index should be considered as [0].*) -type ('a, 'b) clause = pos * 'a * 'b repr list +type ('a, 'b) clause = pos * 'a * 'b list  (** Represent the evaluation over an expression *)  module type Expression = sig @@ -34,7 +32,7 @@ module type Expression = sig    type t'    (** External type used outside of the module *) -  val v : t -> t' * Report.t list +  val v : t -> t'    val ident : (pos, t) variable -> t    (* @@ -61,54 +59,50 @@ module type Instruction = sig    type t'    (** External type used outside of the module *) -  val v : t -> t' * Report.t list +  val v : t -> t'    type expression -  val call : pos -> T.keywords -> expression list -> t repr +  val call : pos -> T.keywords -> expression list -> t    (** Call for an instruction like [GT] or [*CLR] *) -  val location : pos -> string -> t repr +  val location : pos -> string -> t    (** Label for a loop *) -  val comment : pos -> t repr +  val comment : pos -> t    (** Comment *) -  val expression : expression -> t repr +  val expression : expression -> t    (** Raw expression *)    val if_ :      pos ->      (expression, t) clause ->      elifs:(expression, t) clause list -> -    else_:(pos * t repr list) option -> -    t repr +    else_:(pos * t list) option -> +    t -  val act : pos -> label:expression -> t repr list -> t repr +  val act : pos -> label:expression -> t list -> t    val assign :      pos ->      (pos, expression) variable ->      T.assignation_operator ->      expression -> -    t repr +    t  end  module type Location = sig    type t    type instruction -  val location : pos -> instruction list -> (t * Report.t list) repr +  val location : pos -> instruction list -> t * Report.t list  end  module type Analyzer = sig    module Expression : Expression - -  module Instruction : -    Instruction with type expression = Expression.t' * Report.t list - -  module Location : -    Location with type instruction = (Instruction.t' * Report.t list) repr +  module Instruction : Instruction with type expression = Expression.t' +  module Location : Location with type instruction = Instruction.t'  end  (** Helper module used in order to convert elements from the differents @@ -124,39 +118,11 @@ module Helper (E : sig    type t'    (** External type used outside of the module *) -  val v : t -> t' * Report.t list +  val v : t -> t'  end) : sig -  val v : E.t repr -> Report.t list -> E.t' * Report.t list -  (** Convert an instruction from the internal representation *) - -  val v' : E.t -> E.t' * Report.t list -  (** Convert an expression from the internal representation *) - -  val variable : -    (pos, E.t) variable -> (pos, Report.t list -> E.t' * Report.t list) variable - -  val variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable +  val variable : (pos, E.t) variable -> (pos, E.t') variable    (** Convert a variable from the [Expression.t] into [Expression.t'] *)  end = struct -  let v : E.t repr -> Report.t list -> E.t' * Report.t list = -   fun v report -> -    let value = v report in -    E.v value - -  let v' : E.t -> E.t' * Report.t list = fun v -> E.v v - -  let variable : -      (pos, E.t) variable -> -      (pos, Report.t list -> E.t' * Report.t list) variable = -   fun variable -> -    let v' : E.t -> Report.t list -> E.t' * Report.t list = -     fun t report -> -      ignore report; -      E.v t -    in - -    { variable with index = Option.map v' variable.index } - -  let variable' : (pos, E.t) variable -> (pos, E.t' * Report.t list) variable = -   fun variable -> { variable with index = Option.map v' variable.index } +  let variable : (pos, E.t) variable -> (pos, E.t') variable = +   fun variable -> { variable with index = Option.map E.v variable.index }  end diff --git a/lib/syntax/check.ml b/lib/syntax/check.ml index 10e4809..54eb295 100644 --- a/lib/syntax/check.ml +++ b/lib/syntax/check.ml @@ -59,9 +59,9 @@ type t =              and type Instruction.t' = 'd              and type Location.t = 'e);        expr_witness : 'a Id.typeid; -      expr' : ('b * Report.t list) Id.typeid; +      expr' : 'b Id.typeid;        instr_witness : 'c Id.typeid; -      instr' : ('d * Report.t list) Id.typeid; +      instr' : 'd Id.typeid;        location_witness : 'e Id.typeid;      }        -> t @@ -90,27 +90,6 @@ module type App = sig  end  module Helper = struct -  type 'a args_list = { witness : 'a Id.typeid; values : 'a S.repr list } -  (** This types helps the compiler to know which kind of arguments are hold -        inside the list. This is just a list with the additionnal witness -        information *) - -  (** Extract all the lines from the given module  - -      **Beware** The values are reversed. You should apply a List.rev if you -      want to keep them in the same order than the modules to apply. -    *) -  let args_i : result array list -> 'a Id.typeid -> int -> 'a args_list = -   fun args witness i -> -    let result = -      List.fold_left args ~init:{ values = []; witness } -        ~f:(fun (type a) ({ values; witness } : a args_list) t : a args_list -> -          match get witness (Array.get t i) with -          | None -> failwith "Does not match" -          | Some value_1 -> { values = (fun _ -> value_1) :: values; witness }) -    in -    { result with values = result.values } -    type 'a expr_list = { witness : 'a Id.typeid; values : 'a list }    let expr_i : result array list -> 'a Id.typeid -> int -> 'a expr_list = @@ -123,11 +102,12 @@ module Helper = struct            | Some value_1 -> { values = value_1 :: values; witness })      in      { result with values = result.values } - -  let map_args report args = List.map args ~f:(fun v -> v report)  end  module Make (A : App) = struct +  (* 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 @@ -172,51 +152,32 @@ module Make (A : App) = struct        results      (** Basically the same as uoperator, but operate over two operands instead -        of a single one.  - -        In order to operate over the values (application, op1, op2) I’ve -        written a function [take_arg] which works like a [Array.map3] *) +        of a single one. *)      let boperator : S.pos -> T.boperator -> t -> t -> t =       fun pos op expr1 expr2 -> -      let take_arg : result array -> result array -> result array = -       fun expr1 expr2 -> -        let len = Array.length A.t in -        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") -      in - -      take_arg 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 -> -      let len = Array.length A.t in -      let result = -        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 }) -      in -      result +      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 } -> -      let len = Array.length A.t in -        Array.init len ~f:(fun i ->            let (E { module_ = (module S); expr_witness; _ }) = Array.get A.t i in @@ -236,7 +197,7 @@ module Make (A : App) = struct      (** Convert each internal represention for the expression into its external          representation *) -    let v : t -> t' * Report.t list = +    let v : t -> t' =       fun t ->        let result =          Array.map2 A.t t @@ -247,101 +208,69 @@ module Make (A : App) = struct                  let value = S.Expression.v value in                  R { witness = expr'; value })        in -      (result, []) +      result    end    module Instruction :      S.Instruction -      with type expression = Expression.t' * Report.t list +      with type expression = Expression.t'         and type t' = result array = struct -    type expression = Expression.t' * Report.t list +    type expression = Expression.t'      type t = result array      type t' = result array -    let location : S.pos -> string -> t S.repr = -     fun pos label report -> -      let values = -        Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> -            let value = S.Instruction.location pos label report in -            R { value; witness = instr_witness }) -      in -      values - -    let comment : S.pos -> t S.repr = -     fun pos report -> -      let values = -        Array.map A.t ~f:(fun (E { module_ = (module S); instr_witness; _ }) -> -            let value = S.Instruction.comment pos report in -            R { value; witness = instr_witness }) -      in -      values - -    let expression : expression -> t S.repr = -     fun expr report -> -      let expr, _report = expr in -      let results = -        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 report in -                R { value; witness = instr_witness }) -      in -      results +    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 S.repr = -     fun pos keyword args report -> +    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 -      (* Accumulate the results *) -      let report, args = -        List.fold_left_map args ~init:report ~f:(fun report (v, r) -> -            (r @ report, v)) -      in - -      let len = Array.length A.t in -      let result = -        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 report in -            R { witness = instr_witness; value }) -      in -      result - -    let act : S.pos -> label:expression -> t S.repr list -> t S.repr = -     fun pos ~label instructions _report -> -      let label, report = label in -      let instructions = Helper.map_args report instructions in -      let len = Array.length A.t in +          let values = List.rev (Helper.expr_i args expr' i).values in -      let result = -        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.args_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 report -                in -                R { witness = instr_witness; value }) -      in +          let value = S.Instruction.call pos keyword values in +          R { witness = instr_witness; value }) -      result +    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… *) @@ -350,131 +279,91 @@ module Make (A : App) = struct          (S.pos, expression) S.variable ->          T.assignation_operator ->          expression -> -        t S.repr = -     fun pos { pos = var_pos; name; index } op expression _report -> -      let expression, report = expression in -      let report = ref report and len = Array.length A.t in - -      let index = -        Option.map -          (fun v -> -            let v, r = v in -            report := r; -            v) -          index -      in - -      let result = -        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 -> -                  match get expr' (Array.get expression i) with -                  | None -> failwith "Does not match" -                  | Some value -> value) -                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 !report -                in - -                R { value; witness = instr_witness }) -      in +        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 -> +                match get expr' (Array.get expression i) with +                | None -> failwith "Does not match" +                | Some value -> value) +              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 -      result +              R { value; witness = instr_witness })      (** Helper function used to prepare the clauses *) -    let map_clause : -        Report.t list -> -        (expression, t) S.clause -> -        Report.t list * (S.pos * Expression.t' * t list) = -     fun _report clause -> +    let map_clause : (expression, t) S.clause -> S.pos * Expression.t' * t list +        = +     fun clause ->        let clause_pos, expression, t = clause in -      let expression, report = expression in -      let t = -        List.map t ~f:(fun t -> -            let t = t report in -            t) -      in +      let expression = expression in        let clause = (clause_pos, expression, t) in -      (report, clause) +      clause      let rebuild_clause :          type a b.          int ->          a Id.typeid ->          b Id.typeid -> -        (b -> 'c) ->          S.pos * result array * result array list -> -        ('c, a) S.clause = -     fun i instr_witness expr' f clause -> +        (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.args_i ts instr_witness i in +          let ts = Helper.expr_i ts instr_witness i in            let ts = List.rev ts.values in -          let clause = (pos_clause, f value, ts) 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 S.repr list) option -> -        t S.repr = -     fun pos clause ~elifs ~else_ report -> +        else_:(S.pos * t list) option -> +        t = +     fun pos clause ~elifs ~else_ ->        (* First, apply the report for all the instructions *) -      let report, clause = map_clause report clause in - -      let report, elifs = List.fold_left_map elifs ~init:report ~f:map_clause in -      let report, else_ = +      let clause = map_clause clause and elifs = List.map elifs ~f:map_clause in +      let else_ =          match else_ with -        | None -> (report, None) -        | Some (pos, instructions) -> -            let instructions = Helper.map_args report instructions in -            (report, Some (pos, instructions)) -      in -      let len = Array.length A.t in - -      let result = -        Array.init len ~f:(fun i -> -            let (E { module_ = (module A); instr_witness; expr'; _ }) = -              Array.get A.t i -            in - -            (* This function helps to build the expression in the clauses *) -            let f = Fun.id in - -            let clause = rebuild_clause i instr_witness expr' f clause -            and elifs = -              List.map elifs ~f:(rebuild_clause i instr_witness expr' f) -            and else_ = -              match else_ with -              | None -> None -              | Some (pos, instructions) -> -                  let elses = Helper.args_i instructions instr_witness i in -                  Some (pos, List.rev elses.values) -            in - -            let value = A.Instruction.if_ pos clause ~elifs ~else_ report in -            R { value; witness = instr_witness }) +        | None -> None +        | Some (pos, instructions) -> Some (pos, instructions)        in - -      result +      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' * Report.t list = +    let v : t -> t' =       fun t ->        let result =          Array.map2 A.t t @@ -486,38 +375,29 @@ module Make (A : App) = struct                  let value = S.Instruction.v value in                  R { witness = instr'; value })        in -      (result, []) +      result    end    module Location : -    S.Location -      with type t = result array -       and type instruction = (Instruction.t' * Report.t list) S.repr = struct -    type instruction = (Instruction.t' * Report.t list) S.repr +    S.Location with type t = result array and type instruction = Instruction.t' = +  struct +    type instruction = Instruction.t'      type t = result array -    let location : S.pos -> instruction list -> (t * Report.t list) S.repr = -     fun pos instructions report -> +    let location : S.pos -> instruction list -> t * Report.t list = +     fun pos args ->        ignore pos; -      (* Extract the instructions and accumulate the result *) -      let instructions = Helper.map_args report instructions in - -      let report, args = -        List.fold_left_map instructions ~init:report ~f:(fun report (v, r) -> -            (r @ report, v)) -      in - -      let report = ref report and len = Array.length A.t in +      let report = ref [] in        let result =          Array.init len ~f:(fun i ->              let (E { module_ = (module A); instr'; location_witness; _ }) =                Array.get A.t i              in -            let instructions = List.rev (Helper.args_i args instr' i).values in -            let value, re = A.Location.location pos instructions !report in -            report := re; +            let instructions = List.rev (Helper.expr_i args instr' i).values in +            let value, re = A.Location.location pos instructions in +            report := List.rev_append re !report;              R { value; witness = location_witness })        in        (result, !report) diff --git a/lib/syntax/dead_end.ml b/lib/syntax/dead_end.ml index d1683cd..1240e72 100644 --- a/lib/syntax/dead_end.ml +++ b/lib/syntax/dead_end.ml @@ -10,11 +10,11 @@ module Expression = struct      let default = ()    end) -  let v : t -> t' * Report.t list = fun () -> ((), []) +  let v : t -> t' = fun () -> ()  end  module Instruction = struct -  type expression = Expression.t' * Report.t list +  type expression = Expression.t'    type cause = Missing_else | Unchecked_path    type state = { @@ -24,7 +24,7 @@ module Instruction = struct      pos : (cause * S.pos) option;    } -  type t = state * Report.t list +  type t = state    type t' = state    (** For each instruction, return thoses two informations : @@ -33,7 +33,7 @@ module Instruction = struct        - the last instruction is a [gt]      *) -  let v : t -> t' * Report.t list = fun t -> t +  let v : t -> t' = fun t -> t    let default =      { @@ -44,36 +44,33 @@ module Instruction = struct      }    (** Call for an instruction like [GT] or [*CLR] *) -  let call : S.pos -> T.keywords -> expression list -> t S.repr = -   fun pos f _ report -> +  let call : S.pos -> T.keywords -> expression 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 }, report) -    | T.Gosub -> -        ({ block_pos = pos; has_gt = false; is_gt = true; pos = None }, report) -    | _ -> (default, report) +        { 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 S.repr = -   fun _ _ report -> (default, report) +  let location : S.pos -> string -> t = fun _ _ -> default    (** Comment *) -  let comment : S.pos -> t S.repr = fun _ report -> (default, report) +  let comment : S.pos -> t = fun _ -> default    (** Raw expression *) -  let expression : expression -> t S.repr = fun _ report -> (default, report) +  let expression : expression -> 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 S.repr list -> t S.repr = -   fun pos instructions report -> +  let check_block : S.pos -> t list -> t = +   fun pos instructions ->      let last_element = -      List.fold_left instructions ~init:(default, report) -        ~f:(fun (t, report) instruction -> -          let result, report = instruction report in +      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 }, report)) +          { result with block_pos = pos; is_gt; has_gt })      in      last_element @@ -81,27 +78,27 @@ module Instruction = struct        S.pos ->        (expression, t) S.clause ->        elifs:(expression, t) S.clause list -> -      else_:(S.pos * t S.repr list) option -> -      t S.repr = -   fun pos clause ~elifs ~else_ report -> +      else_:(S.pos * t list) option -> +      t = +   fun pos clause ~elifs ~else_ ->      (* For each block, evaluate the instructions *) -    let report, res, has_gt, is_gt = -      List.fold_left ~init:(report, [], false, false) (clause :: elifs) -        ~f:(fun (report, acc, has_gt, is_gt) clause -> +    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, report = check_block pos instructions report 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 -          (report, (clause_t, pos) :: acc, has_gt, is_gt)) +          ((clause_t, pos) :: acc, has_gt, is_gt))      in -    let else_pos, else_block, report = +    let else_pos, else_block =        match else_ with        | Some (pos, instructions) -> -          let block, report = check_block pos instructions report in -          (pos, block, report) -      | None -> (pos, default, report) +          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 @@ -110,7 +107,7 @@ module Instruction = struct      (* 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, report) +    | Some (v, _) -> v      | None -> (          match (is_gt, has_gt) with          | _, true -> ( @@ -119,41 +116,37 @@ module Instruction = struct              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 }, report) +                { 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) }, -                  report )) -        | _, _ -> ({ default with block_pos = pos; has_gt; is_gt }, report)) +                { 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 S.repr list -> t S.repr = -   fun pos ~label expressions report -> +  let act : S.pos -> label:expression -> t list -> t = +   fun pos ~label expressions ->      ignore label; -    check_block pos expressions report +    check_block pos expressions    let assign :        S.pos ->        (S.pos, expression) S.variable ->        T.assignation_operator ->        expression -> -      t S.repr = -   fun _ _ _ _ report -> (default, report) +      t = +   fun _ _ _ _ -> default  end  module Location = struct    type t = unit -  type instruction = (Instruction.t' * Report.t list) S.repr +  type instruction = Instruction.t' -  let location : S.pos -> instruction list -> (t * Report.t list) S.repr = -   fun _pos instructions report -> +  let location : S.pos -> instruction list -> t * Report.t list = +   fun _pos instructions ->      ( (), -      List.fold_left instructions ~init:report ~f:(fun report instruction -> -          let t, r = instruction [] in - -          let report = List.rev_append r report in +      List.fold_left instructions ~init:[] ~f:(fun report t ->            match (t.Instruction.is_gt, t.Instruction.pos) with            | false, Some (cause, value) ->                ignore cause; diff --git a/lib/syntax/tree.ml b/lib/syntax/tree.ml index cf02bf6..d4af905 100644 --- a/lib/syntax/tree.ml +++ b/lib/syntax/tree.ml @@ -36,7 +36,7 @@ module Expression : S.Expression with type t' = S.pos Ast.expression = struct    type t = S.pos Ast.expression    type t' = t -  let v : t -> t' * Report.t list = fun t -> (t, []) +  let v : t -> t' = fun t -> t    let integer : S.pos -> string -> t = fun pos i -> Ast.Integer (pos, i)    let literal : S.pos -> string -> t = fun pos l -> Ast.Literal (pos, l) @@ -59,78 +59,57 @@ end  module Instruction :    S.Instruction -    with type expression = Expression.t' * Report.t list +    with type expression = Expression.t'       and type t' = S.pos Ast.statement = struct    type t = S.pos Ast.statement    type t' = t -  let v : t -> t' * Report.t list = fun t -> (t, []) +  let v : t -> t' = fun t -> t -  type expression = Expression.t' * Report.t list +  type expression = Expression.t' -  let call : S.pos -> T.keywords -> expression list -> t S.repr = -   fun pos name args _ -> -    let args = List.map ~f:fst args in -    Ast.Call (pos, name, args) +  let call : S.pos -> T.keywords -> expression list -> t = +   fun pos name args -> Ast.Call (pos, name, args) -  let location : S.pos -> string -> t S.repr = -   fun loc label _ -> Ast.Location (loc, label) +  let location : S.pos -> string -> t = +   fun loc label -> Ast.Location (loc, label) -  let comment : S.pos -> t S.repr = fun pos _ -> Ast.Comment pos - -  let expression : expression -> t S.repr = -   fun expr _ -> Ast.Expression (fst expr) +  let comment : S.pos -> t = fun pos -> Ast.Comment pos +  let expression : expression -> t = fun expr -> Ast.Expression expr    let if_ :        S.pos ->        (expression, t) S.clause ->        elifs:(expression, t) S.clause list -> -      else_:(S.pos * t S.repr list) option -> -      t S.repr = -   fun pos predicate ~elifs ~else_ _ -> -    let clause (pos, expr, repr) = -      let repr = List.map ~f:(fun instr -> instr []) repr in -      (pos, fst @@ expr, repr) -    in +      else_:(S.pos * t list) option -> +      t = +   fun pos predicate ~elifs ~else_ -> +    let clause (pos, expr, repr) = (pos, expr, repr) in      let elifs = List.map ~f:clause elifs      and else_ = -      match else_ with -      | None -> [] -      | Some (_, instructions) -> -          List.map ~f:(fun instr -> instr []) instructions +      match else_ with None -> [] | Some (_, instructions) -> instructions      in      Ast.If { loc = pos; then_ = clause predicate; elifs; else_ } -  let act : S.pos -> label:expression -> t S.repr list -> t S.repr = -   fun pos ~label statements _ -> -    let label = fst label -    and statements = List.map ~f:(fun instr -> instr []) statements in -    Ast.Act { loc = pos; label; statements } +  let act : S.pos -> label:expression -> t list -> t = +   fun pos ~label statements -> Ast.Act { loc = pos; label; statements }    let assign :        S.pos ->        (S.pos, expression) S.variable ->        T.assignation_operator ->        expression -> -      t S.repr = -   fun pos_loc { pos; name; index } op expr _ -> +      t = +   fun pos_loc { pos; name; index } op expr ->      (*let index = Option.map (fun i -> fst @@ Expression.observe (i [])) index*) -    let index = Option.map fst index in -    let expr = fst expr in      Ast.Declaration (pos_loc, { pos; name; index }, op, expr)  end  module Location = struct -  type instruction = (Instruction.t' * Report.t list) S.repr +  type instruction = Instruction.t'    type t = S.pos * S.pos Ast.statement list -  let location : S.pos -> instruction list -> (t * Report.t list) S.repr = -   fun pos block report -> -    let report, block = -      List.fold_left_map ~init:report block ~f:(fun report b -> -          let v, report = b report in -          (report, v)) -    in -    ((pos, block), report) +  let location : S.pos -> instruction list -> t * Report.t list = +   fun pos block -> ((pos, block), [])  end diff --git a/lib/syntax/type_of.ml b/lib/syntax/type_of.ml index 683a27a..485fbe2 100644 --- a/lib/syntax/type_of.ml +++ b/lib/syntax/type_of.ml @@ -144,9 +144,9 @@ end  module Expression = struct    type state = { result : Helper.t; pos : S.pos; empty : bool }    type t = state * Report.t list -  type t' = state +  type t' = state * Report.t list -  let v : t -> t' * Report.t list = fun t -> t +  let v : t -> t' = fun t -> t    let arg_of_repr : state -> Helper.argument_repr =     fun { result; pos; empty } -> @@ -352,29 +352,26 @@ end  module Instruction = struct    type t = Report.t list -  type t' = unit +  type t' = Report.t list -  let v : t -> t' * Report.t list = fun local_report -> ((), local_report) +  let v : t -> t' = fun local_report -> local_report -  type expression = Expression.t' * Report.t list +  type expression = Expression.t'    (** Call for an instruction like [GT] or [*CLR] *) -  let call : S.pos -> T.keywords -> expression list -> t S.repr = -   fun _pos _ expressions report -> -    List.fold_left expressions ~init:report ~f:(fun acc a -> +  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 S.repr = fun _pos _ report -> report +  let location : S.pos -> string -> t = fun _pos _ -> []    (** Comment *) -  let comment : S.pos -> t S.repr = fun _pos report -> report +  let comment : S.pos -> t = fun _pos -> []    (** Raw expression *) -  let expression : expression -> t S.repr = -   fun expression report -> -    ignore report; -    snd 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 = @@ -386,37 +383,36 @@ module Instruction = struct      List.fold_left instructions        ~init:(r @ r2 @ report)        ~f:(fun acc a -> -        let report = a [] in +        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 S.repr list) option -> -      t S.repr = -   fun _pos clause ~elifs ~else_ report -> +      else_:(S.pos * t list) option -> +      t = +   fun _pos clause ~elifs ~else_ ->      (* Traverse the whole block recursively *) -    let report = fold_clause report clause in +    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 +            let report = a in              (List.rev_append report) acc) -  let act : S.pos -> label:expression -> t S.repr list -> t S.repr = -   fun _pos ~label instructions report -> -    let result, r = label in -    let report = r @ report in +  let act : S.pos -> label:expression -> t list -> t = +   fun _pos ~label instructions -> +    let result, report = label in      let report =        Helper.compare Helper.String (Expression.arg_of_repr result) report      in      List.fold_left instructions ~init:report ~f:(fun acc a -> -        let report = a [] in +        let report = a in          (List.rev_append report) acc)    let assign : @@ -424,11 +420,11 @@ module Instruction = struct        (S.pos, expression) S.variable ->        T.assignation_operator ->        expression -> -      t S.repr = -   fun pos variable _ expression report -> -    let right_expression, r = expression in +      t = +   fun pos variable _ expression -> +    let right_expression, report = expression in      let expr1, report' = Expression.ident variable in -    let report = report' @ r @ report in +    let report = report' @ report in      match right_expression.empty with      | true -> report      | false -> ( @@ -451,15 +447,14 @@ end  module Location = struct    type t = unit -  type instruction = (Instruction.t' * Report.t list) S.repr - -  let location : S.pos -> instruction list -> (t * Report.t list) S.repr = -   fun _pos instructions report -> -    let (), report = -      List.fold_left instructions ~init:((), report) -        ~f:(fun ((), report) instruction -> -          let _, report' = instruction [] in -          ((), report' @ report)) +  type instruction = Instruction.t' + +  let location : S.pos -> instruction list -> t * Report.t list = +   fun _pos instructions -> +    let report = +      List.fold_left instructions ~init:[] ~f:(fun report instruction -> +          let report' = instruction in +          report' @ report)      in      ((), report)  end | 
