(library (sph storage dg export)
  (export
    dg-export
    dg-export-files
    dg-export-scm)
  (import
    (guile)
    (rnrs bytevectors)
    (rnrs io simple)
    (rnrs io ports)
    (sph)
    (sph filesystem)
    (sph storage dg)
    (sph storage dg file)
    (sph storage dg one)
    (sph storage dg stream)
    (sph storage dg tag)
    (sph stream)
    (sph vector))

  (define sph-storage-dg-export-description "extract all data (dump)")

  (define* (dg-export txn proc #:optional (buffer-size 15000))
    "dg-txn procedure:{symbol:type any ... -> any} #:buffer-size integer -> unspecified
     call proc for every node and relation in database.
     type: id/intern/extern/intern-small/relation"
    (stream-each proc (dg-node-selection->element-stream (dg-node-select txn #f #f) buffer-size))
    (stream-each proc
      (dg-relation-selection->element-stream (dg-relation-select txn #f #f #f) buffer-size)))

  (define* (dg-export-files txn target #:key mode select map-tag-strings map-name)
    "dg-txn string:path #:mode symbol:copy/symlink/hardlink (string ...) procedure:{id (string ...):tag-strings} -> unspecified
     export only (sph storage dg file) files into a directory.
     dg-tag must have been initialised.
     default mode is copy.
     deletes existing files in target"
    (if (not (pair? dg-tag-intern-tag)) (raise (q dg-tag-not-initialised)))
    (if (not (pair? dg-file-intern-file)) (raise (q dg-file-not-initialised)))
    (and-let*
      ( (target
          (ensure-trailing-slash
            (if (file-exists? target)
              (if (directory? target) target
                (raise (pair (q target-exists-as-non-directory) target)))
              (and (ensure-directory-structure target) target))))
        (copy* (case (or mode (q copy)) ((symlink) symlink) ((copy) copy-file) ((hardlink) link)))
        (files (dg-relation-selection->element-stream (dg-file-all txn) 1500))
        (select (or select (const #t)))
        (map-tag-strings (or map-tag-strings (l (id tag-strings) tag-strings)))
        (map-name (or map-name (l (id name) name))))
      (stream-each
        (l a
          (let* ((id (first a)) (tag-strings (dg-tag-get-string txn a)))
            (if (select id tag-strings)
              (let*
                ( (tag-strings (map-tag-strings id tag-strings))
                  (tag-strings (if (null? tag-strings) (list "other") tag-strings))
                  (name
                    (map-name id
                      (string-append (dg-file-name id) "." (string-join tag-strings "."))))
                  (path (string-append target name)) (source (dg-file-path id)))
                (if (file-exists? path) (delete-file path))
                (if (file-exists? source) (copy* source path))))))
        files)))

  (define* (dg-export-scm txn port #:optional buffer-size)
    "dg-txn port [integer] -> unspecified
     export to port using a scheme syntax format. displays format information at the beginning of output.
     \"symbol integer ...\\n\""
    (put-string port "; node-type node-id [data]\n; \"re\" left label right ordinal\n")
    (dg-export txn
      (l (data)
        (if (= 2 (vector-length data))
          (begin
            ; node
            (let*
              ( (id (vector-first data)) (node-type (string-take (dg-id->type-string id) 2))
                (data (vector-second data)))
              (put-string port node-type) (put-char port #\space)
              (put-datum port id) (put-char port #\space)
              (if (not (and (bytevector? data) (= 0 (bytevector-length data))))
                (put-datum port data))))
          (begin
            ; relation
            (put-string port "re")
            (vector-map (l (a) (put-char port #\space) (put-datum port a)) data)))
        (put-char port #\newline))
      buffer-size)))