Reshuffle files for libraries and executables into different folders

Author: mhallin

Makefile

@@ -4,15 +4,15 @@ OS:=$(shell uname -s)
 TARGET_BUCKLESCRIPT:=$(findstring $(shell opam switch show),4.02.3)
 
 build:
-	$(DUNE) build src/graphql_ppx_bucklescript.exe
-	# if [ "$(TARGET_BUCKLESCRIPT)" = "" ]; then  $(DUNE) build src/graphql_ppx_native.a; fi  ## FIXME: Native library does not build
-	cp _build/default/src/graphql_ppx_bucklescript.exe graphql_ppx.exe
+	$(DUNE) build src/bucklescript/graphql_ppx.exe
+	if [ "$(TARGET_BUCKLESCRIPT)" = "" ]; then  $(DUNE) build src/native/graphql_ppx.a; fi
+	cp _build/default/src/bucklescript/graphql_ppx.exe .
 
 buildall:
-	# $(DUNE) build --workspace=dune-workspace.dev-native src/graphql_ppx_native.a ## FIXME: Native library does not build
-	$(DUNE) build --workspace=dune-workspace.dev-bs src/graphql_ppx_bucklescript.exe
-	([ -x _build/4.02.3/src/graphql_ppx_bucklescript.exe ] \
-		&& cp _build/4.02.3/src/graphql_ppx_bucklescript.exe graphql_ppx.exe)
+	$(DUNE) build --workspace=dune-workspace.dev-native src/native/graphql_ppx.a
+	$(DUNE) build --workspace=dune-workspace.dev-bs src/bucklescript/graphql_ppx.exe
+	([ -x _build/4.02.3/src/bucklescript/graphql_ppx.exe ] \
+		&& cp _build/4.02.3/src/bucklescript/graphql_ppx.exe .)
 
 test: build only-test
 

dune

@@ -1,4 +1,4 @@
 (alias
  (name graphql_ppx)
- (deps src/graphql_ppx_bucklescript.exe
-       src/graphql_ppx_native.a))
+ (deps src/bucklescript/graphql_ppx.exe
+       src/native/graphql_ppx.a))

src/ast_serializer_apollo.ml src/base/ast_serializer_apollo.ml

@@ -0,0 +1,14 @@
+(library
+ (name graphql_ppx_base)
+ (public_name graphql_ppx_base)
+ (libraries unix
+            result
+            yojson)
+ (preprocess (pps ppx_tools_versioned.metaquot_402)))
+
+(rule
+ (targets build_config.ml)
+ (deps    (:first-dep build_config.cppo.ml))
+  (action
+   (chdir ${ROOT}
+    (run %{bin:cppo} -V OCAML:%{ocaml_version} %{first-dep} -o %{targets}))))

src/build_config.cppo.ml src/base/build_config.cppo.ml

@@ -0,0 +1,6 @@
+(executable
+ (name graphql_ppx)
+ (libraries ocaml-migrate-parsetree
+            graphql_ppx_base)
+ (flags (:include ../../discover/dune.flags))
+ (preprocess (pps ppx_tools_versioned.metaquot_402)))

src/compat.ml src/base/compat.ml

@@ -1,65 +0,0 @@
-(executable
- (name graphql_ppx_bucklescript)
- (libraries ocaml-migrate-parsetree
-            graphql_ppx_base)
- (modules graphql_ppx_bucklescript
-          output_bucklescript_decoder
-          output_bucklescript_encoder
-          output_bucklescript_module
-          output_bucklescript_unifier
-          output_bucklescript_utils)
- (flags (:include ../discover/dune.flags))
- (preprocess (pps ppx_tools_versioned.metaquot_402)))
-
-(library
- (name graphql_ppx_native)
- (public_name graphql_ppx)
- (modules graphql_ppx_native)
- (wrapped false)
- (kind ppx_rewriter)
- (libraries ocaml-migrate-parsetree
-            graphql_ppx_base
-            ppxlib)
- (preprocess (pps ppx_tools_versioned.metaquot_402)))
-
-(library
- (name graphql_ppx_base)
- (public_name graphql_ppx_base)
- (modules ast_serializer_apollo
-          build_config
-          compat
-          dirty_checker
-          generator_utils
-          graphql_ast
-          graphql_lexer
-          graphql_parser_document
-          graphql_parser_value
-          graphql_parser
-          graphql_ppx_base
-          graphql_printer
-          log
-          multi_visitor
-          option
-          ppx_config
-          read_schema
-          result_decoder
-          result_ext
-          result_structure
-          rule_known_argument_names
-          rule_no_unused_variables
-          schema
-          source_pos
-          traversal_utils
-          type_utils
-          validations)
- (libraries unix
-            result
-            yojson)
- (preprocess (pps ppx_tools_versioned.metaquot_402)))
-
-(rule
- (targets build_config.ml)
- (deps    (:first-dep build_config.cppo.ml))
-  (action
-   (chdir ${ROOT}
-    (run %{bin:cppo} -V OCAML:%{ocaml_version} %{first-dep} -o %{targets}))))

