Skip to content
This repository
tag: v702
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 227 lines (185 sloc) 6.439 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 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
(*
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 J = JsAst
module Cons = JsCons

let (|>) = InfixOperator.(|>)

module IdentMap = JsAst.IdentMap;;
module IdentSet = JsAst.IdentSet;;

module List = Base.List
module String = Base.String

type jsp = JsAst.code -> JsAst.code

(*
If we need to have unicity of annotation,
we must replace rlabel by :
{[
let rlabel = Annot.refresh
]}
*)
external rlabel : Annot.label -> Annot.label = "%identity"

module Rename :
sig
  type env
  val empty : env
  val add : JsAst.ident -> env -> env
  val new_binding : env -> JsAst.ident -> env * JsAst.ident
  val resolve : env -> JsAst.ident -> JsAst.ident
  val assert_resolve : env -> JsAst.ident -> JsAst.ident
end =
struct

  (*
Generate a short JS identifier from an int.
In case the identifier returned is a js keyword,
skip it, and inspect the next generated one.

The function return the next int to use for generating
the next short ident.
*)
  let rec name_of_int i =
    let name = IdentGenerator.alphanum i in
    if JsAst.is_keyword name then name_of_int (i+1) else JsCons.Ident.native name, (i+1)

  type env = JsAst.ident IdentMap.t * int
  let empty = (IdentMap.empty, 0)

  let new_binding (map, number) ident =
    let new_ident, number = name_of_int number in
    let map = IdentMap.add ident new_ident map in
    (map, number), new_ident

  let add ident (map, number) =
    let new_ident, number = name_of_int number in
    let map = IdentMap.add ident new_ident map in
    (map, number)

  let resolve (map, _) ident =
    match IdentMap.find_opt ident map with
    | Some ident -> ident
    | None -> ident

  let assert_resolve (map, _) ident =
    match IdentMap.find_opt ident map with
    | Some ident -> ident
    | None ->
        assert false
end

(*
Collect vars and function local to a statement, without entering
internal function inside other functions.
*)
let stmt_collect_locals acc s =
  JsWalk.OnlyStatement.traverse_fold (
    fun tra acc -> function
    | J.Js_var (_, ident, _) -> Rename.add ident acc
    | J.Js_function (_, ident, _, _) -> Rename.add ident acc (* NOT traversing *)
    | J.Js_trycatch (_,_,catches,_) ->
        let acc = List.fold_left (fun acc (ident,_,_) -> Rename.add ident acc) acc catches in
        tra acc s
    | s ->
        tra acc s
  ) acc s

(*
Cf the notice for the 3 following recursive functions.

{[
let rec rename_expr
and rename_function
and rename_statement
]}
*)

let rec rename_expr (acc : Rename.env) e =
  JsWalk.OnlyExpr.traverse_map (
    fun tra e ->
      match e with
      | J.Je_function (label, ident, params, body) ->
          let recons (ident, params, body) = J.Je_function (label, ident, params, body) in
          recons (rename_function acc ident params body)

      | J.Je_ident (label, ident) ->
          let ident = Rename.resolve acc ident in
          let e = J.Je_ident (label, ident) in
          e

      | e ->
          tra e
  ) e

and rename_function acc ident params body =
  let ident = Option.map (Rename.resolve acc) ident in
  let acc, params = List.fold_left_map Rename.new_binding acc params in
  let acc = List.fold_left stmt_collect_locals acc body in
  let body = List.tail_map (rename_statement acc) body in
  (ident, params, body)

and rename_statement acc stmt =
  JsWalk.TStatement.traverse_map (
    fun traS _traE s ->
      match s with
      | J.Js_var (label, ident, expr) ->
          let ident = Rename.resolve acc ident in
          let expr = Option.map (rename_expr acc) expr in
          J.Js_var (label, ident, expr)

      | J.Js_function (label, ident, params, body) ->
          let recons (ident, params, body) =
            let ident = Option.get ident in
            J.Js_function (label, ident, params, body) in
          recons (rename_function acc (Some ident) params body)

      | J.Js_trycatch (label, body, catches, finally) ->
          let catches = List.map (fun (ident, e, s) -> (Rename.resolve acc ident, e, s)) catches in
          let s = J.Js_trycatch (label, body, catches, finally) in
          traS s

      (*
the node with is not supported by the local renaming
*)
      | J.Js_with _ -> assert false

      | s -> traS s
  )
    (fun _traE _traS e -> rename_expr acc e)
    stmt


(*
Renaming function parameters, and local variables.
This renaming does not affect toplevel identifiers
*)
let local_alpha_stm stm =
  let acc = Rename.empty in
  rename_statement acc stm
let local_alpha code =
  let acc = Rename.empty in
  List.tail_map (rename_statement acc) code

(*
NOTICE:

let rec rename_expr (acc : Rename.env) e =
let rec aux e =
ExprOnly.map_down
ou un traverse_map_down où on fait gaffe aux je_function
map_down utilisant acc
sauf dans le cas Je_function,
où on appelle une regle de renommage des fonctions
qui appelle rename_statement avec (acc + quelque chose)
in
aux_expr e

and rename_function recons acc ident params body =
1) on rename ident avec ce acc,

2) collect les var et les function dans body sans rentrer dans les function
fold sur statement only, pas de tra sur Js_function
StatementOnly.traverse_fold

3) ca en fait un acc2,
on met params dans acc2
on renomme le body avec acc2 (rename_statement)
et on recons

and rename_statement acc s =

- si tombe sur Js_function, simplement appliquer rename_function
- si var : simplement appliquer le renommage

sinon : rename_expr avec le meme acc
et tra acc sur les statement
TStatement.traverse_map
avec rename_expr sur les expr
et tra sur les statement

TStatement.traverse_map
(fun traS traE e -> rename_expr acc e)
(fun traS traE s ->
match s with
| Js_function -> rename_function
| JsVar -> lookup acc pour renommer
| s -> traS s)
s
*)
Something went wrong with that request. Please try again.