;;; u8.scm -- Guile-SMC functional u8 binary context for FSMs.

;; Copyright (C) 2023 Artyom V. Poptsov <poptsov.artyom@gmail.com>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; The program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with the program.  If not, see <http://www.gnu.org/licenses/>.


;;; Commentary:

;; This file contains functional u8 binary port context for finite-state
;; machines.  This context helps to read and parse a stream of bytes from a
;; specified port.


;;; Code:

(define-module (smc context functional u8)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 binary-ports)
  #:use-module (smc core common)
  #:use-module (smc core log)
  #:export (<u8-context>
            u8-context?
            make-u8-context

            context-debug-mode?
            context-debug-mode-set
            context-port

            context-counter
            context-counter-set
            context-counter-update
            context-buffer
            context-buffer/reversed
            context-buffer-set
            context-stanza
            context-stanza/reversed
            context-stanza-set
            context-result
            context-result/reversed
            context-result-set
            context-custom-data
            context-custom-data-set

            ;; Event source.
            next-u8

            ;; Guards.
            buffer-empty?
            stanza-empty?
            result-empty?

            ;; Actions.
            pre-action
            clear-buffer
            clear-stanza
            clear-result
            reverse-buffer
            reverse-stanza
            reverse-result
            push-event-to-buffer
            push-event-to-stanza
            push-event-to-result
            push-buffer-to-stanza
            push-stanza-to-result
            pop-buffer
            pop-stanza
            pop-result
            update-counter
            throw-syntax-error

            ;; Logging procedures
            context-log-error
            context-log-warning
            context-log-info
            context-log-debug

            ;; Low-level procedures.
            %make-u8-context))



(define-immutable-record-type <u8-context>
  (%make-u8-context debug-mode?
                    port
                    counter
                    buffer
                    stanza
                    result
                    custom-data)
  u8-context?

  ;; Flag that specifies whether the debug mode for the context is enabled.
  ;;
  ;; <boolean>
  (debug-mode? context-debug-mode? context-debug-mode-set)

  ;; Context port that is used to read the data.
  ;;
  ;; <port>
  (port context-port context-port-set)

  ;; Context counter.  Can be used to count incoming events, for example.
  ;;
  ;; <number>
  (counter     context-counter     context-counter-set)

  ;; Context buffer to store intermediate values.
  ;;
  ;; <list>
  (buffer      context-buffer      context-buffer-set)

  ;; Context stanza to store the chunks of intermediate context data.
  ;;
  ;; <list>
  (stanza      context-stanza      context-stanza-set)

  ;; Context result to store the end result of the parser.
  ;;
  ;; <list>
  (result      context-result      context-result-set)

  ;; Context custom data that can be used by the custom contexts to store
  ;; different things such as ports or some data structures.
  (custom-data context-custom-data context-custom-data-set))

