├── src ├── Index.re ├── worker │ ├── Bridge.re │ └── RefmtWorker.re ├── index.css ├── index.html ├── bindings │ ├── Worker.re │ └── ReactMonaco.re ├── App.re └── ppxs │ └── ReasonReactPpx.ml ├── .gitignore ├── bsconfig.json ├── docs └── index.html ├── webpack.config.js ├── README.md └── package.json /src/Index.re: -------------------------------------------------------------------------------- 1 | [%bs.raw {|require("./index.css")|}]; 2 | 3 | ReactDOMRe.renderToElementWithId(, "root"); 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | .merlin 3 | .bsb.lock 4 | npm-debug.log 5 | /lib/bs/ 6 | /node_modules/ 7 | *.bs.js 8 | _esy/ 9 | -------------------------------------------------------------------------------- /src/worker/Bridge.re: -------------------------------------------------------------------------------- 1 | module Types = { 2 | type fromApp = {code: string}; 3 | type fromWorker = {result: Belt.Result.t(string, exn)}; 4 | [@bs.new] [@bs.module] 5 | external make: unit => Worker.worker = "worker-loader!./RefmtWorker.bs.js"; 6 | }; 7 | 8 | include Worker.Make(Types); 9 | -------------------------------------------------------------------------------- /bsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "reason-react-starter", 3 | "reason": { 4 | "react-jsx": 3 5 | }, 6 | "sources": { 7 | "dir": "src", 8 | "subdirs": true 9 | }, 10 | "bsc-flags": ["-bs-super-errors", "-bs-no-version-header"], 11 | "package-specs": [ 12 | { 13 | "module": "es6", 14 | "in-source": true 15 | } 16 | ], 17 | "suffix": ".bs.js", 18 | "namespace": true, 19 | "bs-dependencies": ["@jchavarri/bs-refmt", "reason-react"], 20 | "refmt": 3 21 | } 22 | -------------------------------------------------------------------------------- /src/index.css: -------------------------------------------------------------------------------- 1 | body { 2 | margin: 0; 3 | font-family: -apple-system, system-ui, "Segoe UI", Helvetica, Arial, 4 | sans-serif, "Apple Color Emoji", "Segoe UI Emoji", "Segoe UI Symbol"; 5 | height: 100%; 6 | } 7 | 8 | main { 9 | padding: 20px; 10 | height: 100%; 11 | } 12 | 13 | .counter { 14 | padding: 20px; 15 | display: inline-block; 16 | } 17 | 18 | .left-editor { 19 | position: absolute; 20 | top: 160px; 21 | left: 20px; 22 | width: 757px; 23 | height: 281px; 24 | } 25 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 10 | 14 | PPX explorer 15 | 16 | 17 |
18 | 19 | Fork me on GitHub 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 10 | 14 | PPX explorer 15 | 16 | 17 |
18 | 19 | Fork me on GitHub 26 | 27 | 28 | -------------------------------------------------------------------------------- /webpack.config.js: -------------------------------------------------------------------------------- 1 | const path = require("path") 2 | const HtmlWebpackPlugin = require("html-webpack-plugin") 3 | const outputDir = path.join(__dirname, "docs/") 4 | 5 | const isProd = process.env.NODE_ENV === "production" 6 | 7 | module.exports = { 8 | entry: "./src/Index.bs.js", 9 | mode: isProd ? "production" : "development", 10 | output: { 11 | path: outputDir, 12 | filename: "Index.js" 13 | }, 14 | plugins: [ 15 | new HtmlWebpackPlugin({ 16 | template: "src/index.html", 17 | inject: false 18 | }) 19 | ], 20 | devServer: { 21 | compress: true, 22 | contentBase: outputDir, 23 | port: process.env.PORT || 8000, 24 | historyApiFallback: true 25 | }, 26 | module: { 27 | rules: [ 28 | { 29 | test: /\.css$/, 30 | use: ["style-loader", "css-loader"] 31 | } 32 | ] 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PPX explorer 2 | 3 | See how the resulting code after applying the most used PPXs transformations: 4 | 5 | https://ml-in-barcelona.github.io/ppx-explorer/ 6 | 7 | (note: Currently targeting Reason syntax and ReasonReact PPX exclusively, PRs welcomed!) 8 | 9 | ## Run Project 10 | 11 | ```sh 12 | yarn install 13 | yarn start 14 | # in another tab 15 | yarn server 16 | ``` 17 | 18 | View the app in the browser at http://localhost:8000. Running in this environment provides hot reloading and support for routing; just edit and save the file and the browser will automatically refresh. 19 | 20 | To use a port other than 8000 set the `PORT` environment variable (`PORT=8080 yarn server`). 21 | 22 | ## Build for Production 23 | 24 | ```sh 25 | yarn clean 26 | yarn build 27 | yarn webpack:production 28 | ``` 29 | 30 | This will replace the development artifact `docs/Index.js` for an optimized version as well as copy `src/index.html` into `docs/`. You can then deploy the contents of the `docs` directory (`index.html` and `Index.js`). 31 | -------------------------------------------------------------------------------- /src/bindings/Worker.re: -------------------------------------------------------------------------------- 1 | type worker; 2 | 3 | [@bs.new] external make: string => worker = "Worker"; 4 | 5 | module type Config = { 6 | type fromApp; 7 | type fromWorker; 8 | let make: unit => worker; 9 | }; 10 | 11 | module Make = (Config: Config) => { 12 | include Config; 13 | 14 | module App = { 15 | [@bs.send] external postMessage: (worker, fromApp) => unit = "postMessage"; 16 | [@bs.set] 17 | external onMessage: (worker, {. "data": fromWorker} => unit) => unit = 18 | "onmessage"; 19 | [@bs.set] 20 | external onError: (worker, Js.t('a) => unit) => unit = "onerror"; 21 | [@bs.send] external terminate: worker => unit = "terminate"; 22 | }; 23 | 24 | module Worker = { 25 | type self; 26 | [@bs.val] external postMessage: fromWorker => unit = "postMessage"; 27 | [@bs.set] 28 | external onMessage: (self, {. "data": fromApp} => unit) => unit = 29 | "onmessage"; 30 | [@bs.val] external self: self = "self"; 31 | [@bs.val] external importScripts: string => unit; 32 | }; 33 | }; 34 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "ppx-explorer", 3 | "version": "0.1.0", 4 | "scripts": { 5 | "build": "bsb -make-world", 6 | "start": "bsb -make-world -w -ws _ ", 7 | "clean": "bsb -clean-world", 8 | "webpack": "webpack -w", 9 | "webpack:production": "NODE_ENV=production webpack", 10 | "server": "webpack-dev-server", 11 | "test": "echo \"Error: no test specified\" && exit 1", 12 | "refmt:list": "find ./src -type f \\( -name *.re -o -name *.rei \\)", 13 | "refmt": "yarn --silent refmt:list | xargs bsrefmt --in-place" 14 | }, 15 | "keywords": [ 16 | "BuckleScript", 17 | "ReasonReact", 18 | "reason-react" 19 | ], 20 | "author": "", 21 | "license": "MIT", 22 | "dependencies": { 23 | "@jchavarri/bs-refmt": "^0.0.5", 24 | "react": "^16.8.1", 25 | "react-dom": "^16.8.1", 26 | "react-monaco-editor": "^0.36.0", 27 | "reason-react": ">=0.7.1" 28 | }, 29 | "devDependencies": { 30 | "bs-platform": "^7.3.2", 31 | "css-loader": "^3.2.0", 32 | "html-webpack-plugin": "^3.2.0", 33 | "style-loader": "^1.0.0", 34 | "webpack": "^4.0.1", 35 | "webpack-cli": "^3.1.1", 36 | "webpack-dev-server": "^3.1.8", 37 | "worker-loader": "^2.0.0" 38 | } 39 | } 40 | -------------------------------------------------------------------------------- /src/worker/RefmtWorker.re: -------------------------------------------------------------------------------- 1 | module Converter = 2 | Reason_toolchain_packed.Migrate_parsetree.Convert( 3 | Reason_toolchain_packed.Migrate_parsetree.OCaml_408, 4 | Reason_toolchain_packed.Migrate_parsetree.OCaml_406, 5 | ); 6 | module ConverterBack = 7 | Reason_toolchain_packed.Migrate_parsetree.Convert( 8 | Reason_toolchain_packed.Migrate_parsetree.OCaml_406, 9 | Reason_toolchain_packed.Migrate_parsetree.OCaml_408, 10 | ); 11 | 12 | Bridge.Worker.( 13 | self->onMessage(data => 14 | try({ 15 | let {Bridge.Types.code} = data##data; 16 | let lexbuf = Lexing.from_string(code); 17 | let (_ast, comments) = 18 | lexbuf |> Refmt_api.RE.implementation_with_comments; 19 | let reactAst = 20 | lexbuf 21 | ->Reason_toolchain_packed.Reason_toolchain.RE.implementation 22 | ->Converter.copy_structure; 23 | let newAst = ReasonReactPpx.rewrite_implementation(reactAst); 24 | Refmt_api.RE.print_implementation_with_comments( 25 | Format.str_formatter, 26 | (newAst->ConverterBack.copy_structure, comments), 27 | ); 28 | postMessage({result: Ok(Format.flush_str_formatter())}); 29 | }) { 30 | | exn => 31 | Js.log(exn); 32 | postMessage({result: Error(exn)}); 33 | } 34 | ) 35 | ); 36 | -------------------------------------------------------------------------------- /src/bindings/ReactMonaco.re: -------------------------------------------------------------------------------- 1 | type editor; 2 | 3 | module Editor: { 4 | [@react.component] 5 | let make: 6 | ( 7 | ~width: string=?, 8 | ~height: string=?, 9 | ~value: string=?, 10 | ~defaultValue: string=?, 11 | ~language: string=?, 12 | ~theme: string=?, 13 | ~options: Js.t({..})=?, 14 | ~overrideServices: string=?, 15 | ~onChange: (string, 'event) => unit=?, 16 | ~editorWillMount: 'monaco => unit=?, 17 | ~editorDidMount: (editor, 'monaco) => unit=?, 18 | ~className: string=? 19 | ) => 20 | React.element; 21 | } = { 22 | [@bs.module "react-monaco-editor"] [@react.component] 23 | external make: 24 | ( 25 | ~width: string=?, 26 | ~height: string=?, 27 | ~value: string=?, 28 | ~defaultValue: string=?, 29 | ~language: string=?, 30 | ~theme: string=?, 31 | ~options: Js.t({..})=?, 32 | ~overrideServices: string=?, 33 | ~onChange: (string, 'event) => unit=?, 34 | ~editorWillMount: 'monaco => unit=?, 35 | ~editorDidMount: (editor, 'monaco) => unit=?, 36 | ~className: string=? 37 | ) => 38 | React.element = 39 | "default"; 40 | }; 41 | 42 | module DiffViewer: { 43 | [@react.component] 44 | let make: 45 | ( 46 | ~width: string=?, 47 | ~height: string=?, 48 | ~original: string, 49 | ~value: string, 50 | ~defaultValue: string=?, 51 | ~language: string=?, 52 | ~theme: string=?, 53 | ~options: Js.t({..})=?, 54 | ~overrideServices: string=?, 55 | ~onChange: (string, 'event) => unit=?, 56 | ~editorWillMount: 'monaco => unit=?, 57 | ~editorDidMount: (editor, 'monaco) => unit=?, 58 | ~className: string=? 59 | ) => 60 | React.element; 61 | } = { 62 | [@bs.module "react-monaco-editor"] [@react.component] 63 | external make: 64 | ( 65 | ~width: string=?, 66 | ~height: string=?, 67 | ~original: string, 68 | ~value: string, 69 | ~defaultValue: string=?, 70 | ~language: string=?, 71 | ~theme: string=?, 72 | ~options: Js.t({..})=?, 73 | ~overrideServices: string=?, 74 | ~onChange: (string, 'event) => unit=?, 75 | ~editorWillMount: 'monaco => unit=?, 76 | ~editorDidMount: (editor, 'monaco) => unit=?, 77 | ~className: string=? 78 | ) => 79 | React.element = 80 | "MonacoDiffEditor"; 81 | }; 82 | -------------------------------------------------------------------------------- /src/App.re: -------------------------------------------------------------------------------- 1 | module Window = { 2 | type t; 3 | [@bs.val] external window: t = "window"; 4 | [@bs.get] external innerWidth: t => int; 5 | [@bs.get] external innerHeight: t => int; 6 | [@bs.set] external onResize: (t, unit => unit) => unit = "onresize"; 7 | }; 8 | 9 | type state = { 10 | source: string, 11 | result: Belt.Result.t(string, exn), 12 | worker: option(Worker.worker), 13 | }; 14 | 15 | type action = 16 | | EditorValueChanged(string) 17 | | WorkerCreated(Worker.worker) 18 | | WorkerMessageReceived(Bridge.fromWorker) 19 | | WindowResized; 20 | 21 | let initialReasonReact = "module Greeting = { 22 | [@react.component] 23 | let make = () => { 24 | 25 | }; 26 | }; 27 | 28 | ReactDOMRe.renderToElementWithId(, \"preview\");"; 29 | 30 | let initialState = { 31 | source: initialReasonReact, 32 | result: Ok(""), 33 | worker: None, 34 | }; 35 | 36 | let reducer = (state, action) => 37 | switch (action) { 38 | | EditorValueChanged(code) => {...state, source: code} 39 | | WorkerCreated(worker) => {...state, worker: Some(worker)} 40 | | WorkerMessageReceived({result}) => {...state, result} 41 | | WindowResized => {...state, source: state.source} /* Return new copy so component re-renders (without having to add window size to state) */ 42 | }; 43 | 44 | module Style = { 45 | let globalPadding = 20; 46 | let titleHeight = 150; 47 | let innerPadding = 20; 48 | }; 49 | module Editor = { 50 | [@react.component] 51 | let make = (~left, ~width, ~height, ~value, ~readOnly=false, ~onChange=?) => { 52 | let width = width->string_of_int ++ "px"; 53 | let height = height->string_of_int ++ "px"; 54 | let style = 55 | ReactDOMRe.Style.make( 56 | ~position="absolute", 57 | ~top=Style.(globalPadding + titleHeight)->string_of_int ++ "px", 58 | ~left=left->string_of_int ++ "px", 59 | ~width, 60 | ~height, 61 | (), 62 | ); 63 | let options = readOnly ? Some({"readOnly": true}) : None; 64 | let onChange = 65 | onChange->Belt.Option.map((onChange, code, _) => {onChange(code)}); 66 | 67 |
68 | 69 |
; 70 | }; 71 | }; 72 | 73 | [@react.component] 74 | let make = () => { 75 | let (state, dispatch) = React.useReducer(reducer, initialState); 76 | 77 | React.useEffect0(() => { 78 | Window.(window->onResize(() => {dispatch @@ WindowResized})); 79 | let worker = Bridge.make(); 80 | dispatch @@ WorkerCreated(worker); 81 | worker->Bridge.App.onMessage(res => 82 | dispatch @@ WorkerMessageReceived(res##data) 83 | ); 84 | // worker->Toplevel.Top.onErrorFromWorker(Js.log); 85 | None; 86 | }); 87 | 88 | React.useEffect2( 89 | () => { 90 | switch (state.worker) { 91 | | Some(worker) => worker->Bridge.App.postMessage({code: state.source}) 92 | | None => () 93 | }; 94 | None; 95 | }, 96 | (state.source, state.worker), 97 | ); 98 | 99 | let width = Window.(window->innerWidth) - 2 * Style.globalPadding; 100 | let height = Window.(window->innerHeight); 101 | let halfWidth = 102 | Js.Math.floor(((width - Style.innerPadding) / 2)->float_of_int); 103 | let remainingHeight = Style.(height - titleHeight - globalPadding); 104 | 105 |
106 |

{React.string("PPX explorer")}

107 |

108 | {React.string( 109 | "See the transformation from the most used PPXs with live code.", 110 | )} 111 |

112 | {React.string("ReasonReact PPX")} 113 | dispatch @@ EditorValueChanged(code)} 119 | /> 120 | res 127 | | Error(_err) => "err" 128 | } 129 | } 130 | readOnly=true 131 | /> 132 |
; 133 | }; 134 | -------------------------------------------------------------------------------- /src/ppxs/ReasonReactPpx.ml: -------------------------------------------------------------------------------- 1 | open Reason_toolchain_packed.Ast_406 2 | 3 | (* Copied from https://github.com/rescript-lang/syntax/blob/2cd91265d0832251ce9ffbc5d0e32553ab106716/src/reactjs_jsx_ppx_v3.ml 4 | *) 5 | 6 | open Ast_helper 7 | open Ast_mapper 8 | open Asttypes 9 | open Parsetree 10 | open Longident 11 | 12 | let rec find_opt p = function [] -> None | x :: l -> if p x then Some x else find_opt p l 13 | 14 | let nolabel = Nolabel 15 | 16 | let labelled str = Labelled str 17 | 18 | let optional str = Optional str 19 | 20 | let isOptional str = match str with Optional _ -> true | _ -> false 21 | 22 | let isLabelled str = match str with Labelled _ -> true | _ -> false 23 | 24 | let getLabel str = match str with Optional str | Labelled str -> str | Nolabel -> "" 25 | 26 | let optionIdent = Lident "option" 27 | 28 | let constantString ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) 29 | 30 | let safeTypeFromValue valueStr = 31 | let valueStr = getLabel valueStr in 32 | match String.sub valueStr 0 1 with "_" -> "T" ^ valueStr | _ -> valueStr 33 | [@@raises Invalid_argument] 34 | 35 | let keyType loc = Typ.constr ~loc { loc; txt = optionIdent } [ Typ.constr ~loc { loc; txt = Lident "string" } [] ] 36 | 37 | type 'a children = ListLiteral of 'a | Exact of 'a 38 | 39 | type componentConfig = { propsName : string } 40 | 41 | (* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) 42 | let transformChildrenIfListUpper ~loc ~mapper theList = 43 | let rec transformChildren_ theList accum = 44 | (* not in the sense of converting a list to an array; convert the AST 45 | reprensentation of a list to the AST reprensentation of an array *) 46 | match theList with 47 | | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> ( 48 | match accum with 49 | | [ singleElement ] -> Exact singleElement 50 | | accum -> ListLiteral (Exp.array ~loc (List.rev accum)) ) 51 | | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> 52 | transformChildren_ acc (mapper.expr mapper v :: accum) 53 | | notAList -> Exact (mapper.expr mapper notAList) 54 | in 55 | transformChildren_ theList [] 56 | 57 | let transformChildrenIfList ~loc ~mapper theList = 58 | let rec transformChildren_ theList accum = 59 | (* not in the sense of converting a list to an array; convert the AST 60 | reprensentation of a list to the AST reprensentation of an array *) 61 | match theList with 62 | | { pexp_desc = Pexp_construct ({ txt = Lident "[]" }, None) } -> Exp.array ~loc (List.rev accum) 63 | | { pexp_desc = Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple [ v; acc ] }) } -> 64 | transformChildren_ acc (mapper.expr mapper v :: accum) 65 | | notAList -> mapper.expr mapper notAList 66 | in 67 | transformChildren_ theList [] 68 | 69 | let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = 70 | let rec allButLast_ lst acc = 71 | match lst with 72 | | [] -> [] 73 | | [ (Nolabel, { pexp_desc = Pexp_construct ({ txt = Lident "()" }, None) }) ] -> acc 74 | | (Nolabel, _) :: _rest -> raise (Invalid_argument "JSX: found non-labelled argument before the last position") 75 | | arg :: rest -> allButLast_ rest (arg :: acc) 76 | [@@raises Invalid_argument] 77 | in 78 | let allButLast lst = allButLast_ lst [] |> List.rev [@@raises Invalid_argument] in 79 | match List.partition (fun (label, _) -> label = labelled "children") propsAndChildren with 80 | | [], props -> 81 | (* no children provided? Place a placeholder list *) 82 | (Exp.construct ~loc { loc; txt = Lident "[]" } None, if removeLastPositionUnit then allButLast props else props) 83 | | [ (_, childrenExpr) ], props -> (childrenExpr, if removeLastPositionUnit then allButLast props else props) 84 | | _ -> raise (Invalid_argument "JSX: somehow there's more than one `children` label") 85 | [@@raises Invalid_argument] 86 | 87 | let unerasableIgnore loc = ({ loc; txt = "warning" }, PStr [ Str.eval (Exp.constant (Pconst_string ("-16", None))) ]) 88 | 89 | let merlinFocus = ({ loc = Location.none; txt = "merlin.focus" }, PStr []) 90 | 91 | (* Helper method to look up the [@react.component] attribute *) 92 | let hasAttr (loc, _) = loc.txt = "react.component" 93 | 94 | (* Helper method to filter out any attribute that isn't [@react.component] *) 95 | let otherAttrsPure (loc, _) = loc.txt <> "react.component" 96 | 97 | (* Iterate over the attributes and try to find the [@react.component] attribute *) 98 | let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None 99 | 100 | (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) 101 | let getFnName binding = 102 | match binding with 103 | | { pvb_pat = { ppat_desc = Ppat_var { txt } } } -> txt 104 | | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") 105 | [@@raises Invalid_argument] 106 | 107 | let makeNewBinding binding expression newName = 108 | match binding with 109 | | { pvb_pat = { ppat_desc = Ppat_var ppat_var } as pvb_pat } -> 110 | { 111 | binding with 112 | pvb_pat = { pvb_pat with ppat_desc = Ppat_var { ppat_var with txt = newName } }; 113 | pvb_expr = expression; 114 | pvb_attributes = [ merlinFocus ]; 115 | } 116 | | _ -> raise (Invalid_argument "react.component calls cannot be destructured.") 117 | [@@raises Invalid_argument] 118 | 119 | (* Lookup the value of `props` otherwise raise Invalid_argument error *) 120 | let getPropsNameValue _acc (loc, exp) = 121 | match (loc, exp) with 122 | | { txt = Lident "props" }, { pexp_desc = Pexp_ident { txt = Lident str } } -> { propsName = str } 123 | | { txt }, _ -> 124 | raise (Invalid_argument ("react.component only accepts props as an option, given: " ^ Longident.last txt)) 125 | [@@raises Invalid_argument] 126 | 127 | (* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) 128 | let getPropsAttr payload = 129 | let defaultProps = { propsName = "Props" } in 130 | match payload with 131 | | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_record (recordFields, None) }, _) } :: _rest)) -> 132 | List.fold_left getPropsNameValue defaultProps recordFields 133 | | Some (PStr ({ pstr_desc = Pstr_eval ({ pexp_desc = Pexp_ident { txt = Lident "props" } }, _) } :: _rest)) -> 134 | { propsName = "props" } 135 | | Some (PStr ({ pstr_desc = Pstr_eval (_, _) } :: _rest)) -> 136 | raise (Invalid_argument "react.component accepts a record config with props as an options.") 137 | | _ -> defaultProps 138 | [@@raises Invalid_argument] 139 | 140 | (* Plucks the label, loc, and type_ from an AST node *) 141 | let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = (label, default, loc, type_) 142 | 143 | (* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) 144 | let filenameFromLoc (pstr_loc : Location.t) = 145 | let fileName = match pstr_loc.loc_start.pos_fname with "" -> !Location.input_name | fileName -> fileName in 146 | let fileName = try Filename.chop_extension (Filename.basename fileName) with Invalid_argument _ -> fileName in 147 | let fileName = String.capitalize_ascii fileName in 148 | fileName 149 | 150 | (* Build a string representation of a module name with segments separated by $ *) 151 | let makeModuleName fileName nestedModules fnName = 152 | let fullModuleName = 153 | match (fileName, nestedModules, fnName) with 154 | (* TODO: is this even reachable? It seems like the fileName always exists *) 155 | | "", nestedModules, "make" -> nestedModules 156 | | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) 157 | | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules 158 | | fileName, nestedModules, fnName -> fileName :: List.rev (fnName :: nestedModules) 159 | in 160 | let fullModuleName = String.concat "$" fullModuleName in 161 | fullModuleName 162 | 163 | (* 164 | AST node builders 165 | These functions help us build AST nodes that are needed when transforming a [@react.component] into a 166 | constructor and a props external 167 | *) 168 | 169 | (* Build an AST node representing all named args for the `external` definition for a component's props *) 170 | let rec recursivelyMakeNamedArgsForExternal list args = 171 | match list with 172 | | (label, default, loc, interiorType) :: tl -> 173 | recursivelyMakeNamedArgsForExternal tl 174 | (Typ.arrow ~loc label 175 | ( match (label, interiorType, default) with 176 | (* ~foo=1 *) 177 | | label, None, Some _ -> 178 | { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } 179 | (* ~foo: int=1 *) 180 | | _label, Some type_, Some _ -> type_ 181 | (* ~foo: option(int)=? *) 182 | | label, Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, _ 183 | | label, Some { ptyp_desc = Ptyp_constr ({ txt = Ldot (Lident "*predef*", "option") }, [ type_ ]) }, _ 184 | (* ~foo: int=? - note this isnt valid. but we want to get a type error *) 185 | | label, Some type_, _ 186 | when isOptional label -> 187 | type_ 188 | (* ~foo=? *) 189 | | label, None, _ when isOptional label -> 190 | { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } 191 | (* ~foo *) 192 | | label, None, _ -> { ptyp_desc = Ptyp_var (safeTypeFromValue label); ptyp_loc = loc; ptyp_attributes = [] } 193 | | _label, Some type_, _ -> type_ ) 194 | args) 195 | | [] -> args 196 | [@@raises Invalid_argument] 197 | 198 | (* Build an AST node for the [@bs.obj] representing props for a component *) 199 | let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = 200 | let propsName = fnName ^ "Props" in 201 | { 202 | pval_name = { txt = propsName; loc }; 203 | pval_type = 204 | recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef 205 | (Typ.arrow nolabel 206 | { ptyp_desc = Ptyp_constr ({ txt = Lident "unit"; loc }, []); ptyp_loc = loc; ptyp_attributes = [] } 207 | propsType); 208 | pval_prim = [ "" ]; 209 | pval_attributes = [ ({ txt = "bs.obj"; loc }, PStr []) ]; 210 | pval_loc = loc; 211 | } 212 | [@@raises Invalid_argument] 213 | 214 | (* Build an AST node representing an `external` with the definition of the [@bs.obj] *) 215 | let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = 216 | { pstr_loc = loc; pstr_desc = Pstr_primitive (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } 217 | [@@raises Invalid_argument] 218 | 219 | (* Build an AST node for the signature of the `external` definition *) 220 | let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = 221 | { psig_loc = loc; psig_desc = Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType) } 222 | [@@raises Invalid_argument] 223 | 224 | (* Build an AST node for the props name when converted to an object inside the function signature *) 225 | let makePropsName ~loc name = { ppat_desc = Ppat_var { txt = name; loc }; ppat_loc = loc; ppat_attributes = [] } 226 | 227 | let makeObjectField loc (str, attrs, type_) = Otag ({ loc; txt = str }, attrs, type_) 228 | 229 | (* Build an AST node representing a "closed" object representing a component's props *) 230 | let makePropsType ~loc namedTypeList = 231 | Typ.mk ~loc (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) 232 | 233 | (* Builds an AST node for the entire `external` definition of props *) 234 | let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = 235 | makePropsExternal fnName loc 236 | (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) 237 | (makePropsType ~loc namedTypeList) 238 | [@@raises Invalid_argument] 239 | 240 | (* TODO: some line number might still be wrong *) 241 | let jsxMapper () = 242 | let jsxVersion = ref None in 243 | 244 | let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = 245 | let children, argsWithLabels = extractChildren ~loc ~removeLastPositionUnit:true callArguments in 246 | let argsForMake = argsWithLabels in 247 | let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in 248 | let recursivelyTransformedArgsForMake = 249 | argsForMake |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression)) 250 | in 251 | let childrenArg = ref None in 252 | let args = 253 | recursivelyTransformedArgsForMake 254 | @ ( match childrenExpr with 255 | | Exact children -> [ (labelled "children", children) ] 256 | | ListLiteral { pexp_desc = Pexp_array list } when list = [] -> [] 257 | | ListLiteral expression -> 258 | (* this is a hack to support react components that introspect into their children *) 259 | childrenArg := Some expression; 260 | [ (labelled "children", Exp.ident ~loc { loc; txt = Ldot (Lident "React", "null") }) ] ) 261 | @ [ (nolabel, Exp.construct ~loc { loc; txt = Lident "()" } None) ] 262 | in 263 | let isCap str = 264 | let first = String.sub str 0 1 [@@raises Invalid_argument] in 265 | let capped = String.uppercase_ascii first in 266 | first = capped 267 | [@@raises Invalid_argument] 268 | in 269 | let ident = 270 | match modulePath with 271 | | Lident _ -> Ldot (modulePath, "make") 272 | | Ldot (_modulePath, value) as fullPath when isCap value -> Ldot (fullPath, "make") 273 | | modulePath -> modulePath 274 | in 275 | let propsIdent = 276 | match ident with 277 | | Lident path -> Lident (path ^ "Props") 278 | | Ldot (ident, path) -> Ldot (ident, path ^ "Props") 279 | | _ -> raise (Invalid_argument "JSX name can't be the result of function applications") 280 | in 281 | let props = Exp.apply ~attrs ~loc (Exp.ident ~loc { loc; txt = propsIdent }) args in 282 | (* handle key, ref, children *) 283 | (* React.createElement(Component.make, props, ...children) *) 284 | match !childrenArg with 285 | | None -> 286 | Exp.apply ~loc ~attrs 287 | (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElement") }) 288 | [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props) ] 289 | | Some children -> 290 | Exp.apply ~loc ~attrs 291 | (Exp.ident ~loc { loc; txt = Ldot (Lident "React", "createElementVariadic") }) 292 | [ (nolabel, Exp.ident ~loc { txt = ident; loc }); (nolabel, props); (nolabel, children) ] 293 | [@@raises Invalid_argument] 294 | in 295 | 296 | let transformLowercaseCall3 mapper loc attrs callArguments id = 297 | let children, nonChildrenProps = extractChildren ~loc callArguments in 298 | let componentNameExpr = constantString ~loc id in 299 | let childrenExpr = transformChildrenIfList ~loc ~mapper children in 300 | let createElementCall = 301 | match children with 302 | (* [@JSX] div(~children=[a]), coming from
a
*) 303 | | { 304 | pexp_desc = 305 | ( Pexp_construct ({ txt = Lident "::" }, Some { pexp_desc = Pexp_tuple _ }) 306 | | Pexp_construct ({ txt = Lident "[]" }, None) ); 307 | } -> 308 | "createDOMElementVariadic" 309 | (* [@JSX] div(~children= value), coming from
...(value)
*) 310 | | _ -> 311 | raise 312 | (Invalid_argument 313 | "A spread as a DOM element's children don't make sense written together. You can simply remove the \ 314 | spread.") 315 | in 316 | let args = 317 | match nonChildrenProps with 318 | | [ _justTheUnitArgumentAtEnd ] -> 319 | [ (* "div" *) (nolabel, componentNameExpr); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] 320 | | nonEmptyProps -> 321 | let propsCall = 322 | Exp.apply ~loc 323 | (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "domProps") }) 324 | (nonEmptyProps |> List.map (fun (label, expression) -> (label, mapper.expr mapper expression))) 325 | in 326 | [ 327 | (* "div" *) 328 | (nolabel, componentNameExpr); 329 | (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) 330 | (labelled "props", propsCall); 331 | (* [|moreCreateElementCallsHere|] *) 332 | (nolabel, childrenExpr); 333 | ] 334 | in 335 | Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs 336 | (* ReactDOMRe.createElement *) 337 | (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", createElementCall) }) 338 | args 339 | [@@raises Invalid_argument] 340 | in 341 | 342 | let rec recursivelyTransformNamedArgsForMake mapper expr list = 343 | let expr = mapper.expr mapper expr in 344 | match expr.pexp_desc with 345 | (* TODO: make this show up with a loc. *) 346 | | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> 347 | raise 348 | (Invalid_argument 349 | "Key cannot be accessed inside of a component. Don't worry - you can always key a component from its \ 350 | parent!") 351 | | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> 352 | raise (Invalid_argument "Ref cannot be passed as a normal prop. Please use `forwardRef` API instead.") 353 | | Pexp_fun (arg, default, pattern, expression) when isOptional arg || isLabelled arg -> 354 | let () = 355 | match (isOptional arg, pattern, default) with 356 | | true, { ppat_desc = Ppat_constraint (_, { ptyp_desc }) }, None -> ( 357 | match ptyp_desc with 358 | | Ptyp_constr ({ txt = Lident "option" }, [ _ ]) -> () 359 | | _ -> 360 | let currentType = 361 | match ptyp_desc with 362 | | Ptyp_constr ({ txt }, []) -> String.concat "." (Longident.flatten txt) 363 | | Ptyp_constr ({ txt }, _innerTypeArgs) -> String.concat "." (Longident.flatten txt) ^ "(...)" 364 | | _ -> "..." 365 | in 366 | Location.prerr_warning pattern.ppat_loc 367 | (Preprocessor 368 | (Printf.sprintf 369 | "ReasonReact: optional argument annotations must have explicit `option`. Did you mean \ 370 | `option(%s)=?`?" 371 | currentType)) ) 372 | | _ -> () 373 | in 374 | let alias = 375 | match pattern with 376 | | { ppat_desc = Ppat_alias (_, { txt }) | Ppat_var { txt } } -> txt 377 | | { ppat_desc = Ppat_any } -> "_" 378 | | _ -> getLabel arg 379 | in 380 | let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in 381 | 382 | recursivelyTransformNamedArgsForMake mapper expression 383 | ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list) 384 | | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) -> 385 | (list, None) 386 | | Pexp_fun 387 | ( Nolabel, 388 | _, 389 | { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) }, 390 | _expression ) -> 391 | (list, Some txt) 392 | | Pexp_fun (Nolabel, _, pattern, _expression) -> 393 | Location.raise_errorf ~loc:pattern.ppat_loc 394 | "ReasonReact: react.component refs only support plain arguments and type annotations." 395 | | _ -> (list, None) 396 | [@@raises Invalid_argument] 397 | in 398 | 399 | let argToType types (name, default, _noLabelName, _alias, loc, type_) = 400 | match (type_, name, default) with 401 | | Some { ptyp_desc = Ptyp_constr ({ txt = Lident "option" }, [ type_ ]) }, name, _ when isOptional name -> 402 | ( getLabel name, 403 | [], 404 | { type_ with ptyp_desc = Ptyp_constr ({ loc = type_.ptyp_loc; txt = optionIdent }, [ type_ ]) } ) 405 | :: types 406 | | Some type_, name, Some _default -> 407 | ( getLabel name, 408 | [], 409 | { ptyp_desc = Ptyp_constr ({ loc; txt = optionIdent }, [ type_ ]); ptyp_loc = loc; ptyp_attributes = [] } ) 410 | :: types 411 | | Some type_, name, _ -> (getLabel name, [], type_) :: types 412 | | None, name, _ when isOptional name -> 413 | ( getLabel name, 414 | [], 415 | { 416 | ptyp_desc = 417 | Ptyp_constr 418 | ( { loc; txt = optionIdent }, 419 | [ { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] } ] ); 420 | ptyp_loc = loc; 421 | ptyp_attributes = []; 422 | } ) 423 | :: types 424 | | None, name, _ when isLabelled name -> 425 | (getLabel name, [], { ptyp_desc = Ptyp_var (safeTypeFromValue name); ptyp_loc = loc; ptyp_attributes = [] }) 426 | :: types 427 | | _ -> types 428 | [@@raises Invalid_argument] 429 | in 430 | 431 | let argToConcreteType types (name, loc, type_) = 432 | match name with 433 | | name when isLabelled name -> (getLabel name, [], type_) :: types 434 | | name when isOptional name -> (getLabel name, [], Typ.constr ~loc { loc; txt = optionIdent } [ type_ ]) :: types 435 | | _ -> types 436 | in 437 | 438 | let nestedModules = ref [] in 439 | let transformComponentDefinition mapper structure returnStructures = 440 | match structure with 441 | (* external *) 442 | | { 443 | pstr_loc; 444 | pstr_desc = Pstr_primitive ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as value_description); 445 | } as pstr -> ( 446 | match List.filter hasAttr pval_attributes with 447 | | [] -> structure :: returnStructures 448 | | [ _ ] -> 449 | let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = 450 | match ptyp_desc with 451 | | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isLabelled name || isOptional name 452 | -> 453 | getPropTypes ((name, ptyp_loc, type_) :: types) rest 454 | | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest 455 | | Ptyp_arrow (name, type_, returnValue) when isLabelled name || isOptional name -> 456 | (returnValue, (name, returnValue.ptyp_loc, type_) :: types) 457 | | _ -> (fullType, types) 458 | in 459 | let innerType, propTypes = getPropTypes [] pval_type in 460 | let namedTypeList = List.fold_left argToConcreteType [] propTypes in 461 | let pluckLabelAndLoc (label, loc, type_) = (label, None (* default *), loc, Some type_) in 462 | let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in 463 | let externalPropsDecl = 464 | makePropsExternal fnName pstr_loc 465 | ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) :: List.map pluckLabelAndLoc propTypes) 466 | retPropsType 467 | in 468 | (* can't be an arrow because it will defensively uncurry *) 469 | let newExternalType = 470 | Ptyp_constr ({ loc = pstr_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) 471 | in 472 | let newStructure = 473 | { 474 | pstr with 475 | pstr_desc = 476 | Pstr_primitive 477 | { 478 | value_description with 479 | pval_type = { pval_type with ptyp_desc = newExternalType }; 480 | pval_attributes = List.filter otherAttrsPure pval_attributes; 481 | }; 482 | } 483 | in 484 | externalPropsDecl :: newStructure :: returnStructures 485 | | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) 486 | (* let component = ... *) 487 | | { pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings) } -> 488 | let fileName = filenameFromLoc pstr_loc in 489 | let emptyLoc = Location.in_file fileName in 490 | let mapBinding binding = 491 | if hasAttrOnBinding binding then 492 | let bindingLoc = binding.pvb_loc in 493 | let bindingPatLoc = binding.pvb_pat.ppat_loc in 494 | let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in 495 | let fnName = getFnName binding in 496 | let internalFnName = fnName ^ "$Internal" in 497 | let fullModuleName = makeModuleName fileName !nestedModules fnName in 498 | let modifiedBindingOld binding = 499 | let expression = binding.pvb_expr in 500 | (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) 501 | let rec spelunkForFunExpression expression = 502 | match expression with 503 | (* let make = (~prop) => ... *) 504 | | { pexp_desc = Pexp_fun _ } -> expression 505 | (* let make = {let foo = bar in (~prop) => ...} *) 506 | | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } -> 507 | (* here's where we spelunk! *) 508 | spelunkForFunExpression returnExpression 509 | (* let make = React.forwardRef((~prop) => ...) *) 510 | | { pexp_desc = Pexp_apply (_wrapperExpression, [ (Nolabel, innerFunctionExpression) ]) } -> 511 | spelunkForFunExpression innerFunctionExpression 512 | | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } -> 513 | spelunkForFunExpression innerFunctionExpression 514 | | _ -> 515 | raise 516 | (Invalid_argument 517 | "react.component calls can only be on function definitions or component wrappers (forwardRef, \ 518 | memo).") 519 | [@@raises Invalid_argument] 520 | in 521 | spelunkForFunExpression expression 522 | in 523 | let modifiedBinding binding = 524 | let hasApplication = ref false in 525 | let wrapExpressionWithBinding expressionFn expression = 526 | Vb.mk ~loc:bindingLoc 527 | ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) 528 | (Pat.var ~loc:bindingPatLoc { loc = bindingPatLoc; txt = fnName }) 529 | (expressionFn expression) 530 | in 531 | let expression = binding.pvb_expr in 532 | let unerasableIgnoreExp exp = 533 | { exp with pexp_attributes = unerasableIgnore emptyLoc :: exp.pexp_attributes } 534 | in 535 | (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) 536 | let rec spelunkForFunExpression expression = 537 | match expression with 538 | (* let make = (~prop) => ... with no final unit *) 539 | | { 540 | pexp_desc = 541 | Pexp_fun 542 | ( ((Labelled _ | Optional _) as label), 543 | default, 544 | pattern, 545 | ({ pexp_desc = Pexp_fun _ } as internalExpression) ); 546 | } -> 547 | let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in 548 | ( wrap, 549 | hasUnit, 550 | unerasableIgnoreExp { expression with pexp_desc = Pexp_fun (label, default, pattern, exp) } ) 551 | (* let make = (()) => ... *) 552 | (* let make = (_) => ... *) 553 | | { 554 | pexp_desc = 555 | Pexp_fun 556 | ( Nolabel, 557 | _default, 558 | { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, 559 | _internalExpression ); 560 | } -> 561 | ((fun a -> a), true, expression) 562 | (* let make = (~prop) => ... *) 563 | | { pexp_desc = Pexp_fun ((Labelled _ | Optional _), _default, _pattern, _internalExpression) } -> 564 | ((fun a -> a), false, unerasableIgnoreExp expression) 565 | (* let make = (prop) => ... *) 566 | | { pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression) } -> 567 | if hasApplication.contents then ((fun a -> a), false, unerasableIgnoreExp expression) 568 | else 569 | Location.raise_errorf ~loc:pattern.ppat_loc 570 | "ReasonReact: props need to be labelled arguments.\n\ 571 | \ If you are working with refs be sure to wrap with React.forwardRef.\n\ 572 | \ If your component doesn't have any props use () or _ instead of a name." 573 | (* let make = {let foo = bar in (~prop) => ...} *) 574 | | { pexp_desc = Pexp_let (recursive, vbs, internalExpression) } -> 575 | (* here's where we spelunk! *) 576 | let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in 577 | (wrap, hasUnit, { expression with pexp_desc = Pexp_let (recursive, vbs, exp) }) 578 | (* let make = React.forwardRef((~prop) => ...) *) 579 | | { pexp_desc = Pexp_apply (wrapperExpression, [ (Nolabel, internalExpression) ]) } -> 580 | let () = hasApplication := true in 581 | let _, hasUnit, exp = spelunkForFunExpression internalExpression in 582 | ((fun exp -> Exp.apply wrapperExpression [ (nolabel, exp) ]), hasUnit, exp) 583 | | { pexp_desc = Pexp_sequence (wrapperExpression, internalExpression) } -> 584 | let wrap, hasUnit, exp = spelunkForFunExpression internalExpression in 585 | (wrap, hasUnit, { expression with pexp_desc = Pexp_sequence (wrapperExpression, exp) }) 586 | | e -> ((fun a -> a), false, e) 587 | in 588 | let wrapExpression, hasUnit, expression = spelunkForFunExpression expression in 589 | (wrapExpressionWithBinding wrapExpression, hasUnit, expression) 590 | in 591 | let bindingWrapper, hasUnit, expression = modifiedBinding binding in 592 | let reactComponentAttribute = 593 | try Some (List.find hasAttr binding.pvb_attributes) with Not_found -> None 594 | in 595 | let _attr_loc, payload = 596 | match reactComponentAttribute with 597 | | Some (loc, payload) -> (loc.loc, Some payload) 598 | | None -> (emptyLoc, None) 599 | in 600 | let props = getPropsAttr payload in 601 | (* do stuff here! *) 602 | let namedArgList, forwardRef = 603 | recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] 604 | in 605 | let namedArgListWithKeyAndRef = 606 | (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc)) 607 | :: namedArgList 608 | in 609 | let namedArgListWithKeyAndRef = 610 | match forwardRef with 611 | | Some _ -> 612 | (optional "ref", None, Pat.var { txt = "key"; loc = emptyLoc }, "ref", emptyLoc, None) 613 | :: namedArgListWithKeyAndRef 614 | | None -> namedArgListWithKeyAndRef 615 | in 616 | let namedArgListWithKeyAndRefForNew = 617 | match forwardRef with 618 | | Some txt -> namedArgList @ [ (nolabel, None, Pat.var { txt; loc = emptyLoc }, txt, emptyLoc, None) ] 619 | | None -> namedArgList 620 | in 621 | let pluckArg (label, _, _, alias, loc, _) = 622 | let labelString = 623 | match label with label when isOptional label || isLabelled label -> getLabel label | _ -> "" 624 | in 625 | ( label, 626 | match labelString with 627 | | "" -> Exp.ident ~loc { txt = Lident alias; loc } 628 | | labelString -> 629 | Exp.apply ~loc 630 | (Exp.ident ~loc { txt = Lident "##"; loc }) 631 | [ 632 | (nolabel, Exp.ident ~loc { txt = Lident props.propsName; loc }); 633 | (nolabel, Exp.ident ~loc { txt = Lident labelString; loc }); 634 | ] ) 635 | in 636 | let namedTypeList = List.fold_left argToType [] namedArgList in 637 | let loc = emptyLoc in 638 | let externalDecl = makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList in 639 | let innerExpressionArgs = 640 | List.map pluckArg namedArgListWithKeyAndRefForNew 641 | @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else [] 642 | in 643 | let innerExpression = 644 | Exp.apply 645 | (Exp.ident 646 | { loc; txt = Lident (match recFlag with Recursive -> internalFnName | Nonrecursive -> fnName) }) 647 | innerExpressionArgs 648 | in 649 | let innerExpressionWithRef = 650 | match forwardRef with 651 | | Some txt -> 652 | { 653 | innerExpression with 654 | pexp_desc = 655 | Pexp_fun 656 | ( nolabel, 657 | None, 658 | { ppat_desc = Ppat_var { txt; loc = emptyLoc }; ppat_loc = emptyLoc; ppat_attributes = [] }, 659 | innerExpression ); 660 | } 661 | | None -> innerExpression 662 | in 663 | let fullExpression = 664 | Exp.fun_ nolabel None 665 | { 666 | ppat_desc = 667 | Ppat_constraint 668 | (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc namedTypeList); 669 | ppat_loc = emptyLoc; 670 | ppat_attributes = []; 671 | } 672 | innerExpressionWithRef 673 | in 674 | let fullExpression = 675 | match fullModuleName with 676 | | "" -> fullExpression 677 | | txt -> 678 | Exp.let_ Nonrecursive 679 | [ Vb.mk ~loc:emptyLoc (Pat.var ~loc:emptyLoc { loc = emptyLoc; txt }) fullExpression ] 680 | (Exp.ident ~loc:emptyLoc { loc = emptyLoc; txt = Lident txt }) 681 | in 682 | let bindings, newBinding = 683 | match recFlag with 684 | | Recursive -> 685 | ( [ 686 | bindingWrapper 687 | (Exp.let_ ~loc:emptyLoc Recursive 688 | [ 689 | makeNewBinding binding expression internalFnName; 690 | Vb.mk (Pat.var { loc = emptyLoc; txt = fnName }) fullExpression; 691 | ] 692 | (Exp.ident { loc = emptyLoc; txt = Lident fnName })); 693 | ], 694 | None ) 695 | | Nonrecursive -> 696 | ([ { binding with pvb_expr = expression; pvb_attributes = [] } ], Some (bindingWrapper fullExpression)) 697 | in 698 | (Some externalDecl, bindings, newBinding) 699 | else (None, [ binding ], None) 700 | [@@raises Invalid_argument] 701 | in 702 | let structuresAndBinding = List.map mapBinding valueBindings in 703 | let otherStructures (extern, binding, newBinding) (externs, bindings, newBindings) = 704 | let externs = match extern with Some extern -> extern :: externs | None -> externs in 705 | let newBindings = 706 | match newBinding with Some newBinding -> newBinding :: newBindings | None -> newBindings 707 | in 708 | (externs, binding @ bindings, newBindings) 709 | in 710 | let externs, bindings, newBindings = List.fold_right otherStructures structuresAndBinding ([], [], []) in 711 | externs 712 | @ [ { pstr_loc; pstr_desc = Pstr_value (recFlag, bindings) } ] 713 | @ ( match newBindings with 714 | | [] -> [] 715 | | newBindings -> [ { pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings) } ] ) 716 | @ returnStructures 717 | | structure -> structure :: returnStructures 718 | [@@raises Invalid_argument] 719 | in 720 | 721 | let reactComponentTransform mapper structures = 722 | List.fold_right (transformComponentDefinition mapper) structures [] 723 | [@@raises Invalid_argument] 724 | in 725 | 726 | let transformComponentSignature _mapper signature returnSignatures = 727 | match signature with 728 | | { psig_loc; psig_desc = Psig_value ({ pval_name = { txt = fnName }; pval_attributes; pval_type } as psig_desc) } 729 | as psig -> ( 730 | match List.filter hasAttr pval_attributes with 731 | | [] -> signature :: returnSignatures 732 | | [ _ ] -> 733 | let rec getPropTypes types ({ ptyp_loc; ptyp_desc } as fullType) = 734 | match ptyp_desc with 735 | | Ptyp_arrow (name, type_, ({ ptyp_desc = Ptyp_arrow _ } as rest)) when isOptional name || isLabelled name 736 | -> 737 | getPropTypes ((name, ptyp_loc, type_) :: types) rest 738 | | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest 739 | | Ptyp_arrow (name, type_, returnValue) when isOptional name || isLabelled name -> 740 | (returnValue, (name, returnValue.ptyp_loc, type_) :: types) 741 | | _ -> (fullType, types) 742 | in 743 | let innerType, propTypes = getPropTypes [] pval_type in 744 | let namedTypeList = List.fold_left argToConcreteType [] propTypes in 745 | let pluckLabelAndLoc (label, loc, type_) = (label, None, loc, Some type_) in 746 | let retPropsType = makePropsType ~loc:psig_loc namedTypeList in 747 | let externalPropsDecl = 748 | makePropsExternalSig fnName psig_loc 749 | ((optional "key", None, psig_loc, Some (keyType psig_loc)) :: List.map pluckLabelAndLoc propTypes) 750 | retPropsType 751 | in 752 | (* can't be an arrow because it will defensively uncurry *) 753 | let newExternalType = 754 | Ptyp_constr ({ loc = psig_loc; txt = Ldot (Lident "React", "componentLike") }, [ retPropsType; innerType ]) 755 | in 756 | let newStructure = 757 | { 758 | psig with 759 | psig_desc = 760 | Psig_value 761 | { 762 | psig_desc with 763 | pval_type = { pval_type with ptyp_desc = newExternalType }; 764 | pval_attributes = List.filter otherAttrsPure pval_attributes; 765 | }; 766 | } 767 | in 768 | externalPropsDecl :: newStructure :: returnSignatures 769 | | _ -> raise (Invalid_argument "Only one react.component call can exist on a component at one time") ) 770 | | signature -> signature :: returnSignatures 771 | [@@raises Invalid_argument] 772 | in 773 | 774 | let reactComponentSignatureTransform mapper signatures = 775 | List.fold_right (transformComponentSignature mapper) signatures [] 776 | [@@raises Invalid_argument] 777 | in 778 | 779 | let transformJsxCall mapper callExpression callArguments attrs = 780 | match callExpression.pexp_desc with 781 | | Pexp_ident caller -> ( 782 | match caller with 783 | | { txt = Lident "createElement" } -> 784 | raise (Invalid_argument "JSX: `createElement` should be preceeded by a module name.") 785 | (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) 786 | | { loc; txt = Ldot (modulePath, ("createElement" | "make")) } -> ( 787 | match !jsxVersion with 788 | | None | Some 3 -> transformUppercaseCall3 modulePath mapper loc attrs callExpression callArguments 789 | | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) 790 | (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) 791 | (* turn that into 792 | ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) 793 | | { loc; txt = Lident id } -> ( 794 | match !jsxVersion with 795 | | None | Some 3 -> transformLowercaseCall3 mapper loc attrs callArguments id 796 | | Some _ -> raise (Invalid_argument "JSX: the JSX version must be 3") ) 797 | | { txt = Ldot (_, anythingNotCreateElementOrMake) } -> 798 | raise 799 | (Invalid_argument 800 | ( "JSX: the JSX attribute should be attached to a `YourModuleName.createElement` or \ 801 | `YourModuleName.make` call. We saw `" ^ anythingNotCreateElementOrMake ^ "` instead" )) 802 | | { txt = Lapply _ } -> 803 | (* don't think there's ever a case where this is reached *) 804 | raise (Invalid_argument "JSX: encountered a weird case while processing the code. Please report this!") ) 805 | | _ -> raise (Invalid_argument "JSX: `createElement` should be preceeded by a simple, direct module name.") 806 | [@@raises Invalid_argument] 807 | in 808 | 809 | let signature mapper signature = 810 | default_mapper.signature mapper @@ reactComponentSignatureTransform mapper signature 811 | [@@raises Invalid_argument] 812 | in 813 | 814 | let structure mapper structure = 815 | match structure with structures -> default_mapper.structure mapper @@ reactComponentTransform mapper structures 816 | [@@raises Invalid_argument] 817 | in 818 | 819 | let expr mapper expression = 820 | match expression with 821 | (* Does the function application have the @JSX attribute? *) 822 | | { pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes } -> ( 823 | let jsxAttribute, nonJSXAttributes = 824 | List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes 825 | in 826 | match (jsxAttribute, nonJSXAttributes) with 827 | (* no JSX attribute *) 828 | | [], _ -> default_mapper.expr mapper expression 829 | | _, nonJSXAttributes -> transformJsxCall mapper callExpression callArguments nonJSXAttributes ) 830 | (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) 831 | | { 832 | pexp_desc = 833 | ( Pexp_construct ({ txt = Lident "::"; loc }, Some { pexp_desc = Pexp_tuple _ }) 834 | | Pexp_construct ({ txt = Lident "[]"; loc }, None) ); 835 | pexp_attributes; 836 | } as listItems -> ( 837 | let jsxAttribute, nonJSXAttributes = 838 | List.partition (fun (attribute, _) -> attribute.txt = "JSX") pexp_attributes 839 | in 840 | match (jsxAttribute, nonJSXAttributes) with 841 | (* no JSX attribute *) 842 | | [], _ -> default_mapper.expr mapper expression 843 | | _, nonJSXAttributes -> 844 | let fragment = Exp.ident ~loc { loc; txt = Ldot (Lident "ReasonReact", "fragment") } in 845 | let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in 846 | let args = 847 | [ (* "div" *) (nolabel, fragment); (* [|moreCreateElementCallsHere|] *) (nolabel, childrenExpr) ] 848 | in 849 | Exp.apply ~loc (* throw away the [@JSX] attribute and keep the others, if any *) ~attrs:nonJSXAttributes 850 | (* ReactDOMRe.createElement *) 851 | (Exp.ident ~loc { loc; txt = Ldot (Lident "ReactDOMRe", "createElement") }) 852 | args ) 853 | (* Delegate to the default mapper, a deep identity traversal *) 854 | | e -> default_mapper.expr mapper e 855 | [@@raises Invalid_argument] 856 | in 857 | 858 | let module_binding mapper module_binding = 859 | let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in 860 | let mapped = default_mapper.module_binding mapper module_binding in 861 | let _ = nestedModules := List.tl !nestedModules in 862 | mapped 863 | [@@raises Failure] 864 | in 865 | { default_mapper with structure; expr; signature; module_binding } 866 | [@@raises Invalid_argument, Failure] 867 | 868 | let rewrite_implementation (code : Parsetree.structure) : Parsetree.structure = 869 | let mapper = jsxMapper () in 870 | mapper.structure mapper code 871 | [@@raises Invalid_argument, Failure] 872 | 873 | let rewrite_signature (code : Parsetree.signature) : Parsetree.signature = 874 | let mapper = jsxMapper () in 875 | mapper.signature mapper code 876 | [@@raises Invalid_argument, Failure] 877 | --------------------------------------------------------------------------------