|
| 1 | +(* Copyright (C) 2018 Authors of BuckleScript |
| 2 | + * |
| 3 | + * This program is free software: you can redistribute it and/or modify |
| 4 | + * it under the terms of the GNU Lesser General Public License as published by |
| 5 | + * the Free Software Foundation, either version 3 of the License, or |
| 6 | + * (at your option) any later version. |
| 7 | + * |
| 8 | + * In addition to the permissions granted to you by the LGPL, you may combine |
| 9 | + * or link a "work that uses the Library" with a publicly distributed version |
| 10 | + * of this file to produce a combined library or application, then distribute |
| 11 | + * that combined work under the terms of your choosing, with no requirement |
| 12 | + * to comply with the obligations normally placed on you by section 4 of the |
| 13 | + * LGPL version 3 (or the corresponding section of a later version of the LGPL |
| 14 | + * should you choose to use a later version). |
| 15 | + * |
| 16 | + * This program is distributed in the hope that it will be useful, |
| 17 | + * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | + * GNU Lesser General Public License for more details. |
| 20 | + * |
| 21 | + * You should have received a copy of the GNU Lesser General Public License |
| 22 | + * along with this program; if not, write to the Free Software |
| 23 | + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) |
| 24 | +open Ast_helper |
| 25 | + |
| 26 | +let handle_extension record_as_js_object e (self : Bs_ast_mapper.mapper) |
| 27 | + (({txt ; loc} as lid , payload) : Parsetree.extension) = |
| 28 | + begin match txt with |
| 29 | + | "bs.raw" | "raw" -> |
| 30 | + Ast_util.handle_raw loc payload |
| 31 | + | "bs.re" | "re" -> |
| 32 | + Exp.constraint_ ~loc |
| 33 | + (Ast_util.handle_raw ~check_js_regex:true loc payload) |
| 34 | + (Ast_comb.to_js_re_type loc) |
| 35 | + | "bs.external" | "external" -> |
| 36 | + begin match Ast_payload.as_ident payload with |
| 37 | + | Some {txt = Lident x} |
| 38 | + -> Ast_util.handle_external loc x |
| 39 | + (* do we need support [%external gg.xx ] |
| 40 | +
|
| 41 | + {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]} |
| 42 | + *) |
| 43 | + |
| 44 | + | None | Some _ -> |
| 45 | + Location.raise_errorf ~loc |
| 46 | + "external expects a single identifier" |
| 47 | + end |
| 48 | + | "bs.time"| "time" -> |
| 49 | + ( |
| 50 | + match payload with |
| 51 | + | PStr [{pstr_desc = Pstr_eval (e,_)}] -> |
| 52 | + let locString = |
| 53 | + if loc.loc_ghost then |
| 54 | + "GHOST LOC" |
| 55 | + else |
| 56 | + let loc_start = loc.loc_start in |
| 57 | + let (file, lnum, __) = Location.get_pos_info loc_start in |
| 58 | + Printf.sprintf "%s %d" |
| 59 | + file lnum in |
| 60 | + let e = self.expr self e in |
| 61 | + Exp.sequence ~loc |
| 62 | + (Exp.apply ~loc |
| 63 | + (Exp.ident ~loc {loc; |
| 64 | + txt = |
| 65 | + Ldot (Ldot (Lident "Js", "Console"), "timeStart") |
| 66 | + }) |
| 67 | + ["", Exp.constant ~loc (Const_string (locString,None))] |
| 68 | + ) |
| 69 | + ( Exp.let_ ~loc Nonrecursive |
| 70 | + [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e ; |
| 71 | + ] |
| 72 | + (Exp.sequence ~loc |
| 73 | + (Exp.apply ~loc |
| 74 | + (Exp.ident ~loc {loc; |
| 75 | + txt = |
| 76 | + Ldot (Ldot (Lident "Js", "Console"), "timeEnd") |
| 77 | + }) |
| 78 | + ["", Exp.constant ~loc (Const_string (locString,None))] |
| 79 | + ) |
| 80 | + (Exp.ident ~loc {loc; txt = Lident "timed"}) |
| 81 | + ) |
| 82 | + ) |
| 83 | + | _ -> |
| 84 | + Location.raise_errorf |
| 85 | + ~loc "expect a boolean expression in the payload" |
| 86 | + ) |
| 87 | + | "bs.assert" | "assert" -> |
| 88 | + ( |
| 89 | + match payload with |
| 90 | + | PStr [ {pstr_desc = Pstr_eval( e,_)}] -> |
| 91 | + |
| 92 | + let locString = |
| 93 | + if loc.loc_ghost then |
| 94 | + "ASSERT FAILURE" |
| 95 | + else |
| 96 | + let loc_start = loc.loc_start in |
| 97 | + let (file, lnum, cnum) = Location.get_pos_info loc_start in |
| 98 | + let enum = |
| 99 | + loc.Location.loc_end.Lexing.pos_cnum - |
| 100 | + loc_start.Lexing.pos_cnum + cnum in |
| 101 | + Printf.sprintf "File %S, line %d, characters %d-%d" |
| 102 | + file lnum cnum enum in |
| 103 | + let raiseWithString locString = |
| 104 | + (Exp.apply ~loc |
| 105 | + (Exp.ident ~loc {loc; txt = |
| 106 | + Ldot(Ldot (Lident "Js","Exn"),"raiseError")}) |
| 107 | + ["", |
| 108 | + |
| 109 | + Exp.constant (Const_string (locString,None)) |
| 110 | + ]) |
| 111 | + in |
| 112 | + (match e.pexp_desc with |
| 113 | + | Pexp_construct({txt = Lident "false"},None) -> |
| 114 | + (* The backend will convert [assert false] into a nop later *) |
| 115 | + if !Clflags.no_assert_false then |
| 116 | + Exp.assert_ ~loc |
| 117 | + (Exp.construct ~loc {txt = Lident "false";loc} None) |
| 118 | + else |
| 119 | + (raiseWithString locString) |
| 120 | + | Pexp_constant (Const_string (r, _)) -> |
| 121 | + if !Clflags.noassert then |
| 122 | + Exp.assert_ ~loc (Exp.construct ~loc {txt = Lident "true"; loc} None) |
| 123 | + (* Need special handling to make it type check*) |
| 124 | + else |
| 125 | + raiseWithString r |
| 126 | + | _ -> |
| 127 | + let e = self.expr self e in |
| 128 | + if !Clflags.noassert then |
| 129 | + (* pass down so that it still type check, but the backend will |
| 130 | + make it a nop |
| 131 | + *) |
| 132 | + Exp.assert_ ~loc e |
| 133 | + else |
| 134 | + Exp.ifthenelse ~loc |
| 135 | + (Exp.apply ~loc |
| 136 | + (Exp.ident {loc ; txt = Ldot(Lident "Pervasives","not")}) |
| 137 | + ["", e] |
| 138 | + ) |
| 139 | + (raiseWithString locString) |
| 140 | + None |
| 141 | + ) |
| 142 | + | _ -> |
| 143 | + Location.raise_errorf |
| 144 | + ~loc "expect a boolean expression in the payload" |
| 145 | + ) |
| 146 | + | "bs.node" | "node" -> |
| 147 | + let strip s = |
| 148 | + match s with |
| 149 | + | "_module" -> "module" |
| 150 | + | x -> x in |
| 151 | + begin match Ast_payload.as_ident payload with |
| 152 | + | Some {txt = Lident |
| 153 | + ( "__filename" |
| 154 | + | "__dirname" |
| 155 | + | "_module" |
| 156 | + | "require" as name); loc} |
| 157 | + -> |
| 158 | + let exp = |
| 159 | + Ast_util.handle_external loc (strip name) in |
| 160 | + let typ = |
| 161 | + Ast_core_type.lift_option_type |
| 162 | + @@ |
| 163 | + if name = "_module" then |
| 164 | + Typ.constr ~loc |
| 165 | + { txt = Ldot (Lident "Node", "node_module") ; |
| 166 | + loc} [] |
| 167 | + else if name = "require" then |
| 168 | + (Typ.constr ~loc |
| 169 | + { txt = Ldot (Lident "Node", "node_require") ; |
| 170 | + loc} [] ) |
| 171 | + else |
| 172 | + Ast_literal.type_string ~loc () in |
| 173 | + Exp.constraint_ ~loc exp typ |
| 174 | + | Some _ | None -> |
| 175 | + begin match payload with |
| 176 | + | PTyp _ -> |
| 177 | + Location.raise_errorf |
| 178 | + ~loc "Illegal payload, expect an expression payload instead of type payload" |
| 179 | + | PPat _ -> |
| 180 | + Location.raise_errorf |
| 181 | + ~loc "Illegal payload, expect an expression payload instead of pattern payload" |
| 182 | + | _ -> |
| 183 | + Location.raise_errorf |
| 184 | + ~loc "Illegal payload" |
| 185 | + end |
| 186 | + |
| 187 | + end |
| 188 | + | "bs.debugger"|"debugger" -> |
| 189 | + {e with pexp_desc = Ast_util.handle_debugger loc payload} |
| 190 | + | "bs.obj" | "obj" -> |
| 191 | + begin match payload with |
| 192 | + | PStr [{pstr_desc = Pstr_eval (e,_)}] |
| 193 | + -> |
| 194 | + Ext_ref.non_exn_protect record_as_js_object true |
| 195 | + (fun () -> self.expr self e ) |
| 196 | + | _ -> Location.raise_errorf ~loc "Expect an expression here" |
| 197 | + end |
| 198 | + | _ -> |
| 199 | + match payload with |
| 200 | + | PTyp typ when Ext_string.starts_with txt Literals.bs_deriving_dot -> |
| 201 | + self.expr self (Ast_derive.gen_expression lid typ) |
| 202 | + | _ -> |
| 203 | + e (* For an unknown extension, we don't really need to process further*) |
| 204 | + (* Exp.extension ~loc ~attrs:e.pexp_attributes ( |
| 205 | + self.extension self extension) *) |
| 206 | + (* Bs_ast_mapper.default_mapper.expr self e *) |
| 207 | + end |
0 commit comments