Skip to content
This repository
tag: v644
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 184 lines (141 sloc) 5.835 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 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 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183
(*
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/>.
*)
(* refactoring *)

(* alias *)
module Q = QmlAst

module Context =
struct

  type context = {
    pos : FilePos.pos ;

    (* The annotmap is for finding types *)
    annotmap : QmlAst.annotmap list ;

    code_elt : QmlAst.code_elt list ;

    expr : QmlAst.expr list ;

    pat : QmlAst.pat list ;

    ty : QmlAst.ty list ;

    package : string list ; (* sometime the context is related to compilation option of a package, so you are not on shame but you have no position *)

    what_a_shame : string list ;
  }

  let default = {
    pos = FilePos.nopos "QmlError.Context.default" ;
    annotmap = [] ;
    code_elt = [] ;
    expr = [] ;
    pat = [] ;
    ty = [] ;
    package = [] ;
    what_a_shame = [] ;
  }

  let insert_aux list o =
    if List.exists (fun o' -> o == o') list
    then list
    else o::list

  let merge_aux a b = List.fold_left insert_aux b a

  let merge2 c1 c2 = {
    pos = FilePos.merge_pos c1.pos c2.pos ;

    annotmap = merge_aux c1.annotmap c2.annotmap ;
    code_elt = merge_aux c1.code_elt c2.code_elt ;
    expr = merge_aux c1.expr c2.expr ;
    pat = merge_aux c1.pat c2.pat ;
    ty = merge_aux c1.ty c2.ty ;
    package = merge_aux c1.package c2.package;
    what_a_shame = merge_aux c1.what_a_shame c2.what_a_shame ;
  }
  let merge = List.fold_left merge2

  let pos pos = { default with pos = pos }
  let label label = { default with pos = Annot.pos label }
  let annotmap annotmap = { default with annotmap = [annotmap] }
  let code_elt code_elt = { default with code_elt = [code_elt] ; pos = QmlAst.Pos.code_elt code_elt }
  let expr expr = { default with expr = [expr] }
  let exprs expr exprs = { default with expr = expr::exprs }
  let pat pat = { default with pat = [pat] }
  let ty ty = { default with ty = [ty] }
  let package packagename = { default with package = [packagename] }
  let shame_on_me_i_am_too_lazy no_context = { default with what_a_shame = [no_context] }


  let annoted_expr annotmap expr = { default with annotmap = [annotmap] ; expr = [expr] }
  let annoted_pat annotmap pat = { default with annotmap = [annotmap] ; pat = [pat] }

  (* OUTPUT *)

  (*
The goal there:
We try at least to print the location in the console.
If we are not able to do that, we will print some AST, using [QmlPrint.pp].
The full printer is used internally for opatrack traces, as the code
has been transormed, we print totally
*)

  module Output =
  struct
    (* merge all positions found from the context *)
    let extract_position c =
      let fold pos acc e =
        FilePos.merge_pos acc (pos e)
      in
      let pos = c.pos in
      let pos = List.fold_left (fold Q.Pos.expr) pos c.expr in
      let pos = List.fold_left (fold Q.Pos.pat) pos c.pat in
      pos

    (* strategy:
+ if we have some positions, we print just them, it is enough,
printing the code is not a good idea because it does not correspond to
what the user wrote anyway.
+ if we do not have positions, it is because we are not finished with the refactoring
of positions in the AST. In this case, will will print the 'full' printer in the console.
*)

    let sep = String.make 80 '='

    let of_type annot fmt c =
      let iter annotmap =
        match QmlAnnotMap.find_ty_opt annot annotmap with
        | Some ty ->
            Format.fprintf fmt "%s@\nAnnoted with the following type:@\n%a@\n"
              sep QmlPrint.pp#ty ty
        | None -> () in
      List.iter iter c.annotmap

    let full fmt c =
      let pos = extract_position c in

      Format.fprintf fmt "%s@\n%a@\n" sep FilePos.pp_pos pos ;

      if c.expr = [] && c.pat = [] then (

      List.iter (fun code_elt ->
                   Format.fprintf fmt "%s@\nIn the following toplevel definition:@\n%a@\n"
                     sep QmlPrint.pp#code_elt code_elt) c.code_elt ;

        ()

      );

      List.iter (fun expr ->
                   Format.fprintf fmt "%s@\nIn the following expression:@\n%a@\n%a"
                     sep QmlPrint.pp#expr expr (of_type (Q.QAnnot.expr expr)) c) c.expr ;

      List.iter (fun pat ->
                   Format.fprintf fmt "%s@\nIn the following pattern:@\n%a@\n%a"
                     sep QmlPrint.pp#pat pat (of_type (Q.QAnnot.pat pat)) c) c.pat ;

      List.iter (fun ty ->
                   Format.fprintf fmt "%s@\nIn the following type:@\n%a@\n"
                     sep QmlPrint.pp#ty ty) c.ty ;

      List.iter (fun package ->
                   Format.fprintf fmt "%s@\nIn the following package:@\n%a@\n"
                     sep Format.pp_print_string package) c.package ;
      ();

      List.iter (fun shame ->
                   Format.fprintf fmt "%s@\nIn the following internal positions:@\n%a@\n"
                     sep Format.pp_print_string shame) c.what_a_shame ;
      ()

    let console fmt c =
      let pos = extract_position c in
      if FilePos.is_empty pos
      then full fmt c
      else Format.fprintf fmt "%a@\n" FilePos.pp_pos pos
  end

  let full = Output.full
  let console = Output.console
  let get_pos = Output.extract_position

end
type context = Context.context
module E = PassError.LangError(Context)
include E
Something went wrong with that request. Please try again.