├── Makefile ├── README.md ├── examples ├── example1.ml └── exampleOunit.ml └── src ├── mini_unit.ml ├── mini_unit.mli ├── ppx_no_test.ml └── ppx_test.ml /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY : ppx clean 2 | 3 | SRC = src 4 | BIN = bin 5 | EXA = examples 6 | PACK = -package compiler-libs.common -linkpkg 7 | OPT = ocamlopt 8 | CC = ocamlc -I $(SRC) 9 | FIND = ocamlfind 10 | OUNIT = -package oUnit -linkpkg -g 11 | CCUNIT = ocamlc $(PPX) -o $(BIN)/test $(OUNIT) 12 | 13 | ifeq ($(TEST), yes) 14 | PPX = -ppx $(BIN)/ppx_test.native 15 | else ifeq ($(TEST), no) 16 | PPX = -ppx $(BIN)/ppx_no_test.native 17 | endif 18 | 19 | ifeq ($(DSOURCE), yes) 20 | SOURCE = -dsource 21 | endif 22 | 23 | make_dir : 24 | mkdir -p $(BIN) 25 | 26 | ppx : ppx_no_test.native ppx_test.native 27 | 28 | mini_unit : 29 | $(CC) $(SRC)/mini_unit.mli 30 | $(CC) $(SRC)/mini_unit.ml 31 | 32 | %.native : $(SRC)/%.ml make_dir 33 | $(FIND) $(OPT) $(PACK) $(<) -o $(BIN)/$(@) 34 | 35 | # example compilation 36 | example% : $(EXA)/example%.ml ppx mini_unit make_dir 37 | $(CC) $(PPX) $(SOURCE) mini_unit.cmo $(<) -o $(BIN)/$(@) 38 | 39 | clean : 40 | rm -rf $(BIN)/* 41 | 42 | # OUnit example : 43 | OUnit_example : ppx 44 | $(FIND) $(CCUNIT) $(SOURCE) $(EXA)/exampleOunit.ml 45 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ppx_test 2 | This package implements refutable test context. Each test can be writted inline (into the OCaml file) and ignored or executed. 3 | 4 | [A french blog post about ppx_test](https://github.com/xvw/xvw.github.io__archives/blob/master/raw/articles/ppx_test.md) 5 | -------------------------------------------------------------------------------- /examples/example1.ml: -------------------------------------------------------------------------------- 1 | [@@@test_process open Mini_unit ] 2 | 3 | let succ x = x + 1 4 | let pred x = x - 1 5 | 6 | [@@@test_register "test_succ", 7 | let x = 9 in 8 | Assert.isEquals (succ x) 10 9 | ] 10 | 11 | [@@@test_register "test_pred", 12 | let x = 9 in 13 | Assert.isEquals (pred x) 8 14 | ] 15 | 16 | (* Test qui va échouer *) 17 | [@@@test_register "test_qui_echoue", 18 | let x = 9 in 19 | Assert.isNotEquals (succ x) 10 20 | ] 21 | 22 | (* un dernier tests pour la route *) 23 | [@@@test_register "un_dernier_test", 24 | Assert.isNotEquals 10 11 25 | ] 26 | 27 | (* Lancement des tests *) 28 | [@@@test_process 29 | let _ = execute_tests () in report () 30 | ] 31 | -------------------------------------------------------------------------------- /examples/exampleOunit.ml: -------------------------------------------------------------------------------- 1 | [@@@test_process open OUnit] 2 | 3 | (* To test *) 4 | let succ x = x + 1 5 | let pred x = x - 1 6 | 7 | (* Tests register*) 8 | [@@@test_register "testSucc", assert_equal 10 (succ 9)] 9 | [@@@test_register "testPred", assert_equal 8 (pred 9)] 10 | (* Test failure *) 11 | [@@@test_register "testFail", assert_equal 9 (succ 9)] 12 | 13 | (* Execute *) 14 | [@@@test_process 15 | let uTests = 16 | List.map (fun (l,t) -> l>::t ) (registered_tests ()) 17 | in 18 | run_test_tt 19 | ~verbose:true 20 | ("TestSuccAndPred">:::uTests) 21 | ] 22 | -------------------------------------------------------------------------------- /src/mini_unit.ml: -------------------------------------------------------------------------------- 1 | (* A little Assert module, only for ppx_test presentation *) 2 | (* Xavier van de Woestyne *) 3 | 4 | module Assert = 5 | struct 6 | 7 | let total = ref 0 8 | let successed = ref 0 9 | 10 | let execute ?(verbose=true) v = 11 | let _ = incr total in 12 | if v then begin 13 | let _ = incr successed in 14 | if verbose then print_string "success" 15 | end 16 | else 17 | if verbose then print_string "fail" 18 | 19 | let isTrue = execute 20 | let isFalse ?(verbose=true) x = execute ~verbose (not x) 21 | let isEquals ?(verbose=true) x y = isTrue ~verbose (x = y) 22 | let isNotEquals ?(verbose=true) x y = isFalse ~verbose (x = y) 23 | 24 | end 25 | 26 | let report () = 27 | Printf.printf 28 | "\n[Test status]: %d/%d successed\n" 29 | !Assert.successed 30 | !Assert.total 31 | 32 | -------------------------------------------------------------------------------- /src/mini_unit.mli: -------------------------------------------------------------------------------- 1 | module Assert : 2 | sig 3 | val isTrue : ?verbose:bool -> bool -> unit 4 | val isFalse : ?verbose:bool -> bool -> unit 5 | val isEquals : ?verbose:bool -> 'a -> 'a -> unit 6 | val isNotEquals : ?verbose:bool -> 'a -> 'a -> unit 7 | end 8 | val report : unit -> unit 9 | -------------------------------------------------------------------------------- /src/ppx_no_test.ml: -------------------------------------------------------------------------------- 1 | (* Clean all components with test annotation *) 2 | (* Xavier Van de Woestyne *) 3 | 4 | open Ast_mapper 5 | open Ast_helper 6 | open Asttypes 7 | open Parsetree 8 | open Longident 9 | 10 | (* clean all test annotation *) 11 | let clean_floating_test this s = 12 | let has_test x = 13 | match x.pstr_desc with 14 | | Pstr_attribute ({txt="test_register";_},_) 15 | | Pstr_attribute ({txt="test_process";_},_) -> false 16 | | _ -> true 17 | in default_mapper.structure this (List.filter has_test s) 18 | 19 | let mapper argv = 20 | let super = default_mapper in 21 | {super with structure = clean_floating_test} 22 | 23 | let _ = register "test" mapper 24 | -------------------------------------------------------------------------------- /src/ppx_test.ml: -------------------------------------------------------------------------------- 1 | (* Let's test sets launchable *) 2 | (* Xavier Van de Woestyne *) 3 | 4 | open Ast_mapper 5 | open Ast_helper 6 | open Asttypes 7 | open Parsetree 8 | open Longident 9 | 10 | (* Location creation *) 11 | let create_loc ?(loc = !default_loc) v = 12 | {txt = v; loc = loc} 13 | let loc = create_loc 14 | 15 | (* Id creation *) 16 | let create_ident ?(loc = !default_loc) v = 17 | create_loc ~loc (Lident v) 18 | let ident = create_ident 19 | 20 | (* Generalisation on Pattern var *) 21 | let pattern s = Pat.var (loc s) 22 | 23 | (* Error handling *) 24 | let fail ?(loc = !default_loc) message = 25 | let open Location in 26 | raise (Error (error ~loc message)) 27 | 28 | (* Create registered reference *) 29 | let ref_test_list = 30 | let empty = Exp.construct (ident "[]") None in 31 | let refc = Exp.record [ident "contents", empty] None in 32 | let vb = Vb.mk (pattern "ref_test_list") refc in 33 | Str.value Nonrecursive [vb] 34 | 35 | (* Create tests access *) 36 | let tests_access = 37 | let str_t = Typ.constr (ident "string") [] in 38 | let unit_t = Typ.constr (ident "unit") [] in 39 | let unit_f = Typ.arrow "" unit_t unit_t in 40 | let content = 41 | Exp.field 42 | (Exp.ident (ident "ref_test_list")) 43 | (ident "contents") 44 | in 45 | let revl = 46 | Exp.apply (Exp.ident (ident "rev")) ["", content] in 47 | let openl = Exp.open_ Fresh (ident "List") revl in 48 | let t_type = Typ.tuple [str_t; unit_f] in 49 | let func = 50 | Exp.fun_ "" None (pattern "()") openl in 51 | let list_t = Typ.constr (ident "list") [t_type] in 52 | let c_type = Typ.arrow "" unit_t list_t in 53 | let constr = Exp.constraint_ func c_type in 54 | let binding = Vb.mk (pattern "registered_tests") constr in 55 | Str.value Nonrecursive [binding] 56 | 57 | (* Create execution routine *) 58 | let test_execution = 59 | let apply_f = 60 | Exp.apply 61 | (Exp.ident (ident "f")) 62 | ["", Exp.ident (ident "()")] 63 | in 64 | let print = 65 | Exp.apply 66 | (Exp.ident (ident "printf")) 67 | ["", Exp.constant (Const_string ("[%s] ", None)); 68 | "", Exp.ident (ident "label") 69 | ] 70 | in 71 | let openp = Exp.open_ Fresh (ident "Printf") print in 72 | let ifthen = 73 | Exp.ifthenelse 74 | (Exp.ident (ident "verbose")) 75 | (openp) 76 | None 77 | in 78 | let nl = 79 | Exp.apply 80 | (Exp.ident (ident "print_endline")) 81 | ["", (Exp.constant (Const_string ("",None)))] 82 | in 83 | let iterator = 84 | Exp.fun_ 85 | "" 86 | None 87 | (Pat.tuple [pattern "label"; pattern "f"]) 88 | (Exp.sequence ifthen (Exp.sequence apply_f nl)) 89 | in 90 | let reg = 91 | Exp.apply 92 | (Exp.ident (ident "registered_tests")) 93 | ["", Exp.ident (ident "()")] 94 | in 95 | let map = 96 | Exp.apply 97 | (Exp.ident (ident "map")) 98 | ["", iterator; "", reg;] 99 | in 100 | let openl = Exp.open_ Fresh (ident "List") map in 101 | let func = Exp.fun_ "" None (pattern "()") openl in 102 | let subf = 103 | Exp.fun_ 104 | "?verbose" 105 | (Some (Exp.construct (ident "true") None)) 106 | (pattern "verbose") 107 | func 108 | in 109 | let binding = Vb.mk (pattern "execute_tests") subf 110 | in Str.value Nonrecursive [binding] 111 | 112 | (* Create registered lambda *) 113 | let create_lambda lbl expr = 114 | let contents = 115 | Exp.field 116 | (Exp.ident (ident "ref_test_list")) 117 | (ident "contents") 118 | in 119 | let cons f = 120 | Exp.construct 121 | (ident "::") 122 | (Some (Exp.tuple [f; contents])) 123 | in 124 | let lambda = Exp.fun_ "" None (pattern "()") expr in 125 | Exp.setfield 126 | (Exp.ident (ident "ref_test_list")) 127 | (ident "contents") 128 | (cons (Exp.tuple [lbl; lambda])) 129 | 130 | (* Tests substitution *) 131 | let struct_test s = 132 | match s.pstr_desc with 133 | | Pstr_attribute ({txt="test_process"; loc=loc}, pl) -> 134 | begin (* @@@test_process case *) 135 | match pl with 136 | | PStr [substr] -> Str.mk (substr.pstr_desc) 137 | | _ -> fail ~loc "[@@@test_process] Malformed expr" 138 | end 139 | | Pstr_attribute ({txt="test_register"; loc=loc}, pl) -> 140 | begin (*@@@test_register case *) 141 | match pl with 142 | | PStr [{pstr_desc = Pstr_eval (e, _);pstr_loc=l}] -> 143 | begin 144 | match e.pexp_desc with 145 | | Pexp_tuple [lbl; expr] -> 146 | begin (*Valid registration*) 147 | Str.mk (Pstr_eval (create_lambda lbl expr, [])) 148 | end 149 | | _ -> 150 | fail 151 | ~loc:l"[@@@test_register] Malformed tuple" 152 | end 153 | | _ -> fail ~loc "[@@@test_register] Malformed expr" 154 | end 155 | | _ -> s 156 | 157 | (* General procedure *) 158 | let map_ast this s = 159 | let sub = List.map struct_test s in 160 | (ref_test_list 161 | :: tests_access 162 | :: test_execution 163 | :: sub) 164 | 165 | (* Change structure value *) 166 | let test_mapper argv = 167 | let super = default_mapper in 168 | { super with structure = map_ast } 169 | 170 | (* Register AST *) 171 | let _ = register "test_mapper" test_mapper 172 | --------------------------------------------------------------------------------