(module sql-quote-unit mzscheme
(require (lib "etc.ss")
(lib "pregexp.ss")
(lib "unitsig.ss")
(lib "list.ss" "srfi" "1")
(lib "string.ss" "srfi" "13")
(lib "time.ss" "srfi" "19")
(lib "vector-lib.ss" "srfi" "43"))
(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2)))
(require (file "../base.ss")
(file "../era.ss")
(file "../type.ss")
(file "../generic/sql-sig.ss")
(prefix generic: (file "../generic/sql-quote-unit.ss")))
(provide sql-quote@)
(define sql-quote@
(let ([mixin@
(unit/sig sql-quote^
(import (generic : sql-quote^))
(define (quote-id identifier)
(if (symbol? identifier)
(string-append "\"" (symbol->string identifier) "\"")
(string-append "\"" identifier "\"")))
(define (quote-data type data)
(let ([base (type-base type)])
(cond [(eq? base type:id)
(cond [(integer? data) (number->string data)]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U integer #f), given ~a" data))])]
[(eq? base type:revision)
(cond [(integer? data) (number->string data)]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U integer #f), given ~a" data))])]
[(eq? base type:text)
(cond [(string? data) (string-append "'" (regexp-replace* #rx"'" data "''") "'")]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U string #f), given ~a" data))])]
[(eq? base type:integer)
(cond [(integer? data) (number->string data)]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U integer #f), given ~a" data))])]
[(eq? base type:real)
(cond [(real? data) (number->string (exact->inexact data))]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U real #f), given ~a" data))])]
[(eq? base type:symbol)
(cond [(symbol? data) (string-append "'" (regexp-replace* #rx"'" (symbol->string data) "''") "'")]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U symbol #f), given ~a\n" data))])]
[(eq? base type:boolean)
(cond [(eq? data #t) "true"]
[(eq? data #f) "false"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U #t #f), given ~a\n" data))])]
[(eq? base type:time-tai)
(cond [(time? data)
(date->string (time-tai->date data) "'~Y-~m-~d ~H:~M:~S.~N'")]
[(equal? data (type-null type)) "NULL"]
[else (raise-exn exn:fail:snooze
(format "Expected data of type (U time-tai time-utc #f), given ~a\n" data))])])))
(define (unquote-data type data)
(let ([base (type-base type)])
(cond [(eq? base type:text)
(cond [(sql-null? data) #f]
[(string? data) data]
[else (raise-exn exn:fail:snooze (format "Cannot parse ~a: ~s" type data))])]
[(or (eq? base type:id)
(eq? base type:revision)
(eq? base type:integer))
(cond [(sql-null? data) #f]
[(integer? data) data]
[else (raise-exn exn:fail:snooze (format "Cannot parse ~a: ~s" type data))])]
[(eq? base type:real)
(cond [(sql-null? data) #f]
[(number? data) data]
[else (raise-exn exn:fail:snooze (format "Cannot parse ~a: ~s" type data))])]
[(eq? base type:symbol)
(cond [(sql-null? data) #f]
[(string? data) (string->symbol data)]
[else (raise-exn exn:fail:snooze (format "Cannot parse ~a: ~s" type data))])]
[(eq? base type:boolean)
(cond [(sql-null? data) #f]
[(boolean? data) data]
[else #f])]
[(eq? base type:time-tai)
(cond [(sql-null? data) #f]
[(sql-timestamp? data) (date->time-tai (sql-datetime->srfi-date data))]
[else (raise-exn exn:fail:snooze (format "Cannot parse ~a: ~s" type data))])])))
(define (make-data-unquoter types)
(let ([types (list->vector types)])
(lambda (source)
(if source
(vector-map (lambda (index type val)
(unquote-data type val))
types
source)
#f))))
)])
(compound-unit/sig
(import)
(link (original : sql-quote^ (generic:sql-quote@))
(variation : sql-quote^ (mixin@ original)))
(export (open variation)))))
)