(import (chicken base)
        scheme
        (scheme base)
        (chicken foreign)
        (chicken memory)
        (chicken gc)
        (chicken format)
        rfc3339
        coops
        coops-primitive-objects)

(foreign-declare "#include <toml.h>")

(define (zeropad n)
  (if (< n 10)
      (sprintf "0~S" n)
      (sprintf "~S" n)))

(define (set-toml-table-finalizer ttable)
  (set-finalizer! ttable
                  (lambda (obj)
                    ((foreign-lambda* void ((c-pointer ttp))
                       "toml_free(ttp);")
                     (ptr ttable)))))

(define-class <TomlArray> ()
  ((ptr :accessor ptr :initform #f)))

(define-class <TomlTable> ()
  ((ptr :accessor ptr :initform #f)))



(define-method (toml-self-key (tarr <TomlArray>))
  ((foreign-lambda* c-string ((c-pointer tarr))
     "C_return(toml_array_key(tarr));")
   (ptr tarr)))

(define-method (toml-count-entries (tarr <TomlArray>))
  ((foreign-lambda* int ((c-pointer tarr))
     "C_return(toml_array_nelem(tarr));")
   (ptr tarr)))

(define-method (toml-string (tarr <TomlArray>) (index <integer>))
  ((foreign-primitive ((c-pointer tarr)
                       (int index))
       "toml_datum_t datum = toml_string_at(tarr, index);"
     "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
     "C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
     "free(datum.u.s);"
     "C_values(3, data);")
   (ptr tarr) index))

(define-method (toml-bool (tarr <TomlArray>) (index <integer>))
  ((foreign-lambda* bool ((c-pointer tarr)
                          (int index))
     "C_return(toml_bool_at(tarr, index).u.b);")
   (ptr tarr) index))

(define-method (toml-int (tarr <TomlArray>) (index <integer>))
  ((foreign-lambda* int ((c-pointer tarr)
                         (int index))
     "C_return(toml_int_at(tarr, index).u.i);")
   (ptr tarr) index))

(define-method (toml-double (tarr <TomlArray>) (index <integer>))
  ((foreign-lambda* double ((c-pointer tarr)
                            (int index))
     "C_return(toml_double_at(tarr, index).u.d);")
   (ptr tarr) index))

(define-method (toml-timestamp (tarr <TomlArray>) (index <integer>))
  (let*-values (((Y M D h m s millis z)
                 ((foreign-primitive ((c-pointer tarr)
                                      (int index))
                      "toml_datum_t datum = toml_timestamp_at(tarr, index);"
                    "toml_timestamp_t* stamp = datum.u.ts;"
                    "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
                    "C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
                    "C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
                    "C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
                    "C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
                    "C_string2(&s, stamp->z ?: \"Z\") } ;"
                    "free(datum.u.ts);"
                    "C_values(10, data);")
                  (ptr tarr) index))
                ((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
                                   Y (zeropad M) (zeropad D)
                                   (zeropad h) (zeropad m) (zeropad s)
                                   millis z)))
    (string->rfc3339 rfcstr)))

(define-method (toml-array (tarr <TomlArray>) (index <integer>))
  (make <TomlArray> 'ptr
        ((foreign-lambda* c-pointer ((c-pointer tarr)
                                     (int index))
           "C_return(toml_array_at(tarr, index));")
         (ptr tarr) index)))

(define-method (toml-table (tarr <TomlArray>) (index <integer>))
  (make <TomlTable> 'ptr
        ((foreign-lambda* c-pointer ((c-pointer tarr)
                                     (int index))
           "C_return(toml_table_at(tarr, index));")
         (ptr tarr) index)))



(define (table-from-file filename)
  (let ((ttp ((foreign-lambda* c-pointer ((c-string fname))
                "FILE* fp = fopen(fname, \"r\");"
                "char errbuf[200];"
                "toml_table_t* conf = toml_parse_file(fp, errbuf, sizeof(errbuf));"
                "fclose(fp);"
                "C_return(conf);")
              filename)))
    (when (not (eq? ttp 0))
      (let ((tomltable (make <TomlTable> 'ptr ttp)))
        (set-toml-table-finalizer tomltable)
        tomltable))))

(define (table-from-string str)
  (let ((ttp ((foreign-lambda* c-pointer ((c-string confdata))
                "char errbuf[200];"
                "toml_table_t* conf = toml_parse(confdata, errbuf, sizeof(errbuf));"
                "C_return(conf);")
              str)))
    (when (not (eq? ttp 0))
      (let ((tomltable (make <TomlTable> 'ptr ttp)))
        (set-toml-table-finalizer tomltable)
        tomltable))))

(define (set-toml-datum-string-finalizer tdatum)
  (set-finalizer! tdatum
                  (lambda (obj)
                    ((foreign-lambda* void ((c-pointer tdat))
                       "free(tdat);")
                     (ptr tdatum)))))

(define-method (toml-self-key (ttbl <TomlTable>))
  ((foreign-lambda* c-string ((c-pointer ttbl))
     "C_return(toml_table_key(ttbl));")
   (ptr ttbl)))

(define-method (toml-key-exists? (ttbl <TomlTable>) (key <string>))
  (= 1
     ((foreign-lambda* int ((c-pointer ttbl)
                            (c-string key))
        "C_return(toml_key_exists(ttbl, key));")
      (ptr ttbl) key)))

(define-method (toml-count-key-vals (ttbl <TomlTable>))
  ((foreign-lambda* int ((c-pointer ttbl))
     "C_return(toml_table_nkval(ttbl));")
   (ptr ttbl)))

(define-method (toml-count-arrays (ttbl <TomlTable>))
  ((foreign-lambda* int ((c-pointer ttbl))
     "C_return(toml_table_narr(ttbl));")
   (ptr ttbl)))

(define-method (toml-count-tables (ttbl <TomlTable>))
  ((foreign-lambda* int ((c-pointer ttbl))
     "C_return(toml_table_ntab(ttbl));")
   (ptr ttbl)))

(define-method (toml-key-at (ttbl <TomlTable>) (index <integer>))
  ((foreign-lambda* c-string ((c-pointer ttbl)
                              (int index))
     "C_return(toml_key_in(ttbl, index));")
   (ptr ttbl) index))

(define-method (toml-string (ttbl <TomlTable>) (key <string>))
  ((foreign-primitive ((c-pointer ttbl)
                       (c-string key))
       "toml_datum_t datum = toml_string_in(ttbl, key);"
     "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(datum.u.s)));"
     "C_word data[3] = { C_SCHEME_UNDEFINED, C_k, C_string2(&s, datum.u.s) };"
     "free(datum.u.s);"
     "C_values(3, data);")
   (ptr ttbl) key))

(define-method (toml-bool (ttbl <TomlTable>) (key <string>))
  ((foreign-lambda* bool ((c-pointer ttbl)
                          (c-string key))
     "C_return(toml_bool_in(ttbl, key).u.b);")
   (ptr ttbl) key))

(define-method (toml-int (ttbl <TomlTable>) (key <string>))
  ((foreign-lambda* int ((c-pointer ttbl)
                         (c-string key))
     "C_return(toml_int_in(ttbl, key).u.i);")
   (ptr ttbl) key))

(define-method (toml-double (ttbl <TomlTable>) (key <string>))
  ((foreign-lambda* double ((c-pointer ttbl)
                            (c-string key))
     "C_return(toml_double_in(ttbl, key).u.d);")
   (ptr ttbl) key))

(define-method (toml-timestamp (ttbl <TomlTable>) (key <string>))
  (let*-values (((Y M D h m s millis z)
                 ((foreign-primitive ((c-pointer ttbl)
                                      (c-string key))
                      "toml_datum_t datum = toml_timestamp_in(ttbl, key);"
                    "toml_timestamp_t* stamp = datum.u.ts;"
                    "C_word* s = C_alloc(C_SIZEOF_STRING(strlen(stamp->z ?: \"Z\")));"
                    "C_word data[10] = { C_SCHEME_UNDEFINED, C_k, "
                    "C_fix(stamp->year ? *stamp->year : 0), C_fix(stamp->month ? *stamp->month : 0), C_fix(stamp->day ? *stamp->day : 0), "
                    "C_fix(stamp->hour ? *stamp->hour : 0), C_fix(stamp->minute ? *stamp->minute : 0),"
                    "C_fix(stamp->second ? *stamp->second : 0), C_fix(stamp->millisec ? *stamp->second : 0), "
                    "C_string2(&s, stamp->z ?: \"Z\") } ;"
                    "free(datum.u.ts);"
                    "C_values(10, data);")
                  (ptr ttbl) key))
                ((rfcstr) (sprintf "~A-~A-~AT~A:~A:~A.~A~A"
                                   Y (zeropad M) (zeropad D)
                                   (zeropad h) (zeropad m) (zeropad s)
                                   millis z)))
    (string->rfc3339 rfcstr)))

(define-method (toml-array (ttbl <TomlTable>) (key <string>))
  (make <TomlArray> 'ptr
        ((foreign-lambda* c-pointer ((c-pointer ttbl)
                                     (c-string key))
           "C_return(toml_array_in(ttbl, key));")
         (ptr ttbl) key)))

(define-method (toml-table (ttbl <TomlTable>) (key <string>))
  (make <TomlTable> 'ptr
        ((foreign-lambda* c-pointer ((c-pointer ttbl)
                                     (c-string key))
           "C_return(toml_table_in(ttbl, key));")
         (ptr ttbl) key)))