286 lines
8.5 KiB
OCaml
286 lines
8.5 KiB
OCaml
open Import
|
|
open Jbuild
|
|
open Build.O
|
|
open! No_io
|
|
|
|
module SC = Super_context
|
|
|
|
module Backend = struct
|
|
module M = struct
|
|
module Info = struct
|
|
let name = Sub_system_name.make "inline_tests.backend"
|
|
|
|
type t =
|
|
{ loc : Loc.t
|
|
; runner_libraries : (Loc.t * string) list
|
|
; flags : Ordered_set_lang.Unexpanded.t
|
|
; generate_runner : (Loc.t * Action.Unexpanded.t) option
|
|
; extends : (Loc.t * string) list
|
|
}
|
|
|
|
type Jbuild.Sub_system_info.t += T of t
|
|
|
|
let loc t = t.loc
|
|
|
|
(* The syntax of the driver sub-system is part of the main dune
|
|
syntax, so we simply don't create a new one.
|
|
|
|
If we wanted to make the ppx system an extension, then we
|
|
would create a new one.
|
|
*)
|
|
let syntax = Stanza.syntax
|
|
|
|
open Stanza.Of_sexp
|
|
|
|
let parse =
|
|
record
|
|
(loc >>= fun loc ->
|
|
field "runner_libraries" (list (located string)) ~default:[]
|
|
>>= fun runner_libraries ->
|
|
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
|
|
field_o "generate_runner" (located Action.Unexpanded.t)
|
|
>>= fun generate_runner ->
|
|
field "extends" (list (located string)) ~default:[]
|
|
>>= fun extends ->
|
|
return
|
|
{ loc
|
|
; runner_libraries
|
|
; flags
|
|
; generate_runner
|
|
; extends
|
|
})
|
|
end
|
|
|
|
type t =
|
|
{ info : Info.t
|
|
; lib : Lib.t
|
|
; runner_libraries : Lib.t list Or_exn.t
|
|
; extends : t list Or_exn.t
|
|
}
|
|
|
|
let desc ~plural = "inline tests backend" ^ if plural then "s" else ""
|
|
let desc_article = "an"
|
|
|
|
let lib t = t.lib
|
|
let extends t = t.extends
|
|
|
|
let instantiate ~resolve ~get lib (info : Info.t) =
|
|
{ info
|
|
; lib
|
|
; runner_libraries =
|
|
Result.all (List.map info.runner_libraries ~f:resolve)
|
|
; extends =
|
|
let open Result.O in
|
|
Result.all
|
|
(List.map info.extends
|
|
~f:(fun ((loc, name) as x) ->
|
|
resolve x >>= fun lib ->
|
|
match get ~loc lib with
|
|
| None ->
|
|
Error (Loc.exnf loc "%S is not an %s" name
|
|
(desc ~plural:false))
|
|
| Some t -> Ok t))
|
|
}
|
|
|
|
let to_sexp t =
|
|
let open Sexp.To_sexp in
|
|
let lib x = string (Lib.name x) in
|
|
let f x = string (Lib.name x.lib) in
|
|
((1, 0),
|
|
record_fields
|
|
[ field "runner_libraries" (list lib)
|
|
(Result.ok_exn t.runner_libraries)
|
|
; field "flags" Ordered_set_lang.Unexpanded.sexp_of_t t.info.flags
|
|
; field_o "generate_runner" Action.Unexpanded.sexp_of_t
|
|
(Option.map t.info.generate_runner ~f:snd)
|
|
; field "extends" (list f) (Result.ok_exn t.extends) ~default:[]
|
|
])
|
|
end
|
|
include M
|
|
include Sub_system.Register_backend(M)
|
|
end
|
|
|
|
include Sub_system.Register_end_point(
|
|
struct
|
|
module Backend = Backend
|
|
|
|
module Info = struct
|
|
let name = Sub_system_name.make "inline_tests"
|
|
|
|
type t =
|
|
{ loc : Loc.t
|
|
; deps : Dep_conf.t list
|
|
; flags : Ordered_set_lang.Unexpanded.t
|
|
; backend : (Loc.t * string) option
|
|
; libraries : (Loc.t * string) list
|
|
}
|
|
|
|
type Jbuild.Sub_system_info.t += T of t
|
|
|
|
let empty loc =
|
|
{ loc
|
|
; deps = []
|
|
; flags = Ordered_set_lang.Unexpanded.standard
|
|
; backend = None
|
|
; libraries = []
|
|
}
|
|
|
|
let loc t = t.loc
|
|
let backends t = Option.map t.backend ~f:(fun x -> [x])
|
|
|
|
let syntax = Stanza.syntax
|
|
|
|
open Stanza.Of_sexp
|
|
|
|
let parse =
|
|
eos >>= function
|
|
| true -> loc >>| empty
|
|
| false ->
|
|
record
|
|
(loc >>= fun loc ->
|
|
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
|
|
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
|
|
field_o "backend" (located string) >>= fun backend ->
|
|
field "libraries" (list (located string)) ~default:[]
|
|
>>= fun libraries ->
|
|
return
|
|
{ loc
|
|
; deps
|
|
; flags
|
|
; backend
|
|
; libraries
|
|
})
|
|
end
|
|
|
|
let gen_rules c ~(info:Info.t) ~backends =
|
|
let { Sub_system.Library_compilation_context.
|
|
super_context = sctx
|
|
; dir
|
|
; stanza = lib
|
|
; scope
|
|
; source_modules
|
|
; _
|
|
} = c
|
|
in
|
|
|
|
let inline_test_dir =
|
|
Path.relative dir (sprintf ".%s.inline-tests" lib.name)
|
|
in
|
|
|
|
let name = "run" in
|
|
let main_module_filename = name ^ ".ml" in
|
|
let main_module_name = Module.Name.of_string name in
|
|
let modules =
|
|
Module.Name.Map.singleton main_module_name
|
|
(Module.make main_module_name
|
|
~impl:{ name = main_module_filename
|
|
; syntax = OCaml
|
|
}
|
|
~obj_name:name)
|
|
in
|
|
|
|
let extra_vars =
|
|
String.Map.singleton "library-name" ([Value.String lib.name])
|
|
in
|
|
|
|
let runner_libs =
|
|
let open Result.O in
|
|
Result.concat_map backends
|
|
~f:(fun (backend : Backend.t) -> backend.runner_libraries)
|
|
>>= fun libs ->
|
|
Lib.DB.find_many (Scope.libs scope) [lib.name]
|
|
>>= fun lib ->
|
|
Result.all
|
|
(List.map info.libraries
|
|
~f:(Lib.DB.resolve (Scope.libs scope)))
|
|
>>= fun more_libs ->
|
|
Lib.closure (lib @ libs @ more_libs)
|
|
in
|
|
|
|
(* Generate the runner file *)
|
|
SC.add_rule sctx (
|
|
let target = Path.relative inline_test_dir main_module_filename in
|
|
let source_modules = Module.Name.Map.values source_modules in
|
|
let files ml_kind =
|
|
Value.L.paths (
|
|
List.filter_map source_modules ~f:(fun m ->
|
|
Module.file m ~dir ml_kind))
|
|
in
|
|
let extra_vars =
|
|
List.fold_left
|
|
[ "impl-files", files Impl
|
|
; "intf-files", files Intf
|
|
]
|
|
~init:extra_vars
|
|
~f:(fun acc (k, v) -> String.Map.add acc k v)
|
|
in
|
|
Build.return []
|
|
>>>
|
|
Build.all
|
|
(List.filter_map backends ~f:(fun (backend : Backend.t) ->
|
|
Option.map backend.info.generate_runner ~f:(fun (loc, action) ->
|
|
SC.Action.run sctx action ~loc
|
|
~extra_vars ~dir ~dep_kind:Required ~targets:Alias ~scope)))
|
|
>>^ (fun actions ->
|
|
Action.with_stdout_to target
|
|
(Action.progn actions))
|
|
>>>
|
|
Build.action_dyn ~targets:[target] ());
|
|
|
|
let cctx =
|
|
Compilation_context.create ()
|
|
~super_context:sctx
|
|
~scope
|
|
~dir:inline_test_dir
|
|
~modules
|
|
~requires:runner_libs
|
|
~flags:(Ocaml_flags.of_list ["-w"; "-24"]);
|
|
in
|
|
Exe.build_and_link cctx
|
|
~program:{ name; main_module_name }
|
|
~linkages:[Exe.Linkage.native_or_custom (SC.context sctx)]
|
|
~link_flags:(Build.return ["-linkall"]);
|
|
|
|
let flags =
|
|
let flags =
|
|
List.map backends ~f:(fun backend ->
|
|
backend.Backend.info.flags) @ [info.flags]
|
|
in
|
|
Build.all (
|
|
List.map flags ~f:(fun flags ->
|
|
Super_context.expand_and_eval_set sctx flags
|
|
~scope
|
|
~dir
|
|
~extra_vars
|
|
~standard:(Build.return [])))
|
|
>>^ List.concat
|
|
in
|
|
|
|
SC.add_alias_action sctx
|
|
(Build_system.Alias.runtest ~dir)
|
|
~stamp:(List [ Sexp.unsafe_atom_of_string "ppx-runner"
|
|
; Quoted_string name
|
|
])
|
|
(let module A = Action in
|
|
let exe = Path.relative inline_test_dir (name ^ ".exe") in
|
|
Build.path exe >>>
|
|
Build.fanout
|
|
(Super_context.Deps.interpret sctx info.deps ~dir ~scope)
|
|
flags
|
|
>>^ fun (_deps, flags) ->
|
|
A.chdir dir
|
|
(A.progn
|
|
(A.run (Ok exe) flags ::
|
|
(Module.Name.Map.values source_modules
|
|
|> List.concat_map ~f:(fun m ->
|
|
[ Module.file m ~dir Impl
|
|
; Module.file m ~dir Intf
|
|
])
|
|
|> List.filter_map ~f:(fun x -> x)
|
|
|> List.map ~f:(fun fn ->
|
|
A.diff ~optional:true
|
|
fn (Path.extend_basename fn ~suffix:".corrected"))))))
|
|
end)
|
|
|
|
let linkme = ()
|