;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Contract-Utils: general-purpose PLT contract utilities.
;;  Copyright (C) 2005-2010  Richard Cobbe
;;  Version 4.0
;;
;;  For licensing information, see the Scribble manual.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#lang racket

(require (prefix-in srfi-67: srfi/67))

;; abstract types provided by Racket:
;;   Contract
;;   Flat-Contract

;; Pred-Contract ::= (Union (a -> Bool) Contract)
;; Pred-Flat-Contract ::= (Union (a -> Bool) Flat-Contract)

;; listof-unique/c :: (a a -> Bool) -> Flat-Contract
;; produces a flat contract that recognizes lists whose elements are unique
;; with respect to equ?
;; FIXME: take a contract that also applies to each element, like listof?
(define listof-unique/c
  (lambda (equ?)
    (flat-named-contract
     "list of unique elements"
     (lambda (elems)
       (let scan ([elems elems])
         (if (null? elems)
             #t
             (let* ([elem (car elems)]
                    [rest (cdr elems)])
               (and (andmap (lambda (other) (not (equ? elem other))) rest)
                    (scan rest)))))))))

;; listof-unique-compare/c :: (a a -> (Union -1 0 1)) -> Flat-Contract
;; produces a flat contract that recognizes lists whose elements are unique
;; with respect to cmp.
(define listof-unique-compare/c
  (lambda (cmp)
    (flat-named-contract
     "list of unique elements"
     (lambda (elems)
       (apply srfi-67:chain<? cmp (sort elems (srfi-67:<? cmp)))))))

;; nelistof/c :: Pred-Flat-Contract -> Flat-Contract
;; produces a contract that recognizes a non-empty list of elements
;; which satisfy the contract c.
(define nelistof/c
  (lambda (c)
    (and/c (listof c) (not/c null?))))

;; sexp/c :: Flat-Contract
;; recognizes arbitrary s-expressions.
(define sexp/c
  (flat-rec-contract sexp
                     (cons/c sexp sexp)
                     null?
                     number?
                     symbol?
                     string?
                     boolean?
                     char?))

;; predicate/c :: Contract
;; recognizes unary predicates
(define predicate/c (any/c . -> . boolean?))

;; binary-predicate/c :: Contract -> Contract
;; recognizes binary predicates that accept elements that satisfy arg/c
(define binary-predicate/c
  (lambda (arg/c)
    (arg/c arg/c . -> . boolean?)))

;; equality/c :: Contract -> Contract
;; recognizes equality predicates that work on values that satisfy arg/c
(define equality/c
  (lambda (arg/c)
    (arg/c arg/c . -> . boolean?)))

;; comparison/c :: Contract -> Contract
;; recognizes comparison functions as defined by SRFI 67 that work on values
;; that satisfy arg/c
(define comparison/c
  (lambda (arg/c)
    (arg/c arg/c . -> . (integer-in -1 1))))

;; optional/c :: Pred-Contract -> Contract
;; produces a contract that recognizes both #f and all values recognized
;; by the argument
(define optional/c (lambda (contract) (or/c contract false/c)))

;; positive-int/c :: Flat-Contract
;; recognizes all positive integers
(define positive-int/c
  (flat-named-contract "positive integer"
                       (and/c natural-number/c (lambda (x) (> x 0)))))

;; contract/c :: Contract
;; recognizes contracts and predicates
(define contract/c (or/c contract? predicate/c))

;; flat-contract/c :: Contract
;; recognizes flat contracts and predicates
(define flat-contract/c (or/c flat-contract? predicate/c))

;; immutable-string/c :: Flat-Contract
;; recognizes immutable strings.
(define immutable-string/c (and/c string? immutable?))

;; contract-of :: Pred-Contract -> Contract
;; wraps a predicate in a flat contract; idempotent
(define contract-of
  (lambda (c/p)
    (if (contract? c/p) c/p (flat-contract c/p))))

;; predicate-of :: Pred-Flat-Contract -> Predicate
;; extracts a flat contract's predicate if necessary.  Idempotent.
(define predicate-of
  (lambda (c/p)
    (if (flat-contract? c/p) (flat-contract-predicate c/p) c/p)))

(define-syntax eta
  (syntax-rules ()
    [(_ f) (lambda args (apply f args))]))

(provide/contract [sexp/c flat-contract?]
                  [predicate/c contract?]
                  [binary-predicate/c (contract/c . -> . contract/c)]
                  [equality/c (contract/c . -> . contract/c)]
                  [comparison/c (contract/c . -> . contract/c)]
                  [optional/c (contract/c . -> . contract?)]
                  [positive-int/c flat-contract?]
                  [listof-unique/c (equality/c . -> . flat-contract/c)]
                  [listof-unique-compare/c (comparison/c . -> .
                                                         flat-contract/c)]
                  [nelistof/c (contract/c . -> . flat-contract?)]
                  [contract/c contract?]
                  [flat-contract/c contract?]
                  [immutable-string/c flat-contract?]
                  [contract-of (contract/c . -> . contract?)]
                  [predicate-of (flat-contract/c . -> . predicate/c)])

(provide eta)