(module
 magic-pipes
 (data-read
  data-write
  parse-code
  unparse-code
  parse-data
  unparse-data
  make-eval-context
  eval-context-handler-closure
  eval-context-end-closure
  without-input-port
  without-output-port
  without-ports
  with-values-to-output
  for-each-input-datum
  fold-input-data
  parse-mp-args

  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?)

 (import scheme)
 (import chicken)
 (use files)
 (use extras) ;; pp for debugging
 (use ports)
 (use posix)
 (use args)
 (use srfi-1)
 (use srfi-38) ; objects with shared structure
 (use typed-records)

#|
 (define safe-read-table
   (let ((rt (copy-read-table (current-read-table))))
     (parameterize ((current-read-table rt))
                   ;; Manually disable everything unsafe from
                   ;; http://wiki.call-cc.org/man/4/Non-standard%20read%20syntax
                   (set-sharp-read-syntax! #\, #f) ; Kill srfi-10
                   (set-sharp-read-syntax! #! #f) ; Kill #!eof, line comment, DSSSL keywords, read marks.
                   (set-sharp-read-syntax! #+ #f) ; KIll conditional expansions
                   rt)))
  |#
 (define safe-read-table (current-read-table))

 (: data-read (#!optional input-port -> *))
 (define (data-read #!optional port)
   (parameterize ((current-read-table safe-read-table))
                 (read-with-shared-structure
                  (if port port (current-input-port)))))

 (: data-write (* #!optional output-port -> undefined))
 (define (data-write datum #!optional port)
   (write-with-shared-structure
    datum
    (if port port (current-output-port)))
   (void))

 (: parse-code (string --> *))
 (define (parse-code str)
   (with-input-from-string str read))

 (: unparse-code (* --> string))
 (define (unparse-code datum)
   (with-output-to-string (lambda () (write datum))))

 (: parse-data (string --> *))
 (define (parse-data str)
   (with-input-from-string str data-read))

 (: unparse-data (* --> string))
 (define (unparse-data datum)
   (with-output-to-string (lambda () (data-write datum))))

 (define-record-type eval-context
   (make-eval-context* handler-closures end-closure)
   eval-context?
   (handler-closures eval-context-handler-closures : (vector-of procedure))
   (end-closure eval-context-end-closure : procedure))

 (define (eval-context-handler-closure ec index)
   (vector-ref (eval-context-handler-closures ec) index))

 (define *standard-prelude*
   `((import chicken)
     (import scheme)
     (use srfi-1) ;; lists
     (use srfi-13) ;; strings
     (use data-structures)
     (use srfi-69) ;; hash tables
     (use alist-lib)
     (use magic-pipes-runtime))) ;; Utility procedures, and shadows read/write

 (: make-eval-context (list list list
                       --> (struct eval-context)))
 (define (make-eval-context before-exprs wanted-exprs after-exprs)
   ;; FIXME: Can we wrap all the *-exprs so that if they error, the
   ;; call trace doesn't extend back into magic-pipes internals?
   ;; Clear the buffer somehow?
   (let* ((eval-expr (append '(begin)
                             *standard-prelude*
                             `((let ((read mpread)
                                     (write mpwrite))
                                 . ,(append
                                   before-exprs
                                   `((cons ,(append '(vector) wanted-exprs)
                                           (lambda () ,(append '(begin) after-exprs)))))))))
          (eval-results (begin
                          #;(pp eval-expr)
                          (eval eval-expr (interaction-environment))))
          (wanted-results (car eval-results))
          (after-proc (cdr eval-results)))
     (make-eval-context*
      wanted-results
      after-proc)))

 (define bad-input-port (make-input-port
                         (lambda ()
                           (error "Input is not allowed in this context"))
                         (lambda () #f)
                         (lambda () (void))
                         (lambda ()
                           (error "Input is not allowed in this context"))))

 (define bad-output-port (make-output-port
                          (lambda (x)
                            (error "Output is not allowed in this context"))
                          (lambda () (void))
                          (lambda () (void))))

 (: without-input-port (forall (s) ((-> s) -> s)))
 (define (without-input-port thunk)
   (parameterize ((current-input-port bad-input-port))
                 (thunk)))

 (: without-output-port (forall (s) ((-> s) -> s)))
 (define (without-output-port thunk)
   (parameterize ((current-output-port bad-output-port))
                 (thunk)))

 (: without-ports (forall (s) ((-> s) -> s)))
 (define (without-ports thunk)
   (parameterize ((current-output-port bad-output-port)
                  (current-input-port bad-input-port))
                 (thunk)))

 (: with-values-to-output ((-> *) -> undefined))
 (define (with-values-to-output thunk)
   (call-with-values
       thunk
     (lambda results ;; Spaces between items, not after every one
       (fold (lambda (datum not-first?)
               (if (eq? (void) datum) ;; Skip void values
                   not-first?
                   (begin
                    (when not-first? (display " "))
                    (data-write datum)
                    #t)))
             #f results)
       (newline))) ;; Newline after the results, even for 0 values
   (void))

 (: for-each-input-datum ((* -> *) -> undefined))
 (define (for-each-input-datum fn)
   (fold-input-data (lambda (datum acc)
                      (fn datum)
                      (void))
                    (void)))

 (define (fold-input-data fn init)
   ;; FIXME: Trap errors, and report sexpr number and the starting
   ;; line/column.
   ;; Include parse errors from data-read as well as errrors in 'fn'!
   (port-fold
    fn
    init
    data-read))

 (define (parse-mp-args args local-opts args-help-string help-string)
   (let* ((before-exprs '())
          (after-exprs '())
          (add-before-expr! (lambda (e)
                              (set! before-exprs
                                    (cons e before-exprs))))
          (add-after-expr! (lambda (e)
                              (set! after-exprs
                                    (cons e after-exprs))))
          (usage (void))
          (opts (append
                local-opts
                (list
                 (args:make-option (u use) (required: "MODULE") "Preload a Chicken module"
                                   (add-before-expr! `(use ,(string->symbol arg))))
                 (args:make-option (i include) (required: "FILENAME") "Pre-load a Chicken script"
                                   (add-before-expr! `(include arg)))
                 (args:make-option (d do-before) (required: "EXPR") "Pre-evaluate the expression"
                                   (add-before-expr! (parse-code arg)))
                 (args:make-option (e do-after) (required: "EXPR") "Post-evaluate the expression"
                                   (add-after-expr! (parse-code arg)))
                 (args:make-option (h help) #:none "Display this text"
                                   (usage))))))
     ; This is done to resolve the recursive nature of usage
     ; printing a list of options, one of which calls it.
     (set! usage (lambda ()
                   (with-output-to-port (current-error-port)
                     (lambda ()
                       (print "Usage: " (car (argv)) " [options...] " args-help-string)
                       (newline)
                       (print (args:usage opts))
                       (print help-string)))
                   (exit 1)))
     (receive (options operands)
              (args:parse args opts)
              (values options operands
                      (reverse! before-exprs) (reverse! after-exprs)
                      usage))))

 (define (dirent? thing)
   (and (list? thing)
        (assq 'mpdirent thing)))

 (define (->dirent thing)
   (cond
    ((string? thing)                   ; Treat as filename
     (let ((stats (file-stat thing #t)))
       (let ((props `((mpdirent . #t)
                      (path . ,thing)
                      (inode-number . ,(vector-ref stats 0))
                      (mode . ,(bitwise-and (vector-ref stats 1)))
                      (number-of-links . ,(vector-ref stats 2))
                      (uid . ,(vector-ref stats 3))
                      (gid . ,(vector-ref stats 4))
                      (size . ,(vector-ref stats 5))
                      (access-time . ,(vector-ref stats 6))
                      (change-time . ,(vector-ref stats 7))
                      (modification-time . ,(vector-ref stats 8))
                      (parent-device-id . ,(vector-ref stats 9))
                      (device-id . ,(vector-ref stats 10))
                      (block-size . ,(vector-ref stats 11))
                      (number-of-blocks . ,(vector-ref stats 12))
                      (type . ,(file-type thing #t))))) ; FIXME: Race
         (when (symbolic-link? thing) ; FIXME: Race
               (set! props (cons (cons 'link-target
                                       (read-symbolic-link thing)) ; FIXME: Race
                                 props)))
         props)))
    ((dirent? thing)                    ; Already a dirent
     thing)
    (else (error "It's impossible to turn this into a dirent" thing))))

 (define (dirent-assq dirent field)
   (let ((result (assq field (->dirent dirent))))
     (if result
         (cdr result)
         (error "Unknown field in dirent" field))))

 (define (dirent-path dirent)
   (dirent-assq dirent 'path))

 (define (dirent-directory dirent)
   (receive (dir filename ext) (decompose-pathname (dirent-path dirent))
            dir))

 (define (dirent-filename dirent)
   (receive (dir filename ext) (decompose-pathname (dirent-path dirent))
            (if ext
                (string-append filename "." ext)
                filename)))

 (define (dirent-inode-number dirent)
   (dirent-assq dirent 'type))

 (define (dirent-mode dirent)
   (dirent-assq dirent 'mode))
 ;; FIXME: Finer-grained permissions

 (define (dirent-number-of-links dirent)
   (dirent-assq dirent 'number-of-links))

 (define (dirent-uid dirent)
   (dirent-assq dirent 'uid))

 (define (dirent-gid dirent)
   (dirent-assq dirent 'gid))

 (define (dirent-size dirent)
   (dirent-assq dirent 'size))

 (define (dirent-access-time dirent)
   (dirent-assq dirent 'access-time))

 (define (dirent-change-time dirent)
   (dirent-assq dirent 'change-time))

 (define (dirent-modification-time dirent)
   (dirent-assq dirent 'modification-time))

 (define (dirent-parent-device-id dirent)
   (dirent-assq dirent 'parent-device-id))

 (define (dirent-device-id dirent)
   (dirent-assq dirent 'device-id))

 (define (dirent-block-size dirent)
   (dirent-assq dirent 'block-size))

 (define (dirent-number-of-blocks dirent)
   (dirent-assq dirent 'number-of-blocks))

 (define (dirent-link-target dirent)
   (dirent-assq dirent 'link-target))

 (define (dirent-type dirent)
   (dirent-assq dirent 'type))

 (define (dirent-regular-file? dirent)
   (eq? (dirent-type dirent) 'regular-file))

 (define (dirent-directory? dirent)
   (eq? (dirent-type dirent) 'directory))

 (define (dirent-fifo? dirent)
   (eq? (dirent-type dirent) 'fifo))

 (define (dirent-socket? dirent)
   (eq? (dirent-type dirent) 'socket))

 (define (dirent-symbolic-link? dirent)
   (eq? (dirent-type dirent) 'symbolic-link))

 (define (dirent-character-device? dirent)
   (eq? (dirent-type dirent) 'character-device))

 (define (dirent-block-device? dirent)
   (eq? (dirent-type dirent) 'block-device))



 )