├── .gitignore ├── .vscode └── tasks.json ├── Readme.md ├── bsconfig.json ├── package.json ├── ppx_magic.sh ├── ppx_magic_native.sh ├── src ├── Devtools.re ├── Json.re ├── Lib.re ├── SharedTypes.re ├── Utils.re ├── YoJson.re ├── ppx_magic.re └── ppx_magic_native.re └── syntax_test ├── DevtoolsSerialize.re ├── JsonParse.re ├── JsonStringify.re ├── Syntax_test.re └── YojsonStringify.re /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | .merlin 3 | _build 4 | *.install 5 | lib 6 | node_modules 7 | -------------------------------------------------------------------------------- /.vscode/tasks.json: -------------------------------------------------------------------------------- 1 | { 2 | // See https://go.microsoft.com/fwlink/?LinkId=733558 3 | // for the documentation about the tasks.json format 4 | "version": "2.0.0", 5 | "tasks": [ 6 | { 7 | "taskName": "make-test", 8 | "type": "shell", 9 | "command": "eval `opam config env` && npm run build -s && npm test -s", 10 | "group": { 11 | "isDefault": true, 12 | "kind": "build" 13 | } 14 | } 15 | ] 16 | } -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # Autoserialize 2 | 3 | What do we want? no-pain jsonifying, devtools integration, and pretty printing 4 | of values for debugging! 5 | 6 | What does it look like? 7 | 8 | ```reason 9 | type myThing = { 10 | something: int, 11 | moreThings: option string, 12 | }; 13 | let myValue = {something: 10, moreThings: Some "hello"}; 14 | /* ooh magically myThing__to_devtools is available! */ 15 | Js.log (myThing__to_devtools myValue); 16 | Js.log (Js.Json.stringify (myThing__to_json myValue)); 17 | switch (myThing__from_json (myThing__to_json myValue)) { 18 | | None => Js.log "Failed to deserialize" 19 | | Some roundTripped => Js.log "It worked!" 20 | } 21 | ``` 22 | 23 | ## Example screenshots! 24 | ![screenshot](screenshot.png) 25 | ![devtools](devtools.png) 26 | 27 | ## How battled hardened is it? 28 | 29 | As much as a wooden horse. 30 | 31 | ## How well does it work? 32 | 33 | As a ppx, it will only run on the code in the current project. If you want to 34 | serialize code that includes types from other libraries, we'll need something 35 | else (I have an idea for that too). Or we could have bucklescript run this ppx 36 | on all of everything, which would probably have prohibitive performance 37 | implications. 38 | -------------------------------------------------------------------------------- /bsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "ppx_autoserialize", 3 | "version": "0.1.0", 4 | "sources": [ 5 | "./src", 6 | "./syntax_test", 7 | ], 8 | "entries": [ 9 | {"backend": "native", "main-module": "Ppx_magic"}, 10 | {"backend": "native", "main-module": "Ppx_magic_native"}, 11 | {"backend": "native", "main-module": "Syntax_test"}, 12 | ], 13 | "bsc-flags": ["-w", "+40", "-w", "-30", "-bs-super-errors"], 14 | "ocaml-dependencies": ["compiler-libs"], 15 | // "ocamlfind-dependencies": [ 16 | // "ocaml-migrate-parsetree" 17 | // ], 18 | "ppx-flags": [ 19 | "ppx_metaquot_402" 20 | ] 21 | } 22 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "ppx_autoserialize", 3 | "version": "1.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "dependencies": { 7 | "bs-platform": "bsansouci/bsb-native.git#3.2.0", 8 | "ppx_tools_bs": "jaredly/ppx_tools_bs.git" 9 | }, 10 | "scripts": { 11 | "build": "bsb -make-world -backend native", 12 | "postinstall": "bsb -make-world -backend native", 13 | "watch": "bsb -make-world -backend native -w", 14 | "test": "./lib/bs/native/syntax_test.native", 15 | "clean": "bsb -clean-world" 16 | }, 17 | "bin": { 18 | "ppx_magic": "./ppx_magic.sh", 19 | "ppx_magic_native": "./ppx_magic_native.sh" 20 | }, 21 | "keywords": [], 22 | "author": "", 23 | "license": "ISC" 24 | } 25 | -------------------------------------------------------------------------------- /ppx_magic.sh: -------------------------------------------------------------------------------- 1 | `dirname $(realpath $0)`/lib/bs/native/ppx_magic.native $@ 2 | -------------------------------------------------------------------------------- /ppx_magic_native.sh: -------------------------------------------------------------------------------- 1 | `dirname $(realpath $0)`/lib/bs/native/ppx_magic_native.native $@ 2 | -------------------------------------------------------------------------------- /src/Devtools.re: -------------------------------------------------------------------------------- 1 | open SharedTypes; 2 | 3 | open Utils; 4 | 5 | /* open Migrate_parsetree.Ast_403; */ 6 | 7 | let config = { 8 | prefix: [%str 9 | external to_devtools : 'a => Js.t({.}) = "%identity"; 10 | let unit__to_devtools = to_devtools; 11 | let int__to_devtools = to_devtools; 12 | let float__to_devtools = to_devtools; 13 | let string__to_devtools = to_devtools; 14 | let bool__to_devtools = to_devtools; 15 | let list__to_devtools = (convert, items) => 16 | {"$bs": "list", "items": List.map(convert, items) |> Array.of_list} |> to_devtools; 17 | let array__to_devtools = (convert, items) => Array.map(convert, items) |> to_devtools; 18 | let option__to_devtools = (convert, item) => 19 | ( 20 | switch item { 21 | | None => {"$bs": "optional", "empty": true, "value": Js.Null.empty} 22 | | Some((x)) => {"$bs": "optional", "empty": false, "value": Js.Null.return(convert(x))} 23 | } 24 | ) 25 | |> to_devtools 26 | ], 27 | decorator: "to.devtools", 28 | suffix: "__to_devtools", 29 | typ: To([%type : Js.t({.})]), 30 | variant: (core_type_converter, constructors, name) => { 31 | open Parsetree; 32 | open Ast_helper; 33 | open Longident; 34 | let cases = 35 | List.map( 36 | ({pcd_name: {txt, loc}, pcd_args: types}) => { 37 | let strConst = Exp.constant(Const_string(txt, None)); 38 | let lid = Location.mknoloc(Lident(txt)); 39 | /* switch pcd_args { 40 | | Pcstr_tuple(types) => */ 41 | switch types { 42 | | [] => 43 | Exp.case( 44 | Pat.construct(lid, None), 45 | [%expr 46 | { 47 | "$bs": "variant", 48 | "type": [%e Utils.strConst(name)], 49 | "constructor": [%e strConst], 50 | "arguments": [||] 51 | } 52 | |> to_devtools 53 | ] 54 | ) 55 | | _ => 56 | let items = List.mapi((i, typ) => Utils.patVar("arg" ++ string_of_int(i)), types); 57 | let args = 58 | switch items { 59 | | [] => None 60 | | [single] => Some(single) 61 | | _ => Some(Pat.tuple(items)) 62 | }; 63 | let pat = Pat.construct(lid, args); 64 | let values = 65 | List.mapi( 66 | (i, typ) => { 67 | let larg = Utils.expIdent("arg" ++ string_of_int(i)); 68 | [%expr [%e core_type_converter(typ)]([%e larg])]; 69 | }, 70 | types 71 | ); 72 | let expr = [%expr 73 | { 74 | "$bs": "variant", 75 | "type": [%e Utils.strConst(name)], 76 | "constructor": [%e strConst], 77 | "arguments": [%e Utils.list(values)] |> Array.of_list 78 | } 79 | |> to_devtools 80 | ]; 81 | Exp.case(pat, expr); 82 | } /* This isn't supported in 4.02 anyway */ 83 | /* | Pcstr_record(labels) => Utils.fail(loc, "Nope record labels") 84 | }; */ 85 | }, 86 | constructors 87 | ); 88 | Exp.fun_("", None, Utils.patVar("value"), Exp.match([%expr value], cases)); 89 | }, 90 | record: (core_type_converter, labels, name) => { 91 | open Parsetree; 92 | open Longident; 93 | open Ast_helper; 94 | let strConst = (txt) => Exp.constant(Const_string(txt, None)); 95 | let sets = 96 | List.map( 97 | ({pld_name: {txt}, pld_type}) => { 98 | let value = Exp.field([%expr value], Location.mknoloc(Lident(txt))); 99 | [%expr 100 | Js.Dict.set(result, [%e strConst(txt)], [%e core_type_converter(pld_type)]([%e value])) 101 | ]; 102 | }, 103 | labels 104 | ); 105 | let body = 106 | List.append( 107 | sets, 108 | [ 109 | [%expr 110 | {"$bs": "record", "type": [%e strConst(name)], "attributes": result |> to_devtools} 111 | |> to_devtools 112 | ] 113 | ] 114 | ) 115 | |> chainExpressions; 116 | let body = 117 | Exp.let_(Nonrecursive, [Ast_helper.Vb.mk(left("result"), [%expr Js.Dict.empty()])], body); 118 | Exp.fun_("", None, Pat.var(Location.mknoloc("value")), body); 119 | } 120 | }; 121 | -------------------------------------------------------------------------------- /src/Json.re: -------------------------------------------------------------------------------- 1 | open SharedTypes; 2 | 3 | open Utils; 4 | 5 | /* open Migrate_parsetree.Ast_403; */ 6 | 7 | let stringify = { 8 | decorator: "to.json", 9 | prefix: [%str 10 | let unit__to_json = () => Js.Json.string(""); 11 | let int__to_json = (x) => Js.Json.number(float_of_int(x)); 12 | let float__to_json = Js.Json.number; 13 | let list__to_json = (convert, items) => Js.Json.array(Array.of_list(List.map(convert, items))); 14 | let string__to_json = Js.Json.string; 15 | let array__to_json = (convert, items) => Js.Json.array(Array.map(convert, items)); 16 | let bool__to_json = (b) => Js.Json.boolean @@ Js.Boolean.to_js_boolean(b); 17 | let option__to_json = (convert, value) => 18 | switch value { 19 | | None => Js.Json.null 20 | | Some((value)) => Js.Json.array([|convert(value)|]) 21 | } 22 | ], 23 | suffix: "__to_json", 24 | typ: To([%type : Js.Json.t]), 25 | variant: (core_type_converter, constructors, name) => { 26 | open Parsetree; 27 | open Ast_helper; 28 | open Longident; 29 | let cases = 30 | List.map( 31 | ({pcd_name: {txt, loc}, pcd_args:types}) => { 32 | let strConst = Exp.constant(Const_string(txt, None)); 33 | let lid = Location.mknoloc(Lident(txt)); 34 | /* switch pcd_args { 35 | | Pcstr_tuple(types) => */ 36 | switch types { 37 | | [] => Exp.case(Pat.construct(lid, None), [%expr Js.Json.string([%e strConst])]) 38 | | _ => 39 | let items = List.mapi((i, typ) => Utils.patVar("arg" ++ string_of_int(i)), types); 40 | let args = 41 | switch items { 42 | | [] => None 43 | | [single] => Some(single) 44 | | _ => Some(Pat.tuple(items)) 45 | }; 46 | let pat = Pat.construct(lid, args); 47 | let values = 48 | List.mapi( 49 | (i, typ) => { 50 | let larg = Utils.expIdent("arg" ++ string_of_int(i)); 51 | [%expr [%e core_type_converter(typ)]([%e larg])]; 52 | }, 53 | types 54 | ); 55 | let values = [[%expr Js.Json.string([%e strConst])], ...values]; 56 | Exp.case(pat, [%expr Js.Json.array([%e Exp.array(values)])]); 57 | } /* This isn't supported in 4.02 anyway */ 58 | /* | Pcstr_record(labels) => Utils.fail(loc, "Nope record labels") 59 | }; */ 60 | }, 61 | constructors 62 | ); 63 | Exp.fun_("", None, Utils.patVar("value"), Exp.match([%expr value], cases)); 64 | }, 65 | record: (core_type_converter, labels, name) => { 66 | open Parsetree; 67 | open Longident; 68 | open Ast_helper; 69 | let sets = 70 | List.map( 71 | ({pld_name: {txt}, pld_type}) => { 72 | let value = Exp.field([%expr value], Location.mknoloc(Lident(txt))); 73 | let strConst = Exp.constant(Const_string(txt, None)); 74 | [%expr 75 | Js.Dict.set(result, [%e strConst], [%e core_type_converter(pld_type)]([%e value])) 76 | ]; 77 | }, 78 | labels 79 | ); 80 | let body = List.append(sets, [[%expr Js.Json.object_(result)]]) |> chainExpressions; 81 | let body = 82 | Exp.let_(Nonrecursive, [Ast_helper.Vb.mk(left("result"), [%expr Js.Dict.empty()])], body); 83 | Exp.fun_("", None, Pat.var(Location.mknoloc("value")), body); 84 | } 85 | }; 86 | 87 | let parse = { 88 | decorator: "from.json", 89 | prefix: [%str 90 | let unit__from_json = (_) => Some(); 91 | let int__from_json = (x) => 92 | switch (Js.Json.classify(x)) { 93 | | Js.Json.JSONNumber(n) => Some(int_of_float(n)) 94 | | _ => None 95 | }; 96 | let float__from_json = (x) => 97 | switch (Js.Json.classify(x)) { 98 | | Js.Json.JSONNumber(n) => Some(n) 99 | | _ => None 100 | }; 101 | let list__from_json = (convert, items) => 102 | switch (Js.Json.classify(items)) { 103 | | Js.Json.JSONArray(arr) => 104 | try { 105 | let items = 106 | Array.map( 107 | (item) => 108 | switch (convert(item)) { 109 | | Some((x)) => x 110 | | None => failwith("Item failed to parse") 111 | }, 112 | arr 113 | ); 114 | Some(Array.to_list(items)); 115 | } { 116 | | _ => None 117 | } 118 | | _ => None 119 | }; 120 | let string__from_json = (value) => 121 | switch (Js.Json.classify(value)) { 122 | | Js.Json.JSONString(str) => Some(str) 123 | | _ => None 124 | }; 125 | let array__from_json = (convert, items) => 126 | switch (Js.Json.classify(items)) { 127 | | Js.Json.JSONArray(arr) => 128 | try { 129 | let items = 130 | Array.map( 131 | (item) => 132 | switch (convert(item)) { 133 | | Some((x)) => x 134 | | None => failwith("Item failed to parse") 135 | }, 136 | arr 137 | ); 138 | Some(items); 139 | } { 140 | | _ => None 141 | } 142 | | _ => None 143 | }; 144 | let bool__from_json = (value) => 145 | switch (Js.Json.classify(value)) { 146 | | Js.Json.JSONFalse => Some(false) 147 | | Js.Json.JSONTrue => Some(true) 148 | | _ => None 149 | }; 150 | let option__from_json = (convert, value) => 151 | switch (Js.Json.classify(value)) { 152 | | Js.Json.JSONNull => Some(None) 153 | | Js.Json.JSONArray([|item|]) => 154 | switch (convert(item)) { 155 | | None => None 156 | | Some((value)) => Some(Some(value)) 157 | } 158 | | _ => None 159 | } 160 | ], 161 | suffix: "__from_json", 162 | typ: From([%type : Js.Json.t]), 163 | variant: (core_type_converter, constructors, name) => { 164 | /* [%expr fun _ => failwith "not supported"] */ 165 | open Parsetree; 166 | open Ast_helper; 167 | open 168 | Longident; /* [%expr 169 | fun value => { 170 | switch (Js.Json.classify value) { 171 | | JSONString "awesome" => 172 | | JSONArray arr when Js.Json.classify arr.(0) == JSONString "moresome" => { 173 | 174 | } 175 | } 176 | } 177 | ] */ 178 | let cases = 179 | List.map( 180 | ({pcd_name: {txt, loc}, pcd_args:types}) => { 181 | let patConst = 182 | Pat.constant( 183 | Const_string(txt, None) 184 | ); /* let processArgs = 185 | let body = [%expr switch items { 186 | | [%p Pat.array [Pat.any (), ...args]] => { 187 | [%e processArgs] 188 | } 189 | | _ => None 190 | }]; */ 191 | let strConst = Exp.constant(Const_string(txt, None)); 192 | let lid = Location.mknoloc(Lident(txt)); 193 | /* switch pcd_args { 194 | | Pcstr_tuple(types) => */ 195 | switch types { 196 | | [] => 197 | Exp.case( 198 | [%pat ? Js.Json.JSONString([%p patConst])], 199 | [%expr Some([%e Exp.construct(lid, None)])] 200 | ) 201 | | _ => 202 | let items = List.mapi((i, typ) => Utils.patVar("arg" ++ string_of_int(i)), types); 203 | let pattern = Pat.array([Pat.any(), ...items]); 204 | let args = 205 | switch types { 206 | | [] => None 207 | | [_] => Some(Utils.expIdent("arg0")) 208 | | _ => 209 | Some( 210 | Exp.tuple( 211 | List.mapi((i, typ) => Utils.expIdent("arg" ++ string_of_int(i)), types) 212 | ) 213 | ) 214 | }; 215 | let expr = Exp.construct(lid, args); 216 | let (body, _) = 217 | List.fold_right( 218 | (typ, (body, i)) => ( 219 | [%expr 220 | switch ( 221 | [%e core_type_converter(typ)]( 222 | [%e Utils.expIdent("arg" ++ string_of_int(i))] 223 | ) 224 | ) { 225 | | None => None 226 | | Some(([%p Utils.patVar("arg" ++ string_of_int(i))])) => [%e body] 227 | } 228 | ], 229 | i - 1 230 | ), 231 | types, 232 | ([%expr Some([%e expr])], List.length(types) - 1) 233 | ); 234 | Exp.case( 235 | [%pat ? Js.Json.JSONArray(arr)], 236 | ~guard=[%expr Js.Json.classify(arr[0]) == Js.Json.JSONString([%e strConst])], 237 | [%expr 238 | switch arr { 239 | | [%p pattern] => [%e body] 240 | | _ => None 241 | } 242 | ] 243 | ); 244 | } /* This isn't supported in 4.02 anyway */ 245 | /* | Pcstr_record(labels) => Utils.fail(loc, "Nope record labels") 246 | }; */ 247 | }, 248 | constructors 249 | ); 250 | let cases = List.append(cases, [Exp.case(Pat.any(), [%expr None])]); 251 | Exp.fun_( 252 | "", 253 | None, 254 | Utils.patVar("value"), 255 | Exp.match([%expr Js.Json.classify(value)], cases) 256 | ); 257 | }, 258 | record: (core_type_converter, labels, name) => { 259 | open Parsetree; 260 | open Longident; 261 | open Ast_helper; 262 | let body = 263 | Exp.record( 264 | List.map( 265 | ({pld_name: {txt}}) => ( 266 | Location.mknoloc(Lident(txt)), 267 | Exp.ident(Location.mknoloc(Lident(txt ++ "_extracted"))) 268 | ), 269 | labels 270 | ), 271 | None 272 | ); 273 | let body = 274 | List.fold_right( 275 | ({pld_name: {txt}, pld_type}, body) => { 276 | let strConst = Exp.constant(Const_string(txt, None)); 277 | let strPat = Pat.var(Location.mknoloc(txt ++ "_extracted")); 278 | [%expr 279 | switch (Js.Dict.get(value, [%e strConst])) { 280 | | None => None 281 | | Some((attr)) => 282 | switch ([%e core_type_converter(pld_type)](attr)) { 283 | | None => None 284 | | Some(([%p strPat])) => [%e body] 285 | } 286 | } 287 | ]; 288 | }, 289 | labels, 290 | [%expr Some([%e body])] 291 | ); 292 | let body = [%expr 293 | switch (Js.Json.classify(value)) { 294 | | Js.Json.JSONObject(value) => [%e body] 295 | | _ => None 296 | } 297 | ]; 298 | Exp.fun_("", None, Pat.var(Location.mknoloc("value")), body); 299 | } 300 | }; 301 | -------------------------------------------------------------------------------- /src/Lib.re: -------------------------------------------------------------------------------- 1 | open SharedTypes; 2 | 3 | open Utils; 4 | 5 | /* open Migrate_parsetree.Ast_403; */ 6 | 7 | module Json = Json; 8 | 9 | module YoJson = YoJson; 10 | 11 | module Utils = Utils; 12 | 13 | module Types = Types; 14 | 15 | module Devtools = Devtools; 16 | 17 | let rec core_type_converter = (suffix, typ) => 18 | Parsetree.( 19 | Ast_helper.( 20 | switch typ.ptyp_desc { 21 | | Ptyp_constr({txt}, args) => 22 | let main = simple(suffixify(txt, suffix)); 23 | if (args === []) { 24 | main; 25 | } else { 26 | Exp.apply( 27 | main, 28 | List.map((arg) => ("", core_type_converter(suffix, arg)), args) 29 | ); 30 | }; 31 | | Ptyp_var(name) => 32 | simple( 33 | Lident(name ++ "_converter") 34 | ) /* TODO serlize the AST & show it here for debugging */ 35 | | _ => [%expr ((_) => failwith("Unexpected core type, cannot convert"))] 36 | } 37 | ) 38 | ); 39 | 40 | let make_signatures = 41 | ( 42 | ~autoAll, 43 | configs, 44 | { 45 | Parsetree.ptype_name: {txt} as name, 46 | ptype_params, 47 | ptype_kind, 48 | ptype_manifest, 49 | ptype_attributes 50 | } 51 | ) => { 52 | let param_names = 53 | List.map( 54 | ((typ, _)) => 55 | switch typ.Parsetree.ptyp_desc { 56 | | Ptyp_var(text) => text 57 | | _ => assert false 58 | }, 59 | ptype_params 60 | ); 61 | let thisType = 62 | Ast_helper.Typ.constr( 63 | Location.mknoloc(Longident.Lident(txt)), 64 | List.map(((typ, _)) => typ, ptype_params) 65 | ); 66 | List.fold_left( 67 | (results, {suffix, variant, record, typ, decorator}) => { 68 | let generate = autoAll || List.exists((({Asttypes.txt}, _)) => txt == decorator, ptype_attributes); 69 | 70 | if (generate) { 71 | let right = 72 | switch typ { 73 | | To(typ) => Ast_helper.Typ.arrow("", thisType, typ) 74 | | From(typ) => Ast_helper.Typ.arrow("", typ, [%type : option([%t thisType])]) 75 | }; 76 | [Ast_helper.Sig.value( 77 | Ast_helper.Val.mk(Location.mknoloc(txt ++ suffix), paramd_type(param_names, right, typ)) 78 | ), ...results]; 79 | } else { 80 | results 81 | } 82 | }, 83 | [], 84 | configs 85 | ); 86 | }; 87 | 88 | let make_converters = 89 | ( 90 | ~autoAll, 91 | configs, 92 | {Parsetree.ptype_name: {txt}, ptype_params, ptype_kind, ptype_manifest, ptype_attributes} 93 | ) => 94 | switch ptype_attributes { 95 | | [({txt: "noserialize"}, _)] => [] 96 | | _ => 97 | let param_names = 98 | List.map( 99 | ((typ, _)) => 100 | switch typ.Parsetree.ptyp_desc { 101 | | Ptyp_var(text) => text 102 | | _ => assert false 103 | }, 104 | ptype_params 105 | ); 106 | List.fold_left( 107 | (results, {suffix, variant, record, decorator}) => { 108 | let generate = autoAll || List.exists((({Asttypes.txt}, _)) => txt == decorator, ptype_attributes); 109 | 110 | if (generate) { 111 | let right = 112 | switch ptype_manifest { 113 | | Some((typ)) => [%expr ((value) => [%e core_type_converter(suffix, typ)](value))] 114 | | None => 115 | switch ptype_kind { 116 | | Ptype_abstract => [%expr ((value) => "type is abstract & cannot be converted")] 117 | | Ptype_variant(constructors) => 118 | variant(core_type_converter(suffix), constructors, txt) 119 | | Ptype_record(labels) => record(core_type_converter(suffix), labels, txt) 120 | | Ptype_open => [%expr ((value) => "type is open & cannot be converted")] 121 | } 122 | }; 123 | [Ast_helper.Str.value( 124 | Nonrecursive, 125 | [Ast_helper.Vb.mk(left(txt ++ suffix), paramd_fun(param_names, right))] 126 | ), ...results]; 127 | } else { 128 | results 129 | } 130 | }, 131 | [], 132 | configs 133 | ) |> List.rev; 134 | }; 135 | 136 | let mapper = (~autoAll=false, configs) => 137 | Parsetree.{ 138 | ...Ast_mapper.default_mapper, 139 | payload: (mapper, payload) => payload, 140 | signature: (mapper, signature) => { 141 | let rec loop = (items) => 142 | switch items { 143 | | [] => [] 144 | | [{psig_desc: Psig_type(declarations)} as item, ...rest] => 145 | let converters = List.map(make_signatures(~autoAll, configs), declarations) |> List.concat; 146 | [item, ...List.append(converters, loop(rest))]; 147 | | [item, ...rest] => [mapper.signature_item(mapper, item), ...loop(rest)] 148 | }; 149 | loop(signature); 150 | }, 151 | structure: (mapper, structure) => { 152 | let rec loop = (items) => 153 | switch items { 154 | | [] => [] 155 | | [{pstr_desc: Pstr_type(declarations)} as item, ...rest] => 156 | let converters = List.map(make_converters(~autoAll, configs), declarations) |> List.concat; 157 | [item, ...List.append(converters, loop(rest))]; 158 | | [item, ...rest] => [mapper.structure_item(mapper, item), ...loop(rest)] 159 | }; 160 | let items = loop(structure); 161 | List.append(List.concat(List.map((config) => config.prefix, configs)), items); 162 | } 163 | }; 164 | -------------------------------------------------------------------------------- /src/SharedTypes.re: -------------------------------------------------------------------------------- 1 | /* open Migrate_parsetree.Ast_403; */ 2 | 3 | type tofrom = 4 | | To(Parsetree.core_type) 5 | | From(Parsetree.core_type); 6 | 7 | type config = { 8 | prefix: Parsetree.structure, 9 | decorator: string, 10 | suffix: string, 11 | typ: tofrom, 12 | variant: 13 | ( 14 | Parsetree.core_type => Parsetree.expression, 15 | list(Parsetree.constructor_declaration), 16 | string 17 | ) => 18 | Parsetree.expression, 19 | record: 20 | (Parsetree.core_type => Parsetree.expression, list(Parsetree.label_declaration), string) => 21 | Parsetree.expression 22 | }; 23 | -------------------------------------------------------------------------------- /src/Utils.re: -------------------------------------------------------------------------------- 1 | /* open Migrate_parsetree.Ast_403; */ 2 | 3 | let fail = (loc, txt) => raise(Location.Error(Location.error(~loc=loc, txt))); 4 | 5 | let left = (txt) => Ast_helper.Pat.var(Location.mknoloc(txt)); 6 | 7 | let simple = (txt) => Ast_helper.Exp.ident(Location.mknoloc(txt)); 8 | 9 | let strConst = (txt) => Ast_helper.Exp.constant(Const_string(txt, None)); 10 | 11 | let patVar = (txt) => Ast_helper.Pat.var(Location.mknoloc(txt)); 12 | 13 | let expIdent = (txt) => Ast_helper.Exp.ident(Location.mknoloc(Longident.Lident(txt))); 14 | 15 | let rec suffixify = (lident, suffix) => 16 | Longident.( 17 | switch lident { 18 | | Lident(x) => Lident(x ++ suffix) 19 | | Ldot(x, y) => Ldot(x, y ++ suffix) 20 | | Lapply(a, b) => Lapply(a, suffixify(b, suffix)) 21 | } 22 | ); 23 | 24 | let rec patList = (items: list(Parsetree.pattern)) => 25 | List.fold_right( 26 | (item, rest) => 27 | Ast_helper.Pat.construct( 28 | Location.mknoloc(Longident.Lident("::")), 29 | Some(Ast_helper.Pat.tuple([item, rest])) 30 | ), 31 | items, 32 | Ast_helper.Pat.construct(Location.mknoloc(Longident.Lident("[]")), None) 33 | ); 34 | 35 | let rec list = (items: list(Parsetree.expression)) => 36 | List.fold_right( 37 | (item, rest) => 38 | Ast_helper.Exp.construct( 39 | Location.mknoloc(Longident.Lident("::")), 40 | Some(Ast_helper.Exp.tuple([item, rest])) 41 | ), 42 | items, 43 | Ast_helper.Exp.construct(Location.mknoloc(Longident.Lident("[]")), None) 44 | ); 45 | 46 | let rec chainExpressions = (expressions) => 47 | switch expressions { 48 | | [] => assert false 49 | | [one] => one 50 | | [one, ...rest] => Ast_helper.Exp.sequence(one, chainExpressions(rest)) 51 | }; 52 | 53 | let paramd_fun = (param_names, body) => 54 | Parsetree.( 55 | Longident.( 56 | Ast_helper.( 57 | List.fold_right( 58 | (name, body) => 59 | Exp.fun_( 60 | "", 61 | None, 62 | Pat.var(Location.mknoloc(name ++ "_converter")), 63 | body 64 | ), 65 | param_names, 66 | body 67 | ) 68 | ) 69 | ) 70 | ); 71 | 72 | let paramd_type = (param_names, body, typ) => 73 | Parsetree.( 74 | Longident.( 75 | Ast_helper.( 76 | List.fold_right( 77 | (name, body) => { 78 | let vtyp = Ast_helper.Typ.var(name); 79 | open SharedTypes; 80 | let converter = 81 | switch typ { 82 | | To(typ) => Ast_helper.Typ.arrow("", vtyp, typ) 83 | | From(typ) => Ast_helper.Typ.arrow("", typ, [%type : option([%t vtyp])]) 84 | }; 85 | Typ.arrow("", converter, body); 86 | }, 87 | param_names, 88 | body 89 | ) 90 | ) 91 | ) 92 | ); 93 | -------------------------------------------------------------------------------- /src/YoJson.re: -------------------------------------------------------------------------------- 1 | open SharedTypes; 2 | 3 | open Utils; 4 | 5 | /* open Migrate_parsetree.Ast_403; */ 6 | 7 | let stringify = { 8 | decorator: "to.yojson", 9 | prefix: [%str 10 | let int__to_yojson = (x) => `Int(x); 11 | let float__to_yojson = (x) => `Float(x); 12 | let list__to_yojson = (convert, items) => `List(List.map(convert, items)); 13 | let string__to_yojson = (x) => `String(x); 14 | let array__to_yojson = (convert, items) => `List(Array.to_list(Array.map(convert, items))); 15 | let boolean__to_yojson = (x) => `Bool(x); 16 | let option__to_yojson = (convert, x) => 17 | switch x { 18 | | None => `Null 19 | | Some((x)) => `List([convert(x)]) 20 | } 21 | ], 22 | suffix: "__to_yojson", 23 | typ: To([%type : Yojson.Safe.json]), 24 | variant: (core_type_converter, constructors, name) => { 25 | open Parsetree; 26 | open Ast_helper; 27 | open Longident; 28 | let cases = 29 | List.map( 30 | ({pcd_name: {txt, loc}, pcd_args: types}) => { 31 | let strConst = Exp.constant(Const_string(txt, None)); 32 | let lid = Location.mknoloc(Lident(txt)); 33 | /* switch pcd_args { 34 | | Pcstr_tuple(types) => */ 35 | switch types { 36 | | [] => Exp.case(Pat.construct(lid, None), [%expr `String([%e strConst])]) 37 | | _ => 38 | let items = List.mapi((i, typ) => Utils.patVar("arg" ++ string_of_int(i)), types); 39 | let args = 40 | switch items { 41 | | [] => None 42 | | [single] => Some(single) 43 | | _ => Some(Pat.tuple(items)) 44 | }; 45 | let pat = Pat.construct(lid, args); 46 | let values = 47 | List.mapi( 48 | (i, typ) => { 49 | let larg = Utils.expIdent("arg" ++ string_of_int(i)); 50 | [%expr [%e core_type_converter(typ)]([%e larg])]; 51 | }, 52 | types 53 | ); 54 | let values = [[%expr `String([%e strConst])], ...values]; 55 | Exp.case(pat, [%expr `List([%e Utils.list(values)])]); 56 | } /* This isn't supported in 4.02 anyway */ 57 | /* | Pcstr_record(labels) => Utils.fail(loc, "Nope record labels") */ 58 | /* }; */ 59 | }, 60 | constructors 61 | ); 62 | Exp.fun_("", None, Utils.patVar("value"), Exp.match([%expr value], cases)); 63 | }, 64 | record: (core_type_converter, labels, name) => { 65 | open Parsetree; 66 | open Longident; 67 | open Ast_helper; 68 | let sets = 69 | List.map( 70 | ({pld_name: {txt}, pld_type}) => { 71 | let value = Exp.field([%expr value], Location.mknoloc(Lident(txt))); 72 | let strConst = Exp.constant(Const_string(txt, None)); 73 | [%expr ([%e strConst], [%e core_type_converter(pld_type)]([%e value]))]; 74 | }, 75 | labels 76 | ); 77 | Exp.fun_( 78 | "", 79 | None, 80 | Pat.var(Location.mknoloc("value")), 81 | [%expr `Assoc([%e Utils.list(sets)])] 82 | ); 83 | } 84 | }; 85 | 86 | let parse = { 87 | decorator: "to.yojson", 88 | prefix: [%str 89 | let int__from_yojson = (x) => 90 | switch x { 91 | | `Int(n) => Some(n) 92 | | _ => None 93 | }; 94 | let float__from_yojson = (x) => 95 | switch x { 96 | | `Float(n) => Some(n) 97 | | _ => None 98 | }; 99 | let list__from_yojson = (convert, items) => 100 | switch items { 101 | | `List(arr) => 102 | try { 103 | let items = 104 | List.map( 105 | (item) => 106 | switch (convert(item)) { 107 | | Some((x)) => x 108 | | None => failwith("Item failed to parse") 109 | }, 110 | arr 111 | ); 112 | Some(items); 113 | } { 114 | | _ => None 115 | } 116 | | _ => None 117 | }; 118 | let string__from_yojson = (value) => 119 | switch value { 120 | | `String(str) => Some(str) 121 | | _ => None 122 | }; 123 | let array__from_yojson = (convert, items) => 124 | switch items { 125 | | `List(arr) => 126 | try { 127 | let items = 128 | List.map( 129 | (item) => 130 | switch (convert(item)) { 131 | | Some((x)) => x 132 | | None => failwith("Item failed to parse") 133 | }, 134 | arr 135 | ); 136 | Some(Array.of_list(items)); 137 | } { 138 | | _ => None 139 | } 140 | | _ => None 141 | }; 142 | let boolean__from_yojson = (value) => 143 | switch value { 144 | | `Bool(v) => Some(v) 145 | | _ => None 146 | }; 147 | let option__from_yojson = (convert, value) => 148 | switch value { 149 | | `Null => Some(None) 150 | | `List([value]) => 151 | switch (convert(value)) { 152 | | None => None 153 | | Some((x)) => Some(Some(x)) 154 | } 155 | | _ => None 156 | } 157 | ], 158 | suffix: "__from_yojson", 159 | typ: From([%type : Yojson.Safe.json]), 160 | variant: (core_type_converter, constructors, name) => { 161 | open Parsetree; 162 | open Ast_helper; 163 | open Longident; 164 | let cases = 165 | List.map( 166 | ({pcd_name: {txt, loc}, pcd_args: types}) => { 167 | let strConst = Exp.constant(Const_string(txt, None)); 168 | let patConst = [%pat ? `String([%p Pat.constant(Const_string(txt, None))])]; 169 | let lid = Location.mknoloc(Lident(txt)); 170 | /* switch pcd_args { 171 | | Pcstr_tuple(types) => */ 172 | switch types { 173 | | [] => Exp.case(patConst, [%expr Some([%e Exp.construct(lid, None)])]) 174 | | _ => 175 | let items = List.mapi((i, typ) => Utils.patVar("arg" ++ string_of_int(i)), types); 176 | let pattern = [%pat ? `List([%p Utils.patList([patConst, ...items])])]; 177 | let args = 178 | switch types { 179 | | [] => None 180 | | [_] => Some(Utils.expIdent("arg0")) 181 | | _ => 182 | Some( 183 | Exp.tuple( 184 | List.mapi((i, typ) => Utils.expIdent("arg" ++ string_of_int(i)), types) 185 | ) 186 | ) 187 | }; 188 | let expr = Exp.construct(lid, args); 189 | let (body, _) = 190 | List.fold_right( 191 | (typ, (body, i)) => ( 192 | [%expr 193 | switch ( 194 | [%e core_type_converter(typ)]( 195 | [%e Utils.expIdent("arg" ++ string_of_int(i))] 196 | ) 197 | ) { 198 | | None => None 199 | | Some(([%p Utils.patVar("arg" ++ string_of_int(i))])) => [%e body] 200 | } 201 | ], 202 | i - 1 203 | ), 204 | types, 205 | ([%expr Some([%e expr])], List.length(types) - 1) 206 | ); 207 | Exp.case(pattern, body); 208 | } /* This isn't supported in 4.02 anyway */ 209 | /* | Pcstr_record(labels) => Utils.fail(loc, "Nope record labels") 210 | }; */ 211 | }, 212 | constructors 213 | ); 214 | let cases = List.append(cases, [Exp.case(Pat.any(), [%expr None])]); 215 | Exp.fun_("", None, Utils.patVar("value"), Exp.match([%expr value], cases)); 216 | }, 217 | record: (core_type_converter, labels, name) => { 218 | open Parsetree; 219 | open Longident; 220 | open Ast_helper; 221 | let body = 222 | Exp.record( 223 | List.map( 224 | ({pld_name: {txt}}) => ( 225 | Location.mknoloc(Lident(txt)), 226 | Exp.ident(Location.mknoloc(Lident(txt ++ "_extracted"))) 227 | ), 228 | labels 229 | ), 230 | None 231 | ); 232 | let body = 233 | List.fold_right( 234 | ({pld_name: {txt}, pld_type}, body) => { 235 | let strConst = Exp.constant(Const_string(txt, None)); 236 | let strPat = Pat.var(Location.mknoloc(txt ++ "_extracted")); 237 | [%expr 238 | switch (get(items, [%e strConst])) { 239 | | None => None 240 | | Some((attr)) => 241 | switch ([%e core_type_converter(pld_type)](attr)) { 242 | | None => None 243 | | Some(([%p strPat])) => [%e body] 244 | } 245 | } 246 | ]; 247 | }, 248 | labels, 249 | [%expr Some([%e body])] 250 | ); 251 | let body = [%expr 252 | { 253 | let rec get = (items, name) => 254 | switch items { 255 | | [] => None 256 | | [(attr, value), ..._] when attr == name => Some(value) 257 | | [_, ...rest] => get(rest, name) 258 | }; 259 | switch value { 260 | | `Assoc(items) => [%e body] 261 | | _ => None 262 | }; 263 | } 264 | ]; 265 | Exp.fun_("", None, Pat.var(Location.mknoloc("value")), body); 266 | } 267 | }; 268 | -------------------------------------------------------------------------------- /src/ppx_magic.re: -------------------------------------------------------------------------------- 1 | /* open Migrate_parsetree.Ast_403; */ 2 | 3 | let () = Ast_mapper.run_main(args => Lib.mapper([Lib.Json.stringify, Lib.Json.parse, Lib.Devtools.config])); 4 | 5 | /* let () = 6 | Migrate_parsetree.Driver.register( 7 | ~name="ppx_magic", 8 | Migrate_parsetree.Versions.ocaml_403, 9 | my_rewriter 10 | ); 11 | 12 | let () = Migrate_parsetree.Driver.run_as_ppx_rewriter(); */ 13 | -------------------------------------------------------------------------------- /src/ppx_magic_native.re: -------------------------------------------------------------------------------- 1 | /* open Migrate_parsetree.Ast_403; */ 2 | 3 | let () = Ast_mapper.run_main(args => Lib.mapper([Lib.YoJson.stringify, Lib.YoJson.parse])); 4 | 5 | /* let () = 6 | Migrate_parsetree.Driver.register( 7 | ~name="ppx_magic", 8 | Migrate_parsetree.Versions.ocaml_403, 9 | my_rewriter 10 | ); 11 | 12 | let () = Migrate_parsetree.Driver.run_as_ppx_rewriter(); */ 13 | -------------------------------------------------------------------------------- /syntax_test/DevtoolsSerialize.re: -------------------------------------------------------------------------------- 1 | let fixtures = [ 2 | ( 3 | /* (input, output) */ 4 | [%str type x = int], 5 | [%str type x = int; let x__to_devtools = (value) => int__to_devtools(value)] 6 | ), 7 | ( 8 | [%str 9 | type x = 10 | | One 11 | | Two 12 | | Three 13 | ], 14 | [%str 15 | type x = 16 | | One 17 | | Two 18 | | Three; 19 | let x__to_devtools = (value) => 20 | switch value { 21 | | One => 22 | {"$bs": "variant", "type": "x", "constructor": "One", "arguments": [||]} |> to_devtools 23 | | Two => 24 | {"$bs": "variant", "type": "x", "constructor": "Two", "arguments": [||]} |> to_devtools 25 | | Three => 26 | {"$bs": "variant", "type": "x", "constructor": "Three", "arguments": [||]} |> to_devtools 27 | } 28 | ] 29 | ) 30 | ]; -------------------------------------------------------------------------------- /syntax_test/JsonParse.re: -------------------------------------------------------------------------------- 1 | let fixtures = [ 2 | ( 3 | /* (input, output) */ 4 | [%str type x = int], 5 | [%str type x = int; let x__from_json = (value) => int__from_json(value)] 6 | ), 7 | ( 8 | [%str 9 | type x = { 10 | a: int, 11 | c: string 12 | } 13 | ], 14 | [%str 15 | type x = { 16 | a: int, 17 | c: string 18 | }; 19 | let x__from_json = (value) => 20 | switch (Js.Json.classify(value)) { 21 | | Js.Json.JSONObject(value) => 22 | switch (Js.Dict.get(value, "a")) { 23 | | None => None 24 | | Some((attr)) => 25 | switch (int__from_json(attr)) { 26 | | None => None 27 | | Some((a_extracted)) => 28 | switch (Js.Dict.get(value, "c")) { 29 | | None => None 30 | | Some((attr)) => 31 | switch (string__from_json(attr)) { 32 | | None => None 33 | | Some((c_extracted)) => Some({a: a_extracted, c: c_extracted}) 34 | } 35 | } 36 | } 37 | } 38 | | _ => None 39 | } 40 | ] 41 | ), 42 | ( 43 | [%str module type T = {type t;}], 44 | [%str module type T = {type t; let t__from_json: Js.Json.t => option(t);}] 45 | ) 46 | ]; 47 | -------------------------------------------------------------------------------- /syntax_test/JsonStringify.re: -------------------------------------------------------------------------------- 1 | let fixtures = [ 2 | ( 3 | /* (input, output) */ 4 | [%str type x = int], 5 | [%str type x = int; let x__to_json = (value) => int__to_json(value)] 6 | ), 7 | ([%str [@noserialize] 8 | type x = int], [%str [@noserialize] 9 | type x = int]), 10 | ( 11 | [%str type x = awesome], 12 | [%str type x = awesome; let x__to_json = (value) => awesome__to_json(value)] 13 | ), 14 | ( 15 | [%str type x = list(int)], 16 | [%str type x = list(int); let x__to_json = (value) => (list__to_json(int__to_json))(value)] 17 | ), 18 | ( 19 | [%str 20 | type x = { 21 | a: int, 22 | c: string 23 | } 24 | ], 25 | [%str 26 | type x = { 27 | a: int, 28 | c: string 29 | }; 30 | let x__to_json = (value) => { 31 | let result = Js.Dict.empty(); 32 | Js.Dict.set(result, "a", int__to_json(value.a)); 33 | Js.Dict.set(result, "c", string__to_json(value.c)); 34 | Js.Json.object_(result); 35 | } 36 | ] 37 | ), 38 | ( 39 | [%str 40 | type x = 41 | | One 42 | | Two 43 | | Three 44 | ], 45 | [%str 46 | type x = 47 | | One 48 | | Two 49 | | Three; 50 | let x__to_json = (value) => 51 | switch value { 52 | | One => Js.Json.string("One") 53 | | Two => Js.Json.string("Two") 54 | | Three => Js.Json.string("Three") 55 | } 56 | ] 57 | ), 58 | ( 59 | [%str type x('a) = list('a)], 60 | [%str 61 | type x('a) = list('a); 62 | let x__to_json = (a_converter, value) => (list__to_json(a_converter))(value) 63 | ] 64 | ), 65 | ( 66 | [%str 67 | type x('a) = { 68 | a: 'a, 69 | c: string 70 | } 71 | ], 72 | [%str 73 | type x('a) = { 74 | a: 'a, 75 | c: string 76 | }; 77 | let x__to_json = (a_converter, value) => { 78 | let result = Js.Dict.empty(); 79 | Js.Dict.set(result, "a", a_converter(value.a)); 80 | Js.Dict.set(result, "c", string__to_json(value.c)); 81 | Js.Json.object_(result); 82 | } 83 | ] /*** TODO records, variants. maybe that's it? */ 84 | ) 85 | ]; 86 | -------------------------------------------------------------------------------- /syntax_test/Syntax_test.re: -------------------------------------------------------------------------------- 1 | /* open Migrate_parsetree.Ast_403; */ 2 | 3 | /* module Convert = 4 | Migrate_parsetree.Convert(Migrate_parsetree.OCaml_403, Migrate_parsetree.OCaml_current); */ 5 | 6 | let show_structure = (structure) => { 7 | Pprintast.structure(Format.str_formatter, 8 | /* Convert.copy_structure */ 9 | (structure)); 10 | Format.flush_str_formatter(); 11 | }; 12 | 13 | let fixtures = [ 14 | (JsonStringify.fixtures, Lib.Json.stringify), 15 | (DevtoolsSerialize.fixtures, Lib.Devtools.config), 16 | (JsonParse.fixtures, Lib.Json.parse), 17 | (YojsonStringify.fixtures, Lib.YoJson.stringify) 18 | ]; 19 | 20 | let show_error = (input, result, expected) => { 21 | print_endline(">> Input:"); 22 | print_endline(show_structure(input)); 23 | print_endline(">> Output:"); 24 | print_endline(show_structure(result)); 25 | print_endline(">> Expected:"); 26 | print_endline(show_structure(expected)); 27 | }; 28 | 29 | let run = () => { 30 | let (total, failures) = 31 | List.fold_left( 32 | ((total, failures), (fixtures, config)) => { 33 | let mapper = Lib.mapper(~autoAll=true, [{...config, prefix: []}]); 34 | List.fold_left( 35 | ((total, failures), (input, expected)) => 36 | try { 37 | let result = mapper.structure(mapper, input); 38 | if (result != expected) { 39 | show_error(input, result, expected); 40 | (total + 1, failures + 1); 41 | } else { 42 | (total + 1, failures); 43 | }; 44 | } { 45 | | Location.Error(error) => 46 | print_endline(">> Input:"); 47 | print_endline(show_structure(input)); 48 | print_endline(">> Error:"); 49 | print_endline(error.Location.msg); 50 | (total + 1, failures + 1); 51 | }, 52 | (total, failures), 53 | fixtures 54 | ); 55 | }, 56 | (0, 0), 57 | fixtures 58 | ); 59 | if (failures !== 0) { 60 | Printf.printf("Total: %d, Failures: %d", total, failures); 61 | exit(1); 62 | } else { 63 | Printf.printf("All %d succeeded!", total); 64 | exit(0); 65 | }; 66 | }; 67 | 68 | run(); 69 | -------------------------------------------------------------------------------- /syntax_test/YojsonStringify.re: -------------------------------------------------------------------------------- 1 | 2 | let fixtures = [ 3 | /* ( 4 | [%str type x = One string | Two int float | Three], 5 | [%str type x = One string | Two int float | Three; 6 | let x__to_yojson value => switch value { 7 | | One (arg0) => `List [`String "One", string__to_yojson arg0] 8 | | Two arg0 arg1 => `List [`String "Two", int__to_yojson arg0, float__to_yojson arg1] 9 | | Three => `String "Three" 10 | } 11 | ], 12 | ) */ 13 | ]; 14 | --------------------------------------------------------------------------------