#!/bin/sh
#| -*- scheme -*-
exec guile -e main -s "$0" "$@"

Flat Fuck Format
--- a new configuration format, because who doesn't need that?

Copyright (C) 2023 Case Duckworth <acdw@acdw.net>

Everyone is permitted to do whatever with this software, without
limitation.  This software comes without any warranty whatsoever,
but with two pieces of advice:

- Don't hurt yourself.
- Make good choices.

Commentary:

This script will convert files defined in the Flat Fuck Format (fff) into json.
It will not convert anything back to fff.  fff is explicitly made to be as
simple as possible, and exclusively human-written.  If a machine writes your
configuration, ... use a better configuration format.  Or make your program
scriptable!

FLAT FUCK FORMAT : Specification
|#
!#


;;; Format

(use-modules (ice-9 peg))

;;; Structure

(define-peg-pattern fff all
  (and (* (or WHITESPACE NEWLINE))
       (* (or comment
              object
              array
              object-item))
       blanks
       (not-followed-by peg-any)))

(define-peg-pattern object all
  (and name
       (+ object-item)
       blanks))

(define-peg-pattern array all
  (and name
       (+ array-item)
       blanks))

(define-peg-pattern anon all
  (and (+ object-item)
       blanks))

;; (define-peg-pattern anon-array all
;;   (and (+ array-item)
;;        (* NEWLINE)))

(define-peg-pattern name body
  (and key COLON COLON NEWLINE))

(define-peg-pattern object-item body
  (and key (* WHITESPACE)
       COLON (* WHITESPACE)
       (or ref val)
       blanks))

(define-peg-pattern array-item body
  (and (* WHITESPACE)
       COLON (* WHITESPACE)
       (or ref val)
       blanks))

(define-peg-pattern key body
  (+ (and (not-followed-by COLON)
          NONEWLINE)))

;; (define-peg-pattern key body
;;   key-raw)

(define-peg-pattern val all
  (* NONEWLINE))

(define-peg-pattern ref all
  (and AT key))

;;; Comments

(define-peg-pattern comment none
  (and HASH (* WHITESPACE)
       (* (and (not-followed-by NEWLINE)
               peg-any))
       blanks))

(define-peg-pattern blanks none
  (* NEWLINE))

;;; Escaped characters

(define-peg-pattern escaped body
  (and BACKSLASH (or (and NEWLINE (* WHITESPACE))
                     peg-any)))

;;; Terminals

(define-peg-pattern BACKSLASH none
  "\\")

(define-peg-pattern COLON none
  ":")

(define-peg-pattern NEWLINE none
  "\n")

(define-peg-pattern WHITESPACE none
  (or " " "\t"))

(define-peg-pattern NONEWLINE body
  (or escaped
      (and (not-followed-by NEWLINE)
           peg-any)))

(define-peg-pattern HASH none
  "#")

(define-peg-pattern AT none
  "@")


