#lang racket

#|

File: teachpack/batch-io.rkt
Author: Bill Turtle (wrturtle)

Provide a wrapper to the batch-io.ss teachpack used by htdp.

NOT SUPPORTED: read-lstrings, read-csv-file, read-csv-file/rows

|#

(require 2htdp/batch-io)
(require "../semantics/wrap-prim.rkt")
(require "../utilities.rkt")
(require (prefix-in pysem: "../semantics/hash-percents.rkt"))

; Before we can perform the /normal/ wrapping, we have to
; first create "inner" functions which will error out if
; the first argument fails the file-exists? predicate.
(define-syntax (wrap-can-read-check stx)
  (syntax-case stx ()
    [(_ inner-name real-function-name error-name)
     (syntax/loc stx
       (define inner-name
         (lambda args
           ; we assume there is at least one argument, and that it is
           ; a string, since this function will be wrapped inside one
           ; that does the checking.
           (let ([the-str (first args)]
                 [locs (app-locations-first)])
             (validate-app-locs locs)
             (unless (file-exists? the-str)
               (let ([arg-loc (second locs)])
                 (raise-pyret-error
                  (format
                   (string-append "~a: expects the name of a file in the "
                                  "program's folder as the first argument, "
                                  "given ~e")
                   (quote error-name)
                   the-str)
                  arg-loc)))
             (unless (member 'read (file-or-directory-permissions the-str))
               (let ([arg-loc (second locs)])
                 (raise-pyret-error
                  (format
                   (string-append "~a: you do not have permission to read "
                                  "file ~e")
                   (quote error-name)
                   the-str)
                  arg-loc)))
             (apply real-function-name args)))))]))

(define-syntax (wrap-can-write-check stx)
  (syntax-case stx ()
    [(_ inner-name real-function-name error-name)
     (syntax/loc stx
       (define inner-name
         (lambda args
           ; we assume there is at least one argument, and that it is
           ; a string, since this function will be wrapped inside one
           ; that does the checking.
           (let ([the-str (first args)]
                 [locs (app-locations-first)])
             (validate-app-locs locs)
             (unless (file-exists? the-str)
               (let ([arg-loc (second locs)])
                 (raise-pyret-error
                  (format
                   (string-append "~a: expects the name of a file in the "
                                  "program's folder as the first argument, "
                                  "given ~e")
                   (quote error-name)
                   the-str)
                  arg-loc)))
             (unless (member 'write (file-or-directory-permissions the-str))
               (let ([arg-loc (second locs)])
                 (raise-pyret-error
                  (format
                   (string-append "~a: you do not have permission to write "
                                  "file ~e")
                   (quote error-name)
                   the-str)
                  arg-loc)))
             (apply real-function-name args)))))]))



(wrap-can-read-check inner_read_file read-file read_file)
(wrap read_file inner_read_file (exactly 1) (list string-sig))
#;(wrap-can-read-check inner_read_lstrings read-lstrings read_lstrings)
#;(wrap read_lstrings inner_read_lstrings (exactly 1) (list string-sig))
(wrap-can-read-check inner_read_words read-words read_words)
(wrap read_words inner_read_words (exactly 1) (list string-sig))
(wrap-can-read-check inner_read_words_line read-words/line read_words_line)
(wrap read_words_line inner_read_words (exactly 1) (list string-sig))

(wrap-can-write-check inner_write_file write-file write_file)
(wrap write_file inner_write_file (exactly 1) (list string-sig))

(provide read_file #;read_lstrings read_words read_words_line)

#|
(make-first-order-and-provide [read_file read-file 1 read_file]
                              [read_lstrings read-lstrings 1 read_lstrings]
                              [read_lines read-lines 1 read_lines]
                              [read_words read-words 1 read_words]
                              [read_words_line read-words/line 1 read_words_line]
                              [read_csv_file read-csv-file 1 read_csv_file]
                              [read_csv_file_rows read-csv-file/rows 1 read_csv_file_rows]
                              [write_file write-file 2 write_file])
|#