Skip to content

Commit

Permalink
Add ppx_tester
Browse files Browse the repository at this point in the history
Signed-off-by: Kakadu <Kakadu@pm.me>
  • Loading branch information
Kakadu committed Sep 24, 2023
1 parent 155b750 commit a386619
Show file tree
Hide file tree
Showing 8 changed files with 160 additions and 2 deletions.
6 changes: 6 additions & 0 deletions ppx/dune
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,12 @@
(libraries ppx_distrib)
(modules pp_distrib))

(executable
(public_name pp_tester)
(package OCanren-ppx)
(libraries ppx_tester)
(modules pp_tester))

(executable
(public_name pp_deriving_reify)
(package OCanren-ppx)
Expand Down
12 changes: 12 additions & 0 deletions ppx/pp_tester.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,12 @@
(*
* OCanren PPX
* Copyright (C) 2016-2023
* Dmitrii Kosarev aka Kakadu
* St.Petersburg State University, JetBrains Research
*)

let () =
(* TODO: Invent something for margins
https://github.com/ocaml-ppx/ppxlib/issues/273*)
Ppxlib.Driver.standalone ()
;;
21 changes: 20 additions & 1 deletion ppx/reify/deriving_reify.ml
Original file line number Diff line number Diff line change
Expand Up @@ -17,7 +17,26 @@
* (enclosed in the file COPYING).
*)

(* module Pprintast_ = Pprintast *)
(*
# type 'a t = 'a OCanren.Std.List.injected [@@deriving reify];;
type 'a t = 'a OCanren.Std.List.injected
val reify :
('a, 'b) OCanren__.Logic.Reifier.t ->
('a OCanren.Std.List.injected, 'b OCanren.Std.List.logic)
OCanren__.Logic.Reifier.t = <fun>
val prj_exn :
('a, 'b) OCanren__.Logic.Reifier.t ->
('a OCanren.Std.List.injected, 'b OCanren.Std.List.ground)
OCanren__.Logic.Reifier.t = <fun>
# [%reify: GT.int OCanren.Std.List.injected];;
- : ('_weak2 OCanren.ilogic OCanren.Std.List.injected,
'_weak2 OCanren.logic OCanren.Std.List.logic)
OCanren__.Logic.Reifier.t
= <fun>
*)
open Ppxlib
open Stdppx

Expand Down
10 changes: 10 additions & 0 deletions ppx/tester/dune
Original file line number Diff line number Diff line change
@@ -0,0 +1,10 @@
(library
(name ppx_tester)
(public_name OCanren-ppx.ppx_tester)
(kind ppx_rewriter)
(libraries ppxlib)
(modules ppx_tester)
(flags
(:standard -linkall))
(preprocess
(pps ppxlib.metaquot)))
83 changes: 83 additions & 0 deletions ppx/tester/ppx_tester.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,83 @@
(*
* OCanren. PPX syntax extensions.
* Copyright (C) 2016-2023
* Dmitrii Kosarev aka Kakadu
* St.Petersburg State University, JetBrains Research
*)

(**
An extension that allows not to write errornous qh, qrh and stuff like that.
It looks at number of lambdas in the last argument, and insert numberals as penultimate argument.
Expands
{[ let __ _ = [%tester runR OCanren.reify show_int show_intl (fun q -> q === !!1)] ]}
to
{[
let __ _ =
runR OCanren.reify show_int show_intl q qh
("<string repr of goal>", (fun q -> q === (!! 1)))
]}
*)

open Ppxlib

let string_of_expression e =
Format.set_margin 1000;
Format.set_max_indent 0;
let ans = Format.asprintf "%a" Pprintast.expression e in
ans
;;

let name = "tester"

let () =
let extensions =
let pattern =
let open Ast_pattern in
pstr
(pstr_eval
(pexp_apply
__
((nolabel ** __) ^:: (nolabel ** __) ^:: (nolabel ** __) ^:: (nolabel ** __) ^:: nil))
nil
^:: nil)
in
[ Extension.declare
name
Extension.Context.Expression
pattern
(fun ~loc ~path:_ runner reifier shower n realtion ->
let open Ppxlib.Ast_builder.Default in
let count =
let rec helper acc e =
match e.pexp_desc with
| Pexp_fun (_, _, _, body) -> helper (1 + acc) body
| _ -> acc
in
helper 0 realtion
in
let middle =
match count with
| 0 -> failwith "Bad syntax"
| 1 -> [ [%expr OCanren.q]; [%expr qh] ]
| 2 -> [ [%expr OCanren.qr]; [%expr qrh] ]
| 3 -> [ [%expr OCanren.qrs]; [%expr qrsh] ]
| 4 -> [ [%expr OCanren.qrst]; [%expr qrsth] ]
| _ -> failwith (Printf.sprintf "5 and more arguments are not supported")
in
let last =
let s = string_of_expression @@ realtion in
let open Ppxlib.Ast_builder.Default in
[%expr [%e pexp_constant ~loc (Pconst_string (s, loc, None))], [%e realtion]]
in
pexp_apply ~loc runner
@@ List.map (fun e -> Nolabel, e)
@@ List.concat [ [ reifier; shower; n ]; middle; [ last ] ])
]
in
Ppxlib.Driver.register_transformation ~extensions name
;;
2 changes: 1 addition & 1 deletion regression_ppx/dune
Original file line number Diff line number Diff line change
Expand Up @@ -91,7 +91,7 @@
;
))
(preprocess
(pps OCanren-ppx.ppx_distrib GT.ppx_all -- -pretty))
(pps OCanren-ppx.ppx_tester OCanren-ppx.ppx_distrib GT.ppx_all -- -pretty))
(libraries OCanren OCanren.tester))

(executables
Expand Down
13 changes: 13 additions & 0 deletions regression_ppx/test009.ml
Original file line number Diff line number Diff line change
Expand Up @@ -21,3 +21,16 @@ end = struct

type nonrec ground = (GT.int, GT.bool) t]
end

let () =
let open OCanren in
let open Tester in
run_r
OCanren.reify
(GT.show OCanren.logic (GT.show GT.int))
1
q
Tester.qh
("<string repr of goal>", fun q -> q === inj 1);
[%tester run_r OCanren.reify (GT.show OCanren.logic (GT.show GT.int)) 1 (fun q -> q === inj 1)]
;;
15 changes: 15 additions & 0 deletions regression_ppx/test009.t
Original file line number Diff line number Diff line change
Expand Up @@ -54,6 +54,21 @@
let lBool _x__002_ = OCanren.inji (LBool _x__002_)
end
end

let () =
let open OCanren in
let open Tester in
run_r OCanren.reify
(GT.show OCanren.logic (GT.show GT.int))
1 q Tester.qh
("<string repr of goal>", fun q -> q === inj 1) ;
[%tester run_r OCanren.reify (GT.show OCanren.logic (GT.show GT.int)) 1 (fun q -> q === inj 1)]

$ ./test009.exe
test009
<string repr of goal>, 1 answer {
q=1;
}
fun q -> q === (inj 1), 1 answer {
q=1;
}

0 comments on commit a386619

Please sign in to comment.