;;; Serialization
;; I want fff to serialize to a structure that's compatible with the structure
;; guile-json uses ( https://github.com/aconchillo/guile-json )

(use-modules (ice-9 exceptions)
             (ice-9 match))

(define (fff? x)
  (and (pair? x)
       (eq? (car x) 'fff)))

;; (define (car-safe x)
;;   (if (pair? x)
;;       (car x)
;;       #f))

;; (define (fff-tree->scm tree)
;;   (let loop ((rest (cdr tree))
;;              (accum '()))
;;     (if (null? rest)
;;         (reverse accum)
;;         (let ((this (match (car rest)
;;                       (`(anon . ,obj)
;;                        (cons 'anon (fff-object->scm obj)))
;;                       (`(object  ,name ,obj)
;;                        (cons (cons 'obj name) (fff-object->scm obj)))
;;                       (`(array ,name ,arr)
;;                        (cons (cons 'arr name) (fff-array->scm arr))))))
;;           (loop (cdr rest) (cons this accum))))))

(define (fff->scm str)
  (let ((fff (peg:tree
              (match-pattern fff str))))
    (if fff
        (fff/refs->scm (fff->scm/refs fff))
        #f)))

(define (fff->scm/refs tree)
  (let loop ((xs (cdr tree))
             (it '()))
    (if (null? xs)
        (reverse it)
        (loop (cdr xs)
              (match (car xs)
                ;; (`(anon . ,obj)
                ;;  ;; Because of how peg's parsing works it collapses one-element
                ;;  ;; lists, necessitating this check.
                ;;  (if (pair? (car obj))
                ;;      ;; We could use `map-in-order', but according to JSON the
                ;;      ;; order of an object's keys doesn't matter ....
                ;;      (append (map fff-pair->scm obj) it)
                ;;      (cons (fff-pair->scm obj) it)))
                (`(array ,name ,vals)
                 (cons (cons name
                             (list->vector (map fff-val->scm vals)))
                       it))
                (`(object ,name ,pairs)
                 (cons (cons name
                             (map fff-pair->scm pairs))
                       it))
                (`(item . ,pair)
                 (cons (fff-pair->scm pair)
                       it))
                (_ it))))))

(define (fff-val->scm val)
  (match val
    (`(val ,v) v)
    (`(ref ,r) (lambda (alist)
                 (assoc-ref alist r)))))

(define (fff-pair->scm pair)
  (cons (cdr pair) (fff-val->scm (cadr pair))))

(define (atom? x)
  (and (not (null? x))
       (not (pair? x))))

(define (fff/refs->scm tree)
  (define dupes '())
  (filter (lambda (x)
            (not (member (car x) dupes)))
          (let loop ((xs tree)
                     (it '())
                     (v? #f))
            (if (null? xs)
                ((if v? list->vector identity) (reverse it))
                (loop (cdr xs)
                      (cons (let ((x (car xs)))
                              (cond
                               ((atom? x)
                                x)
                               ((procedure? (cdr x))
                                (set! dupes (cons (car x) dupes))
                                (cons (car x)
                                      ((cdr x) tree)))
                               ((atom? (cdr x))
                                x)
                               ((vector? (cdr x))
                                (cons (car x)
                                      (loop (vector->list (cdr x)) '() #t)))
                               (else
                                (cons (car x)  ; still not tail-recursive!
                                      (loop (cdr x) '() #f)))))
                            it)
                      v?)))))

;; (define (ref-resolve tree)
;;   (map (lambda (x)
;;          (display x)
;;          (cond
;;           ((atom? x)
;;            (display ": atom\n")
;;            x)
;;           ((procedure? (cdr x))
;;            (display " (cdr): procedure\n")
;;            (cons (car x) ((cdr x) )))
;;           ((atom? (cdr x))
;;            (display " (cdr): atom\n")
;;            x)
;;           (else ; not tail-recursive!
;;            (display " ...\n")
;;            (cons (car x) (ref-resolve (cdr x))))))
;;        tree))

;; (define (fff-object->scm obj)
;;   (let loop ((rest obj)
;;              (accum '()))
;;     (if (null? rest)
;;         (reverse accum)
;;         (let* ((this (car rest))
;;                (k (car (assq-ref this 'key)))
;;                (v (car-safe (assq-ref this 'val)))
;;                (r (assq-ref this 'ref)))
;;           (loop (cdr rest)
;;                 (cons (cond
;;                        (v (cons k v))
;;                        (r (cons 'ref (cons k r)))
;;                        (else 'fuck))
;;                       accum))))))

;; (define (fff-array->scm arr)
;;   (let loop ((rest arr)
;;              (accum '()))
;;     (if (null? rest)
;;         (list->vector (reverse accum))
;;         (let* ((this (car rest)))
;;           (loop (cdr rest)
;;                 (cons (case (car this)
;;                         ((val) (cadr this))
;;                         ((ref) this))
;;                       accum))))))


;;; Testing

(use-modules (ice-9 textual-ports))

(define test-input
  (call-with-input-file "/home/case/var/fff.fff" get-string-all))

(define test-input2
  "
a: 1
b:2

c:3

d::
da: 10
db: 20

e::
: 30
:40
:     50

f::
z: @d
y: @a

g::
f: @f
another one: @f
")

(use-modules (ice-9 format))

(define (test-parse input)
  (let loop ((str "")
             (num 0)
             (lst (string-split input #\newline)))
    (if (or (null? lst)
            (not (match-pattern fff str)))
        (format #t "~s~%" lst)
        (begin
          ;; (display (peg:tree (match-pattern fff str)))
          (format #t "~s~%" (match-pattern fff str))
          (when (match-pattern fff str)
            (format #t "~s~%~%" (car lst)))
          (loop (string-append str "\n" (car lst))
                (+ num 1)
                (cdr lst))))))


;;; Notes

#|
allow only `key:value` or named objects (list::..., dict::...)
put everything in a big object/dict
resolve references: fff string => list with refs (lambdas ?) => resolved list
|#