odoc extract-code cleanup and test

Author: panglesd

src/odoc/extract_code.ml

@@ -1,58 +1,76 @@
 open Odoc_utils
 open Odoc_parser
 
-let rec nestable_block_element = function
-  | {
-      Loc.location = _;
-      value = `Verbatim _ | `Modules _ | `Math_block _ | `Media _ | `Paragraph _;
-    } ->
-      ()
-  | {
-      location = _;
-      value = `Code_block { Ast.content = { value; location }; _ };
-    } ->
-      Format.printf "#%d \"%s\"\n" (location.start.line + 1) location.file;
-      Format.printf "%s"
-        (String.v ~len:(location.start.column + 1) (fun _ -> ' '));
-      Format.printf "%s" value
-  | { location = _; value = `List (_, _, l) } ->
-      List.iter (List.iter nestable_block_element) l
-  | { location = _; value = `Table ((table, _), _) } ->
+let tags_included_in_names names tags =
+  let fields = String.fields ~empty:false tags in
+  List.exists
+    (fun tag ->
+      match String.cut ~sep:"=" tag with
+      | Some ("name", n) -> List.exists (String.equal n) names
+      | _ -> false)
+    fields
+
+let needs_extraction names meta =
+  let check_language l = String.equal "ocaml" l.Loc.value in
+  let check_name tags =
+    if List.is_empty names then true
+    else
+      match tags with
+      | None -> false
+      | Some tags -> tags_included_in_names names tags.Loc.value
+  in
+  match meta with
+  | None -> false
+  | Some meta -> check_language meta.Ast.language && check_name meta.tags
+
+let print oc line_directives location value =
+  if line_directives then (
+    Printf.fprintf oc "#%d \"%s\"\n" (location.Loc.start.line + 1) location.file;
+    Printf.fprintf oc "%s%s\n"
+      (String.v ~len:(location.start.column + 1) (fun _ -> ' '))
+      value)
+  else Printf.fprintf oc "%s" value
+
+let rec nestable_block_element line_directives oc names v =
+  match v.Loc.value with
+  | `Verbatim _ | `Modules _ | `Math_block _ | `Media _ | `Paragraph _ -> ()
+  | `Code_block { Ast.content = { value; location }; meta; _ }
+    when needs_extraction names meta ->
+      print oc line_directives location value
+  | `Code_block _ -> ()
+  | `List (_, _, l) ->
+      List.iter (List.iter (nestable_block_element line_directives oc names)) l
+  | `Table ((table, _), _) ->
       List.iter
-        (List.iter (fun (x, _) -> List.iter nestable_block_element x))
+        (List.iter (fun (x, _) ->
+             List.iter (nestable_block_element line_directives oc names) x))
         table
 
-and block_element = function
-  | {
-      Loc.value =
-        `Tag
-          ( `Deprecated l
-          | `Param (_, l)
-          | `Raise (_, l)
-          | `Return l
-          | `See (_, _, l)
-          | `Before (_, l) );
-      _;
-    } ->
-      List.iter nestable_block_element l
-  | {
-      Loc.value =
-        `Tag
-          ( `Author _ | `Since _ | `Version _ | `Canonical _ | `Inline | `Open
-          | `Children_order _ | `Toc_status _ | `Order_category _
-          | `Short_title _ | `Closed | `Hidden );
-      _;
-    }
-  | { Loc.value = `Heading _; _ } ->
+and block_element line_directives oc names v =
+  match v.Loc.value with
+  | `Tag
+      ( `Deprecated l
+      | `Param (_, l)
+      | `Raise (_, l)
+      | `Return l
+      | `See (_, _, l)
+      | `Before (_, l) ) ->
+      List.iter (nestable_block_element line_directives oc names) l
+  | `Tag
+      ( `Author _ | `Since _ | `Version _ | `Canonical _ | `Inline | `Open
+      | `Children_order _ | `Toc_status _ | `Order_category _ | `Short_title _
+      | `Closed | `Hidden )
+  | `Heading _ ->
       ()
-  | { Loc.value = #Ast.nestable_block_element; _ } as x ->
-      nestable_block_element x
+  | #Ast.nestable_block_element as value ->
+      nestable_block_element line_directives oc names { v with value }
 
-let extract ~dst:_ ~input ~names:_ ~line_directives:_ =
+let extract ~dst ~input ~names ~line_directives =
   let location =
     { Lexing.pos_fname = input; pos_lnum = 0; pos_bol = 0; pos_cnum = 0 }
   in
   let c = Io_utils.read_lines input |> String.concat ~sep:"\n" in
   let parsed = parse_comment ~location ~text:c in
   let ast = ast parsed in
-  List.iter block_element ast
+  let go oc = List.iter (block_element line_directives oc names) ast in
+  match dst with None -> go stdout | Some dst -> Io_utils.with_open_out dst go

test/extract_code/dune

@@ -0,0 +1,3 @@
+(cram
+ (package odoc)
+ (deps %{bin:odoc}))

test/extract_code/mld_extraction.t/main.mld

@@ -0,0 +1,27 @@
+{0 Test}
+
+By default, language is assumed to be OCaml
+
+{[
+(** By default, an odoc code block is assumed to contain OCaml code *)
+let () = ()
+]}
+
+{@c name=c-quine[
+#include <stdio.h>
+int main(){
+char*a="#include <stdio.h>%cint main(){char*a=%c%s%c;printf(a,10,34,a,34);}";
+printf(a,10,34,a,34);
+}
+]}
+
+{@ocaml name=error.ml name=printing[let x = 5]}
+
+   {@ocaml name=printing[
+   let () = print_int x
+  ]}
+
+
+   {@ocaml name=error.ml[
+   let y = x + 6. (* This is a typing error *)
+   ]}

test/extract_code/mld_extraction.t/run.t

@@ -0,0 +1,79 @@
+Without --name argument, all OCaml code blocks are extracted
+
+  $ odoc extract-code main.mld
+  let x = 5
+     let () = print_int x
+    
+     let y = x + 6. (* This is a typing error *)
+     
+
+We can add (OCaml) line directives
+
+  $ odoc extract-code --line-directives main.mld
+  #18 "main.mld"
+                                       let x = 5
+  #20 "main.mld"
+                            
+     let () = print_int x
+    
+  #25 "main.mld"
+                            
+     let y = x + 6. (* This is a typing error *)
+     
+
+We can restrict to a named code blocks
+
+  $ odoc extract-code --line-directives --name error.ml main.mld
+  #18 "main.mld"
+                                       let x = 5
+  #25 "main.mld"
+                            
+     let y = x + 6. (* This is a typing error *)
+     
+
+We can output to a file
+
+  $ odoc extract-code --line-directives --name error.ml -o error.ml main.mld
+  $ cat error.ml
+  #18 "main.mld"
+                                       let x = 5
+  #25 "main.mld"
+                            
+     let y = x + 6. (* This is a typing error *)
+     
+
+Let's check line directive work:
+
+  $ ocaml error.ml
+  File "main.mld", line 26, characters 15-17:
+  Error: This expression has type "float" but an expression was expected of type
+           "int"
+  [2]
+
+Here is the line 26, and the characters 15-17:
+
+  $ sed -n '26p' main.mld
+     let y = x + 6. (* This is a typing error *)
+  $ sed -n '26p' main.mld | cut -c15-17
+   6.
+
+We can get content from multiple names
+
+  $ odoc extract-code --line-directives --name error.ml --name printing main.mld
+  #18 "main.mld"
+                                       let x = 5
+  #20 "main.mld"
+                            
+     let () = print_int x
+    
+  #25 "main.mld"
+                            
+     let y = x + 6. (* This is a typing error *)
+     
+  $ odoc extract-code --line-directives --name error.ml --name printing -o names.ml main.mld
+  $ ocaml names.ml
+  File "main.mld", line 26, characters 15-17:
+  Error: This expression has type "float" but an expression was expected of type
+           "int"
+  5
+  [2]