(module util mzscheme ; Don't use (lib "plt-pretty-big-text.ss"), as we want plt-match rather than match.
  
  ; If using this module in drscheme,
  ; go to drscheme's "Edit:Preferences:Indenting",
  ; and declare the following as define-like or lambda-like:
  ;  opt-define  define/opt   lambda/opt
  ; case-define  define/case  lambda/case
  ;              define/match*
  
  (provide
   define-syntax-rule/guarded
   create-binop-setter  ; Given +, makes the macro +! etc.
   create-unop-setter   ; Given rest, makes the macro rest! etc.

   when-not  ; Same as "unless".
   begin1

   debug?
   debug-out
   >>>       ; Debugging: prints file location/line-number; may wrap an expr or stand alone.
   ....
   
   
   ; Syntax; use "require-for-syntax" to get this:
   ;?? No, regular ol' "require" seems to be the one?
   test
   test*
   test*/unary
   require/expose  ; Allow peeking at non-exported variables.  For white-box testing only.

   warn
   assert assert*
   assert-type
   assert-type*   ; assert that arg is a           list of the given type.
   assert-type+   ; assert that arg is a non-empty list of the given type.
   define/opt
   define/case
   define/match*
   letdef*        ; Like letrec*, but w/ define's shorter syntax.
   
   tweak
   )



  (require (lib "list.ss")
           (lib "plt-match.ss")
           (lib "etc.ss")       ; For false, opt-lambda.
           )

  (require-for-syntax (lib "etc.ss")) ; for namespace-defined?


  
  ;; define-syntax-rule/guarded:
  ;; Like define-syntax-rule, but you can provide additional guard clauses,
  ;; which (if they fail) can give tailored error messages.
  ;; 
  ;; For very simple macros where there is only one rule,
  ;; using a syntax parallel to "define":
  ;   ; Example:
  ;   (define-syntax-rule (my-times num1 num2) (if (zero? num1) 0 (* num1 num2)))
  ;   (my-times (- 2 2) (+ 3 'apple)) => 0  ;not an error.
  ;
  ;   ; Also allows a parallel to define, allowing just a re-name:
  ;   (define-syntax-rule fn lambda)
  ;   ((fn (x) (+ x 17)) 3)  => 20
  ;;
  (define-syntax define-syntax-rule/guarded
    (syntax-rules ()
      [(define-syntax-rule/guarded (macro-name args ...) guards ... body)
       (define-syntax (macro-name stx)
         (syntax-case stx ()
           [(macro-name args ...)
            (begin guards ...)
            (syntax body)]
           [_ (raise-syntax-error 'macro-name (format "Could not match ~v" '(macro-name args ...)) (syntax _))]
           ))]))


  
  
  
 
  
  ;; when-not: same as "unless".
  ;;
  (define-syntax-rule (when-not expr ...)
    (unless expr ...))
  #| Discussion:
   Why have two different keywords for the same semantics? 
   For the same reason that in Scheme, it's more appropriate to write 
       (when condition action!)
   than
       (if   condition action!)
   even though in this case they have the same semantics: 
   English nuances convey intent better, to people reading the code.

   In considering "unless" vs "when-not":
       (unless condition action)
   suggests that action! is routinely taken, and only occasionally does 
   condition hold.  On the other hand, 
       (when-not condition action)
   doesn't suggest whether or not condition is routine.  Thus
      (when-not (good? input) (raise-error-condition))
   is fine, and would sound a bit stilted if replaced with "unless".

   "unless" is still has its place:
      (unless   (bad?  input) (process input))
      (unless   (> time timeout) ...)
      (unless   (zero? n) (printf "and the average is ~a." (/ sum n)))

   Were a language to support only one of these two keywords,
   I'd lean towards "when-not" over "unless": while replacing an appropriate
   "when-not" with an "unless" can be jarring, the converse holds much 
   less frequently.  (Perhaps because
   programmers are trained to think of corner cases as not-so-unlikely?)
   Also, "when-not" makes its dual to "when" slightly more evident.
  |#

  
  ;; begin1: like begin or begin0, but return
  ;; the result of the second expression.
  ;; Ill-formed, if only 1 expression.
  
  (define-syntax-rule (begin1 expr0 exprs ...)
    (begin expr0 (begin0 exprs ...)))
  
  
  ;; define/opt: like define, but allow optional arguments.
  ;; See opt-lambda (in helpdesk).
  ;;
  (define-syntax-rule (define/opt (f . formals) body ...)
    (define f (opt-lambda formals body ...)))
  

  ;; define/case: like case-lambda, but defines a function.
  ;;  lambda is to define, as case-lambda is to case-define
  ;;  (should better be called "letdef*", or "overload"?)
  ;;  See also define/match*.
  ;;
  (define-syntax-rule (define/case func-name the-cases ...)
    (define func-name (case-lambda the-cases ...)))

  ;; define/match*
  ;; Similar to lisp's destructuring-bind, this is a define
  ;; whose formal parameters are each a pattern.
  ;; It uses plt-match.ss (not match.ss).
  ;; (There is only one pattern/shape to try to match, not many.)
  ;; E.g.   (define-match* (f (list a b) (list c d)) (list a b c d))
  ;;        (f '(2 3) '(4 5)) => '(2 3 4 5)
  ;; 
  (define-syntax-rule (define/match* (f param-pats ...) body ...)
    (define f (match-lambda* [(list param-pats ...) body ...])))
  
  
  ;; define-or-define/opt: an internal helper for letdef*,
  ;; which can take either simple-define or a function-style define/opt.
  ;;
  (define-syntax define-or-define/opt
    (syntax-rules ()
      [(define-or-define/opt (func-name args ...) body ...)
       (define/opt (func-name args ...) body ...)]
      [(define-or-define/opt id val)
       (define id val)]))
       
  ;; letdef*   -- call this letdefs ?
  ;; Like a letrec*
  (define-syntax-rule (letdef* {[a-defn a-body] ...} body ...)
    (local {[define-or-define/opt a-defn a-body] ...}
      body ...))
  
  ;; assert: expr --> (void)
  ;; assert: expr string expr.. --> (void)
  ;;
  ;; Assert that some boolean expression holds.
  ;; If it doesn't, we print a diagnostic message, but continue.
  ;; The second form uses a format string and values (like printf).
  ;;
  ;; Example:
  ;; (define (length=1? lst)
  ;;   (begin
  ;;     (assert (list? lst) "Uhoh -- length=1? called on the non-list ~v." lst)
  ;;     (and (cons? lst) (empty? (rest lst)))))
  ;;
  (define-syntax assert
    (syntax-rules ()
      [(assert expr)
       (unless expr (error 'assert "failed: ~v [line ~v]"
                           (quote expr)
                           (syntax-line (syntax expr))))]
      [(assert expr msg args ...)
       (unless expr (error 'assert (string-append "failed: " msg " [line ~v: ~v]")
                           args ... 
                           (syntax-line (syntax expr))
                           (quote expr)))]
      ))
  
  (define-syntax-rule (assert* props ...)
    (begin (assert props) ...))
  
  
  ;; assert-type: (ANY -> boolean) ANY symbol string [ANYs] --> ANY or HALT
  ;; A blend of assert and raise-type-error:
  ;; If the assert fails, pass all other args on to raise-type-error.
  ;; Otherwise return the value.
  ;; (This makes it useful for make-parameter guards; see also and/f for this.)
  ;;
  (define/case assert-type
    [(type? val name-symbol expected-string) 
     (if (type? val)
         val
         (raise-type-error name-symbol expected-string val))]
    [(type? val name-symbol expected-string k vs) 
     (if (type? val)
         val
         (raise-type-error name-symbol expected-string k vs))])

  ;; assert-type*:
  ;; assert-type+:
  ;; Make sure the argument is a *list* (or, a non-empty list) of things which match "type".
  ;; If so, return that list.
  ;; E.g. (assert-type* number? '(3 4 5) 'hohum "number") => '(3 4 5)
  ;;      (assert-type* number? '(3 A 5) 'hohum "number") => ERROR 'hohum: expected list of number, got '(3 A 5)
  ;;
  (define (assert-type* type? val* name-symbol expected-string)
    (assert-type (lambda (__) (and (list? __) (andmap type? __))) val*
                 name-symbol (string-append "list of " expected-string))
    #;(if (and (list? val*)
             (andmap type? val*))
        val*
        (raise-type-error name-symbol (string-append           "list of " expected-string) val*)))
  (define (assert-type+ type? val* name-symbol expected-string)
    (assert-type (lambda (__) (and (cons? __) (andmap type? __))) val*
                 name-symbol (string-append "list of " expected-string))
    #;(if (and (cons? val*)
             (andmap type? val*))
        val*
        (raise-type-error name-symbol (string-append "non-empty list of " expected-string) val*)))
  

  
  
  ;; warn: print a message to stderr.  (Like error, but non-fatal.)
  ;; proc-name: symbol, or false (meaning omit printing a proc-name)
  ;; msg: string
  ;; msg-info: ANY...
  ;;
  ;; Example: (warn 'some-func "Potential problem with ~v and ~v." x y)
  ;;
  (define/opt (warn proc-name [msg "[No details provided.]"] . msg-info)
    (parameterize {[current-output-port (current-error-port)]}
      (printf "Warning: ")
      (when proc-name (printf "~v: " proc-name))
      (printf (apply format msg msg-info))
      (newline)))
    
       
  ;; test [macro]: expr ANY expr --> (void)
  ;; Allow nice placement of test-cases;
  ;; when evaluated either acknowledge by printing ".", or
  ;; print an error message if q and a aren't equal.
  ;; Account for numeric near-misses.
  ;;
  (define-syntax-rule (test expr-a cmpr expr-b)
    (let* {[a-val expr-a]
           [b-val expr-b]
           [numeric? (and (number? a-val) (number? b-val))]
           [comparer (if (and (eq? cmpr =) (not numeric?)) equal? cmpr)]
           }
      (if (comparer a-val b-val)
          (printf ".")
          (warn false "  test failed [line ~v]:~n    ~s~nreturned ~v,~nexpected ~v."
                ; Leading spaces of "  test" are just to
                ; have both test and assert warnings line up.
                (syntax-line (syntax expr-a))
                (quote expr-a)
                a-val
                b-val
                ))))
  
  (define (test* func comparer ins-and-outs)
    (void
      (map (lambda (io) (test (apply func (first io)) comparer (second io))) ins-and-outs)))
 
  (define (test*/unary func comparer ins-and-outs)
    (test* func comparer (map (lambda (io) `[(,(first io)) ,(second io)]) ins-and-outs)))

  
  #|
  (define-syntax (test* stx)
    (syntax-case stx ()
      [(_ func comparer {[q a] ... })
       (begin (test (apply func q) comparer a))]))
  |#
  
  ;; require/expose:
  ;; Like require, but add a list of identifiers
  ;;   which you can then peek at.  For use in white-box testing ONLY.
  ;;   The list of identifiers is not quoted.
  ;; Example:
  ;;   (require/expose (lib "foo.ss" "My-collects") 
  ;;                   (internal-id another-secret))
  ;; Now, internal-id and another-secret can be accessed, even though they
  ;; weren't exported.
  ;;
  ;; Thanks to Raymond Racine, Richard Cobbe.
  ;;
  (define-syntax-rule (require/expose mod (id ...))
    (begin
      (require mod)
      (warn 'require/expose 
            "Non-exported IDs being exposed from ~v.~nThis had better be for white-box testing only!" 'mod)
      (define-values (id ...)
        (parameterize {[current-namespace (module->namespace 'mod)]}
          (values (namespace-variable-value 'id) ...))))) 
  
  
  ;; debug?
  ;; Given 0 args: return the debug status;
  ;; Given 1 boolean arg: set the debug status, and return it.
  ;;
  (define debug? (make-parameter false (lambda (x) (if (boolean? x) x (raise-type-error 'debug? "Expected boolean, received ~v." x)))))
  
  
  ;; debug-out: string expr... --> (void)
  ;; If debugging is on, printf the info.
  ;;
  ;; Future plans: allow for an optional log file;
  ;; allow for an initial symbol (name of function), or get via "syntax";
  ;;
  (define (debug-out msg . details)
     (when (debug?) 
        (apply printf (cons msg details))
        (flush-output)))

  
                 
 #|
 From: Eli Barzilay <eli@barzilay.org>
 Date: Mon, 31 May 2004 13:27:17 -0400
 Cc: plt-scheme@list.cs.brown.edu
 Subject: Re: [plt-scheme] source code location
 
 Another thing that might be useful in this context is the following
 module.  I use it in two ways when debugging: either drop a `>>>' in
 some place and it'll print the source file and line, or wrap it around
 some computation to print & return the result, with the source+line.
 |#
 (define-syntax (>>> stx)
    (syntax-case stx ()
      [(_ args ...)
       #`(dprint #,(syntax-source stx)
                 #,(syntax-position stx)
                 #,(syntax-line stx)
                 args ...)]
      [else #`(dprint #,(syntax-source stx)
                      #,(syntax-position stx)
                      #,(syntax-line stx))]))
  (define (eprintf fmt . args)
    (apply fprintf (current-error-port) fmt args)
    (newline (current-error-port)))
  (define (dprint source pos line . args)
    (let* ([source (and source (regexp-replace #rx"^.*/" source ""))]
           [marker (cond [(and source line) (format ">>>~a:~a" source line)]
                         [(and source pos)  (format ">>>~a:#~a" source pos)]
                         [source (format ">>>~a" source)]
                         [else ">>>"])])
      (cond [(null? args) (eprintf "~a" marker)]
            [(null? (cdr args)) (eprintf "~a ~s" marker (car args)) (car args)]
            [(and (string? (car args)) (regexp-match #rx"~" (car args)))
             (eprintf "~a ~a" marker (apply format args))]
            [else (parameterize ([current-output-port (current-error-port)])
                    (display marker)
                    (let ([r #f])
                      (for-each (lambda (x) (display " ") (write x) (set! r x))
                                args)
                      (newline)))])))


  ;; Implementation:
  ;; Conceptually what we want to do is pretty simple:
  ;;   (define-syntax-rule (create-binop-setter op)
  ;;      (define-syntax-rule (op! var val) (set! var (op var val))))
  ;; But the trickiness comes in in adding `!' to the name,
  ;; and in doing a little bit of error-checking.
  ;;
  (define-syntax (create-binop-setter stx)
    (syntax-case stx ()
      [(create-binop-setter op)
       (unless (identifier? (syntax op)) (raise-syntax-error 'create-binop-setter "Expected the name of a binary function" (syntax op)))
       (let* {[op!-name ; (symbol-append op '!),   but inlined (and de-syntaxified):
               (string->symbol (string-append (symbol->string (syntax-e (syntax op))) (symbol->string '!)))
               ; Why can't I factor this into separate function?  Dunno; see note in create-unop-setter below.
               ]
              [op! (datum->syntax-object stx op!-name)]}
         #`(define-syntax-rule/guarded (#,op! <id> <expr>) 
             (unless (identifier? (syntax <id>)) 
               (raise-syntax-error '#,op! "Expected an identifier to set!" (syntax <id>)))
             (set! <id> (op <id> <expr>))))]
      [some-other-pattern
       (raise-syntax-error 'create-binop-setter
                           "Usage: (create-binop-setter <binary-function-name>)"
                           (syntax some-other-pattern))]
      ))
  
  
  (define-syntax (create-unop-setter stx)
    (syntax-case stx ()
      [(create-binop-setter <op>)
       (unless (identifier? (syntax <op>)) (raise-syntax-error 'create-unop-setter "Expected identifier" (syntax <op>)))
       (let* {[op!-name ; (symbol-append op '!),   but inlined (and de-syntaxified):
               (string->symbol (string-append (symbol->string (syntax-e (syntax <op>))) (symbol->string '!)))
               ; (I couldn't figure out how to define this as a separate function;
               ;  I kept getting "unbound variable in module (transformer environment): symbol-append",
               ;  even when defining symbol-append as a macro.
               ; Similarly -- I have to use `unless' above; I can't use `when-not'.
               ]
              [op! (datum->syntax-object stx op!-name)]}
         #`(define-syntax-rule/guarded (#,op! <id>) 
             (unless (identifier? (syntax <id>))
               (raise-syntax-error '#,op! "Expected an identifier to set!" (syntax <id>)))
             (set! <id> (<op> <id>))))]
      [some-other-pattern
       (raise-syntax-error 'create-unop-setter
                           "Usage: (create-unop-setter <unary-function-name>)"
                           (syntax some-other-pattern))]
      ))

  


  ;; (tweak val needs-fixing? fixer)
  ;; Return val, unless it needs fixing, in which case apply fixer.
  ;; That is,
  ;;   (if (needs-fixing? val) (fixer val) val)
  ;; 
  ;; Usually fixer is a function,
  ;; but we generalize a bit if it is not:
  ;; - if fixer is a constant instead of a function,
  ;;   use that value as the fixed version:
  ;;   that is, treat it as the function  (lambda (v) fixer)
  ;; 
  ;; Examples:
  ;;   (tweak data empty? '(0))                   ; Never returns empty.
  ;;   (tweak (- (* b b) (* 4 a c)) negative? -)  ; Always returns non-negative.
  ;;   (tweak info (non string-null?) (cute string-append <> ".")) ; Result is null-str, or ends in "."
  ;;   (tweak (some-text) exaggerate? (cute string-append <> "!!!"))
  ;; 
  ;; The higher-order functions non, compose, cut, cute (see srfi 26) 
  ;; are often helpful.  Or personally I prefer my "l1" from (lib "function.ss" "Ian").
  ;;
  ;; WARNING: Using the constant version is convenient, but might be
  ;; misleading if your fixed-answer is a specific function (rather
  ;; than apply that function to the input-val).  In this case,
  ;; wrap the desired fixed answer in a constant/f.
  ;;
  ;; IMPROVEMENT?: should we have fixer always be an expression,
  ;;    but allow __ as the implicit argument, a la l1?
  ;;
  (define (tweak val needs-fixing? fixer)
    (if (cond [(procedure? needs-fixing?) (needs-fixing? val)]
              [(boolean?   needs-fixing?)  needs-fixing?     ]
              [else (raise-type-error 'tweak "predicate or boolean" needs-fixing?)])
        ; What to return if the value needs fixing:
        (if (procedure? fixer)
            (fixer val)
            fixer)
        ; What to return if the value doesn't need fixing:
        val))
    ;
    ; Design comment: I thought about allowing needs-fixing? to
    ; be a constant which would be compared to val (via equal?),
    ; but I think that most constants you'd want to compare against
    ; have their own function (empty?, string-null?, zero?, ...),
    ; so I decided against making that a special case.  
    ; Later I discovered that it's handy to allow needs-fixing? be a boolean.
  (define false? not)

  ;; syntax-source-string: syntax -> string
  ;; Return a string of the form "<module>:<line>:<column>",
  ;; as seen in built-in error messages.
  ;; There is probably a built-in for this,
  ;; and I thought it would be "syntax-source", but that returns
  ;; the source.
  ;;
  (define (syntax-source-string stx)
    (letdef* {[(string-empty? str) (string=? str "")]
              [(string-append-if-nonempty str suff) 
               ; Return "" if str is empty or a non-string; otherwise append.
               (if (and (string? str) (string-empty? "" str))
                   (string-append str suff)
                   "")]
              }
      (tweak
       (string-append (string-append-if-nonempty (syntax-source-module stx) ":")
                      (string-append-if-nonempty (syntax-line          stx) ":")
                      (string-append-if-nonempty (syntax-column        stx) ""))
       string-empty?
       "unknown")))              
  
  (define-syntax ....
    (syntax-id-rules ()
      [.... (error '.... "Function not yet implemented (line ~a)"
                        (syntax-line #'....)#;(syntax-source-string #'....))]))
      
  )

;(require util)
;(define (f x) (+ ... 7))
;(f 7)