logfuck toplevel

README.md

dirty untested logfuck implementation in OCaml

how to run

availability: unix only

git clone git@gist.github.com:de628cd8c419daff8ab5333833739bce logfuck
cd logfuck
ocaml -I +unix unix.cma Logfuck.ml

Logfuck.ml

let get_char () =
  let attr = Unix.tcgetattr Unix.stdin in
  let () =
    Unix.tcsetattr
      Unix.stdin
      Unix.TCSADRAIN
      { attr with Unix.c_icanon = false }
  in
  let res = input_byte stdin in
  Unix.tcsetattr Unix.stdin Unix.TCSADRAIN attr;
  Int32.of_int res
;;

let ( let+ ) = Option.bind

module Binary_tree = struct
  type t =
    { mutable value : int32
      (* we don't have 16 bits integers :( *)
    ; mutable parent : t ref option
    ; mutable left : t option
    ; mutable right : t option
    }

  let create ?parent ?left ?right (value : int32) =
    { value; parent; left; right }
  ;;
end

module State = struct
  type nonrec t = Binary_tree.t ref

  let create () : t = ref (Binary_tree.create 0l)

  let mask ~(state : t) =
    !state.value <- Int32.logand !state.value 0xffl
  ;;

  let go_up ~(state : t) : unit =
    match !state.parent with
    | None -> ()
    | Some parent -> state := !parent
  ;;

  let go_left ~(state : t) : unit =
    let left =
      match !state.left with
      | None ->
        let child = Binary_tree.create ~parent:state 0l in
        !state.left <- Some child;
        child
      | Some child -> child
    in
    state := left
  ;;

  let go_right ~(state : t) : unit =
    let right =
      match !state.right with
      | None ->
        let child = Binary_tree.create ~parent:state 0l in
        !state.right <- Some child;
        child
      | Some child -> child
    in
    state := right
  ;;

  let pop_lowest_bit ~(state : t) : unit =
    !state.value <- Int32.shift_right_logical !state.value 1;
    mask ~state
  ;;

  let get_low_byte ~(state : t) : int32 =
    Int32.logand !state.value 0x7fl
  ;;

  let get_lowest_bit ~(state : t) : bool =
    let masked = Int32.logand (get_low_byte ~state) 1l in
    if masked = 0l then false else true
  ;;

  let read_byte ~(state : t) : unit =
    let raw_byte = get_char () in
    if raw_byte = 4l
    then !state.value <- 0xFFFEl
    else !state.value <- raw_byte
  ;;

  let shift_in ~(state : t) (bit : bool) : unit =
    !state.value <- Int32.(add (shift_left !state.value 1) 1l);
    mask ~state
  ;;
end

type nonrec token_type =
  | Caret
  | Less
  | Greater
  | Lowercase_v
  | Dot
  | Comma
  | Bracket_left
  | Bracket_right
  | Semicolon
  | Paren_left
  | Paren_right
  | Zero
  | One
  | Eof

type nonrec token =
  { ty : token_type
  ; lexeme : char
  }

type parse_tree =
  | Parent
  | Descent_left
  | Descent_right
  | Pop_lowest
  | Print_byte
  | Input_byte
  | Branch of parse_tree * parse_tree
  | Execute of parse_tree
  | Shift_in of bool

type program = parse_tree list

module Tokenizer = struct
  type t =
    { source : string
    ; mutable current : int
    }

  let create ~source = { source; current = 0 }

  let is_at_end tokenizer =
    tokenizer.current >= String.length tokenizer.source
  ;;

  let peek tokenizer =
    if is_at_end tokenizer
    then None
    else Some tokenizer.source.[tokenizer.current]
  ;;

  let advance tokenizer =
    tokenizer.current <- tokenizer.current + 1
  ;;

  let consume tokenizer =
    let+ char = peek tokenizer in
    advance tokenizer;
    Some char
  ;;

  let make_token tokenizer ty : token =
    { ty; lexeme = tokenizer.source.[tokenizer.current - 1] }
  ;;

  let rec scan_token tokenizer =
    match consume tokenizer with
    | None -> make_token tokenizer Eof
    | Some '^' -> make_token tokenizer Caret
    | Some '<' -> make_token tokenizer Less
    | Some '>' -> make_token tokenizer Greater
    | Some 'v' -> make_token tokenizer Lowercase_v
    | Some '.' -> make_token tokenizer Dot
    | Some ',' -> make_token tokenizer Comma
    | Some '[' -> make_token tokenizer Bracket_left
    | Some ']' -> make_token tokenizer Bracket_right
    | Some ';' -> make_token tokenizer Semicolon
    | Some '(' -> make_token tokenizer Paren_left
    | Some ')' -> make_token tokenizer Paren_right
    | Some '0' -> make_token tokenizer Zero
    | Some '1' -> make_token tokenizer One
    | Some _ -> scan_token tokenizer
  ;;

  let scan tokenizer =
    let rec tailrec tokenizer acc =
      if is_at_end tokenizer
      then List.rev acc
      else tailrec tokenizer (scan_token tokenizer :: acc)
    in
    tailrec tokenizer []
  ;;
end

module Parser = struct
  type t =
    { tokens : token list
    ; mutable current : int
    }

  let create ~tokens = { tokens; current = 0 }
  let peek parser = List.nth_opt parser.tokens parser.current

  let is_at_end parser =
    match peek parser with
    | None | Some { ty = Eof } -> true
    | _ -> false
  ;;

  let advance parser = parser.current <- parser.current + 1

  let consume parser =
    let+ token = peek parser in
    advance parser;
    Some token
  ;;

  let consume_unsafe parser =
    match consume parser with
    | None -> failwith "unreachable"
    | Some token -> token
  ;;

  let expect func parser =
    let+ token = consume parser in
    if func token.ty then Some token else None
  ;;

  let rec parse_expr parser : parse_tree option =
    let token = consume_unsafe parser in
    match token.ty with
    | Caret -> Some Parent
    | Less -> Some Descent_left
    | Greater -> Some Descent_right
    | Lowercase_v -> Some Pop_lowest
    | Dot -> Some Print_byte
    | Comma -> Some Input_byte
    | Bracket_left -> parse_branch parser
    | Paren_left -> parse_execute parser
    | Zero -> Some (Shift_in false)
    | One -> Some (Shift_in true)
    | Semicolon | Bracket_right | Paren_right | Eof -> None

  and parse_branch parser : parse_tree option =
    let+ left = parse_expr parser in
    let+ _ = expect (fun ty -> ty = Semicolon) parser in
    let+ right = parse_expr parser in
    let+ _ = expect (fun ty -> ty = Bracket_right) parser in
    Some (Branch (left, right))

  and parse_execute parser : parse_tree option =
    let+ subexp = parse_expr parser in
    let+ _ = expect (fun ty -> ty = Paren_right) parser in
    Some (Execute subexp)
  ;;

  let parse parser : program option =
    let rec tailrec parser acc =
      if is_at_end parser
      then Some (List.rev acc)
      else
        let+ first = parse_expr parser in
        tailrec parser (first :: acc)
    in
    tailrec parser []
  ;;
end

module Eval = struct
  let rec eval_instruction instruction ~state =
    match instruction with
    | Parent -> State.go_up ~state
    | Descent_left -> State.go_left ~state
    | Descent_right -> State.go_right ~state
    | Pop_lowest -> State.pop_lowest_bit ~state
    | Print_byte ->
      let byte = State.get_low_byte ~state in
      Printf.printf "%c" (Char.chr (Int32.to_int byte))
    | Input_byte -> State.read_byte ~state
    | Branch (a, b) ->
      (match State.get_lowest_bit ~state with
       | false -> eval_instruction a ~state
       | true -> eval_instruction b ~state)
    | Execute a ->
      if !state.value > 0l
      then ()
      else (
        eval_instruction a ~state;
        eval_instruction instruction ~state)
    | Shift_in bit -> State.shift_in ~state bit
  ;;

  let rec eval ?(state = State.create ()) program =
    match program with
    | [] -> ()
    | first :: rest ->
      eval_instruction first ~state;
      eval ~state rest
  ;;
end

module Repl = struct
  let exec_line source =
    let tokenizer = Tokenizer.create ~source in
    let tokens = Tokenizer.scan tokenizer in
    let parser = Parser.create ~tokens in
    match Parser.parse parser with
    | None -> Printf.eprintf "parsing error\n"
    | Some program -> Eval.eval program
  ;;

  let repl () =
    Printf.printf "logfuck - Ctrl+D to quit";
    let rec loop () =
      Printf.printf "\n>>> ";
      match read_line () with
      | line ->
        exec_line line;
        loop ()
      | exception End_of_file -> ()
    in
    loop ()
  ;;
end

let () = Repl.repl ()