A simple cram test runner (OCaml)

simplecram.ml

module Files = struct

  let line c =
    try
      let result = input_line c in
      Some result
    with End_of_file -> None

  let rec read c acc =
    match line c with
    | Some l -> read c (List.append acc [l])
    | None -> acc

  let load f =
    let c = open_in f in
    try
      read c []
    with e ->
      close_in c;
      raise e

end

module Proc = struct

  let int_of_status s =
    match s with
    | Unix.WEXITED n -> n
    | Unix.WSIGNALED n -> n
    | Unix.WSTOPPED n -> n

  let shell cmd out err =
    match Unix.fork () with
    | 0 ->
      Unix.dup2 out Unix.stdout;
      Unix.close out;
      Unix.dup2 err Unix.stderr;
      Unix.close err;
      Unix.execvp "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
    | pid -> pid

  let popen cmd =
    let (stdout_read, stdout_write) = Unix.pipe ~cloexec:true () in
    let (stderr_read, stderr_write) =
      try Unix.pipe ~cloexec:true ()
      with e ->
        Unix.close stdout_read;
        Unix.close stdout_write;
        raise e in
    Unix.set_nonblock stdout_read;
    Unix.set_nonblock stderr_read;
    let out_ch = Unix.in_channel_of_descr stdout_read in
    let err_ch = Unix.in_channel_of_descr stderr_read in
    begin
      try
        let pid = shell cmd stdout_write stderr_write in
        Unix.close stdout_write;
        Unix.close stderr_write;
        (pid, out_ch, err_ch)
      with e ->
        Unix.close stdout_read; Unix.close stdout_write;
        Unix.close stderr_read; Unix.close stderr_write;
        raise e;
    end

  let poll pid =
    let pid', s = Unix.waitpid [Unix.WNOHANG] pid in
    match pid' with
    | 0 -> None
    | _ -> Some (int_of_status s)

end

module Buff = struct

    let create ch len = (ch, Buffer.create len)

    let contents b =
      let buf = snd(b) in
      Buffer.contents buf

    let read b =
      let ch = fst(b) and buf = snd(b) in
      try
        while true do
          Buffer.add_channel buf ch 1
        done
      with
      | Sys_blocked_io -> ()
      | End_of_file -> ()

end

module Cmd = struct

  let rec while_waiting pid delay f x =
    match Proc.poll pid with
    | None ->
      f x;
      Unix.sleepf delay;
      while_waiting pid delay f x
    | Some n ->
      f x;
      n

  let collect out_buf err_buf =
    Buff.read out_buf; Buff.read err_buf

  let run cmd =
    let pid, stdout_ch, stderr_ch = Proc.popen cmd in
    let out_buf = Buff.create stdout_ch 80 in
    let err_buf = Buff.create stderr_ch 80 in
    let exit_code = while_waiting pid 0.25 (collect out_buf) err_buf in
    close_in stdout_ch;
    close_in stderr_ch;
    (exit_code, out_buf, err_buf)

end

module Token_type = struct
  type t = Blank | Comment | Code | Output
  let string_of t =
    match t with
    | Blank -> "BLANK"
    | Comment -> "COMMENT"
    | Code -> "CODE"
    | Output -> "OUTPUT"
end

module Token = struct
  type t = { token : Token_type.t; data : string list }
  let create token data = { token; data }
  let string_of t =
    Printf.sprintf "%s:\n%s" (Token_type.string_of t.token) (String.concat "\n- " t.data)
end

module Lexer = struct

  let pad s = String.concat "" [s; "    "]

  let is_blank s =
    match String.trim s with
    | "" -> true
    | _ -> false

  let token_of s =
    match is_blank s with
    | true -> Token_type.Blank
    | false ->
      let padded_s = pad s in
      let fst_two = String.sub padded_s 0 2 in
      match is_blank fst_two with
      | false -> Token_type.Comment
      | true ->
        let snd_two = String.sub padded_s 2 2 in
        match snd_two with
        | "$ " -> Token_type.Code
        | _ -> Token_type.Output


  let are_grouped tk_1 tk_2 matches =
    match matches with
    | [] -> true
    | _ ->
      match tk_1 with
      | Token_type.Blank -> tk_2 = Token_type.Blank
      | Token_type.Comment -> tk_2 = Token_type.Comment
      | Token_type.Code -> tk_2 = Token_type.Output
      | _ -> false

  let rec collect tk matches the_rest =
    match the_rest with
    | [] -> (matches, [])
    | hd :: tl ->
      let tk_2 = token_of hd in
      match are_grouped tk tk_2 matches with
      | false -> (matches, the_rest)
      | true ->
        let new_matches = List.append matches [hd] in
        collect tk new_matches tl

  let rec tokenize src acc =
    match src with
    | [] -> acc
    | hd :: tl ->
      let tk = token_of hd in
      let matches, the_rest = collect tk [] src in
      let record = Token.create tk matches in
      tokenize the_rest (List.append acc [record])

end

module Node = struct
  type t = { token : Token_type.t; data : string list; cmd : string; output : string list }
  let create token data cmd output = { token; data; cmd; output }
  let string_of t =
    Printf.sprintf "TOKEN: %s\nDATA: %s\nCMD: %s\nOUTPUT: %s\n----\n%!" 
      (Token_type.string_of t.token) 
      (String.concat "\n- " t.data) 
      (t.cmd)
      (String.concat "\n-- " t.output)
