package require TclOO
package require snit
package require sqlite3
package require tcl::chan::events
package require tcl::chan::string
source isbl-parser.tcl
# Here are some little helpers.
#
proc K { x y } { set x }
proc cat { file } { K [read [set fp [open $file]]] [close $fp] }
proc lremove { list value args } { # https://wiki.tcl-lang.org/15659 Thanks to RS
lsearch -all -inline -not -exact {*}$args $list $value
}
proc : { args } {
set body [lindex $args end]
set reply {}
foreach {*}[lrange $args 0 end-1] { append reply [subst $body] }
set reply
}
proc map { args } {
set body [lindex $args end]
set reply {}
foreach {*}[lrange $args 0 end-1] { lappend reply [eval $body] }
set reply
}
oo::class create isbl {
variable parser string count \
cStack cColumns cType \
Templates FunType \
vPrefix
constructor { database } {
set count 0
sqlite3 [namespace current]::sql $database
set vPrefix ""
# Sql statement templates for each isbl operator
#
set Templates { # This should be a classvar?
+ { select * from (%a1) UNION select * from (%a2) }
. { select * from (%a1) INTERSECT select * from (%a2) }
- { select * from (%a1) EXCEPT select t1.* from (%a1) as t1 NATURAL JOIN (%a2) }
: { select * from (%a1) where (%a2) }
% { select distinct %a2 from (%a1) }
* { select * from (%a1) NATURAL JOIN (%a2) }
}
set parser [isbl-parser]
}
# This block of methods generates sql from the AST built by the isbl-parser peg parser.
# Each method can be seen as the parser "action" associated with the corresponding rule.
#
# Many of the non-terminal symbols in the grammer are evaluated using the same code.
# The parser-actions preprocessor reads the grammer file and generates a bunch of parser
# actions # from the directives given in the comments there and the templates provided
# in the isbl-actions.act file we include the generated actions here.
#
source isbl-actions.tcl
method Tupple { start end args } { ; # Use select wo/from to generate a tupple.
my cPush {}
K "select [my {*}[lindex $args 1]]" [my cPop; my cPush $cColumns]
}
method Sum { start end args } { my Operator $args } ; # These are the operators.
method Join { start end args } { my Operator $args }
method Select { start end args } { my Operator $args }
method Project { start end args } { my Operator $args }
method Operator { args } { ; # Convert infix to sql using the
set args [lindex $args 0] ; # template sql strings.
set reply [my {*}[lindex $args 0]]
foreach { op a2 } [lrange $args 1 end] {
set op [my {*}$op]
set a2 [my {*}$a2]
my cOperator $op
set reply [string map [list %a1 $reply %a2 $a2] [dict get $Templates $op]]
}
set reply
}
# A top level sql expression.
#
# The top level evaluation returns a list to evaluate
#
method TopExpr { start end relexpr } { list [my {*}$relexpr] }
method Assign { start end args } { ; # Insert into or Overwrie a table.
set tab [my {*}[lindex $args 0]]
set op [my {*}[lindex $args 1]]
set val [my {*}[lindex $args 2]]
set drop {}
set sql {}
switch $op {
= { set sql [subst {
drop table if exists $tab ;
drop view if exists $tab ;
create table $tab ( [join [lindex $cStack end] ,]
, constraint uc_set unique ( [join [map x [lindex $cStack end] { lindex $x 0 }] ,] )
on conflict replace ) ;
insert or replace into $tab $val ;
}]
}
+= { set sql [subst { insert or replace into $tab $val ; }] }
:= { set sql [subst {
drop view if exists $tab ;
drop table if exists $tab ;
create view $tab as $val ;
}]
}
-= { return [list $val [subst {
sql eval {
delete from $tab
where [join [: col [my cPop] { [list [lindex $col 0]=\$[lindex $col 0]] }] " and "]
}
}]]
}
*= {
set vPrefix " \$"
set asslist [my {*}[lindex $args 3]]
set vPrefix ""
return [list $val [subst {
sql eval {
update $tab set $asslist
}
}]]
}
}
list [subst {
begin transaction ;
$sql;
commit transaction ;
}]
}
method Cols { start end args } { ; # This part of the grammer tracks the
set columns {} ; # column definition of a term.
foreach arg $args { set columns [my {*}$arg $columns] }
foreach col $columns {
switch [llength $col] {
1 { lappend Columns $col; lappend sql $col }
2 { lappend Columns $col; lappend sql [lindex $col 0] }
3 { lappend Columns [lrange $col 0 1]; lappend sql "[lindex $col 2] as [lindex $col 0]" }
}
}
set cColumns $Columns
join $sql ,
}
method Col { start end column columns } { my {*}$column $columns }
method CFunc { start end name in out columns } {
set name [my {*}$name]
set args [my {*}$in]
set n 0
set call "set [namespace current]::__$name \[$name {*}\$args]"
foreach col [split [my {*}$out] ,] {
if { [info proc [namespace current]::__$name$n] eq {} } {
sql function __$name$n [namespace current]::__$name$n
proc [namespace current]::__$name$n args [subst {
$call
lindex $[namespace current]::__$name $n
}]
}
lappend reply [list $col [lindex $FunType($name) $n] __$name${n}($args)]
incr n
set call {}
set args {}
}
lappend $columns {*}$reply
}
method CName { start end columns } {
set col [string range $string $start $end]
set columns [lremove $columns $col -index 0]
lappend columns [list $col [my cType $col]]
}
method CAll { start end columns } {
set all [my cAll]
foreach col $columns { set all [lremove $all [lindex $col 0] -index 0] }
lappend columns {*}$all
}
method CDel { start end columns } {
if { $columns eq {} } {
set columns [my CAll $start $end $columns]
}
lremove $columns [string range $string $start $end] -index 0
}
method CMap { start end value column columns } {
set val [my {*}$value]
set col [my {*}$column]
set columns [lremove $columns $col]
lappend columns [list $col $cType $val]
}
method Table { start end } { my cTab [string range $string $start $end] }
method VName { start end } { my tType "$vPrefix[string range $string $start $end]" }
method Real { start end } { my tReal; string range $string $start $end }
method Int { start end } { my tInt; string range $string $start $end }
method String { start end } { my tTxt; string range $string $start $end }
method EOF { args } {}
# These methods are the "op codes" of the column tracking machine
#
method cTab { table } { my cPush [my cColumns $table]; set table }
method cOperator { Op } {
switch $Op {
% { my cPop; my cPush $cColumns }
* {
set c2 [my cPop]
set c1 [my cPop]
set cc $c1
foreach col $c2 {
if { [lsearch -index 0 $c1 [lindex $col 0]] < 0 } { lappend cc $col }
}
my cPush $cc
}
+ - - - . { my cPop }
}
}
method cColumns { Table } {
set x {}
sql eval [subst { pragma table_info($Table) }] { lappend x [list $name $type] }
set x
}
method cAll {} { lindex $cStack end }
method cPop {} { K [lindex $cStack end] [set cStack [lrange $cStack 0 end-1]] }
method cPush { value } { lappend cStack $value }
method cType { column } { lindex [my tCol $column] 1 }
method tReal {} { set cType real }
method tInt {} { set cType int }
method tTxt {} { set cType text }
method tCol { column } { lindex $cStack end [lsearch -index 0 [lindex $cStack end] $column] }
method tType { column } {
set cType [lindex [my tCol $column] 1]
set column
}
unexport cTab cOperator cColumns cColumns cAll cPop cPush cType tReal tInt tTxt tCol tType
# Here is the worker bee
#
method isbl2sql { isbl } {
set cStack {}
set cColumns {}
set vPrefix {}
try {
set sql {}
set string $isbl
set sql [my {*}[K [set ast [$parser parse [set chan [::tcl::chan::string $string]]]] [close $chan]]]
} on error message {
puts "$message"
lassign $message rde pos
if { $rde eq "pt::rde" } {
error "syntax : [string range $string 0 $pos] ?? [string range $string $pos+1 end]"
} else {
error $message
}
}
if { [llength [split [lindex $sql 0] " "]] == 1 } {
set sql [lreplace $sql 0 0 "select * from [lindex $sql 0]"]
}
#puts "ast : $ast"
#puts "sql : $sql"
set sql
}
# Evaluate the sql on the attached sqlite database. This is how we interact with sqlite.
#
method sql { sql args } { uplevel [list [namespace current]::sql eval $sql {*}$args] }
method eval { isbl } { ; # Evaluate an isbl expression
set sql {}
try { sql eval {*}[set sql [my isbl2sql $isbl]]
} on error message {
puts "$message : $sql"
error $message
}
}
method +sql { isbl } { ; # Print sql result for debugging
puts [my isbl2sql $isbl]
}
method list { isbl } { ; # List expression result as tab table
set sql [lindex [my isbl2sql $isbl] 0]
if { [lindex $cStack 0] eq {} } {
puts stderr "No Table?"
exit 1
}
foreach col [lindex $cStack 0] { lappend columns [lindex $col 0] }
puts [join $columns "\t"]
puts [regsub -all {[^\t]} [join $columns "\t"] -]
try {
sql eval $sql T {
set sep ""
foreach name $T(*) {
puts -nonewline "$sep$T($name)"
set sep "\t"
}
puts ""
}
} on error message {
puts "[self] list $isbl : $sql : $message"
}
}
method function { type func args body } { ; # Define a function
set FunType($func) $type
sql function $func $func
proc [namespace current]::$func $args $body
}
}