(module
 magic-pipes-runtime
 (mpread
  mpwrite
  
  mplog
  mplookup

  dirent?
  ->dirent
  dirent-path
  dirent-inode-number
  dirent-mode
  dirent-number-of-links
  dirent-uid
  dirent-gid
  dirent-size
  dirent-access-time
  dirent-change-time
  dirent-modification-time
  dirent-parent-device-id
  dirent-device-id
  dirent-block-size
  dirent-number-of-blocks
  dirent-link-target
  dirent-type
  dirent-regular-file?
  dirent-directory?
  dirent-fifo?
  dirent-socket?
  dirent-symbolic-link?
  dirent-character-device?
  dirent-block-device?

         )
 (import chicken)
 (import scheme)
 (use extras)
 (use sql-de-lite)
 (use srfi-69)
 (use ports)
 (use irregex)
 (use alist-lib)
 (use srfi-1)
 (use srfi-13)
 (use magic-pipes)

 (: mpread (#!optional input-port -> *))
 (define mpread data-read)

 (: mpwrite (* #!optional output-port -> undefined))
 (define mpwrite data-write)

 (: mplookup-sqlite (string symbol boolean ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            (-> undefined) ;; close
                            ))
 (define (mplookup-sqlite mapfile dupmode reverse)
   (let ((db (open-database mapfile)))
     (with-exclusive-transaction
      db
      (lambda ()
        (exec (sql/transient db "CREATE TABLE IF NOT EXISTS map(a TEXT, b TEXT);"))
        (exec (sql/transient db "CREATE UNIQUE INDEX IF NOT EXISTS map_a ON map(a);"))
        (exec (sql/transient db "CREATE INDEX IF NOT EXISTS map_b ON map(b);"))))
     (let* ((lookup (sql db
                         (if reverse
                             "SELECT a FROM map WHERE b = ?;"
                             "SELECT b FROM map WHERE a = ?;")))
            (set (sql db
                      (if reverse
                          "INSERT INTO map (b,a) VALUES (?,?);"
                          "INSERT INTO map (a,b) VALUES (?,?);")))
            (delete (sql db
                         (if reverse
                             "DELETE FROM map WHERE b = ?"
                             "DELETE FROM map WHERE a = ?")))
            (dump (sql db
                       (if reverse
                           "SELECT b, a FROM map;"
                           "SELECT a, b FROM map;"))))
       (values
        (lambda (in #!optional default)
          (let ((col (query fetch-column lookup (unparse-data in))))
            (case dupmode
              ((all) (map parse-data col))
              ((one) (if (pair? col) (parse-data (car col)) default)))))
        (lambda (in out)
          (let ((inkey (unparse-data in)))
           (exec delete inkey)
           (exec set inkey (unparse-data out)))
          (void))
        (lambda (in)
          (exec delete (unparse-data in))
          (void))
        (lambda (kons knil)
          (query (fold-rows
                  (lambda (row acc)
                    (kons (parse-data (car row))
                          (parse-data (cadr row))
                          acc))
                  knil) dump))
        (lambda ()
          (close-database db))))))

 (: mplookup-hash (hash-table symbol ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            ))

 (define (mplookup-hash hash dupmode)
   (values
    (lambda (in #!optional (default (if (eq? dupmode 'all) '() #f)))
      (hash-table-ref/default hash in default))
    (lambda (in out)
      (hash-table-set! hash in
                       (case dupmode
                         ((all) (list out))
                         ((one) out)))
      (void))
    (lambda (in)
      (hash-table-delete! hash in)
      (void))
    (lambda (kons knil)
      (hash-table-fold hash (case dupmode
                              ((one) kons)
                              ((all)
                               (lambda (key vals acc)
                                 (fold (lambda (val acc)
                                         (kons key val acc))
                                       acc vals)))) knil))))

 (: mplookup-file ((-> hash-table)
                   (hash-table -> undefined)
                   symbol ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            (-> undefined) ;; close
                            ))
 (define (mplookup-file loader saver dupmode)
   (let ((hash (loader))
         (updated #f))
     (receive (get put del dump)
              (mplookup-hash hash dupmode)
              (values get
                      (lambda (in out)
                        (put in out)
                        (set! updated #t)
                        (void))
                      (lambda (in)
                        (del in)
                        (set! updated #t)
                        (void))
                      dump
                      (lambda ()
                        (when updated
                              (saver hash))
                        (set! hash (void)))))))

 (: mplookup-aliases (string symbol boolean ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            (-> undefined) ;; close
                            ))
 (define (mplookup-aliases mapfile dupmode reverse)
   (let ((line-re (irregex '(seq (* space)
                                 ($ (*? (~ #\:)))
                                 (* space)
                                 #\:
                                 (* space)
                                 ($ (*? any))
                                 (* space))))
         (add-to-hash! (lambda (hash key val)
                        (let ((a (if reverse val key))
                              (b (if reverse key val)))
                          (case dupmode
                            ((all)
                             (hash-table-update!/default hash a
                                                         (lambda (old)
                                                           (cons b old))
                                                         '()))
                            ((one)
                             (hash-table-set! hash a b)))))))
     (mplookup-file
      (lambda () (if (file-exists? mapfile)
                     (with-input-from-file mapfile
                       (lambda ()
                         (port-fold
                          (lambda (line hash)
                            (let* ((hashpos (string-index line #\#))
                                   (clean-line
                                    (if hashpos
                                        (string-take line hashpos)
                                        line)))
                              (let ((m (irregex-match line-re clean-line)))
                                (when m
                                      (add-to-hash! hash
                                                    (irregex-match-substring m 1)
                                                    (irregex-match-substring m 2)))))
                            hash)
                          (make-hash-table)
                          read-line)))
                     (make-hash-table)))
      (lambda (hash) (with-output-to-file mapfile
                       (lambda ()
                         (hash-table-for-each
                          hash
                          (lambda (key val)
                            (case dupmode
                              ((all)
                               (for-each
                                (lambda (val*)
                                  (let ((a (if reverse val* key))
                                        (b (if reverse key val*)))
                                    (printf "~A: ~A\n" a b))) val))
                              ((one)
                            (let ((a (if reverse val key))
                                  (b (if reverse key val)))
                              (printf "~A: ~A\n" a b)))))))))
      dupmode)))

 (: mplookup-sexprs (string symbol boolean ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            (-> undefined) ;; close
                            ))
 (define (mplookup-sexprs mapfile dupmode reverse)
   (let ((add-to-hash! (lambda (hash key val)
                        (let ((a (if reverse val key))
                              (b (if reverse key val)))
                          (case dupmode
                            ((all)
                             (hash-table-update!/default hash a
                                                         (lambda (old)
                                                           (cons b old))
                                                         '()))
                            ((one)
                             (hash-table-set! hash a b)))))))
     (mplookup-file
      (lambda () (if (file-exists? mapfile)
                     (with-input-from-file mapfile
                       (lambda ()
                         (port-fold
                          (lambda (pair hash)
                            (add-to-hash! hash
                                          (car pair)
                                          (cdr pair))
                            hash)
                          (make-hash-table)
                          data-read)))
                     (make-hash-table)))
      (lambda (hash) (with-output-to-file mapfile
                       (lambda ()
                         (hash-table-for-each
                          hash
                          (lambda (key val)
                            (case dupmode
                              ((all)
                               (for-each
                                (lambda (val*)
                                  (let ((a (if reverse val* key))
                                        (b (if reverse key val*)))
                                    (data-write (cons a b)))) val))
                              ((one)
                            (let ((a (if reverse val key))
                                  (b (if reverse key val)))
                              (data-write (cons a b)))))
                            (newline))))))
      dupmode)))

 (: mplookup-alist (string symbol boolean ->
                            (* #!optional * -> *) ;; Lookup b given a
                            (* * -> undefined) ;; Set a = b
                            (* -> undefined) ;; Delete a = *
                            (forall (acc) ((* * acc -> acc) acc -> acc)) ;; fold
                            (-> undefined) ;; close
                            ))
 (define (mplookup-alist mapfile dupmode reverse)
   (let ((add-to-hash! (lambda (hash key val)
                        (let ((a (if reverse val key))
                              (b (if reverse key val)))
                          (case dupmode
                            ((all)
                             (hash-table-update!/default hash a
                                                         (lambda (old)
                                                           (cons b old))
                                                         '()))
                            ((one)
                             (hash-table-set! hash a b)))))))
     (mplookup-file
      (lambda () (if (file-exists? mapfile)
                     (with-input-from-file mapfile
                       (lambda ()
                         (port-fold
                          (lambda (alist hash)
                            (alist-map
                             (lambda (key value)
                               (add-to-hash! hash key value))
                             alist)
                            hash)
                          (make-hash-table)
                          data-read)))
                     (make-hash-table)))
      (lambda (hash) (with-output-to-file mapfile
                       (lambda ()
                         (printf "(")
                         (hash-table-for-each
                          hash
                          (lambda (key val)
                            (case dupmode
                              ((all)
                               (for-each
                                (lambda (val*)
                                  (let ((a (if reverse val* key))
                                        (b (if reverse key val*)))
                                    (data-write (cons a b)))) val))
                              ((one)
                            (let ((a (if reverse val key))
                                  (b (if reverse key val)))
                              (data-write (cons a b)))))
                            (newline)))
                         (printf ")\n"))))
      dupmode)))

; (: mplookup (symbol string )) How do I declare the type of #!key?
 (define (mplookup type mapfile #!key (dupmode 'one) (reverse #f))
   (case dupmode
     ((all))
     ((one))
     (else (error 'mplookup "Unknown duplicate mode (should be all or one)" dupmode)))
   (case type
     ((sqlite) (mplookup-sqlite mapfile dupmode reverse))
     ((aliases) (mplookup-aliases mapfile dupmode reverse))
     ((alist) (mplookup-alist mapfile dupmode reverse))
     ((sexprs) (mplookup-sexprs mapfile dupmode reverse))
     (else (error 'mplookup "Unknown mplookup map type (should be sqlite, aliases, alist or sexprs)" type)))
   )
 (define (mplog format . args)
   (apply fprintf (append (list (current-error-port) format) args))
   (newline (current-error-port)))
)
