fixed width record reading and writing

fixed-width-record.lisp

(defpackage :fixed-width-record
  (:use :cl)
  (:export #:define-format
           #:write*
           #:read*
           #:field-parse-error
           #:create-table
           #:insert-record))

(in-package :fixed-width-record)

(define-condition field-parse-error (error)
  ((error :initarg :error)
   (file-position :initarg :file-position)
   (field-name :initarg :field-name)
   (field-start :initarg :field-start)
   (field-end :initarg :field-end)
   (field-value :initarg :field-value)
   (picture :initarg :picture))
  (:report (lambda (c stream)
             (with-slots (error file-position field-name field-value field-start field-end picture) c
               (format stream "could not parse field ~A picture ~A value ~S at ~D-~D, file position ~A: ~A"
                       field-name picture field-value field-start field-end file-position error)))))

(defun daynum-of-year (timestamp)
  (floor (1+ (/ (local-time:timestamp-difference timestamp (local-time:timestamp-minimize-part timestamp :month)) (* 24 60 60)))))

(defgeneric field-type-default (type))
(defgeneric field-writer (type))
(defgeneric field-reader (type))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun picture-symbol (picture)
    (intern (string picture) :fixed-width-record)))

(defmacro define-field-type (picture &key default-value formatter reader db-type)
  ;; This macro is a bit nasty because it is unhygienic to make using
  ;; it more terse.  The argument names of the generated methods are
  ;; captured, and the db-type keyword argument uses unusual (lack of)
  ;; quoting.
  (let ((picture (picture-symbol picture)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defmethod field-type-default ((type (eql ',picture)))
         ',default-value)
       (defmethod field-writer ((type (eql ',picture)))
         ',(or formatter
               (error "no :formatter for picture ~A" picture)))
       (defmethod field-reader ((type (eql ',picture)))
         ',reader)
       (defmethod field-db-type ((type (eql ',picture)) length)
         (declare (ignorable length))
         ,(if (listp db-type)
              `(list ',(first db-type) ,(second db-type))
              `',db-type)))))

(define-field-type N
    :default-value 0
  :formatter (if (numberp value)
                 (format stream "~V,'0D" length value)
                 (error "~A is not a number" value))
  :reader (parse-number:parse-number buffer)
  :db-type (integer length))

(define-field-type A
    :default-value ""
  :formatter (format stream "~VA" length value)
  :reader (string-right-trim '(#\Space) buffer)
  :db-type (string length))

(define-field-type AN
    :default-value ""
  :formatter (format stream "~VA" length value)
  :reader (string-right-trim '(#\Space) buffer)
  :db-type (string length))

(define-field-type CCYYJJJHHMMSS
    :default-value (local-time:now)
  :formatter (format stream "~4,'0D~3,'0D~2,'0D~2,'0D~2,'0D"
                     (local-time:timestamp-year value)
                     (daynum-of-year value)
                     (local-time:timestamp-hour value)
                     (local-time:timestamp-minute value)
                     (local-time:timestamp-second value))
  :reader (local-time:timestamp+ (local-time:encode-timestamp 0
                                                              (parse-integer (subseq buffer 11 13))
                                                              (parse-integer (subseq buffer 9 11))
                                                              (parse-integer (subseq buffer 7 9))
                                                              1
                                                              1
                                                              (parse-integer (subseq buffer 0 4)))
                                 (1- (parse-integer (subseq buffer 4 7)))
                                 :day)
  :db-type time)

(define-field-type MMDDCCYY
    :default-value (local-time:today)
  :formatter (format stream "~2,'0D~2,'0D~4,'0D"
                     (local-time:timestamp-month value)
                     (local-time:timestamp-day value)
                     (local-time:timestamp-year value))
  :reader (local-time:encode-timestamp 0 0 0 0
                                       (parse-integer (subseq buffer 2 4))
                                       (parse-integer (subseq buffer 0 2))
                                       (parse-integer (subseq buffer 4 8)))
  :db-type date)

(define-field-type YYYYMMDD
    :default-value (get-universal-time)
  :formatter (format stream "~4,'0D~2,'0D~2,'0D"
                     (local-time:timestamp-year value)
                     (local-time:timestamp-month value)
                     (local-time:timestamp-day value))
  :reader (local-time:encode-timestamp 0 0 0 0
                                       (parse-integer (subseq buffer 6 8))
                                       (parse-integer (subseq buffer 4 6))
                                       (parse-integer (subseq buffer 0 4)))
  :db-type date)

(define-field-type CCYYMM
    :default-value (get-universal-time)
  :formatter (format stream "~4,'0D~2,'0D"
                     (local-time:timestamp-year value)
                     (local-time:timestamp-month value))
  :reader (local-time:encode-timestamp 0 0 0 0
                                       1
                                       (parse-integer (subseq buffer 4 6))
                                       (parse-integer (subseq buffer 0 4)))
  :db-type date)

(define-field-type S
    :formatter (write-char #\Newline stream))

(define-field-type CRLF
    :formatter (progn (write-char #\Return)
                      (write-char #\Linefeed)))

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun constant-field-p (name picture)
    (or (string-equal name 'filler)
        (string-equal name 'reserved)
        (member picture '(S CRLF))))

  (defun fields-to-slots (fields)
    (remove nil
            (mapcar (lambda (field-definition)
                      (destructuring-bind (name start end picture &key (value nil value-provided-p)) field-definition
                        (declare (ignore start end))
                        (let ((picture (picture-symbol picture)))
                          (unless (constant-field-p name picture)
                            `(,name :initarg ,(intern (string name) :keyword)
                                    :reader ,name
                                    :initform ,(if value-provided-p value (field-type-default picture)))))))
                    fields)))

  (defun fields-to-writer (fields)
    (mapcar (lambda (field-definition)
              (destructuring-bind (name start end picture &key value) field-definition
                (declare (ignore value))
                (let ((picture (picture-symbol picture)))
                  `(let ((value ,(cond
                                   ((string-equal name 'filler) (if (string-equal picture 'N) 0 ""))
                                   ((string-equal name 'reserved) (if (string-equal picture 'N) 0 ""))
                                   ((string-equal picture 'S) #\Newline)
                                   (t `(slot-value record ',name))))
                         (length ,(1+ (- end start))))
                     (declare (ignorable value length))
                     ,(field-writer picture)))))
            fields))

  (defun fields-to-reader (fields)
    (let ((record-length (third (car (last fields)))))
      `(let ((buffer (make-string ,record-length)))
         (unless (= ,record-length (read-sequence buffer stream))
           (error 'end-of-file :stream stream))
         (let (field-name field-start field-end field-value picture file-position)
           (handler-case
               (progn ,@(mapcar (lambda (field-definition)
                                  (destructuring-bind (name start end picture &key value) field-definition
                                    (declare (ignore value))
                                    (let ((picture (picture-symbol picture)))
                                      (unless (constant-field-p name picture)
                                        `(let ((buffer (subseq buffer ,(1- start) ,end)))
                                           (setf field-name ',name
                                                 field-start ,start
                                                 field-end ,end
                                                 picture ',picture
                                                 field-value buffer
                                                 file-position (file-position stream)
                                                 (slot-value object ',name) ,(field-reader picture)))))))
                                fields))
             (error (e)
               (error 'field-parse-error
                      :error e
                      :field-name field-name
                      :field-start field-start
                      :field-end field-end
                      :field-value field-value
                      :picture picture
                      :file-position file-position)))))))

  (defun check-field-consistency (record-name field-definitions)
    (let ((position 1))
      (dolist (field-definition field-definitions)
        (destructuring-bind (field-name start end picture &key value) field-definition
          (declare (ignore picture value))
          (unless (= start position)
            (warn "field ~A in ~A unexpectedly starts at position ~A, ~A expected"
                  field-name record-name start position))
          (setf position (1+ end))))))
  
  (defun fields-to-column-definitions (fields)
    (remove nil
            (mapcar (lambda (field-definition)
                      (destructuring-bind (field-name start end picture &key value) field-definition
                        (declare (ignore value))
                        (let ((picture (picture-symbol picture)))
                          (unless (constant-field-p field-name picture)
                            `(,field-name :type ,(field-db-type picture (1+ (- end start))))))))
                    fields)))

  (defun make-db-methods (record-name options fields)
    (destructuring-bind (&key db-table &allow-other-keys) options
      `(progn
         (defmethod create-table ((table-name (eql ',db-table)))
           (pomo:execute (:create-table ,db-table
                                        ,(fields-to-column-definitions fields))))
         (defmethod insert-record (table-name (record ,record-name))
           (pomo:execute (:insert-into ',db-table
                          :set ,@(remove nil
                                         (mapcan (lambda (field-definition)
                                                   (destructuring-bind (field-name start end picture &key value) field-definition
                                                     (declare (ignore start end value))
                                                     (let ((picture (picture-symbol picture)))
                                                       (unless (constant-field-p field-name picture)
                                                         `(',field-name (,field-name record))))))
                                                 fields)))))))))

(defgeneric write-record (record stream))
(defgeneric read* (record-class-name stream))

(defgeneric create-table (table-name))
(defgeneric insert-record (table-name record))

(defmacro define-format (name options &rest fields)
  (check-field-consistency name fields)
  (destructuring-bind (&key db-table) options
    `(progn
       (defclass ,name ()
         ,(fields-to-slots fields))
       (defmethod write-record ((record ,name) stream)
         ,@(fields-to-writer fields))
       (defmethod read* ((class (eql ',name)) stream)
         (let ((object (make-instance ',name)))
           ,(fields-to-reader fields)
           object))
       ,@(when db-table
           (list (make-db-methods name options fields))))))

(defun write* (stream class-name &rest initargs &key &allow-other-keys)
  (write-record (apply #'make-instance class-name initargs) stream))