Skip to content
Browse files

auto flatenning of direct TEST_MODULES

  • Loading branch information...
1 parent 5d38ebd commit f1213182b23dffadc622efeb405855155f092d6c @till-varoquaux committed Nov 29, 2011
Showing with 168 additions and 67 deletions.
  1. +168 −67 src/pa_ounit.ml
View
235 src/pa_ounit.ml
@@ -15,7 +15,19 @@
along with Pa_ounit. If not, see <http://www.gnu.org/licenses/>.
*)
-open Camlp4.PreCast
+(* open Camlp4.PreCast *)
+
+module Ast = Camlp4.PreCast.Ast
+module Loc = Camlp4.PreCast.Loc
+module AstFilters = Camlp4.PreCast.AstFilters
+module Syntax = Camlp4.PreCast.Syntax
+module Gram = Camlp4.PreCast.Gram
+
+type expr = Ast.expr
+type module_expr = Ast.module_expr
+type module_type = Ast.module_type
+type sig_item = Ast.sig_item
+type str_item = Ast.str_item
(**
This syntax extension does not work in the toplevel.
@@ -34,7 +46,6 @@ open Camlp4.PreCast
over the AST.
TODO: think about how to make the fold cheaper.
-
*)
(** This is an optimisation: this variable tells us whether the file we
@@ -45,10 +56,20 @@ let has_tests = ref false
let breadcrumb_id =
"__Pa_ounit_breadcrumb_internal"
-let breadcrumb exp =
+let breadcrumb_list_id =
+ "__Pa_ounit_breadcrumb_internal_list"
+
+(** Registers an expression as a test during the parsing *)
+let breadcrumb (exp: expr) : str_item =
let loc = Ast.loc_of_expr exp in
- Ast.StExp (loc,Ast.ExApp
- (loc,Ast.ExId(loc,Ast.IdLid (loc,breadcrumb_id)),exp))
+ Ast.(StExp (loc,ExApp
+ (loc,ExId(loc,IdLid (loc,breadcrumb_id)),exp)))
+
+(** Registers an expression as a list of tests during the parsing *)
+let breadcrumb_list (exp: expr) : str_item =
+ let loc = Ast.loc_of_expr exp in
+ Ast.(StExp (loc,ExApp
+ (loc,ExId(loc,IdLid (loc,breadcrumb_list_id)),exp)))
let label name e=
let loc = Ast.loc_of_expr e in
@@ -63,7 +84,7 @@ let chop_extension fn =
let module_name_of_file fn =
String.capitalize (chop_extension (Filename.basename fn))
-let rec add_in_sig to_add = function
+let rec add_in_sig (to_add:sig_item) : module_type -> module_type = function
| <:module_type@loc< sig $si$ end >> ->
<:module_type@loc< sig $si$; $to_add$ end >>
| Ast.MtNil loc ->
@@ -89,6 +110,29 @@ let gen_fresh_list_name loc =
incr list_cnt;
Printf.sprintf "__Pa_ounit_test_list_%i" (Hashtbl.hash (!list_cnt,loc))
+let transform_list ~f ~list expr =
+ let loc = Ast.loc_of_expr expr in
+ let list_id,list_expr = match list with
+ | None -> gen_fresh_list_name (),<:expr@loc< [] >>
+ | Some id -> id,<:expr@loc< $lid:id$ () >>
+ in
+ Some list_id,
+ <:str_item@loc< value $lid:list_id$ () : list OUnit.test =
+ $f loc expr list_expr$;
+ value ounit_tests () : OUnit.test =
+ OUnit.TestList (List.rev ($lid:list_id$ ()));
+ >>
+
+let append_to_list =
+ transform_list ~f:(fun loc e le ->
+ let loc = Ast.loc_of_expr e in
+ <:expr@loc< [ $e$ :: $le$ ] >>)
+
+let concat_to_list =
+ transform_list ~f:(fun loc e le ->
+ let loc = Ast.loc_of_expr e in
+ <:expr@loc< $e$ @ $le$ >>)
+
let append_to_list ~list e =
let loc = Ast.loc_of_expr e in
match list with
@@ -106,35 +150,15 @@ let append_to_list ~list e =
>>
(* We use the ast mapper to reach all the deep nested modules that might
- be in expressions etc.. *)
+ be in expressions etc..
+ We do the collection of the breadcrumbs in that mapper (as a result it is
+ a there's a bit of hackery to allow threading through an extra value).
+*)
let ast_mapper = object (self)
inherit Ast.map
method module_expr me = snd (self#module_expr' me)
- method str_item' ~list = function
- (* Bread crumb *)
- | Ast.StExp (_,Ast.ExApp
- (_,Ast.ExId(_,Ast.IdLid (_,fid)),e)) when fid = breadcrumb_id ->
- append_to_list ~list e
- | <:str_item@loc< $s1$;$s2$ >> ->
- let list,s1 = self#str_item' ~list s1 in
- let list,s2 = self#str_item' ~list s2 in
- list,<:str_item@loc< $s1$;$s2$ >>
- | <:str_item@loc< module $uid:name$ = $me$ >> ->
- let has_tests,me = self#module_expr' me in
- let str_item = <:str_item@loc< module $uid:name$ = $me$ >> in
- if has_tests then
- let test =
- <:expr@loc< OUnit.TestLabel $str:name$ ($uid:name$.ounit_tests ()) >>
- in
- let list,test_it = append_to_list ~list test in
- list,<:str_item@loc< $str_item$; $test_it$ >>
- else
- list,str_item
- | str_item -> list,self#str_item str_item
-(* Returns true if the module a ounit_tests component*)
-
- method module_expr' = function
+ method module_expr' : Ast.module_expr -> bool * Ast.module_expr = function
| (Ast.MeNil _
| Ast.MeAnt _ (* $antiquot$ *)
| <:module_expr< $id:_$ >>) as v -> false,v
@@ -166,6 +190,36 @@ let ast_mapper = object (self)
OUnit.TestList (List.rev ($lid:id$ ()));
end >>
| None -> false,<:module_expr@loc<struct $it$ end >>
+
+ method str_item' ~list :
+ Ast.str_item -> string option * Ast.str_item
+ = function
+ (* Matches a bread crumb *)
+ | Ast.StExp (_,Ast.ExApp
+ (_,Ast.ExId(_,Ast.IdLid (_,fid)),e)) when fid = breadcrumb_id ->
+ append_to_list ~list e
+ | Ast.StExp (_,Ast.ExApp
+ (_,Ast.ExId(_,Ast.IdLid (_,fid)),e)) when fid = breadcrumb_list_id ->
+ concat_to_list ~list e
+ | <:str_item@loc< $s1$;$s2$ >> ->
+ let list,s1 = self#str_item' ~list s1 in
+ let list,s2 = self#str_item' ~list s2 in
+ list,<:str_item@loc< $s1$;$s2$ >>
+ | <:str_item@loc< module $uid:name$ = $me$ >> ->
+ let has_tests,me = self#module_expr' me in
+ let str_item = <:str_item@loc< module $uid:name$ = $me$ >> in
+ if has_tests then
+ let test =
+ <:expr@loc< OUnit.TestLabel $str:name$ ($uid:name$.ounit_tests ()) >>
+ in
+ let list,test_it = append_to_list ~list test in
+ list,<:str_item@loc< $str_item$; $test_it$ >>
+ else
+ list,str_item
+ | str_item -> list,self#str_item str_item
+(* Returns true if the module a ounit_tests component*)
+
+
end
let gen_ounit_tests si =
@@ -195,6 +249,16 @@ let () =
<:sig_item@loc< $si$; value ounit_tests : unit -> OUnit.test >>
end
+let rec classify_module_expr = function
+ | Ast.MeNil _
+ | <:module_expr< (value $_$) >>
+ | <:module_expr< functor ($_$:$_$) -> $_$ >>
+ | Ast.MeAnt _ -> `Complex
+ | <:module_expr< $id:_$ >> -> `Alias
+ | <:module_expr< ($me$:$_$) >> -> classify_module_expr me
+ | <:module_expr< $m1$ $m2$ >> -> `App
+ | <:module_expr<struct $str_item$ end >> -> `Simple str_item
+
let test_expr e =
let loc = Ast.loc_of_expr e in
<:expr@loc< fun [ () -> (OUnit.TestCase (fun [ () -> $e$]))] >>
@@ -205,42 +269,55 @@ let syntax_printer =
let buffer = Buffer.create 16
-let string_of_expr expr =
+let ast_print printer v =
Buffer.clear buffer;
- Format.bprintf buffer "%a%!" syntax_printer#expr expr;
+ Format.bprintf buffer "%a%!" printer v;
Buffer.contents buffer
-let string_of_me me =
- Buffer.clear buffer;
- Format.bprintf buffer "%a%!" syntax_printer#module_expr me;
- Buffer.contents buffer
-let rec short_desc_of_expr ~max_len = function
+(** Shorten a string by striping the newlines and indentation
+ and eventually truncating it.
+*)
+let shorten_buf = String.create 50
+
+let rec shorten ~bol ~src_pos ~tgt_pos src tgt =
+ if src_pos = String.length src - 1 then
+ String.sub tgt 0 tgt_pos
+ else if tgt_pos = String.length tgt - 1 then begin
+ String.blit "[...]" 0 tgt (String.length tgt - 5) 5;
+ String.copy tgt
+ end else begin
+ match src.[src_pos] with
+ | ' ' | '\t' | '\n' when bol ->
+ shorten ~bol ~src_pos:(src_pos+1) ~tgt_pos src tgt
+ | '\n' ->
+ tgt.[tgt_pos] <- ' ';
+ shorten ~bol:true ~src_pos:(src_pos+1) ~tgt_pos:(tgt_pos+1) src tgt
+ | c ->
+ tgt.[tgt_pos] <- c;
+ shorten ~bol:false ~src_pos:(src_pos+1) ~tgt_pos:(tgt_pos+1) src tgt
+ end
+
+let shorten s = shorten ~bol:true ~src_pos:0 ~tgt_pos:0 s shorten_buf
+
+let short_ast_print printer v : string =
+ let s = ast_print printer v in
+ shorten s
+
+let rec short_desc_of_expr = function
+ (* Skip all the intermediate values declared for the test. *)
| (<:expr< let $_$ in $e$ >>
| <:expr< let rec $_$ in $e$ >>
| <:expr< let module $_$ = $_$ in $e$ >>)
- -> short_desc_of_expr ~max_len e
+ -> short_desc_of_expr e
| e ->
- let s = string_of_expr e in
- let len = String.length s in
- let res =
- if len >= max_len then
- let s_short = String.sub s 0 (max_len - 5) in
- s_short ^ "[...]"
- else
- s
- in
- for i=0 to String.length res -1 do
- if res.[i]='\n' then
- res.[i] <- ' '
- done;
- res
+ short_ast_print syntax_printer#expr e
let str_item = Syntax.str_item
let create_test ~loc id in_expr expr =
has_tests := true;
- let short () = short_desc_of_expr ~max_len:50 in_expr
+ let short () = short_desc_of_expr in_expr
and eloc = Ast.loc_of_expr expr in
let expr = <:expr@eloc<($expr$ : unit)>>
and id =
@@ -253,6 +330,8 @@ let create_test ~loc id in_expr expr =
breadcrumb
(label id <:expr@loc< OUnit.TestCase (fun [ () -> $expr$]) >>)
+
+open Camlp4.PreCast
EXTEND Gram
GLOBAL: str_item;
opt_raise_exc_pat: [[
@@ -274,7 +353,7 @@ EXTEND Gram
let srep = Printf.sprintf "%s:line %i %s"
filename
line
- (String.escaped (string_of_expr e))
+ (String.escaped (ast_print syntax_printer#expr e))
in
let eloc = Ast.loc_of_expr e in
let test_expr = <:expr@eloc<
@@ -303,21 +382,43 @@ EXTEND Gram
| "TEST_MODULE";
id = OPT Syntax.a_STRING ; "=" ; orig = Syntax.module_expr ->
has_tests := true;
- let me = ast_mapper#module_expr
+ let test_group ?lbl () =
+ let me = ast_mapper#module_expr
<:module_expr< ($orig$:sig
value ounit_tests : unit -> OUnit.test;
end) >>
- and e = <:expr<M.ounit_tests ()>> in
- let e = match id with
- | None ->
- let mes = string_of_me orig in
- if String.contains mes ' ' then
- e
- else
- label mes e
- | Some v -> label v e
+ and e =
+ match lbl with
+ | Some lbl -> label lbl <:expr<M.ounit_tests ()>>
+ | None -> <:expr<M.ounit_tests ()>>
+ in
+ breadcrumb
+ <:expr< let module M = $me$ in $e$ >>
in
- breadcrumb
- <:expr< let module M = $me$ in $e$ >>
+ match id with
+ | Some lbl -> test_group ~lbl ()
+ | None ->
+ match classify_module_expr orig with
+ | `Alias -> test_group ()
+ | `Complex | `App ->
+ let lbl = short_ast_print syntax_printer#module_expr orig in
+ test_group ~lbl ()
+ | `Simple str_item ->
+ (* Unlabelled basic group; we are just adding the cnt to the
+ mix. *)
+ let (test_list_name,str_item) =
+ ast_mapper#str_item' ~list:None str_item
+ in
+ match test_list_name with
+ | None -> Loc.raise
+ (Ast.loc_of_str_item str_item)
+ (Failure "No tests defined in test module")
+ | Some name ->
+ (*ignore name;
+ ignore st *)
+ breadcrumb_list
+ <:expr< let module M = (struct
+ $str_item$;
+ end) in M.$lid:name$ () >>
]];
END

0 comments on commit f121318

Please sign in to comment.
Something went wrong with that request. Please try again.