proof of concept for a basic SGR stack machine

SGR_stack_machine_poc.ml

(* SGR stack machine *)

module Color = struct
  type t =
    | Basic of int
    | Rgb of int * int * int
end

module Style = struct
  type t =
    | Bold
    | Dim
    | Italic
    | Underline
    | Blink
    | Reverse
    | Foreground of Color.t
    | Background of Color.t

  let to_string = function
    | Bold -> "\x1b[1m"
    | Dim -> "\x1b[2m"
    | Italic -> "\x1b[3m"
    | Underline -> "\x1b[4m"
    | Blink -> "\x1b[5m"
    | Reverse -> "\x1b[7m"
    | Foreground (Basic i) -> Printf.sprintf "\x1b[38;5;%dm" i
    | Foreground (Rgb (r, g, b)) ->
      Printf.sprintf "\x1b[38;2;%d;%d;%dm" r g b
    | Background (Basic i) -> Printf.sprintf "\x1b[48;5;%dm" i
    | Background (Rgb (r, g, b)) ->
      Printf.sprintf "\x1b[48;2;%d;%d;%dm" r g b

  let to_cancelling_string = function
    | Bold -> "\x1b[22m"
    | Dim -> "\x1b[22m"
    | Italic -> "\x1b[23m"
    | Underline -> "\x1b[24m"
    | Blink -> "\x1b[25m"
    | Reverse -> "\x1b[27m"
    | Foreground _ -> "\x1b[39m"
    | Background _ -> "\x1b[49m"
end

module Label = struct
  type t = string
end

module Instruction = struct
  type t =
    | Write of string
    | Begin_style of Style.t
    | End_style of Style.t
end

module Section = struct
  type t = Label.t * Instruction.t list

  let create lbl instrs = (lbl, instrs)
end

module Bytecode = struct
  type t =
    { output : Out_channel.t
    ; sections : Section.t list
    }

  let create out sects = { output = out; sections = sects }
end

module Eval = struct
  type t =
    { style_stack : Style.t Stack.t
    ; mutable output : Out_channel.t
    ; mutable current_section : Label.t
    }

  let create () =
    { style_stack = Stack.create ()
    ; output = stdout
    ; current_section = "start"
    }

  module Error = struct
    type t =
      | Unknown_section of Label.t
      | Unterminated_style of Style.t
      | Unexpected_style_end of Style.t
  end

  let ( let* ) = Result.bind
  let get_last_style ev = Stack.top_opt ev.style_stack

  let reset_to_previous_style ev =
    get_last_style ev
    |> Option.map Style.to_cancelling_string
    |> Option.value ~default:"\x1b[0m"
    |> Out_channel.output_string ev.output

  let begin_style stl ev =
    Out_channel.output_string ev.output (Style.to_string stl);
    Ok (Stack.push stl ev.style_stack)

  let end_style stl ev =
    match Stack.pop_opt ev.style_stack with
    | Some popd_stl when stl = popd_stl ->
      reset_to_previous_style ev;
      Ok ()
    | Some popd_st -> Error (Error.Unterminated_style popd_st)
    | None -> Error (Error.Unexpected_style_end stl)

  let run_instruction instr ev =
    match instr with
    | Instruction.Write s ->
      Ok (Out_channel.output_string ev.output s)
    | Begin_style stl -> begin_style stl ev
    | End_style stl -> end_style stl ev

  let rec run_instruction_list instrs ev =
    match instrs with
    | [] -> Ok ()
    | first :: rest ->
      let* () = run_instruction first ev in
      run_instruction_list rest ev

  let run_sections sects ev =
    match List.assoc_opt ev.current_section sects with
    | Some instrs -> run_instruction_list instrs ev
    | None -> Error (Error.Unknown_section ev.current_section)

  let run (bc : Bytecode.t) ev =
    ev.output <- bc.output;
    run_sections bc.sections ev
end

let bc =
  Bytecode.create
    stdout
    [ Section.create
        "start"
        Instruction.
          [ Write "Hello, "
          ; Begin_style Bold
          ; Begin_style (Foreground (Basic 5))
          ; Write "lexa" (* or put your name instead *)
          ; End_style (Foreground (Basic 5))
          ; End_style Bold
          ; Write "!\n"
          ]
    ]

let ev = Eval.create ()
let () = Eval.run bc ev |> Result.get_ok