(define* (make-u8-context #:key
                            (port (current-input-port))
                            (debug-mode? #f)
                            (counter 0)
                            (buffer '())
                            (stanza '())
                            (result '())
                            (custom-data '()))
  (%make-u8-context debug-mode?
                    port
                    counter
                    buffer
                    stanza
                    result
                    custom-data))



(set-record-type-printer!
 <u8-context>
 (lambda (record port)
   (format port
           "#<u8-context ~a>"
           (object-address/hex-string record))))



(define (context-buffer/reversed context)
  (reverse (context-buffer context)))

(define (context-stanza/reversed context)
  (reverse (context-stanza context)))

(define (context-result/reversed context)
  (reverse (context-result context)))

(define* (context-counter-update context #:key (delta 1))
  (context-counter-set context (+ (context-counter context) delta)))


;;; Guards.

(define* (buffer-empty? context #:optional event)
  (null? (context-buffer context)))

(define* (stanza-empty? context #:optional event)
  (null? (context-stanza context)))

(define* (result-empty? context #:optional event)
  (null? (context-result context)))


;;; Actions.

(define* (clear-buffer context #:optional event)
  "Set the CONTEXT buffer to an empty list.  Return the updated context."
  (context-buffer-set context '()))

(define* (clear-stanza context #:optional event)
  "Set the CONTEXT stanza to an empty list.  Return the updated context."
  (context-stanza-set context '()))

(define* (clear-result context #:optional event)
  "Set the CONTEXT result to an empty list.  Return the updated context."
  (context-result-set context '()))

(define* (update-counter context #:optional event)
  "Update the CONTEXT counter.  Return the updated context."
  (context-counter-update context))

(define* (reverse-buffer context #:optional event)
  (context-buffer-set context (reverse (context-buffer context))))

(define* (reverse-stanza context #:optional event)
  (context-stanza-set context (reverse (context-stanza context))))

(define* (reverse-result context #:optional event)
  (context-result-set context (reverse (context-result context))))

(define (push-event-to-buffer context event)
  "Push an EVENT to the CONTEXT buffer.  Return the updated context."
  (context-buffer-set context (cons event (context-buffer context))))

(define (push-event-to-stanza context event)
  "Push an EVENT to the CONTEXT stanza.  Return the updated context."
  (context-stanza-set context (cons event (context-stanza context))))

(define (push-event-to-result context event)
  "Push an EVENT to the CONTEXT result.  Return the updated context."
  (context-result-set context (cons event (context-result context))))

(define (push-buffer-to-stanza context event)
  "Push the CONTEXT buffer content to the CONTEXT stanza and clear the CONTEXT buffer.
Return the updated context."
  (clear-buffer (context-stanza-set context
                                    (cons (context-buffer context)
                                          (context-stanza context)))
                event))

(define (push-stanza-to-result context event)
  "Push the CONTEXT stanza content to the CONTEXT result and clear the CONTEXT stanza.
Return the updated context."
  (clear-stanza context
                (context-result-set context
                                    (cons (context-stanza context)
                                          (context-result context)))))

(define* (pop-buffer context #:optional event)
  "Remove the last element of CONTEXT buffer.  Return the updated context."
  (context-buffer-set context (cdr (context-buffer context))))

(define* (pop-stanza context #:optional event)
  "Remove the last element of CONTEXT stanza.  Return the updated context."
  (context-stanza-set context (cdr (context-stanza context))))

(define* (pop-result context #:optional event)
  "Remove the last element of CONTEXT result.  Return the updated context."
  (context-result-set context (cdr (context-result context))))

(define* (buffer-empty? context #:optional event)
  (null? (context-buffer context)))

(define* (stanza-empty? context #:optional event)
  (null? (context-stanza context)))

(define* (result-empty? context #:optional event)
  (null? (context-result context)))


;; Event source.

(define (next-u8 context)
  "Event source."
  (get-u8 (context-port context)))



(define (pre-action context byte)
  "Update counters in a character CONTEXT based on an incoming BYTE.
These counters are thrown when a syntax error occurred.  Return the updated
context.

This procedure can be used as a pre-action for an FSM."
  (update-counter context))


;;; Logging.

(define (%current-position-prefix ctx)
  "Make a char context CTX prefix for a log message.  Return the prefix as a
string."
  (format #f
          "~a:~a: "
          (context-port ctx)
          (context-counter ctx)))

(define (context-log-error ctx fmt . rest)
  (apply log-error
         (string-append (%current-position-prefix ctx) fmt)
         rest))

(define (context-log-warning ctx fmt . rest)
  (apply log-warning
         (string-append (%current-position-prefix ctx) fmt)
         rest))

(define (context-log-info ctx fmt . rest)
  (apply log-info
         (string-append (%current-position-prefix ctx) fmt)
         rest))

(define (context-log-debug ctx fmt . rest)
  (apply log-debug
         (string-append (%current-position-prefix ctx) fmt)
         rest))


;;; Error reporting.

(define (throw-syntax-error context u8)
  (error "Syntax error"
         (context-port context)
         (context-counter context)
         u8
         context))

;;; char.scm ends here.
