diff options
Diffstat (limited to 'tcllib/modules/doctools2idx/structure.tcl')
| -rw-r--r-- | tcllib/modules/doctools2idx/structure.tcl | 288 |
1 files changed, 288 insertions, 0 deletions
diff --git a/tcllib/modules/doctools2idx/structure.tcl b/tcllib/modules/doctools2idx/structure.tcl new file mode 100644 index 0000000..c7e3285 --- /dev/null +++ b/tcllib/modules/doctools2idx/structure.tcl @@ -0,0 +1,288 @@ +# -*- tcl -*- +# Copyright (c) 2009 Andreas Kupries <andreas_kupries@sourceforge.net> + +# Verification of serialized indices, and conversion between +# serialized indices and other data structures. + +# # ## ### ##### ######## ############# ##################### +## Requirements + +package require Tcl 8.4 ; # Required runtime. +package require snit ; # OO system. + +# # ## ### ##### ######## ############# ##################### +## + +snit::type ::doctools::idx::structure { + # # ## ### ##### ######## ############# + ## Public API + + # Check that the proposed serialization of a keyword index is + # indeed such. + + typemethod verify {serial {canonvar {}}} { + # Basic syntax: Length and outer type code + if {[llength $serial] != 2} { + return -code error $ourprefix$ourshort + } + + foreach {tag contents} $serial break + #struct::list assign $serial tag contents + + if {$tag ne $ourcode} { + return -code error $ourprefix[format $ourtag $tag] + } + + if {[llength $contents] != 8} { + return -code error $ourprefix$ourcshort + } + + # Unpack the contents, then check that all necessary keys are + # present. Together with the length check we can then also be + # sure that no other key is present either. + array set idx $contents + + foreach k {label title keywords references} { + if {[info exists idx($k)]} continue + return -code error $ourprefix[format $ourmiss $k] + } + + # Pull the keys and check their use (n duplicates allowed). At + # the same time we collect the references they are associated + # with. + + set refs {} + set keys {} + array set kw {} + + foreach {k reflist} $idx(keywords) { + lappend keys $k + set kw($k) {} + foreach r $reflist { lappend refs $r } + } + + # Fail if keys are duplicated + if {[llength [array names kw]] != [llength $keys]} { + return -code error $ourprefix$ourkdup + } + + # Pull the references and check their values, and use. + array set rd {} + set refids {} + foreach {id rdef} $idx(references) { + if {[llength $rdef] != 2} { + return -code error $ourprefix$ourrshort + } + set rtag [lindex $rdef 0] + if {($rtag ne "manpage") && ($rtag ne "url")} { + return -code error $ourprefix[format $ourrtag $rtag] + } + lappend refids $id + set rd($id) {} + } + + # Fail if reference ids are duplicated + if {[llength [array names rd]] != [llength $refids]} { + return -code error $ourprefix$ourrdup + } + + # Fail if we have references in keys without decl, or + # references not used by any key. + if {[lsort -dict [lsort -unique $refs]] ne [lsort -dict $refids]} { + return -code error $ourprefix$ourrmismatch + } + + if {$canonvar ne {}} { + upvar 1 $canonvar iscanonical + + # Now various checks if the keys and identifiers are + # properly sorted to make this a canonical serialization. + set iscanonical 1 + + foreach {a _ b _ c _ d _} $contents break + #struct::list assign $contents a _ b _ c _ d _ + if { + ([list $a $b $c $d] ne {label keywords references title}) || + ($keys ne [lsort -dict [array names kw]]) || + ($refids ne [lsort -dict [array names rd]]) + } { + set iscanonical 0 + } + } + + # Everything checked out. + return + } + + typemethod verify-as-canonical {serial} { + $type verify $serial iscanonical + if {!$iscanonical} { + #puts <$kw>\n<[lsort -dict [lsort -unique $kw]]> + return -code error $ourprefix$ourdupsort + } + return + } + + typemethod canonicalize {serial} { + $type verify $serial iscanonical + if {$iscanonical} { return $serial } + + # Unpack the serialization. + array set idx $serial + array set idx $idx(doctools::idx) + unset idx(doctools::idx) + array set k $idx(keywords) + array set r $idx(references) + + # Scan and reorder ... + set keywords {} + foreach kw [lsort -dict [array names k]] { + # Sort references in a keyword by their _labels_. + set tmp {} + foreach rid $k($kw) { lappend tmp [list $rid [lindex $r($rid) 1]] } + set refs {} + foreach item [lsort -dict -index 1 $tmp] { + lappend refs [lindex $item 0] + } + lappend keywords $kw $refs + } + + set references {} + foreach rid [lsort -dict [array names r]] { + lappend references $rid $r($rid) + } + + # Construct result + set serial [list doctools::idx \ + [list \ + label $idx(label) \ + keywords $keywords \ + references $references \ + title $idx(title)]] + + return $serial + } + + # Merge the serialization of two indices into a new serialization. + + typemethod merge {seriala serialb} { + $type verify $seriala + $type verify $serialb + + # Merge using title and label of the second index, and the new + # key definitions come after the existing, overriding as + # needed. + + # Unpack the definitions... + + array set a $seriala ; array set a $a(doctools::idx) ; unset a(doctools::idx) + array set b $serialb ; array set a $b(doctools::idx) ; unset b(doctools::idx) + + # Merge keywords... + + array set k $a(keywords) + foreach {kw reflist} $b(keywords) { + if {![info exists k($kw)]} { set k($kw) {} } + foreach r $reflist { lappend k($kw) } + } + + # Merge references... Here we may have conflicting + # declarations for the same id. + + array set r $a(references) + foreach {rid rdecl} $b(references) { + if {[info exists r($rid)]} { + if {$r($rid) ne $rdecl} { + return -code error [format $ourmergeerr $r($rid) $rdecl $rid] + } + continue + } + set r($rid) $decl + } + + # Now construct the result, from the inside out, with proper + # sorting at all levels. + + set keywords {} + foreach kw [lsort -dict [array names k]] { + # Sort references in a keyword by their _labels_. + set tmp {} + foreach rid $k($kw) { lappend tmp [list $rid [lindex $r($rid) 1]] } + set refs {} + foreach item [lsort -dict -index 1 $tmp] { + lappend refs [lindex $item 0] + } + lappend keywords $kw $refs + } + + set references {} + foreach rid [lsort -dict [array names r]] { + lappend references $rid $r($rid) + } + + set serial [list doctools::idx \ + [list \ + label $b(label) \ + keywords $keywords \ + references $references \ + title $b(title)]] + + # Caller has to verify, ensure contract. + #$type verify-as-canonical $serial + return $serial + } + + # Converts an index serialization into a human readable string for + # test results. It assumes that the serialization is at least + # structurally sound. + + typemethod print {serial} { + array set i $serial + array set i $i(doctools::idx) + array set r $i(references) + set lines {} + lappend lines [list doctools::idx $i(label) $i(title)] + foreach {key reflist} $i(keywords) { + lappend lines ....$key + foreach ref $reflist { + lappend lines ........[linsert $r($ref) end $ref] + } + } + return [join $lines \n] + } + + # # ## ### ##### ######## ############# + + typevariable ourcode doctools::idx + typevariable ourprefix {error in serialization:} + # # Test cases (doctools-idx-structure-) + typevariable ourshort { dictionary too short, expected exactly one key} ; # 6.0 + typevariable ourtag { bad type tag "%s"} ; # 6.1 + typevariable ourcshort { dictionary too short, expected exactly four keys} ; # 6.2 + typevariable ourmiss { missing expected key "%s"} ; # 6.3, 6.4, 6.5, 6.6 + typevariable ourkdup { duplicate keywords} ; # 6.8 + typevariable ourrshort { reference list wrong, need exactly 2} ; # 6.12 + typevariable ourrtag { bad reference tag "%s"} ; # 6.13 + typevariable ourrdup { duplicate reference identifiers} ; # 6.14 + typevariable ourrmismatch { use and declaration of references not matching} ; # 6.10, 6.11 + # Message for non-canonical serialization when expecting canonical form + typevariable ourdupsort { duplicate and/or unsorted keywords/identifiers} ; # 6.7, 6.9, 6.15 + + typevariable ourmergeerr {Mismatching declarations '%s' vs. '%s' for '%s'} + + # # ## ### ##### ######## ############# + ## Configuration + + pragma -hasinstances no ; # singleton + pragma -hastypeinfo no ; # no introspection + pragma -hastypedestroy no ; # immortal + + ## + # # ## ### ##### ######## ############# +} + +# # ## ### ##### ######## ############# ##################### +## Ready + +package provide doctools::idx::structure 0.1 +return |