Fix support for multi-lines commands

lib/cram.ml

@@ -1,9 +1,17 @@
+let src = Logs.Src.create "mdx"
+module Log = (val Logs.src_log src : Logs.LOG)
+
 open Astring
 open Misc
 open S
 
 type t = cram
 
+let dump_line ppf = function
+  | #output as o -> Output.dump ppf o
+  | `Exit i      -> Fmt.pf ppf "`Exit %d" i
+  | `Command c   -> Fmt.pf ppf "`Command %a" Fmt.(Dump.list dump_string) c
+
 let dump ppf (t : t) =
   Fmt.pf ppf
     "{@[command: %a;@ output: %a;@ exit_code: %d@]}"
@@ -35,13 +43,14 @@ let pad_of_lines = function
 let of_lines t =
   let pad = pad_of_lines t in
   let unpad line =
-    if String.length line < pad then Fmt.failwith "invalide padding: %S" line
+    if String.length line < pad then Fmt.failwith "invalid padding: %S" line
     else String.with_index_range line ~first:pad
   in
-  let lines = List.rev_map unpad t in
-  let lines =
-    List.rev_map (fun s -> Lexer.cram (Lexing.from_string s)) lines
-  in
+  let lines = List.map unpad t in
+  let lines = Lexer.cram (Lexing.from_string (String.concat ~sep:"\n" lines)) in
+  Log.debug (fun l ->
+      l "Cram.of_lines (pad=%d) %a" pad Fmt.(Dump.list dump_line) lines
+    );
   let mk command output exit_code =
     { command; output = List.rev output; exit_code }
   in
