(module
 magic-pipes-runtime
 (mpread
  mpwrite

  alist-modify
  alist-modifier
  alist-project
  alist-projector

  mplog
  mplookup

  dirent?
  ->dirent
  dirent-path
  dirent-directory
  dirent-filename
  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?

  dirent-older?
  dirent-newer?
  minutes hours days weeks

  dirent-matcher
  dirent-match?

  dirent-globber
  dirent-glob?
)
 (import chicken)
 (import scheme)
 (use extras)
 (use sql-de-lite)
 (use srfi-69)
 (use ports)
 (use irregex)
 (use regex)
 (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)))
   )

 (: mplog (string #!rest * -> undefined))
 (define (mplog format . args)
   (apply fprintf (append (list (current-error-port) format) args))
   (newline (current-error-port)))

 (: alist-modify
    (forall
     (key val)
     ((list-of (pair key (val -> val)))
      (list-of (pair key val))
      ->
      (list-of (pair key val)))))
 (define (alist-modify transformers alist)
   (if (null? alist)
       alist
       (cons
        (let* ((elem (car alist))
               (key (car elem))
               (transformer (assq key transformers)))
          (if transformer
              (cons key ((cdr transformer) (cdr elem)))
              elem))
        (alist-modify transformers (cdr alist)))))

 (: alist-modifier
    (forall
     (key val)
     ((list-of (pair key (val -> val)))
      ->
      ((list-of (pair key val))
       ->
       (list-of (pair key val))))))
 (define ((alist-modifier transformers) alist)
   (alist-modify transformers alist))

 (: alist-project
    (forall
     (key val)
     ((list-of (or key
                   (pair key val)))
      (list-of (pair key val))
      ->
      (list-of (pair key val)))))
 (define (alist-project fields alist)
   (if (null? fields)
       '()
       (let* ((key (if (pair? (car fields))
                       (car (car fields))
                       (car fields)))
              (elem (assq key alist)))
         (if elem
             (cons elem
                   (alist-project (cdr fields) alist))
             (if (pair? (car fields))
                 ;; Default provided
                 (cons (car fields)
                       (alist-project (cdr fields) alist))
                 ;; No default provided, skip
                 (alist-project (cdr fields) alist))))))

 (: alist-projector
    (forall
     (key val)
     ((list-of (or key
                   (pair key val)))
      ->
      ((list-of (pair key val))
       ->
       (list-of (pair key val))))))
 (define ((alist-projector fields) alist)
   (alist-project fields alist))

 ;; Too messy to give these fixed types. dirent is anything ->dirent accepts, target is either that or a number.
 (define (dirent-older? x target #!optional (time-getter dirent-modification-time))
   (let ((x-age (time-getter (->dirent x)))
         (target-age
          (if (number? target)
              (- (current-seconds) target)
              (time-getter (->dirent target)))))
     (< x-age target-age)))

 ;; Too messy to give these fixed types. dirent is anything ->dirent accepts, target is either that or a number.
 (define (dirent-newer? x target #!optional (time-getter dirent-modification-time))
   (let ((x-age (time-getter (->dirent x)))
         (target-age
          (if (number? target)
              (- (current-seconds) target)
              (time-getter (->dirent target)))))
     (> x-age target-age)))

 (: minutes (number -> number))
 (define (minutes x)
   (* x 60))

 (: hours (number -> number))
 (define (hours x)
   (* x 3600))

 (: days (number -> number))
 (define (days x)
   (* x 86400))

 (: weeks (number -> number))
 (define (weeks x)
   (* x 604800))

 (: dirent-matcher (string #!optional boolean -> (* -> boolean)))
 (define (dirent-matcher regexp #!optional (full-path? #f))
   (let ((re (irregex regexp))
         (path-getter (if full-path? dirent-path dirent-filename)))
     (lambda (path-or-dirent)
       (let* ((dirent (->dirent path-or-dirent))
              (path (path-getter dirent)))
         (and (irregex-match re path) #t)))))

 (: dirent-match? (string * #!optional boolean -> boolean))
 (define (dirent-match? regexp path-or-dirent #!optional (full-path? #f))
   ((dirent-matcher regexp full-path?) path-or-dirent))

 (: dirent-globber (string #!optional boolean -> (* -> boolean)))
 (define (dirent-globber glob #!optional (full-path? #f))
   (let ((re (glob->regexp glob))
         (path-getter (if full-path? dirent-path dirent-filename)))
     (lambda (path-or-dirent)
       (let* ((dirent (->dirent path-or-dirent))
              (path (path-getter dirent)))
         (and (string-match re path) #t)))))

 (: dirent-glob? (string * #!optional boolean -> boolean))
 (define (dirent-glob? glob path-or-dirent #!optional (full-path? #f))
   ((dirent-globber glob full-path?) path-or-dirent))


 )