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
let print s = Format.ifprintf Format.std_formatter "%s@." s

module M () = struct
  module Lexer = Lexer
  module Parser = Parser

  type ast = Lang.t

  module Types = Types.Make ()

  type ast_t = Types.type_expression

  let expected_ext = Some "dddddml"

  module Pp = Pp.Make (Types)

  module Error = Error.Make (struct
    module Pp = Pp
    module Types = Types
  end)

  let normalize ast =
    print "analysing scope..." ;
    let module M = Scope_analysis.Make (struct
      module Error = Error
    end) in
    let ast = M.expr ast in
    let module Env = struct
      let get_old_name = Hashtbl.find M.old_names
    end in
    print "usage analysis..." ;
    let module M = Usage_analysis.Make (struct
      let get_old_name = Env.get_old_name

      module Error = Error
    end) in
    M.expr ast ;
    print "simplification analysis..." ;
    let module M = Simplification_analysis.Make (struct
      let get_old_name = Env.get_old_name

      module Error = Error
      module Pp = Pp
    end) in
    M.expr ast ;
    print "scope reduction analysis..." ;
    let module M = Scope_reduction.Make (struct
      let get_old_name = Env.get_old_name

      module Error = Error
      module Pp = Pp
    end) in
    M.expr ast ;
    print "duplication analysis..." ;
    let module M = Duplication_detection.Make (struct
      module Error = Error
    end) in
    M.expr ast ;
    print "infering types..." ;
    let module M = Type_inference.Make (struct
      module Error = Error
      module Types = Types
    end) in
    let t = M.expr ast in
    print "type checking..." ;
    let module M = Type_check.Make (struct
      let get_type = Hashtbl.find M.infered

      module Error = Error
      module Types = Types
    end) in
    M.expr ast ; print "OK !" ; (ast, t)

  let eval ast =
    let module M = Eval.Eval () in
    try
      let ast, t = normalize ast in
      let result = M.expr ast in
      Ok (Format.asprintf "%a" Pp.fprintf_et (result, t))
    with e -> Error (Format.asprintf "%a" Error.fprintf e)

  let eval_lambdalift ast =
    let module M = Eval.Eval () in
    let module Lambda_lifting = Lambda_lifting.Make () in
    let ast, _t = normalize ast in
    let ast_lambda = Lambda_lifting.expr ast in
    Format.printf "%a@." Pp.fprintf_expr ast_lambda
end

module Make () = struct
  module M = M ()

  include Complice.Comp.Make (M)

  let _ = Lexer.Helper.reset ()

  type ast_t = M.ast_t

  let expected_ext = Some "dddddml"

  module Pp = M.Pp
  module Error = M.Error

  let eval_lambdalift = M.eval_lambdalift
end