@@ -54,7 +63,7 @@ let of_lines t =
   in
   match lines with
   | `Command cmd :: t -> pad, aux cmd [] [] t
-  | _ -> Fmt.failwith "invalid cram block: %a" Fmt.(Dump.list string) t
+  | _ -> Fmt.failwith "invalid cram block: %a" Fmt.(Dump.list dump_line) lines
 
 let exit_code t = t.exit_code
 

lib/lexer.mll

@@ -16,14 +16,15 @@ let err lexbuf fmt =
       Fmt.failwith "%a: %s" pp_position lexbuf str
     ) fmt
 
-let commands s = String.cuts ~sep:"\\\n  > " s
 let line_ref = ref 1
 
+let commands s = String.cuts ~sep:"\\\n> " s
+
 }
 
 let eol = '\n' | eof
 let ws = ' ' | '\t'
-let cmd = [^'\n' '\\']+ ("\\\n  > " [^'\n' '\\']+)*
+let cram_cmd = [^'\n' '\\']+ ("\\\n> " [^'\n' '\\'] +)*
 let digit = ['0' - '9']
 
 rule text section = parse
@@ -52,15 +53,24 @@ and block = parse
   | ([^'\n'] * as str) eol { str :: block lexbuf }
 
 and cram = parse
- | "✘ exit" ws+ (digit + as str) ws* eol { `Exit (int_of_string str) }
- | "..." ws* eol                         { `Ellipsis }
- | "$ " (cmd as str) eol                 { `Command (commands str) }
- | ([^'\n']* as str) eol                 { `Output  str }
+ | eol                                   { [] }
+ | "✘ exit" ws+ (digit + as str) ws* eol { `Exit (int_of_string str) :: cram lexbuf }
+ | "..." ws* eol                         { `Ellipsis :: cram lexbuf }
+ | "$ " (cram_cmd as str) eol            { `Command (commands str) :: cram lexbuf }
+ | ([^'\n']* as str) eol                 { `Output str :: cram lexbuf }
 
 and toplevel = parse
- | "..." ws* eol                         { `Ellipsis }
- | "# " (cmd as str) eol                 { `Command (commands str) }
- | ([^'\n']* as str) eol                 { `Output  str }
+ | eol           { [] }
+ | "..." ws* eol { `Ellipsis :: toplevel lexbuf }
+ | "# "          { let c = phrase [] (Buffer.create 8) lexbuf in
+                   `Command c :: toplevel lexbuf }
+ | ([^'#'] [^'\n']* as str) eol { `Output  str :: toplevel lexbuf }
+
+and phrase acc buf = parse
+ | "\n  "       { phrase (Buffer.contents buf :: acc) (Buffer.create 8) lexbuf }
+ | "\n"
+ | ";;" eol     { List.rev ((Buffer.contents buf ^ ";;") :: acc) }
+ | _ as c       { Buffer.add_char buf c; phrase acc buf lexbuf }
 
 {
 

lib/toplevel.ml

@@ -1,9 +1,16 @@
+let src = Logs.Src.create "mdx"
+module Log = (val Logs.src_log src : Logs.LOG)
+
 open Astring
 open Misc
 open S
 
 type t = toplevel
 
+let dump_line ppf = function
+  | #output as o -> Output.dump ppf o
+  | `Command c   -> Fmt.pf ppf "`Command %a" Fmt.(Dump.list dump_string) c
+
 let command (t : toplevel) = t.command
 let output (t : toplevel) = t.output
 
@@ -15,7 +22,7 @@ let dump ppf (t : t) =
 let pp_command ?(pad=0) ppf (t : t) = match t.command with
   | [] -> ()
   | l  ->
-    let sep ppf () = Fmt.pf ppf "\\\n%a> " pp_pad pad in
+    let sep ppf () = Fmt.pf ppf "\n%a  " pp_pad pad in
     Fmt.pf ppf "%a# %a\n" pp_pad pad Fmt.(list ~sep string) l
 
 let pp ?pad ppf (t : t) =
@@ -28,10 +35,12 @@ let of_lines t =
     if String.length line < pad then Fmt.failwith "invalide padding: %S" line
     else String.with_index_range line ~first:pad
   in
-  let lines = List.rev_map unpad t in
-  let lines =
-    List.rev_map (fun s -> Lexer.toplevel (Lexing.from_string s)) lines
-  in
+  let lines = List.map unpad t in
+  let lines = String.concat ~sep:"\n" lines in
+  let lines = Lexer.toplevel (Lexing.from_string lines) in
+  Log.debug (fun l ->
+      l "Toplevel.of_lines (pad=%d) %a" pad Fmt.(Dump.list dump_line) lines
+    );
   let mk command output = { command; output = List.rev output } in
   let rec aux command output acc = function
     | []                  -> List.rev (mk command output :: acc)
@@ -41,4 +50,4 @@ let of_lines t =
   in
   match lines with
   | `Command cmd :: t -> pad, aux cmd [] [] t
-  | _ -> Fmt.failwith "invalid cram block: %a" Fmt.(Dump.list string) t
+  | _ -> Fmt.failwith "invalid toplevel block: %a" Fmt.(Dump.list string) t

test/jbuild

@@ -21,6 +21,13 @@
             (run ${exe:../bin/main.exe} test ${<}))
            (diff? ${<} ${<}.corrected)))))
 
+(alias
+ ((name runtest)
+  (deps (multilines.md))
+  (action (progn
+           (run ${exe:../bin/main.exe} test ${<})
+           (diff? ${<} ${<}.corrected)))))
+
 (rule
  ((targets (section.ml))
   (deps    (section.md))

test/multilines.md

@@ -0,0 +1,28 @@
+Test multi-lines shell commands:
+
+```sh
+$ for i in `seq 1 10`; do \
+>   echo $i; \
+> done
+1
+...
+10
+```
+
+This works trivially for normal OCaml fragments:
+
+```ocaml
+let rec fact = function
+| 1 -> 1
+| n -> n * fact (n-1)
+```
+
+And it should work fine for toplevel too:
+
+```ocaml
+# let rec fact = function
+  | 1 -> 1
+  | n -> n * fact (n-1)
+  ;;
+val fact : int -> int = <fun>
+```