src/dirty_checker.ml src/base/dirty_checker.ml

@@ -0,0 +1,8 @@
+(library
+ (name graphql_ppx)
+ (public_name graphql_ppx)
+ (wrapped false)
+ (kind ppx_rewriter)
+ (libraries graphql_ppx_base
+            ppxlib)
+ (preprocess (pps ppxlib.metaquot)))

src/base/dune

@@ -0,0 +1,135 @@
+open Graphql_ppx_base
+open Ppxlib
+
+open Source_pos
+
+open Output_native_utils
+
+let argv = Sys.argv |> Array.to_list
+
+let add_pos delimLength base pos =
+  {
+    pos_fname = base.pos_fname;
+    pos_lnum = base.pos_lnum + pos.line;
+    pos_bol = 0;
+    pos_cnum = if pos.line = 0 then delimLength + pos.col else pos.col;
+  }
+
+let add_loc delimLength base span =
+  {
+    loc_start = add_pos delimLength base.loc_start (fst span);
+    loc_end = add_pos delimLength base.loc_start (snd span);
+    loc_ghost = false;
+  }
+
+let fmt_lex_err err =
+  let open Graphql_lexer in
+  match err with
+  | Unknown_character ch -> Printf.sprintf "Unknown character %c" ch
+  | Unexpected_character ch -> Printf.sprintf "Unexpected character %c" ch
+  | Unterminated_string -> Printf.sprintf "Unterminated string literal"
+  | Unknown_character_in_string ch -> Printf.sprintf "Unknown character in string literal: %c" ch
+  | Unknown_escape_sequence s -> Printf.sprintf "Unknown escape sequence in string literal: %s" s
+  | Unexpected_end_of_file -> Printf.sprintf "Unexpected end of query"
+  | Invalid_number -> Printf.sprintf "Invalid number"
+
+let fmt_parse_err err =
+  let open Graphql_parser in
+  match err with
+  | Unexpected_token t -> Printf.sprintf "Unexpected token %s" (Graphql_lexer.string_of_token t)
+  | Unexpected_end_of_file -> "Unexpected end of query"
+  | Lexer_error err -> fmt_lex_err err
+
+let is_prefixed prefix str =
+  let i = 0 in
+  let len = String.length prefix in
+  let j = ref 0 in
+  while !j < len && String.unsafe_get prefix !j =
+                    String.unsafe_get str (i + !j) do
+    incr j
+  done;
+  (!j = len)
+
+let make_error_expr loc message =
+  let ext = Location.Error.to_extension (Location.Error.createf ~loc "%s" message) in
+  Ast_helper.Exp.extension ~loc ext
+
+let drop_prefix prefix str =
+  let len = String.length prefix in
+  let rest = (String.length str) - len in
+  String.sub str len rest
+
+let () = Ppx_config.(set_config {
+    verbose_logging = (match List.find ((=) "-verbose") argv with
+        | _ -> true
+        | exception Not_found -> false);
+    output_mode = (match List.find ((=) "-ast-out") argv with
+        | _ -> Ppx_config.Apollo_AST
+        | exception Not_found -> Ppx_config.String);
+    verbose_error_handling = (match List.find ((=) "-o") argv with
+        | _ -> false
+        | exception Not_found -> begin match Sys.getenv "NODE_ENV" with
+            | "production" -> false
+            | _ -> true
+            | exception Not_found -> true
+          end);
+    root_directory = Sys.getcwd ();
+    schema_file = (match List.find (is_prefixed "-schema=") argv with
+        | arg -> drop_prefix "-schema=" arg
+        | exception Not_found -> "graphql_schema.json");
+    raise_error_with_loc = fun loc message ->
+      let loc = conv_loc loc in
+      raise (Location.Error (Location.Error.createf ~loc "%s" message))
+  })
+
+let rewrite_query loc delim query =
+  let lexer = Graphql_lexer.make query in
+  let delimLength = match delim with | Some s -> 2 + String.length s | None -> 1 in
+  match Graphql_lexer.consume lexer with
+  | Result.Error e -> raise (Location.Error (
+      Location.Error.createf ~loc:(add_loc delimLength loc e.span |> conv_loc) "%s" (fmt_lex_err e.item)
+    ))
+  | Result.Ok tokens -> 
+    let parser = Graphql_parser.make tokens in
+    match Graphql_parser_document.parse_document parser with
+    | Result.Error e -> raise (Location.Error (
+        Location.Error.createf ~loc:(add_loc delimLength loc e.span |> conv_loc) "%s" (fmt_parse_err e.item)
+      ))
+    | Result.Ok document ->
+      let config = {
+        Generator_utils.map_loc = add_loc delimLength loc;
+        delimiter = delim;
+        full_document = document;
+        (*  the only call site of schema, make it lazy! *)
+        schema = Lazy.force (Read_schema.get_schema ());
+      } in
+      match Validations.run_validators config document with
+      | Some errs ->
+        Ast_helper.Mod.mk
+          (Pmod_structure (List.map (fun (loc, msg) ->
+               let loc = conv_loc loc in
+               [%stri let _ = [%e make_error_expr loc msg]]) errs))
+      | None ->
+        let parts = Result_decoder.unify_document_schema config document in
+        Output_native_module.generate_modules config parts
+
+
+let rewrite ~loc ~path:_ expr =
+  let open Parsetree in
+  match expr with
+  | { pexp_desc = Pexp_constant (Pconst_string (query, delim)); _ } ->
+    rewrite_query
+      (conv_loc_from_ast loc)
+      delim
+      query
+  | _ -> raise (Location.Error (
+      Location.Error.createf ~loc:loc "[%%graphql] accepts a string, e.g. [%%graphql {| { query |}]"
+    ))
+
+let ext = Extension.declare
+    "graphql"
+    Extension.Context.module_expr
+    Ast_pattern.(single_expr_payload __)
+    rewrite
+
+let () = Ppxlib.Driver.register_transformation "graphql" 

