Skip to content
This repository
tag: v1793
Fetching contributors…

Cannot retrieve contributors at this time

file 118 lines (112 sloc) 4.524 kb
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
(*
Copyright © 2011 MLstate

This file is part of OPA.

OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.

OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.

You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
module P = Passes
module Q = QmlAst

module S =
struct
  type t = {
    pesc_code : QmlAst.code;
    pesc_doc_types : Ident.t P.doc_types;
    pesc_annotmap : QmlAst.annotmap;
    pesc_gamma : QmlTypes.gamma;
    pesc_schema : QmlDbGen.Schema.t;
  }
  let pass = ObjectFiles.last_pass
  let pp f _ = Format.pp_print_string f "<dummy>"
end
module R = ObjectFiles.Make(S)

let process_code :
    'tmp_env Passes.env_Gen ->
    ('tmp_env Passes.env_Gen -> unit) ->
    unit =
  fun env k ->
  let initial =
    { S.pesc_doc_types = []
    ; S.pesc_code = []
    ; S.pesc_annotmap = QmlAnnotMap.empty
    ; S.pesc_gamma = QmlTypes.Env.empty
    ; S.pesc_schema = QmlDbGen.Schema.initial } in
  let merge_code_annotmap ?package (code1,annotmap1,s1) (code2,annotmap2,s2) =
    let annotmap, code2, s2 =
      match package with
      | Some package ->
          let code2 = QmlRefresh.refresh_typevars_from_code package code2 in
          let annotmap2 = QmlRefresh.refresh_annotmap package annotmap2 in
          let annotmap, code2 =
            QmlAstCons.TypedCode.copy_new_when_possible
              ~annotmap_old:annotmap2 annotmap1 code2 in
          let annotmap, s2 =
            QmlRefresh.refresh_schema2 package ~refreshed_annotmap_old:annotmap2
              annotmap s2 in
          annotmap, code2, s2
      | None ->
          QmlAnnotMap.merge annotmap1 annotmap2, code2, s2 in
    (code1 @ code2, annotmap, QmlDbGen.Schema.merge s1 s2) in
  let merge_gamma ?package gamma1 gamma2 =
    let gamma2 =
      match package with
      | Some package -> QmlRefresh.refresh_gamma package gamma2
      | None -> gamma2 in
    QmlTypes.Env.append gamma1 gamma2 in
  let merge_doc = (@) in
  let merge ?package
      {S.pesc_code=code1; S.pesc_doc_types=doc1;
       S.pesc_annotmap=annotmap1;
       S.pesc_gamma=gamma1; S.pesc_schema = schema1}
      {S.pesc_code=code2; S.pesc_doc_types=doc2;
       S.pesc_annotmap=annotmap2;
       S.pesc_gamma=gamma2; S.pesc_schema = schema2} =
    let code,annotmap,schema = merge_code_annotmap ?package (code1,annotmap1,schema1) (code2,annotmap2,schema2) in
    {S.pesc_code = code;
     S.pesc_doc_types = merge_doc doc1 doc2;
     S.pesc_annotmap = annotmap;
     S.pesc_gamma = merge_gamma ?package gamma1 gamma2;
     S.pesc_schema = schema;
    } in
  if ObjectFiles.Arg.is_fully_separated () then
    k env
  else (
    match ObjectFiles.compilation_mode () with
    | `init ->
        k env
    | `linking | `prelude ->
        QmlRefresh.load ();
        (*Format.printf "show:%t@." M_typ.show;*)
        let acc = R.fold_with_name ~packages:true ~deep:true (fun package -> merge ~package) initial in
        let code,annotmap,schema =
          merge_code_annotmap
            (acc.S.pesc_code,acc.S.pesc_annotmap,acc.S.pesc_schema)
            (env.P.qmlAst,env.P.typerEnv.QmlTypes.annotmap,env.P.typerEnv.QmlTypes.schema) in
        let env = {env with P.
                     doc_types = merge_doc acc.S.pesc_doc_types env.P.doc_types;
                     qmlAst = code;
                     typerEnv = {env.P.typerEnv with QmlTypes.annotmap = annotmap;
                                   QmlTypes.gamma = merge_gamma acc.S.pesc_gamma env.P.typerEnv.QmlTypes.gamma;
                                   QmlTypes.schema = schema;
                                };
                  } in
        ObjectFiles.end_of_separate_compilation ();
        QmlRefresh.clear ();
        k env
    | `compilation ->
        QmlRefresh.save ();
        let t = {S.pesc_code = env.P.qmlAst;
                 S.pesc_doc_types = env.P.doc_types;
                 S.pesc_annotmap = env.P.typerEnv.QmlTypes.annotmap;
                 S.pesc_gamma = env.P.typerEnv.QmlTypes.gamma;
                 S.pesc_schema = env.P.typerEnv.QmlTypes.schema;
                } in
        R.save t;
        ObjectFiles.compilation_is_successfull ()
  )
Something went wrong with that request. Please try again.