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 } {                                 # http://wiki.tcl.tk/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
    }
 }