1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
#lang scheme
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PARSEQ.PLT
;; A Parser Combinator library.
;;
;; Bonzai Lab, LLC. All rights reserved.
;;
;; Licensed under LGPL.
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sql.ss - parsing the create table statement
;; yc 1/5/2010 - first version
(require "../main.ss"
mzlib/defmacro
(for-syntax scheme/base
scheme/match
)
(planet bzlib/base)
)
(define sql-identifier
(seq c <- alpha
rest <- (zero-many word)
(return (string->symbol
(string-downcase (list->string (cons c rest)))))))
(define create-table-def
(tokens-ci "create" "table"
name <- sql-identifier
clauses <- (bracket #\(
(delimited clause-def #\,)
#\))
(return (cons name clauses))))
(define clause-def
(choice primary-key-def foreign-key-def column-def))
;; making things without order would be quite a difficult combinator.
;; basically we need to try each of the combinator, and then as we have the binding
;; make sure it is returned in a way that can easily be identified...
;; for example, the first
(define (self-and-value parser)
(seq v <- parser
(return (cons parser v))))
(define (one-of-each parsers defaults)
;; we need to try each one, and then figure out the *rest* that weren't matched
;; continue until we are either out of the stream or out of the combinator...
;; at any time there is anything that none of them matches then we will be in trouble...
(define (each-helper parsers)
(one-of (map self-and-value parsers)))
(define (sort-helper acc parsers defaults)
(map (lambda (v default)
(if (pair? v)
(cdr v)
default))
(map (lambda (parser)
(assf (lambda (p)
(eq? p parser))
acc))
parsers)
defaults))
;; if all of them failed @ the next position, then we need to offer
;; default values for the remainder of the parsers!!!
;; this is where it is *interesting!!!...
;; in such case we want to have a chance to work on the *fail* clause...
;; this is hmm....
(define (helper rest acc)
(bind (each-helper rest)
(lambda (v)
(if (succeeded? v)
(let ((rest (remove (car v) rest)))
(if (null? rest)
(return (sort-helper acc parsers defaults))
(helper rest (cons v acc))))
(return (sort-helper acc parsers defaults))))))
(helper parsers '()))
(define-syntax one-of-each*
(syntax-rules ()
((~ (parser default) ...)
(one-of-each (list parser ...) (list default ...)))))
(define column-def
(tokens name <- sql-identifier
attrs <- (one-of-each* (type-def 'text)
(nullability 'null)
(inline-primary-key #f)
(inline-foreign-key #f))
(return (cons name attrs))))
(define nullability
(choice (tokens-ci "null" (return 'null))
(tokens-ci "not" "null" (return 'not-null))))
(define type-def
(seq type <- (choice (string-ci= "int")
(string-ci= "integer")
(string-ci= "float")
(string-ci= "text"))
(return (string->symbol type))))
(define inline-primary-key
(tokens-ci "primary" "key" (return 'pkey)))
;; (trace inline-primary-key)
(define sql-identifiers/paren
(bracket #\( (delimited sql-identifier #\,) #\)))
(define inline-foreign-key
(tokens-ci "foreign" "key"
(zero-one (string-ci= "references") "references")
table <- sql-identifier
(zero-one (string-ci= "on") "on")
columns <- sql-identifiers/paren
(return `(foreign-key ,table ,columns))))
(define primary-key-def
(tokens-ci "primary" "key"
name <- (zero-one sql-identifier #f)
columns <- sql-identifiers/paren
(return `(primary-key ,name ,columns))))
(define foreign-key-def
(tokens-ci "foreign" "key"
name <- (zero-one sql-identifier #f)
columns <- sql-identifiers/paren
(string-ci= "references")
table <- sql-identifier
(zero-one (string-ci= "on") "on")
fk-columns <- sql-identifiers/paren
(return `(foreign-key ,name ,columns ,table ,fk-columns))))
;; (provide create-table-def)
(define sql-def (choice create-table-def))
(define read-sql (make-reader sql-def))
(provide read-sql)
|
