(module database mzscheme
  (require (lib "plt-match.ss")
           (lib "unitsig.ss")
           (lib "etc.ss")
           (lib "list.ss")
           (lib "file.ss")
           (prefix is: (lib "integer-set.ss")))
  (require (planet "list.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "maybe.ss" ("jaymccarthy" "mmss.plt" 1))
           (planet "fmap.ss" ("jaymccarthy" "trie.plt" 1))
           (planet "string.ss" ("jaymccarthy" "trie.plt" 1)))
  (provide (all-defined-except make-entry ext:make-entry)
           (rename ext:make-entry make-entry))
  
  ; string map
  (define-values/invoke-unit/sig fmap^
    string-fmap@
    string-fmap)
  
  ; database = (list string) * (map string entry)
  (define-struct database (users user->entry-map))
  (define database-empty
    (make-database empty string-fmap:empty))
  (define database-lookup
    (match-lambda*
      [(list user (struct database (users fmap)))
       (string-fmap:lookup user fmap)]))
  (define database-insert
    (match-lambda*
      [(list user entry (struct database (users fmap)))
       (make-database (if (member? user users) users (list* user users))
                      (string-fmap:insert fmap-replace user entry fmap))]))
  
  (define database-unmarshal
    (match-lambda
      [(list (list user entry-sexp) ...)
       (make-database 
        user
        (foldl (lambda (user entry fmap)
                 (string-fmap:insert fmap-replace user entry fmap))
               string-fmap:empty
               user
               (map entry-unmarshal entry-sexp)))]))
  (define database-marshal 
    (match-lambda
      [(struct database (users fmap))
       (string-fmap:foldr (lambda (user entry acc)
                            (list* (list user (entry-marshal entry))
                                   acc))
                          empty
                          fmap)]))
  
  (define (database-load path)
    (let ([users (filter (lambda (p)
                           (not (bytes=? #"." (subbytes (path->bytes p) 0 1))))
                         (with-handlers ([exn? (lambda _ empty)])
                           (directory-list path)))])
      (make-database 
       users
       (foldl (lambda (user fmap)
                (string-fmap:insert
                 fmap-replace (path->string user)
                 (entry-unmarshal (with-input-from-file (build-path path user) read))
                 fmap))
              string-fmap:empty
              users))))
  (define (database-write db path)
    (match db
      [(struct database (users fmap))
       (make-directory* path)
       (string-fmap:foldr (lambda (user entry v)
                            (entry-write entry (build-path path user)))
                          (void)
                          fmap)]))
  
  ; entry = string * (list string) * (map string integer-set)
  (define-struct entry (password activity-order activity->dates-map))
  (define ext:make-entry 
    (match-lambda*
      [(list password)
       (make-entry password empty string-fmap:empty)]))
  (define entry-password-update
    (match-lambda*
      [(list (struct entry (p0 as a->d-map))
             p1)
       (make-entry p1 as a->d-map)]))
  (define entry-activity-on?
    (match-lambda*
      [(list (struct entry (p as a->d-map))
             a d)
       (match (string-fmap:lookup a a->d-map)
         [(struct nothing ())
          #f]
         [(struct just (is))
          (is:member? d is)])]))
  (define entry-activity-add
    (match-lambda*
      [(list (struct entry (p as a->d-map))
             a)
       (make-entry p (list* a as)
                   (match (string-fmap:lookup a a->d-map)
                     [(struct just (_))
                      a->d-map]
                     [(struct nothing ())
                      (string-fmap:insert fmap-replace a (is:make-range) a->d-map)]))]))
  (define entry-activity-edit
    (match-lambda*
      [(list (struct entry (p as a->d-map))
             a0 a1)
       (make-entry p 
                   (map (lambda (e)
                          (if (equal? e a0)
                              a1 e))
                        as)
                   (string-fmap:remove 
                    a0
                    (string-fmap:insert fmap-replace a1
                                        (just-value (string-fmap:lookup a0 a->d-map))
                                        a->d-map)))]))
  (define entry-activity-delete
    (match-lambda*
      [(list (struct entry (p as a->d-map))
             a)
       (make-entry p 
                   (filter (lambda (e)
                             (not (equal? a e)))
                           as)
                   a->d-map)]))
  (define entry-activity-swap
    (match-lambda*
      [(list (struct entry (p as a->d-map))
             n0 n1)
       (make-entry p (list-swap n0 n1 as) a->d-map)]))
  (define entry-activity-flip
    (match-lambda*
      [(list (and e (struct entry (p as a->d-map)))
             a d)
       (make-entry p as (string-fmap:insert 
                         (lambda (new old)
                           (if (is:subset? new old)
                               (is:difference old new)
                               (is:union old new)))
                         a (is:make-range d) a->d-map))]))
  
  (define entry-unmarshal
    (match-lambda
      [(list password activity-order (list (list activity is-sexp) ...))
       (make-entry
        password
        activity-order
        (foldl (lambda (activity is fmap)
                 (string-fmap:insert fmap-replace activity is fmap))
               string-fmap:empty
               activity
               (map integer-set-unmarshal is-sexp)))]))
  (define entry-marshal
    (match-lambda
      [(struct entry (password activity-order fmap))
       (list password
             activity-order
             (string-fmap:foldr (lambda (activity is acc)
                                  (list* (list activity (integer-set-marshal is))
                                         acc))
                                empty
                                fmap))]))
  
  (define (entry-write entry path)
    (with-output-to-file path
      (lambda ()
        (write (entry-marshal entry)))
      'truncate/replace))
  
  ; integer-sets
  (define integer-set-marshal is:integer-set-contents)
  (define integer-set-unmarshal is:make-integer-set))