end

module Node_of_blanks = struct

  let create data =
    Node.create Token_type.Blank data "" []

end

module Node_of_comments = struct

  let create data =
    Node.create Token_type.Comment data "" []

end

module Node_of_code = struct

  let pad s = String.concat "" [s; "    "]

  let rec process data cmd output =
    match data with
    | [] -> (cmd, output)
    | hd :: tl ->
      let padded_s = pad hd in
      match String.sub padded_s 2 2 with
      | "$ " ->
        let cmd_str = String.sub padded_s 4 ((String.length padded_s) - 4) in
        process tl cmd_str output
      | _ ->
        process tl cmd (List.append output [hd])

  let create data =
    let cmd, output = process data "" [] in
    Node.create Token_type.Code data cmd output

end

module AST = struct
  let rec build tokens acc =
    match tokens with
    | [] -> acc
    | hd :: tl ->
      let node = match hd.Token.token with
      | Token_type.Blank -> Node_of_blanks.create hd.Token.data
      | Token_type.Comment -> Node_of_comments.create hd.Token.data
      | Token_type.Code -> Node_of_code.create hd.Token.data
      | Token_type.Output -> raise (Failure "Cannot process output token in AST") in
      build tl (List.append acc [node])
end


module Result = struct
  type t = {
    token: Token_type.t;
    data: string list;
    cmd: string;
    output: string list;
    stdout: string list;
    stderr: string list;
    exit_code: int;
    success: bool;
    diff: string list }

  let create token data cmd output stdout stderr exit_code success diff =
    { token; data; cmd; output; stdout; stderr; exit_code; success; diff }

  let string_of_data data =
    match List.length data > 0 with
    | false -> ""
    | true -> Printf.sprintf "%s\n" (String.concat "\n" data)

  let string_of_output output =
    match List.length output > 0 with
    | false -> ""
    | true ->
      let result = List.map (Printf.sprintf "  %s") output in
      Printf.sprintf "%s\n" (String.concat "\n" result)

  let string_of_stdout stdout =
    match List.length stdout > 0 with
    | false -> ""
    | true ->
      let result = List.map (Printf.sprintf "  1> %s") stdout in
      Printf.sprintf "%s\n" (String.concat "\n" result)

  let string_of_stderr stderr =
    match List.length stderr > 0 with
    | false -> ""
    | true ->
      let result = List.map (Printf.sprintf "  2> %s") stderr in
      Printf.sprintf "%s\n" (String.concat "\n" result)

  let string_of_exit_code exit_code =
    match exit_code with
    | -1 -> ""
    | n -> Printf.sprintf "  Exit code: %d\n" exit_code

  let string_of_diff diff =
    match List.length diff > 0 with
    | false -> ""
    | true ->
      let result = List.map (Printf.sprintf "  +- %s") diff in
      Printf.sprintf "%s\n" (String.concat "\n" result)

  let string_of t =
    match t.token with
    | Token_type.Blank -> Printf.sprintf "%s" (string_of_data t.data)
    | Token_type.Comment -> Printf.sprintf "%s" (string_of_data t.data)
    | Token_type.Code -> 
      Printf.sprintf "%s%s%s%s%s"
        (string_of_data t.data)
        (string_of_stdout t.stdout) (string_of_stderr t.stderr)
        (string_of_exit_code t.exit_code) (string_of_diff t.diff)
    | Token_type.Output -> raise (Failure "Cannot stringify output node.")

end

module Result_of_blanks = struct
  let create data =
    Result.create Token_type.Blank data "" [] [] [] 0 true []
end

module Result_of_comments = struct
  let create data =
    Result.create Token_type.Comment data "" [] [] [] 0 true []
end

module Result_of_code = struct

  let strip_final_newline s =
    match String.length s with
    | 0 -> s
    | n ->
      match String.get s (n - 1) with
      | '\n' -> String.sub s 0 (n - 1)
      | _ -> s

  let marshal_output buf =
    let raw_str = Buff.contents buf in
    let trimmed_str = strip_final_newline raw_str in
    match String.trim trimmed_str with
    | "" -> []
    | _ -> String.split_on_char '\n' trimmed_str

  let create data cmd output =
    let exit_code, out_buf, err_buf = Cmd.run cmd in
    let stdout = marshal_output out_buf in
    let stderr = marshal_output err_buf in
    Result.create
      Token_type.Code data cmd output
      stdout stderr exit_code
      false ["something"; "foo"; "bar"]

end

module Eval = struct

  let rec run ast acc =
    match ast with
    | [] -> acc
    | hd :: tl ->
      let result = match hd.Node.token with
      | Token_type.Blank -> Result_of_blanks.create hd.Node.data
      | Token_type.Comment -> Result_of_comments.create hd.Node.data
      | Token_type.Code -> Result_of_code.create hd.Node.data hd.Node.cmd hd.Node.output
      | Token_type.Output -> raise (Failure "Cannot evaluate an output node.") in
      run tl (List.append acc [result])

end

let main src =
  let tokens = Lexer.tokenize src [] in
  let nodes = AST.build tokens [] in
  let results = Eval.run nodes [] in
  List.iter (fun x -> Printf.printf "%s%!" (Result.string_of x)) results;
  print_endline "Done."

let () =
  let path = Sys.argv.(1) in
  let src = Files.load path in
  main src