mmm... perform_io...

Hoskaml.ml

module Util = struct
  let ( let*? ) = Option.bind
  let ( let*! ) = Result.bind
  let ( let@ ) = ( @@ )
  let ( *> ) f g x = g (f x)
  let curry = ( @@ )
  let curry2 f a b = f (a, b)
  let curry3 f a b c = f (a, b, c)
  let ( let|> ) a k = a (curry k)
  let ( let||> ) a k = a (curry2 k)
  let ( let|||> ) a k = a (curry3 k)

  module Option = struct
    include Option

    let validate predicate option =
      let|> value = bind option in
      if predicate value then Some value else None
  end
end

open Util

module Shell = struct
  module Task = struct
    type t =
      | Init
      | Request
      | Process
      | Exit

    let format =
      (function
        | Init -> "INIT"
        | Request -> "REQUEST"
        | Process -> "PROCESS"
        | Exit -> "EXIT")
      *> Printf.sprintf "\x1b[33m%s\x1b[39m"
  end

  module Log_level = struct
    type t =
      | Error
      | Warning
      | Info
      | Debug

    let is_logged ~filter level =
      match (filter, level) with
      | (_, Error)
      | ((Warning | Info | Debug), Warning)
      | ((Info | Debug), Info)
      | (Debug, Debug) -> true
      | (_, _) -> false
  end

  module IO : sig
    type t

    val create
      :  ?source:In_channel.t
      -> ?sink_default:Out_channel.t
      -> ?sink_logging:Out_channel.t
      -> ?log_filter:Log_level.t
      -> unit
      -> t

    val init : 'a. io:t -> (t -> 'a) -> 'a
    val uninit : 'a. io:t -> (t -> 'a) -> 'a

    val set_log_filter
      : 'a.
      Log_level.t -> io:t -> (t -> 'a) -> 'a

    val update_log_filter
      : 'a.
      (Log_level.t -> Log_level.t) -> io:t -> (t -> 'a) -> 'a

    val read_line : 'a. io:t -> (string option -> t -> 'a) -> 'a

    val print
      : 'a 'b.
      ?ending:string option
      -> format:('b -> string option)
      -> 'b
      -> io:t
      -> (t -> 'a)
      -> 'a

    val print_string
      : 'a.
      ?ending:string option -> string -> io:t -> (t -> 'a) -> 'a

    val log_error : 'a. string -> io:t -> (t -> 'a) -> 'a
    val log_warning : 'a. string -> io:t -> (t -> 'a) -> 'a
    val log_info : 'a. string -> io:t -> (t -> 'a) -> 'a
    val log_debug : 'a. string -> io:t -> (t -> 'a) -> 'a
  end = struct
    type t =
      { source : In_channel.t
      ; sink_default : Out_channel.t
      ; sink_logging : Out_channel.t
      ; log_filter : Log_level.t
      }

    let create
          ?(source = stdin)
          ?(sink_default = stdout)
          ?(sink_logging = stderr)
          ?(log_filter = Log_level.Warning)
          ()
      =
      { source; sink_default; sink_logging; log_filter }

    let init ~io return =
      Sys.catch_break true;
      return io

    let uninit ~io return =
      Sys.catch_break false;
      return io

    let set_log_filter log_filter ~io return =
      return { io with log_filter }

    let update_log_filter fn ~io =
      set_log_filter (fn io.log_filter) ~io

    let read_line ~io return =
      flush io.sink_default;
      match input_line io.source with
      | (exception Sys.Break) | (exception End_of_file) ->
        output_char io.sink_default '\n';
        return None io
      | contents -> return (Some contents) io

    let output ?(ending = Some "\n") ~format value ~channel =
      let final_ending = Option.value ending ~default:"" in
      match format value with
      | Some string ->
        output_string channel (string ^ final_ending);
        flush channel
      | None -> ()

    let print ?(ending = Some "\n") ~format value ~io return =
      output ~ending ~format value ~channel:io.sink_default;
      return io

    let print_string ?(ending = Some "\n") =
      print ~ending ~format:Option.some

    let log ?(ending = Some "\n") ~level line ~io return =
      if Log_level.is_logged ~filter:io.log_filter level
      then
        output
          ~ending
          ~format:Option.some
          line
          ~channel:io.sink_logging;
      return io

    let make_log_tag name color =
      Printf.sprintf "\x1b[1;3%dm%s:\x1b[m" color name

    let log_error message ~io return =
      log
        ~level:Error
        (Printf.sprintf
           "%s %s"
           (make_log_tag "error" 1)
           message)
        ~io
      @@ return

    let log_warning message ~io return =
      log
        ~level:Warning
        (Printf.sprintf
           "%s %s"
           (make_log_tag "warning" 3)
           message)
        ~io
      @@ return

    let log_info message ~io return =
      log
        ~level:Info
        (Printf.sprintf "%s %s" (make_log_tag "info" 4) message)
        ~io
      @@ return

    let log_debug message ~io return =
      log
        ~level:Debug
        (Printf.sprintf
           "%s %s"
           (make_log_tag "debug" 5)
           message)
        ~io
      @@ return
  end

  module rec Core : sig
    type t

    (* Plug-and-play *)

    val create
      :  ?task:Task.t
      -> ?input_count:int
      -> io:IO.t
      -> unit
      -> t

    val run
      : 'a.
      ?input:string -> core:t -> unit -> (int -> 'a) -> 'a

    (* High-level API *)

    val init : 'a. core:t -> (t -> 'a) -> 'a
    val request : 'a. core:t -> (string option -> t -> 'a) -> 'a
    val process : 'a. string option -> core:t -> (t -> 'a) -> 'a
    val exit : 'a. core:t -> (int -> 'a) -> 'a

    (* Low-level API *)

    val set_task : 'a. Task.t -> t -> (t -> 'a) -> 'a

    val update_task
      : 'a.
      (Task.t -> Task.t) -> t -> (t -> 'a) -> 'a
  end = struct
    type t =
      { task : Task.t
      ; input_count : int
      ; task_history : Task.t Dynarray.t
      ; io : IO.t
      }

    let create ?(task = Task.Init) ?(input_count = 1) ~io () =
      { task
      ; input_count
      ; task_history = Dynarray.create ()
      ; io
      }

    let ( *> ) = ( let|> )
    let pipeline ~core return = return core

    let set_task task core return =
      Dynarray.add_last core.task_history core.task;
      return { core with task }

    let update_task fn core = set_task (fn core.task) core

    let set_input_count input_count core return =
      return { core with input_count }

    let update_input_count fn core =
      set_input_count (fn core.input_count) core

    let swap_io io core return = return { core with io }

    let perform_io fn ~core return =
      let|> io = fn ~io:core.io in
      swap_io io core @@ return

    let format_value value =
      match (value : Lang.Value.t) with
      | Tt -> None
      | _ -> Some (Lang.Value.format value)

    let print_value value ~core return =
      match (value : Lang.Value.t) with
      | Tt -> return ()
      | _ ->
        print_endline (Lang.Value.format value);
        return ()

    let rec evaluate term ~core return =
      match term with
      | Lang.Term.Tt -> return Lang.Value.Tt
      | String s -> return (String s)
      | Print (term', block) ->
        let|> value = evaluate term' ~core in
        let|> core =
          perform_io (IO.print ~format:format_value value) ~core
        in
        evaluate block ~core @@ return

    let init ~core return =
      let|> core = perform_io IO.init ~core in
      let|> core =
        perform_io (IO.print_string "Welcome to Chell.") ~core
      in
      set_task Request core @@ return

    let request ~core return =
      let|> core =
        perform_io
          (IO.print_string
             ~ending:None
             (Printf.sprintf "[%d] > " core.input_count))
          ~core
      in
      let||> (input, io) = IO.read_line ~io:core.io in
      pipeline ~core
      *> swap_io io
      *> set_task Process
      *> return input

    let process input ~core return =
      match input with
      | None -> set_task Exit core @@ return
      | Some "#state" ->
        print_endline
          (Printf.sprintf
             "Previous tasks: %s"
             (core.task_history
              |> Dynarray.to_list
              |> List.map Task.format
              |> String.concat ", "));
        print_endline
          (Printf.sprintf
             "Current task: %s"
             (Task.format core.task));
        pipeline ~core
        *> set_task Request
        *> update_input_count (( + ) 1)
        *> return
      | Some raw_contents ->
        print_endline "todo!";
        pipeline ~core
        *> set_task Request
        *> update_input_count (( + ) 1)
        *> return

    let exit ~core return =
      let|> core =
        perform_io (IO.print_string "Goodbye!") ~core
      in
      let|> _ = perform_io IO.uninit ~core in
      return 0

    let rec run ?input ~core () return =
      match core.task with
      | Init ->
        let|> core = init ~core in
        run ~core () @@ return
      | Request ->
        let||> (input, core) = request ~core in
        run ?input ~core () @@ return
      | Process ->
        let|> core = process input ~core in
        run ~core () @@ return
      | Exit ->
        let|> exit_code = exit ~core in
        return exit_code
  end

  let run return =
    let io = IO.create () in
    let core = Core.create ~io () in
    let|> exit_code = Core.run ~core () in
    return exit_code
end

let () = exit (Shell.run Fun.id)