misc-code/config-parser.lisp

;;;; config-parser.lisp

#+quicklisp (ql:quickload :parse-number)

(defpackage #:config-parser
  (:use :esrap
        :cl)
  (:import-from #:parse-number
                #:parse-number)
  (:export open-configuration-file
           write-configuration-file))

(in-package #:config-parser)


;;; "config-parser" goes here. Hacks and glory await!

(defrule space
    (+ (or #\Space #\Tab #\Newline))
  (:constant nil))

(defrule identifier
    (* (or (alphanumericp character) "_" "-" "."))
  (:text t)
  (:lambda (identifier)
    (intern (string-upcase identifier) "KEYWORD")))

(defun not-doublequote (character)
  (not (eql #\" character)))

(defrule string-chars
    (or (not-doublequote character)
       (and #\\ #\")))

(defrule string
    (and #\" (* string-chars) #\")
  (:destructure (sq string eq)
                (declare (ignore sq eq))
                (text string)))

(defrule number
    (and (? (or "-" "+"))
       (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
       (? (and "."
             (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))))
       (? (and (or "e" "E")
             (? "-")
             (+ (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9")))))
  (:text t)
  (:lambda (num-string)
    (parse-number num-string)))

(defrule block-title
    (and (? #\Newline) "[" (? space) identifier (? space) "]" (? #\Newline))
  (:destructure (nl1 lb sp1 ident sp2 rb nl)
                (declare (ignore nl1 lb sp1 sp2 rb nl))
                ident))

(defrule ident-path
    (and identifier (? space) "/" (? space) identifier)
  (:destructure (identa sp1 sep sp2 identb)
                (declare (ignore sp1 sep sp2))
                (list identa identb)))

(defrule variable-expression
    (and identifier (? space) "=" (? space) (or string number ident-path) (? #\Newline))
  (:destructure (identifier sp1 eq sp2 value nl)
                (declare (ignore sp1 eq sp2 nl))
                (list identifier value)))

(defrule block-contents
    (* variable-expression)
  (:lambda (expressions)
    (loop for expression in expressions
       append expression)))

(defrule block
    (and block-title block-contents)
  (:destructure (title contents)
                (list title contents)))

(defrule file
    (* block)
  (:lambda (blocks)
    (loop for block in blocks
       append block)))

(defun open-configuration-file (filename)
  (parse 'file
         (concatenate 'string
                      (with-open-file (input-file filename)
                        (loop for char = (read-char input-file nil 'foo)
                           until (eq char 'foo)
                           collect char)))))

(defun write-identifier (identifier alist stream)
  (format stream "~a" (getf alist identifier)))

(defun write-string-out (string stream)
  (format stream "\"~a\"" string))

(defun write-block-title (identifier alist stream)
  (format stream "~%[")
  (write-identifier identifier alist stream)
  (format stream "]~&"))

(defun write-path (id1 id2 alist stream)
  (write-identifier id1 alist stream)
  (format stream "/")
  (write-identifier id2 alist stream))

(defun write-expression (lhs rhs alist stream)
  (format stream "~&")
  (write-identifier lhs alist stream)
  (format stream " = ")
  (if (typep rhs 'string)
      (write-string-out rhs stream)
      (if (typep rhs 'list)
          (write-path (car rhs) (cadr rhs) alist stream)
          (format stream "~a" rhs)))
  (format stream "~&"))

(defun write-correct (stream alist toplevel-p config-list)
  (if toplevel-p
      (if (listp (car config-list))
          (write-correct stream alist nil (cdr config-list))
          (write-block-title (car config) alist stream))
      (loop for (lhs rhs) in config-list
           do (write-expression lhs rhs alist config-list))))

(defun write-configuration-file (filename config key-to-text-alist)
  (with-open-file (output-file filename :direction :output :if-exists :overwrite :if-does-not-exist :create)
      (write-correct output-file key-to-text-alist t config)))