(module query-core mzscheme
(require (lib "contract.ss")
(lib "struct.ss")
(all-except (lib "list.ss" "srfi" "1") any)
(lib "time.ss" "srfi" "19")
(lib "cut.ss" "srfi" "26"))
(require (planet "symbol.ss" ("untyped" "unlib.plt" 2)))
(require (file "base.ss")
(prefix era: (file "era.ss"))
(file "type.ss"))
(provide (all-defined))
(define-struct named (alias) #f)
(define-struct (select named)
(what from where group order limit offset what-entities from-fields single-item?) #f)
(define-struct (field named) (table name type) #f)
(define-struct (aggregate named) (op arg) #f)
(define-struct (table named) (name) #f)
(define-struct/properties (entity table)
(entity)
([prop:custom-write
(lambda (item port write?)
(fprintf port "<q:entity ~a ~a>" (named-alias item) (table-name item)))])
#f)
(define-struct join (op left right on fields tables) #f)
(define-struct where (expr) #f)
(define-struct on (expr) #f)
(define-struct expr (op args) #f)
(define-struct order (arg dir) #f)
(define (source? item)
(or (table? item)
(join? item)
(select? item)))
(define (select-what-types select)
(map (lambda (field)
(if (field? field)
(field-type field)
(aggregate-type field)))
(select-what select)))
(define (aggregate-type aggregate)
(let ([op (aggregate-op aggregate)]
[arg (aggregate-arg aggregate)])
(cond [(eq? op 'count) type:integer]
[(eq? op 'count*) type:integer]
[(eq? op 'max) (type-base (field-type arg))]
[(eq? op 'min) (type-base (field-type arg))]
[(eq? op 'average) type:real]
[else (raise-exn exn:fail:snooze
(format "Unrecognised aggregate operator: ~a ~a" op aggregate))])))
(define (check-what-fields+tables what from-fields from-tables)
(for-each (lambda (field)
(if (field? field)
(unless (or (member (field-table field) from-tables)
(member field from-fields))
(raise-exn exn:fail:snooze
(format "Field ~a does not come from a selected table" field)))
(let ([arg (aggregate-arg field)])
(if (field? arg)
(unless (or (member (field-table arg) from-tables)
(member field from-fields))
(raise-exn exn:fail:snooze
(format "WHAT: aggregate ~a does not come from a selected table" field)))
(unless (or (not arg)
(member arg from-tables)
(member field from-fields))
(raise-exn exn:fail:snooze
(format "WHAT: aggregate ~a does not come from a selected table" field)))))))
what))
(define (check-expr-fields+tables expr fields tables expr-op)
(cond [(field? expr) (unless (or (member (field-table expr) tables)
(member expr fields))
(raise-exn exn:fail:snooze
(format "~a: field ~a is not declared in a table or subquery." expr-op expr)))]
[(aggregate? expr) (unless (member expr fields)
(raise-exn exn:fail:snooze
(format "~a: aggregate ~a is not declared in a subquery." expr-op expr)))]
[(expr? expr) (map (cut check-expr-fields+tables <> fields tables expr-op) (expr-args expr))]))
(define (check-order-fields+tables order fields tables)
(for-each (lambda (order)
(let ([field (order-arg order)])
(cond [(field? field) (unless (or (member (field-table field) tables)
(member field fields))
(raise-exn exn:fail:snooze
(format "ORDER: field ~a is not declared in a table or subquery." field)))]
[(aggregate? field) (unless (or (member field fields)
(let ([arg (aggregate-arg field)])
(if (field? arg)
(or (member (field-table arg) tables) (member arg fields))
(member arg tables))))
(raise-exn exn:fail:snooze
(format "ORDER: aggregate ~a is not declared in the surrounding query." field)))])))
order))
(define atom/c
(or/c string? integer? symbol? boolean? time? field? aggregate?))
(define expr/c
(or/c expr? atom/c))
)