src/generator_utils.ml src/base/generator_utils.ml

@@ -0,0 +1,6 @@
+open Ppxlib
+
+open Ast_helper
+
+let generate_modules _ _ =
+  Mod.mk (Pmod_structure [])

src/graphql_ast.ml src/base/graphql_ast.ml

@@ -0,0 +1,32 @@
+open Graphql_ppx_base
+
+let conv_pos pos = 
+  {
+    Lexing.pos_fname = pos.Source_pos.pos_fname;
+    Lexing.pos_lnum = pos.Source_pos.pos_lnum;
+    Lexing.pos_bol = pos.Source_pos.pos_bol;
+    Lexing.pos_cnum = pos.Source_pos.pos_cnum;
+  }
+
+let conv_loc loc = 
+  {
+    Location.loc_start = conv_pos loc.Source_pos.loc_start;
+    Location.loc_end = conv_pos loc.Source_pos.loc_end;
+    Location.loc_ghost = loc.Source_pos.loc_ghost;
+  }
+
+let conv_pos_from_ast pos =
+  {
+    Source_pos.pos_fname = pos.Lexing.pos_fname;
+    Source_pos.pos_lnum = pos.Lexing.pos_lnum;
+    Source_pos.pos_bol = pos.Lexing.pos_bol;
+    Source_pos.pos_cnum = pos.Lexing.pos_cnum;
+  }
+
+let conv_loc_from_ast loc = 
+  {
+    Source_pos.loc_start = conv_pos_from_ast loc.Location.loc_start;
+    Source_pos.loc_end = conv_pos_from_ast loc.Location.loc_end;
+    Source_pos.loc_ghost = loc.Location.loc_ghost;
+  }
+