#!/usr/bin/env tclsh
# schema.tcl -- Convert KEKS/Schema schemas to commands
# Copyright (C) 2024-2025 Sergey Matveev <stargrave@stargrave.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, version 3 of the License.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this program.  If not, see <http://www.gnu.org/licenses/>.

package require KEKS

namespace eval KEKS::Schema {

set version 0.1.0

proc EXISTS {} {return {LIST {{STR E}}}}
proc !EXISTS {} {return {LIST {{STR !E}}}}
proc EACH {} {return {LIST {{STR *}}}}
proc EQ {v} {subst {LIST {{STR =} {BIN $v}}}}
proc GT {n} {subst {LIST {{STR >} {INT $n}}}}
proc LT {n} {subst {LIST {{STR <} {INT $n}}}}
proc SCHEMA {s} {subst {LIST {{STR S} {STR $s}}}}
proc TIMEPREC {p} {subst {LIST {{STR TP} {INT $p}}}}
proc UTC {} {return {LIST {{STR UTC}}}}

proc TAKE {k} {
    if {$k == "."} {
        set v [list NIL]
    } elseif {[string first ":" $k] == 0} {
        set v [list STR [string range $k 1 end]]
    } elseif {[string is digit $k]} {
        set v [list INT $k]
    } else {
        set v [list STR $k]
    }
    subst {LIST {{STR .} {$v}}}
}

set knownTypes [dict create \
    bin B blob O bool b hexlet H int I list L magic K map M nil N str S tai T]

proc TYPE {types} {
    variable knownTypes
    set l {{STR T}}
    foreach t $types {
        lappend l [list STR [dict get $knownTypes [string tolower $t]]]
    }
    subst {LIST {$l}}
}

set timeprecArgs [dict create s 0 ms 3 us 6 ns 9 ps 12 fs 15]

proc field {k types args} {
    upvar _cmds _cmds buf buf
    if {$k != "."} {
        lappend _cmds [TAKE $k]
        if {[lsearch -exact $args !exists] != -1} {
            lappend _cmds [!EXISTS]
        } elseif {[lsearch -exact $args optional] == -1} {
            lappend _cmds [EXISTS]
        }
    }
    if {[lindex $types 0] == "with"} {
        lappend _cmds [SCHEMA [lindex $types 1]]
    } elseif {[lsearch -exact $types set] == -1} {
        if {[llength $types] != 0} {
            lappend _cmds [TYPE $types]
        }
    } else {
        if {[llength $types] != 1} {
            error "set can be the only one among types"
        }
        lappend _cmds [TYPE {MAP}]
        lappend _cmds [EACH]
        lappend _cmds [TYPE {NIL}]
        lappend _cmds [TAKE $k]
    }
    set i [lsearch -glob $args "len=*"]
    if {$i != -1} {
        set n [string range [lindex $args $i] 4 end]
        lappend _cmds [GT [expr {$n - 1}]]
        lappend _cmds [LT [expr {$n + 1}]]
    }
    set i [lsearch -glob $args ">*"]
    if {$i != -1} {
        lappend _cmds [GT [string range [lindex $args $i] 1 end]]
    }
    set i [lsearch -glob $args "<*"]
    if {$i != -1} {
        lappend _cmds [LT [string range [lindex $args $i] 1 end]]
    }
    set i [lsearch -glob $args "prec=*"]
    if {$i != -1} {
        set p [string range [lindex $args $i] 5 end]
        variable timeprecArgs
        set p [dict get $timeprecArgs $p]
        lappend _cmds [TIMEPREC $p]
    }
    if {[lsearch -exact $args utc] != -1} {
        lappend _cmds [UTC]
    }
    set i [lsearch -glob $args "=*"]
    if {$i != -1} {
        lappend _cmds [EQ [string range [lindex $args $i] 1 end]]
    }
    set i [lsearch -glob $args "of *"]
    if {$i != -1} {
        lappend _cmds [EACH]
        set s [lindex $args $i]
        if {[llength $s] > 2} {
            lappend _cmds [TYPE [lrange $s 2 end]]
        } else {
            lappend _cmds [SCHEMA [lindex $s 1]]
        }
    }
}

proc process {v} {
    upvar _pairs _pairs buf buf
    foreach {name cmds} $v {
        set _cmds {}
        if {$name == "schema-include"} {
            set fd [open [file join $cmds]]
            set inc [read $fd]
            close $fd
            process $inc
            continue
        }
        foreach cmd $cmds {eval $cmd}
        lappend _pairs $name [list LIST $_cmds]
    }
}

proc do {v} {
    upvar buf buf
    set _pairs {}
    process $v
    MAP $_pairs
}

namespace export TAKE EXISTS !EXISTS EACH EQ TYPE GT LT SCHEMA TIMEPREC UTC
namespace export do process field

}

package provide KEKS::Schema $KEKS::Schema::version

namespace import KEKS::*

if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
    set _schema {}
    foreach f $::argv {lappend _schema schema-include $f}
    set buf ""
    MAGIC schema
    KEKS::Schema::do $_schema
    puts [binary encode hex $buf]
}
