Tcl Library Source Code

[vset VERSION 0.1.6]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin huddle n [vset VERSION]]
[see_also yaml]
[keywords {data exchange}]
[keywords {exchange format}]
[keywords huddle]
[keywords json]
[keywords parsing]
[keywords {text processing}]
[keywords yaml]
[copyright {2008 KATO Kanryu <[email protected]>}]
[moddesc   {HUDDLE}]
[titledesc {Create and manipulate huddle object}]
[require Tcl 8.4]
[require huddle [opt [vset VERSION]]]
[description]
[para]
Huddle provides a generic Tcl-based serialization/intermediary format.
Currently, each node is wrapped in a tag with simple type information.
[para]

When converting huddle-notation to other serialization formats like

[call [cmd "huddle create"] [arg key] [arg value] [opt [arg "key value ..."]]]

Create a huddle object as a dict. It can contain other huddle objects.

[call [cmd "huddle list"] [opt [arg "value value ..."]]]
Create a huddle object as a list. It can contain other huddle objects.

[call [cmd "huddle number"] [arg "number"]]
Create a huddle object as a number.

[call [cmd "huddle string"] [arg "string"]]
Create a huddle object as a string.

[call [cmd "huddle boolean"] [arg "expression to evaluate as true or false"]]
Create a huddle object as a boolean evaluating an expression as true or false-

[call [cmd "huddle true"]]
Create a huddle object as a boolean true.

[call [cmd "huddle false"]]
Create a huddle object as a boolean false.

[call [cmd "huddle null"]]
Create a huddle object as a null.

[call [cmd "huddle get"] [arg object] [arg key]  [opt [arg "key ..."]]]
Almost the same as [cmd "dict get"].
Get a sub-object from the huddle object.
[arg key] can be used to huddle-list's index.

[call [cmd "huddle get_stripped"] [arg object] [arg key]  [opt [arg "key ..."]]]
Get a sub-object from the huddle object, stripped.

[call [cmd "huddle set"] [arg objectVar] [arg key]  [opt [arg "key ..."]] [arg value]]
Almost the same as [cmd "dict set"].
Set a sub-object from the huddle object.
[arg key] can be used to huddle-list's index.

[call [cmd "huddle remove"] [arg objectVar] [arg key]  [opt [arg "key ..."]]]
Almost the same as [cmd "dict remove"].
Remove in place a sub-object from the huddle object.
[arg key] can be used to huddle-list's index.

[call [cmd "huddle removed"] [arg object] [arg key]  [opt [arg "key ..."]]]
Makes a copy of the huddle object and remove the indicated sub-object.
This is more efficient than making first a clone and then use [cmd "huddle remove"] for removing the desired sub-object.

[call [cmd "huddle combine"] [arg object1] [arg object2]  [opt [arg "object3 ..."]]]
Merging huddle objects given.  The objects should be of the same type.

[example {
% set aa [huddle create a b c d]
HUDDLE {D {a {s b} c {s d}}}
% set bb [huddle create a k l m]
HUDDLE {D {a {s k} l {s m}}}
% huddle combine $aa $bb

HUDDLE {D {a {s b} c {s d}}}
% set bb [huddle create c d a b]
HUDDLE {D {c {s d} a {s b}}}
% huddle equal $aa $bb
1
}]

[call [cmd "huddle update_children"] [arg objectVar] [arg key] [arg value] [opt [arg "key value ..."]]]
Update child elements. Lists only allow update indexes that are in its range.

[call [cmd "huddle lappend"] [arg listVar] [arg value] [opt [arg "value ..."]]]
Append new children to a list.

[example {
% set aa [huddle create a b c d]
HUDDLE {D {a {s b} c {s d}}}
% huddle append aa a k l m
HUDDLE {D {a {s k} c {s d} l {s m}}}
% set bb [huddle list i j k l]

the node is a dict.

[opt_def [const list]]

the node is a list.

[opt_def [const number]]

the node is a number.

[opt_def [const boolean]]

the node is a boolean.

[opt_def [const null]]

the node is a null.

[list_end]

[example {
% huddle type {HUDDLE {s str}}
string
% huddle type {HUDDLE {L {{s a} {s b} {s c}}}}
list
% huddle type {HUDDLE {D {aa {s b} cc {s d}}}} cc
string
}]

[call [cmd "huddle strip"] [arg object]]
Stripped all tags. Converted to normal Tcl's list/dict.

[call [cmd "huddle json_dump"] [arg object] [opt [arg offset]] [opt [arg newline]] [opt [arg begin_offset]]]

dump a json-stream from the huddle-object.

[para]
[list_begin options]
[opt_def "[const offset] \"\""]

begin offset as spaces "  ".

[list_end]

[example {# normal output has some indents. some strings are escaped.
% huddle json_dump {HUDDLE {L {{L {{s i} {s baa} {s \\k} {L {{s 1.0} {s true} {s /g} {s h}}} {L {{s g}}}}} {s t}}}}
[
  [
    "i",
    "baa",
    "\\k",
    [
      1.0,
      true,
      "\/g",
      "h"
    ],
    ["g"]
  ],
  "t"
]
# stripped output
% huddle json_dump {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d
a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s 1} j {s { m\a}}}}}}} "" ""
{"dd": {"bb": {"a": "baa","c": "d\na"},"cc": {"g": "h"}},"ee": {"i": "j","k": 1,"j": " m\\a"}}
}]

[call [cmd "huddle compile"] [arg spec] [arg data]]

construct a huddle object from plain old tcl values.

[example {% huddle compile {dict * list} {a {1 2 3} b {4 5}}
HUDDLE {D {a {L {{s 1} {s 2} {s 3}}} b {L {{s 4} {s 5}}}}}
% huddle compile {dict * {list {dict d list}}} {a {{c 1} {d {2 2 2} e 3}} b {{f 4 g 5}}}
HUDDLE {D {a {L {{D {c {s 1}}} {D {d {L {{s 2} {s 2} {s 2}}} e {s 3}}}}} b {L {{D {f {s 4} g {s 5}}}}}}}
}]

[call [cmd "huddle is_huddle"] [arg object]]
if [arg object] is a huddle, returns 1. Otherwise, returns 0.

[call [cmd "huddle check_huddle"] [arg object]]
raise an error if [arg object] is not huddle.

[call [cmd "huddle argument_to_node"] [arg object] [opt [arg tag]]]
for type-callbacks.
[para]
if [arg object] is a huddle, returns root-node. the other, returns [cmd {[list s $object]}].

[example {
% huddle argument_to_node str
s str
% huddle argument_to_node str !!str
!!str str
% huddle argument_to_node {HUDDLE {s str}}
s str
% huddle argument_to_node {HUDDLE {l {a b c}}}
l {a b c}
}]

[call [cmd "huddle wrap"] [arg tag] [arg src]]
for type-callbacks.
[para]
Create a huddle object from [arg src] with specified [arg tag].

[example {
% huddle wrap "" str
HUDDLE str
% huddle wrap s str
HUDDLE {s str}
}]

[call [cmd "huddle call"] [arg tag] [arg command] [arg args]]
for type-callbacks.
[para]
devolving [arg command] to default [arg tag]-callback

[call [cmd "huddle add_type"] [arg namespace]]
add a user-specified-type/tag to the huddle library.
To see "Additional Type".

[para]

[list_begin options]
[opt_def namespace]

name of namespace with the definition of the new type.

[list_end]
[list_end]

[section {TYPE NAMESPACE}]
[para]


There is two kind of types: 
[list_begin definitions]



[def "Containers"]It can contain other huddle object


[def "Not containers"] It can not contain other huddle object
[list_end]



All the types require a variable named settings. This variable has these attributes related to the type:


[list_begin definitions]
[def "[const isContainer] boolean_flag"]
a boolean value indicating whether the new type is a container

[def "[const superclass] name_of_superclass"]
this is optional. It indicantes what is the super class of these type. All the methods of the super class are inherited.

[def "[const publicMethods] {method1 method2 method3 ...}"]
method list as huddle subcommand. Then, you can call [cmd {[huddle method1 ...]}]

[def "[const map] {huddle_subcommand1 proc_name1 huddle_subcommand2 proc_name2 ...}"]
it defines a map bettween huddle subcommands and the associated proc inside the type namespace.

[def "[const tag] tag_name"]
a tag representing the type

[list_end]



[para]
There is some required procs in a container type:

[list_begin definitions]
[call [cmd Set] [arg src_var] [arg key] [arg value]]
set a subnode in the guiven variable containing a subnode content
[call [cmd Strip] [arg src]]
returns the node content stripped
[call [cmd Exists] [arg src] [arg key]]
returns a boolean value indicating whether the key exists in the node content
[call [cmd Equal] [arg src1] [arg src2]]
returns a boolean vlaue indicating whether the two node contents are equal
[call [cmd Update_children] [arg src_var] [arg items]]
udpate several subnodes at the same time for performance
[call [cmd Get_subnode] [arg src] [arg key]]
returns a sub node specified by [arg key].



[call [cmd Combine] [arg list_of_src]]
returns a combined node content using the content of several nodes of the same type
[call [cmd Strip] [arg src]]
returns stripped node contents. if the type has child nodes, every node must be stripped.

[call [cmd Set] [arg src] [arg key] [arg value]]
sets a sub-node from the tagged-content, and returns self.

[call [cmd Remove] [arg src] [arg key] [arg value]]
removes a sub-node from the tagged-content, and returns self.

[list_end]







[example {
# callback sample for my-dict
proc my_dict_setting {command args} {
    switch -- $command {
        setting { ; # type definition
            return {

            # method: add methods to huddle's subcommand.
            #          "get_sub/strip/set/remove/equal/append" called by huddle module.
            #          "strip" must be defined at all types.
            #          "get_sub" must be defined at container types.
            #          "set/remove/equal/append" shuould be defined, if you call them.
            # tag:    tag definition("child/parent" word is maybe obsoleted)
        }
        get_subnode { ; # get a sub-node specified by "key" from the tagged-content
            foreach {src key} $args break
            return [dict get $src $key]
        }
        strip { ; # strip from the tagged-content
            foreach {src nop} $args break
            foreach {key val} $src {
                lappend result $key [huddle strip $val]

        }
        append { ; # append nodes
            foreach {str src list} $args break
            if {[llength $list] % 2} {error {wrong # args: should be "huddle append objvar ?key value ...?"}}
            set resultL $src
            foreach {key value} $list {
                if {$str ne ""} {
                    lappend resultL $key [huddle argument_to_node $value $str]
                } else {
                    lappend resultL $key $value
                }
            }
            return [eval dict create $resultL]
        }
        create { ; # $args: all arguments after "huddle create"
            if {[llength $args] % 2} {error {wrong # args: should be "huddle create ?key value ...?"}}
            set resultL {}
            foreach {key value} $args {
                lappend resultL $key [huddle argument_to_node $value]
            }
            return [huddle wrap D $resultL]
        }
        keys {
            foreach {src nop} $args break
            return [dict keys [lindex [lindex $src 1] 1]]
        }

                str !!str
            }
        }
        mapping { ; # $args: all arguments after "huddle mapping"
            if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
            set resultL {}
            foreach {key value} $args {
                lappend resultL $key [huddle argument_to_node $value !!str]
            }
            return [huddle wrap !!map $resultL]
        }
        default { ; # devolving to default dict-callback
            return [huddle call D $command $args]
        }
    }
}
}]

[section "How to add type"]

[para]
You can add huddle-node types e.g. a special type for dates.

To do so, first, define a namespace for additional tagged-type.

The namespace require a variable named settings indicating the options associated to this type.

[para]
And, execute the proc [cmd add_type] [arg "namespace_of_the_type"]
to register this new type.

[example {
huddle add_type type_name
}]

If the new type is a container of other types, the namespace will require the definition of these procs as mentioned before:
[list_begin itemized]
[item] Set
[item] Strip
[item] Remove
[item] Equal
[item] Exists
[item] Get_subnode
[item] Update_children
[item] Combine

[list_end]

[section "WORKING SAMPLE"]
[example {
# create as a dict
% set bb [huddle create a b c d]
HUDDLE {D {a {s b} c {s d}}}

# remove a node
% huddle remove $folding 2 1
HUDDLE {L {{D {bb {D {a {s b} c {s kkk}}} cc {L {{s e} {s f} {s g} {s h}}}}} {s p} {L {{s q}}} {s s}}}
% huddle strip $folding
{bb {a b c kkk} cc {e f g h}} p {q r} s

# dump as a JSON stream
% huddle json_dump $folding
[
  {
    "bb": {
      "a": "b",
      "c": "kkk"
    },
    "cc": [

# huddle.tcl


#
#   It is published with the terms of tcllib's BSD-style license.
#   See the file named license.terms.
#
# This library provide functions to differentinate string/list/dict in multi-ranks.
#
# Copyright (c) 2008-2011 KATO Kanryu <[email protected]>
# Copyright (c) 2015 Miguel Martínez López


package require Tcl 8.5


package provide huddle 0.2.0

namespace eval ::huddle {
    namespace export huddle wrap unwrap is_huddle strip_node are_equal_nodes argument_to_node get_src delete_src





    variable types

    namespace ensemble create -map {
        set              ::huddle::set_huddle
        get              ::huddle::get
        get_stripped     ::huddle::get_stripped
        update_children  ::huddle::update_children
        removed          ::huddle::removed
        remove           ::huddle::remove
        combine          ::huddle::combine
        type             ::huddle::type
        equal            ::huddle::equal
        exists           ::huddle::exists
        clone            ::huddle::clone
        is_huddle        ::huddle::is_huddle
        wrap             ::huddle::wrap
        unwrap           ::huddle::unwrap
        add_type         ::huddle::add_type
        json_dump        ::huddle::json_dump
        compile          ::huddle::compile
    }
}

proc ::huddle::add_type {typeNamespace} {
    variable types

    set typeName [namespace tail $typeNamespace]
    set typeCommand ::huddle::Type_of_$typeName

    namespace upvar $typeNamespace settings settings

    # We start building the map of the ensemble
    if {[dict exists $settings map]} {
        set ensemble_map_of_type [dict get $settings map]
        set renamed_subcommands [dict values $ensemble_map_of_type]
    } else {
        set renamed_subcommands [list]
    }

    dict set ensemble_map_of_type settings ${typeNamespace}::settings

    foreach path_to_subcommand [info procs ${typeNamespace}::*] {
        set subcommand [namespace tail $path_to_subcommand]

        if {$subcommand ni $renamed_subcommands} {
            dict set ensemble_map_of_type $subcommand ${typeNamespace}::$subcommand
        }
    }

    namespace eval $typeNamespace "
        namespace import ::huddle::wrap ::huddle::unwrap ::huddle::is_huddle ::huddle::strip_node ::huddle::are_equal_nodes ::huddle::argument_to_node ::huddle::get_src ::huddle::delete_src

        namespace ensemble create -unknown ::huddle::unknown_subcommand -command $typeCommand -prefixes false -map {$ensemble_map_of_type}

        proc settings {} {
            variable settings

            return \$settings
        }
    "

    set huddle_map [namespace ensemble configure ::huddle -map]

    dict with settings {
        foreach subcommand $publicMethods {
            dict set huddle_map $subcommand [list $typeCommand $subcommand]
        }


        if {[info exists superclass]} {
            set types(superclass:$tag) $superclass
        }

        set types(type:$tag) $typeName
        set types(callback:$tag) $typeCommand
        set types(isContainer:$tag) $isContainer
        set types(tagOfType:$typeName) $tag
    }



    namespace ensemble configure ::huddle -map $huddle_map
    return
}

proc ::huddle::is_superclass_of {tag1 tag2} {
    variable types

    if {![info exists types(list_of_superclasses:$tag1)]} {
        set types(list_of_superclasses:$tag1) [list]

        set superclass_tag $tag1

        while {true} {
            if {[info exists types(superclass:$superclass_tag)]} {
                set superclass $types(superclass:$superclass_tag)
                set superclass_tag $types(tagOfType:$superclass)

                lappend types(list_of_superclasses:$tag1) $superclass_tag
            } else {
                break
            }
        }
    }

    if {$tag2 in $types(list_of_superclasses:$tag1) } {
        return 1
    } else {

        return 0
    }
}

proc ::huddle::unknown_subcommand {ensembleCmd subcommand args} {
    variable types
    


    set settings [$ensembleCmd settings]


    if {[dict exists $settings superclass]} {
        set superclass [dict get $settings superclass]

        set map [namespace ensemble configure $ensembleCmd -map]

        set superclass_tag $types(tagOfType:$superclass)
        dict set map $subcommand [list $types(callback:$superclass_tag) $subcommand]

        namespace ensemble configure $ensembleCmd -map $map
        return ""
    } else {
        error "Invalid subcommand '$subcommand' for type '$ensembleCmd'"
    }
}

proc ::huddle::is_huddle {obj} {
    # This proc makes the assumption that the user is a good citizen
    
    if {!([string is list $obj] && [lindex $obj 0] eq "HUDDLE")} {
        return 0
    } else {
        return 1
    }
}

proc ::huddle::strip_node {node} {
    variable types
    lassign $node head src
    
    if {[info exists types(type:$head)]} {
        if {$types(isContainer:$head)} {
            return [$types(callback:$head) Strip $src]
        } else {
            return $src
        }
    } else {
        error "This head '$head' doesn't exists."
    }

}

proc ::huddle::call {tag cmd arguments} {
    variable types
    return [$types(callback:$tag) $cmd {*}$arguments]
}

proc ::huddle::combine {args} {
    variable types

    foreach {obj} $args {
        check_huddle $obj
    }

    set first_object [lindex $args 0]
    set tag_of_group [lindex [unwrap $first_object] 0]

    foreach {obj} $args {
        set node [unwrap  $obj]
    

        lassign $node tag src

        if {$tag_of_group ne $tag} {
            error "unmatched types given to 'combine' subcommand."
        }
        
        lappend list_of_src $src
    }

    set combined_src [$types(callback:$tag_of_group) Combine $list_of_src]

    
    return [wrap [list $tag $combined_src]]
}

proc ::huddle::check_huddle {huddle_object} {
    if {![is_huddle $huddle_object]} {
        error "\{$huddle_object\} is not a huddle."
    }
}

proc ::huddle::argument_to_node {src {default_tag s}} {

    if {[is_huddle $src]} {
        return [unwrap $src]
    } else {
        return [list $default_tag $src]
    }
}









proc ::huddle::wrap { node } {
    return [list HUDDLE $node]
}

proc ::huddle::unwrap { huddle_object } {
    return [lindex $huddle_object 1]
}

proc ::huddle::get_src { huddle_object } {

    return [lindex [unwrap $huddle_object] 1]
}

proc ::huddle::delete_src { huddle_var } {
    upvar 1 $huddle_var huddle_object
    lset $huddle_object 1 1 ""


}

proc ::huddle::update_children {objvar args} {
    variable types

    upvar 1 $objvar obj
    check_huddle $obj
    
    if {[llength $args] % 2} {
        return -code error {wrong # args: should be "huddle append objvar ?key value ...?"}



    }
    
    lassign [unwrap $obj] tag src
    
    set subsrc_list [list]
    
    $types(callback:$tag) Update_children src $args
    set obj [wrap [list $tag $src]]
    return $obj
}

proc ::huddle::get {huddle_object args} {
    return [retrieve_huddle $huddle_object $args 0]
}

proc ::huddle::get_stripped {huddle_object args} {
    return [retrieve_huddle $huddle_object $args 1]
}



proc ::huddle::retrieve_huddle {huddle_object path striped} {
    check_huddle $huddle_object

    set target_node [Find_node [unwrap $huddle_object] $path]

    if {$striped} {
        return [strip_node $target_node]
    } else {
        return [wrap $target_node]
    }
}

proc ::huddle::type {huddle_object args} {
    variable types


    check_huddle $huddle_object





    set target_node [Find_node [unwrap $huddle_object] $args]



    lassign $target_node tag src

    return $types(type:$tag)
}

proc ::huddle::Find_node {node path} {
    variable types

    set subnode $node

    foreach subpath $path {
        lassign $subnode tag src
        set subnode [$types(callback:$tag) Get_subnode $src $subpath]

    }


    return $subnode
}

proc ::huddle::exists {huddle_object args} {
    variable types




    check_huddle $huddle_object

    set subnode [unwrap $huddle_object]

    foreach key $args {
        lassign $subnode tag src


        if {$types(isContainer:$tag) && [$types(callback:$tag) Exists $src $key] } {
            set subnode [$types(callback:$tag) Get_subnode $src $key]
        } else {
            return 0
        }
    }




    return 1
}

proc ::huddle::equal {obj1 obj2} {
    check_huddle $obj1

    check_huddle $obj2
    return [are_equal_nodes [unwrap $obj1] [unwrap $obj2]]
}

proc ::huddle::are_equal_nodes {node1 node2} {
    variable types

    lassign $node1 tag1 src1
    lassign $node2 tag2 src2
    
    if {$tag1 ne $tag2} {return 0}
    return [$types(callback:$tag1) Equal $src1 $src2]
}


proc ::huddle::set_huddle {objvar args} {








    upvar 1 $objvar obj

    check_huddle $obj
    set path [lrange $args 0 end-1]

    set new_subnode [argument_to_node [lindex $args end]]

    set root_node [unwrap $obj]

    # We delete the internal reference of $obj to $root_node
    # Now refcount of $root_node is 1
    unset obj


    apply_to_subnode Set root_node [llength $path] $path [list $new_subnode]
    set obj [wrap $root_node]
}





proc ::huddle::remove {objvar args} {
    upvar 1 $objvar obj
    check_huddle $obj

    set root_node [unwrap $obj]

    # We delete the internal reference of $obj to $root_node
    # Now refcount of $root_node is 1
    unset obj


    apply_to_subnode Remove root_node [llength $args] $args


    set obj [wrap $root_node]
}


proc ::huddle::apply_to_subnode {subcommand node_var len path {subcommand_arguments ""}} {
    # This proc is optimized for performance.
    # We make all the surgery for keeping a reference count of 1 for all the variables that we 
    # want to change in place.
    # It's necessary that the user that wants to apply this optimization keeps a reference count
    # of 1 for his huddle object before calling "huddle set" or "huddle remove".
    

    variable types

    upvar 1 $node_var node


    lassign $node tag src

    # We delete $src from $node.
    # In that position there is only an empty string.
    # This way, the refcount of $src is 1
    lset node 1 ""


    # We get the fist key. This information is used in the recursive case ($len>1) and in the base case ($len==1).
    set key [lindex $path 0]


    if {$len > 1} {



        set subpath [lrange $path 1 end]



        incr len -1

        if { $types(isContainer:$tag) } {



            set subnode [$types(callback:$tag) Get_subnode $src $key]



            # We delete the internal reference of $src to $subnode.
            # Now refcount of $subnode is 1
            # We don't want to delete the key, because we will use again later.
            # We only delete delete its subnode associated.
            $types(callback:$tag) Set src $key ""


            ::huddle::apply_to_subnode $subcommand subnode $len $subpath $subcommand_arguments

            # We add again the new $subnode to the original $src
            $types(callback:$tag) Set src $key $subnode



            # We add again the new $src to the parent node
            lset node 1 $src

        } else {

            error "\{$src\} don't have any child node."


        }
    } else {
        if {![info exists types(type:$tag)]} {error "\{$src\} is not a huddle node."}



        $types(callback:$tag) $subcommand src $key {*}$subcommand_arguments
        lset node 1 $src
    }
}

proc ::huddle::removed {obj args} {

    # The procedure returns a cloned huddle object with the requested subnode removed.


    check_huddle $obj

    set modified_node [Remove_node_and_clone [unwrap $obj] [llength $args] $args]

    set obj [wrap $modified_node]

}

proc ::huddle::Remove_node_and_clone {node len path} {
    variable types

    lassign $node tag src

    set key_containing_removed_subnode [lindex $path 0]


    if {$len > 1} {
        if { $types(isContainer:$tag) } {

            set subpath_to_removed_subnode [lrange $path 1 end]

            incr len -1

            set new_src ""


            foreach item [$types(callback:$tag) items $src] {
                lassign $item key subnode

                if {$key eq $key_containing_removed_subnode} {

                    set modified_subnode [Remove_node_and_clone $subnode $len $subpath_to_removed_subnode]
                    $types(callback:$tag) Set new_src $key $modified_subnode
                } else {

                    set cloned_subnode [Clone_node $subnode]
                    $types(callback:$tag) Set new_src $key $cloned_subnode
                }
            }



        
            return [list $tag $new_src]
        } else {
            error "\{$src\} don't have any child node."
        }
    } else {
        $types(callback:$tag) Remove src $key_containing_removed_subnode
        return [list $tag $src]
    }



}



proc ::huddle::clone {obj} {
    set cloned_node [Clone_node [unwrap $obj]]

    return [wrap $cloned_node]
}

proc ::huddle::Clone_node {node} {



    variable types

    lassign $node tag src




    if { $types(isContainer:$tag) } {

        set cloned_src ""


        foreach item [$types(callback:$tag) items $src] {

            lassign $item key subnode


            set cloned_subnode [Clone_node $subnode]
            $types(callback:$tag) Set cloned_src $key $cloned_subnode
        }
        return [list $tag $cloned_src]
    } else {
        return $node
    }
}


proc ::huddle::json_dump {huddle_object {offset "  "} {newline "\n"} {begin ""}} {
    variable types
    set nextoff "$begin$offset"
    set nlof "$newline$nextoff"
    set sp " "
    if {[string equal $offset ""]} {set sp ""}

    set type [type $huddle_object]

    switch -- $type {
        boolean -
        number -
        null {
            return [get_stripped $huddle_object]
        }

        string {
            set data [get_stripped $huddle_object]


            # JSON permits only oneline string
            set data [string map {
                    \n \\n
                    \t \\t
                    \r \\r
                    \b \\b
                    \f \\f
                    \\ \\\\
                    \" \\\"
                    / \\/
                } $data
            ]
        return "\"$data\""
        }
        
        list {
            set inner {}
            set len [huddle llength $huddle_object]
            for {set i 0} {$i < $len} {incr i} {
                set subobject [get $huddle_object $i]
                lappend inner [json_dump $subobject $offset $newline $nextoff]
            }
            if {[llength $inner] == 1} {
                return "\[[lindex $inner 0]\]"
            }
            
            return "\[$nlof[join $inner ,$nlof]$newline$begin\]"
        }
        
        dict {
            set inner {}
            foreach {key} [huddle keys $huddle_object] {
                lappend inner [subst {"$key":$sp[json_dump [huddle get $huddle_object $key] $offset $newline $nextoff]}]
            }
            if {[llength $inner] == 1} {
                return $inner
            }
            return "\{$nlof[join $inner ,$nlof]$newline$begin\}"
        }
        
        default {
            return [$types(callback:$type) json_dump $data $offset $newline $nextoff]
        }
    }
}

# data is plain old tcl values
# spec is defined as follows:
# {string} - data is simply a string, "quote" it if it's not a number
# {list} - data is a tcl list of strings, convert to JSON arrays
# {list list} - data is a tcl list of lists
# {list dict} - data is a tcl list of dicts
# {dict} - data is a tcl dict of strings
# {dict xx list} - data is a tcl dict where the value of key xx is a tcl list
# {dict * list} - data is a tcl dict of lists
# etc..
proc ::huddle::Compile_to_node {spec data} {

    while {[llength $spec]} {
        set type [lindex $spec 0]
        set spec [lrange $spec 1 end]

        switch -- $type {
            dict {
                if {![llength $spec]} {
                    lappend spec * string
                }

                set dict_src [dict create]
                foreach {key value} $data {
                    foreach {matching_key subspec} $spec {
                        if {[string match $matching_key $key]} {
                            dict set dict_src $key [Compile_to_node $subspec $value]
                            break
                        }
                    }
                }
                
                return [list D $dict_src]
            }
            
            list {
                if {![llength $spec]} {
                    set spec string
                } else {
                    set spec [lindex $spec 0]
                }
                
                set list_src [list]
                foreach list_item $data {
                    lappend list_src [Compile_to_node $spec $list_item]
                }
            
                return [list L $list_src]
            }
        
            string {
                set data [string map {\"  \\\"} $data]
                set data [string map {\n \\n} $data]
                
                return [list s $data]
            }
        
            number {
                return [list num $data]
            }
        
            bool {
                return [list b $data]
            }
        
            null {
                if {$data eq ""} {
                    return [list null]
                } else {
                    error "Data must be an empty string: '$data'"
                }
            }
        
            huddle {
                if {[is_huddle $data]} {
                    return [unwrap $data]
                } else {
                    error "Data is not a huddle object: $data"
                }
            }
        
            default {error "Invalid type: '$type'"}
        }
    }
}

proc ::huddle::compile {spec data} {
    return [wrap [Compile_to_node $spec $data]]
}

apply {{selfdir} {
    source [file join $selfdir huddle_types.tcl]


    foreach typeNamespace [namespace children ::huddle::types] {
        add_type $typeNamespace
    }

    return
} ::huddle} [file dirname [file normalize [info script]]]

return

# -*- tcl -*-
# huddle.test:  tests for the huddle library.
#
# Copyright (c) 2008 by KATO Kanryu <[email protected]>
# All rights reserved.
#


if {[lsearch [namespace children] ::tcltest] == -1} {
    # single test
    set selfrun 1
    lappend auto_path [pwd]
    package require tcltest
    namespace import ::tcltest::*
    
    source huddle.tcl
    package require json

    proc dictsort {dict} {
        array set a $dict
        set out [list]
        foreach key [lsort [array names a]] {
            lappend out $key $a($key)
        }
        return $out
    }
} else {
    # all.tcl
    source [file join \
        [file dirname [file dirname [file join [pwd] [info script]]]] \
        devtools testutilities.tcl]

    testsNeedTcl     8.5
    testsNeedTcltest 2
    #testsNeed dict 1








    support {
    use json/json.tcl json
    }
    testing {
        useLocal huddle.tcl huddle
    }

}

test huddle-1.1 "test of huddle create" -body {
    set upper [huddle create a b c d]
} -result {HUDDLE {D {a {s b} c {s d}}}}

test huddle-1.2 "test of huddle create" -body {

} -result {HUDDLE {D {bb {D {a {s b} c {s d}}} cc {D {e {s f} g {s h}}}}}}

test huddle-1.5 "test of huddle create" -body {
    huddle get $folding dd cc
} -result {HUDDLE {D {e {s f} g {s h}}}}

test huddle-1.6 "test of huddle create" -body {
    huddle get_stripped $folding dd
} -result {bb {a b c d} cc {e f g h}}

test huddle-1.7 "test of huddle create" -body {
    huddle get_stripped $folding dd cc
} -result {e f g h}

test huddle-1.8 "test of huddle create" -body {
    huddle type $folding dd
} -result {dict}

test huddle-1.9 "test of huddle create" -body {

} -result {HUDDLE {L {{s i} {L {{s a} {s b} {s c} {s d}}} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}}}

test huddle-2.5 "test of huddle list" -body {
    huddle get $folding 0 1
} -result {HUDDLE {L {{s a} {s b} {s c} {s d}}}}

test huddle-2.6 "test of huddle list" -body {
    huddle get_stripped $folding 0
} -result {i {a b c d} j k {e f g h}}

test huddle-2.7 "test of huddle list" -body {
    huddle get_stripped $folding 0 1
} -result {a b c d}

test huddle-2.8 "test of huddle list" -body {
    huddle type $folding 0
} -result {list}

test huddle-2.9 "test of huddle list" -body {
    huddle type $folding 0 1
} -result {list}

test huddle-2.10 "test of huddle list" -body {
    huddle type $folding 0 1 3
} -result {string}

test huddle-2.11 "test of huddle list" -body {
    huddle get_stripped {HUDDLE {L {{s a} {L {}} {s c}}}}
} -result {a {} c}

test huddle-2.12 "test of huddle list" -body {
    huddle llength {HUDDLE {L {{s a} {s b} {s c}}}}
} -result {3}

#test huddle-3.1 "test of huddle json_dump" {[info tclversion] >= 8.5} {
#    # build a huddle container from normal tcl's container(multi rank dict/list)
#    proc huddle_build {data} {
#        foreach {key val} $data {
#            if {$key eq "layers"} {
#                foreach {l} [dict get $data layers] {
#                    lappend subs [huddle_build $l]
#                }
#                set val [eval huddle list $subs]
#            }
#            lappend result $key $val
#        }
#        return [eval huddle create $result]
#    }
#    set fd [open [file join [file dirname [info script]] layers.txt] r]
#    set json1 [read $fd]
#    close $fd
#
#    set data [json::json2dict $json1]
##    set data [huddle_build $data]
##
##    set json2 [huddle json_dump $data]
##    expr $json1 eq $json2
##    set json2
#} {1}

test huddle-3.2 "test of huddle json_dump" -body {
    huddle json_dump {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{num 1.0} {b true} {s g} {s h}}}}} {s t}}}}
} -result {[
  [
    "i",
    "baa",
    "k",
    [
      1.0,
      true,
      "g",
      "h"
    ]
  ],
  "t"
]}


test huddle-3.3 "test of huddle json_dump" -body {
    set huddle1 {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {num 1} j {s { m\a}}}}}}}

    set json1 [huddle json_dump $huddle1]
    set json2 {{
  "dd": {
    "bb": {
      "a": "baa",
      "c": "d a"
    },
    "cc": {"g": "h"}
  },
  "ee": {
    "i": "j",
    "k": 1,
    "j": " m\\a"
  }
}}
    
    if {$json1 == $json2} {
    return 1
    } else {
    return 0
    }
} -result {1}


test huddle-3.4 "test of huddle compile" -body {
    set huddle1 {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {num 1} j {s { m\a}}}}}}}
    set json1 {{
  "dd": {
    "bb": {
      "a": "baa",
      "c": "d a"
    },
    "cc": {"g": "h"}
  },
  "ee": {
    "i": "j",
    "k": 1,
    "j": " m\\a"
  }
}}
    
    set data [json::json2dict $json1]
    set data [huddle compile {dict dd {dict * dict} ee {dict k number * string}}  $data]
    huddle equal $huddle1 $data
} -result {1}


# ... Tests of addStrings ...
#     (Requires introspection of parser state)

test huddle-4.1 "test of huddle set" -body {
    huddle set data_dict dd bb a baa
} -result {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {e {s f} g {s h}}}}} ee {D {i {s j} k {s l}}}}}}

test huddle-4.2 "test of huddle removed" -body {
    set data_dict [huddle removed $data_dict dd cc e]
} -result {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l}}}}}}

test huddle-4.3 "test of huddle set" -body {
    huddle set data_list 0 1 baa
} -result {HUDDLE {L {{L {{s i} {s baa} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}

test huddle-4.4 "test of huddle remove" -body {
    huddle remove data_list 0 2
    return $data_list
} -result {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}

test huddle-4.5 "test of huddle equal" -body {
    huddle equal $data_dict {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
} -result 1

test huddle-4.6 "test of huddle equal" -body {

    huddle equal $data_list {HUDDLE {L {{L {{s i} {s kkk} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
} -result 0

test huddle-4.10 "test of huddle equal" -body {
    huddle equal $data_list {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t}}}}
} -result 0

test huddle-5.1 "test of huddle boolean" -body {
    huddle true
} -result {HUDDLE {b true}}

test huddle-5.2 "test of huddle boolean" -body {
    huddle false
} -result {HUDDLE {b false}}

test huddle-6.1 "test of huddle null" -body {
    huddle null
} -result {HUDDLE null}

test huddle-7.1 "test of huddle number" -body {
    huddle number -4.5E-6
} -result {HUDDLE {num -4.5E-6}}


test huddle-8.1 "test of complex data structure using the new types: number, boolean and null" -body {
    huddle create key1 var1 key2 [huddle number 4] key3 [huddle list [huddle null] sadf [huddle true]]
} -result {HUDDLE {D {key1 {s var1} key2 {num 4} key3 {L {null {s sadf} {b true}}}}}}


test huddle-9.1 "test of huddle exists" -body {
    set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list  1 2 [huddle list 1 2]] ]
    huddle exists $obj 0 key1
} -result {1}

test huddle-9.2 "test of huddle exists" -body {
    set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list  1 2 [huddle list 1 2]] ]
    huddle exists $obj 3 2 1
} -result {1}

test huddle-9.1 "test of huddle exists" -body {
    set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list  1 2 [huddle list 1 2]] ]
    huddle exists $obj 0 key1
} -result {1}

test huddle-9.3 "test of huddle exists" -body {
    set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list  1 2 [huddle list 1 2]] ]
    huddle exists $obj 3 3 1
} -result {0}

test huddle-10.1 "test of huddle clone" -body {
    set obj [huddle list item0 item1 [huddle create key0 value0 key1 value1]]
    huddle clone $obj
} -result {HUDDLE {L {{s item0} {s item1} {D {key0 {s value0} key1 {s value1}}}}}}


test huddle-11.1 "test of huddle superclass" -body {
    
    namespace eval ::new_types::mapping {
    
        variable settings
        set settings {
                superclass dict
                publicMethods {mapping}
                tag !!map 
                isContainer yes }
        
        proc mapping {args} {
            if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
            set resultL {}
            foreach {key value} $args {
                lappend resultL $key [argument_to_node $value !!str]
            }

            return [wrap [list !!map $resultL]]
        }
        
    }
    
    namespace eval ::new_types::str {
        
            variable settings
            set settings {
                    superclass string
                    publicMethods {}
                    isContainer no
                    tag !!str
            }
    }
    
    huddle add_type ::new_types::mapping
    huddle add_type ::new_types::str

    set a [huddle mapping key1 var1]
    huddle update_children a key2 [huddle mapping key3 var3]
} -result {HUDDLE {!!map {key1 {!!str var1} key2 {!!map {key3 {!!str var3}}}}}}



if {[info exists selfrun]} {
    tcltest::cleanupTests
} else {
    testsuiteCleanup
}

namespace eval ::huddle::types {
    namespace export *
    
    namespace eval dict {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {create keys} 
                        tag D 
                        isContainer yes}


        proc Get_subnode {src key} { 
            # get a sub-node specified by "key" from the tagged-content
            return [dict get $src $key]
        }
        
        # strip from the tagged-content
        proc Strip {src} {
            foreach {key subnode} $src {
                lappend result $key [strip_node $subnode]
            }
            return $result
        }
        
        # set a sub-node from the tagged-content
        proc Set {src_var key value} {
            upvar 1 $src_var src

            dict set src $key $value
        }
        
        proc items {src} {
            set result {}
            dict for {key subnode} $src {
                lappend result [list $key $subnode]
            }
            return $result
        }
        
        
        # remove a sub-node from the tagged-content
        proc Remove {src_var key} {
            upvar 1 $src_var src
            dict unset src $key
        }
        
        # check equal for each node
        proc Equal {src1 src2} {
            if {[llength $src1] != [llength $src2]} {return 0}
            foreach {key1 subnode1} $src1 {
                if {![dict exists $src2 $key1]} {return 0}
                if {![are_equal_nodes $subnode1 [dict get $src2 $key1]]} {return 0}
            }
            return 1
        }
        
        proc Combine {list_of_src} {
            set combined_src [dict merge {*}$list_of_src]
            return $combined_src
        }

        proc Update_children {src_var items} {
            upvar 1 $src_var src

            foreach {key value} $items {
                dict set src $key [argument_to_node $value]
            }
        }

        # $args: all arguments after "huddle create"
        proc create {args} {
            if {[llength $args] % 2} {error {wrong # args: should be "huddle create ?key value ...?"}}
            set resultD [dict create]
            
            foreach {key value} $args {
                if {[is_huddle $key]} {
                    lassign [unwrap $key] tag src

                    if {$tag ne "string"} {
                        return -code error "The key '$key' must a string literal or huddle string" 
                    }
                    set key $src    
                }
                dict set resultD $key [argument_to_node $value]
            }
            return [wrap [list D $resultD]]
        }
        
        proc keys {huddle_object} {
            return [dict keys [get_src $huddle_object]]
        }
        
        proc Exists {src key} {
            return [dict exists $src $key]
        }
    }
    
    
    namespace eval list {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {list llength lappend} 
                        tag L 
                        isContainer yes 
                        map {list List llength Llength lappend Lappend} }
        
        proc Get_subnode {src index} {
            return [lindex $src $index]
        }
        
        proc items {src} {
            set result {}
            for {set i 0} {$i < [llength $src]} {incr i} {
                lappend result [list $i [lindex $src $i]]
            }
            return $result
        }
        
        proc Strip {src} {
            set result {}
            foreach {subnode} $src {
                lappend result [strip_node $subnode]
            }
            return $result
        }
        
        if {[package vcompare [package present Tcl] 8.6] > 0} {
            proc Set {src_var index value} {
                upvar 1 $src_var src
                lset src $index $value
            }
        } else {
            proc Set {src_var index value} {
                upvar 1 $src_var src
                # Manual handling of lset at end of list.
                if {$index == [llength $src]} {
                    lappend src $value
                } else {
                    lset src $index $value
                }
            }
        }
        
        proc Remove {src_var index} {
            upvar 1 $src_var src
            set src [lreplace $src $index $index]
        }
        
        proc Equal {src1 src2} {
            if {[llength $src1] != [llength $src2]} {return 0}
            
            for {set i 0} {$i < [llength $src1]} {incr i} {
                if {![are_equal_nodes [lindex $src1 $i] [lindex $src2 $i]]} {
                    return 0
                }
            }

            return 1
        }

        proc Combine {list_of_src} {
            set combined_src [list]
            foreach src $list_of_src {
                lappend combined_src {*}$src
            }
            
            return $combined_src
        }
        
        proc Update_children {src_var items} {
            upvar 1 $src_var src

            foreach {key value} $items {
                if {!([string is digit $key] && [string index $key 0] ne "0")} {
                    return -code error "The key should be a natural number: $key"
                }
                
                if { $key >= [llength $src]} {
                    return -code error "The key is out of range: $key. List type only allow update children that exists in the list."
                }
                
                lset src $key [argument_to_node $value]
            }
        }
        
        proc Lappend {huddle_var args} {
            upvar 1 $huddle_var huddle_object
            
            set src [get_src $huddle_object]
            
            delete_src huddle_object
            
            foreach argument $args {
                set subnode [argument_to_node $argument]
                lappend src $subnode
            }
            return [wrap [list L $src]]
        }
        
        proc List {args} {

            set resultL {}
            foreach {value} $args {
                lappend resultL [argument_to_node $value]
            }
            return [wrap [list L $resultL]]
        }
        
        proc Llength {huddle_object} {
            return [llength [get_src $huddle_object] ]
        }
        
        proc Exists {src key} {
            return [expr {$key >=0 && $key < [llength $src]}]
        }
    }
    
    namespace eval string {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {string}
                        tag s
                        isContainer no
                        map {string String} }
        
        proc String {src} {
            return [wrap [list s $src]]
        }
        
        proc Equal {string1 string2} {
            return [expr {$string1 eq $string2}]
        }
    }
    
    
    namespace eval number {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {number}
                        tag num
                        isContainer no }
            
        proc number {src} {
            if {[string is double -strict $src]} {
                return [wrap [list num $src]]
            } else {
                return -code error "Argument '$src' is not a number"
            }
        }
        
        proc Equal {number1 number2} {
            return [expr {$number1 == $number2}]
        }
    }
    
    namespace eval boolean {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {boolean true false}
                        tag b
                        isContainer no }
        
        proc boolean {boolean_expresion} {
            
            if {$boolean_expresion} {
                return [wrap [list b true]]
            } else {
                return [wrap [list b false]]
            }
        }
        
        proc true {} {
            return [::huddle::wrap [list b true]]
        }
        
        proc false {} {
            return [wrap [list b false]]
        }

        
        proc Equal {bool1 bool2} {
            return [expr {$bool1 eq $bool2}]
        }
    }
    
    namespace eval null {
        variable settings 
        
        # type definition
        set settings {
                        publicMethods {null}
                        tag null
                        isContainer no }
            
        proc null {} {
            return [wrap [list null]]
        }
        
        proc Equal {null1 null2} {
            return 1
        }        
    }
}

# -*- tcl -*-
# (c) 2015 Miguel Martínez López

package require Tcl 8.5
package require huddle 0.2.0

package require TclOO       ; # For 8.5. Integrated with 8.6
package require try         ; # For 8.5. Integrated with 8.6. Tcllib.
package require throw       ; # For 8.5. Integrated with 8.6. Tcllib.

package provide huddle::json 0.1


interp alias {} ::huddle::json2huddle {} ::huddle::json::json2huddle parse

namespace eval ::huddle {
    namespace export json2huddle
}

    
namespace eval ::huddle::json {
        
    oo::class create Json2huddle {
        
        variable cursor jsonText EndOfTextException numberRE
        
        constructor {} {
            
            set positiveRE {[1-9][[:digit:]]*}
            set cardinalRE "-?(?:$positiveRE|0)"
            set fractionRE {[.][[:digit:]]+}
            set exponentialRE {[eE][+-]?[[:digit:]]+}
            set numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
        
            # Exception code for "End of Text" signal
            set EndOfTextException 5
        }        
            
        method parse {json_to_parse} {
            set cursor -1
            set jsonText $json_to_parse
            
            my parseNextData
        }
            
        method peekChar { {increment 1} } {
            return [string index $jsonText [expr {$cursor+$increment}]]
        }

        method advanceCursor { {increment 1} } {
            incr cursor $increment
        }
        
        method nextChar {} {
            if {$cursor + 1 < [string length $jsonText] } {
                incr cursor
                return [string index $jsonText $cursor]    
            } else {
                return -code $EndOfTextException
            }
        }
    
        method assertNext {ch {target ""}} {
            incr cursor
            
            if {[string index $jsonText $cursor] != $ch} {
                if {$target == ""} {
                    set target $ch
                }
                throw {HUDDLE JSONparser} "Trying to read the string $target at index $cursor."
            }
        }
    
    
        method parseNextData {} {
            
            my eatWhitespace
            
            set ch [my peekChar]
            
            if {$ch eq ""} {
                throw {HUDDLE JSONparser} {Nothing to read}
            }
            
                        
            switch -exact -- $ch {
                "\{" {
                    return [my readObject]
                } 
                "\[" {
                    return [my readArray]
                } 
                "\"" {
                    return [my readString]
                } 

                "t" {
                    return [my readTrue]
                }
                "f" {
                    return [my readFalse]
                }
                "n" {
                    return [my readNull]
                } 
                "/" {
                    my readComment
                    return [my parseNextData]
                }
                "-" -
                "0" -
                "1" -
                "2" -
                "3" -
                "4" -
                "5" -
                "6" -
                "7" -
                "8" -
                "9" {
                    return [my readNumber]
                } 
                default {
                    throw {HUDDLE JSONparser} "Input is not valid JSON: '$jsonText'" 
                }
            }
        }
        
        method eatWhitespace {} {

            while {true} {
                set ch [my peekChar]
                
                if {[string is space -strict $ch]} {
                    my advanceCursor
                } elseif {$ch eq "/"} {
                    my readComment
                } else {
                    break
                }
            }
        }

        
        method readTrue {} {
            my assertNext t true
            my assertNext r true
            my assertNext u true
            my assertNext e true
            return [::huddle true]
        }
    
        
        method readFalse {} {
            my assertNext f false
            my assertNext a false
            my assertNext l false
            my assertNext s false
            my assertNext e false
            return [::huddle false]
        }
    
        
        method readNull {} {
            my assertNext n null
            my assertNext u null
            my assertNext l null
            my assertNext l null
            return [::huddle null]
        }
        
        method readComment {} {

            switch -exact -- [my peekChar 1][my peekChar 2] {
                "//" {
                    my readDoubleSolidusComment
                }
                "/*" {
                    my readCStyleComment
                }
                default {
                    throw {HUDDLE JSONparser} "Not a valid JSON comment: $jsonText"
                }
            }
        }
        
        method readCStyleComment {} {
            my assertNext "/" "/*"
            my assertNext "*" "/*"
            
            try {
                
                while {true} {
                    set ch [my nextChar]
                    
                    switch -exact -- $ch {
                        "*" {
                            if { [my peekChar] eq "/"} {
                                my advanceCursor
                                break
                            }
                        }
                        "/" {
                            if { [my peekChar] eq "*"} {
                                throw {HUDDLE JSONparser} "Not a valid JSON comment: $jsonText, '/*' cannot be embedded in the comment at index $cursor." 
                            }
                        }

                    } 
                }
                
            } on $EndOfTextException {} {
                throw {HUDDLE JSONparser} "not a valid JSON comment: $jsonText, expected */"
            }
        }

        
        method readDoubleSolidusComment {} {
            my assertNext "/" "//"
            my assertNext "/" "//"
            
            try {
                set ch [my nextChar]
                while { $ch ne "\r" && $ch ne "\n"} {
                    set ch [my nextChar]
                }
            } on $EndOfTextException {} {}
        }
                
        method readArray {} {
            my assertNext "\["
            my eatWhitespace

            if { [my peekChar] eq "\]"} {
                my advanceCursor
                return [huddle list]
            }
                
            try {        
                while {true} {
                    
                    lappend result [my parseNextData]
                
                    my eatWhitespace
                        
                    set ch [my nextChar]
            
                    if {$ch eq "\]"} {
                        break
                    } else {
                        if {$ch ne ","} {
                            throw {HUDDLE JSONparser} "Not a valid JSON array: '$jsonText' due to: '$ch' at index $cursor."
                        }
                        
                        my eatWhitespace
                    }
                }
            } on $EndOfTextException {} {
                throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
            }
                
            return [huddle list {*}$result]
        }
            
        
        
        method readObject {} {

            my assertNext "\{"
            my eatWhitespace

            if { [my peekChar] eq "\}"} {
                my advanceCursor
                return [huddle create]
            }
            
            try {        
                while {true} {
                    set key [my readStringLiteral]
                
                    my eatWhitespace
                    
                    set ch [my nextChar]
            
                    if { $ch ne ":"} {
                        throw {HUDDLE JSONparser} "Not a valid JSON object: '$jsonText' due to: '$ch' at index $cursor."
                    }
            
                    my eatWhitespace
            
                    lappend result $key [my parseNextData]
            
                    my eatWhitespace
            
                    set ch [my nextChar]
            
                    if {$ch eq "\}"} {
                        break
                    } else {
                        if {$ch ne ","} {
                            throw {HUDDLE JSONparser} "Not a valid JSON array: '$jsonText' due to: '$ch' at index $cursor."
                        }
                        
                        my eatWhitespace
                    }
                }
            } on $EndOfTextException {} {
                throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
            }
                    
            return [huddle create {*}$result]
        }
        
        
        method readNumber {} {
            regexp -start $cursor -- $numberRE $jsonText number
            my advanceCursor [string length $number]
            
            return [huddle number $number]
        }    
        
        method readString {} {
            set string [my readStringLiteral]
            return [huddle string $string]
        }
                

        method readStringLiteral {} {
            
            my assertNext "\""
            
            set result ""
            try {
                while {true} {
                    set ch [my nextChar]
                    
                    if {$ch eq "\""} break
                    
                    if {$ch eq "\\"} {
                        set ch [my nextChar]
                        switch -exact -- $ch {
                            "b" {
                                set ch "\b"
                            }
                            "r" {
                                set ch "\r"
                            }
                            "n" {
                                set ch "\n"
                            }
                            "f" {
                                set ch "\f"
                            }
                            "t" {
                                set ch "\t"
                            }
                            "u" {
                                set ch [format "%c" 0x[my nextChar][my nextChar][my nextChar][my nextChar]]
                            }
                            "\"" {}
                            "/"  {}
                            "\\" {}
                            default {
                                throw {HUDDLE JSONparser} "Not a valid escaped JSON character: '$ch' in $jsonText"
                            }
                        }
                    }
                    append result $ch
                }
            } on $EndOfTextException {} {
                throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
            }

            return $result
        }
    
    }    
    
    Json2huddle create json2huddle
    
}
    

# -*- tcl -*-
# json2huddle.test:  tests for the huddle library.


if {[lsearch [namespace children] ::tcltest] == -1} {
    # single test
    set selfrun 1
    set auto_path [linsert $auto_path 0 [pwd]]
    package require tcltest
    namespace import ::tcltest::*
    puts [package require huddle::json]
} else {
    # all.tcl
    source [file join \
        [file dirname [file dirname [file join [pwd] [info script]]]] \
        devtools testutilities.tcl]
        
    testsNeedTcl     8.5
    testsNeedTcltest 2

    support {
	use try/try.tcl   try
	use try/throw.tcl throw
        use json/json.tcl json
        useLocal huddle.tcl huddle
    }
    testing {
        useLocal json2huddle.tcl huddle::json
    }
}

namespace import ::huddle::json2huddle


test json2huddle-1.1 "test of parsing json string" -body {
    json2huddle { "hello world" } 
} -result {HUDDLE {s {hello world}}}


test json2huddle-1.2 "test of parsing json string" -body {
    json2huddle { "Unicode characters: \u00e0\u00e8\u00ec\u00f2\u00f9\u00e1\u00e9\u00ed\u00f3\u00fa\u00e4\u00eb\u00ef\u00f6\u00fc" } 
} -result {HUDDLE {s {Unicode characters: àèìòùáéíóúäëïöü}}}


test json2huddle-1.3 "test of parsing json string" -body {
    json2huddle { "escaped tab:\tescaped quote \"" } 
} -result {HUDDLE {s {escaped tab:	escaped quote "}}}


test json2huddle-2.1 "test of parsing json number" -body {
    json2huddle { 4 } 
} -result {HUDDLE {num 4}}


test json2huddle-2.2 "test of parsing json number" -body {
    json2huddle { 2.7 } 
} -result {HUDDLE {num 2.7}}

test json2huddle-2.3 "test of parsing json number" -body {
    json2huddle { -2.7e6 } 
} -result {HUDDLE {num -2.7e6}}

test json2huddle-2.3 "test of parsing json number" -body {
    json2huddle { 2345E-4 } 
} -result {HUDDLE {num 2345E-4}}

test json2huddle-3.1 "test of parsing json boolean" -body {
    json2huddle { true } 
} -result {HUDDLE {b true}}

test json2huddle-3.1 "test of parsing json boolean" -body {
    json2huddle { false } 
} -result {HUDDLE {b false}}

test json2huddle-4.1 "test of parsing json null" -body {
    json2huddle { null } 
} -result {HUDDLE null}


test json2huddle-5.1 "test of parsing json array" -body {
    json2huddle { [1,2, "3", 4, null, false] } 
} -result {HUDDLE {L {{num 1} {num 2} {s 3} {num 4} null {b false}}}}


test json2huddle-5.2 "test of parsing json array" -body {
    json2huddle { [ ] } 
} -result {HUDDLE {L {}}}


test json2huddle-6.1 "test of parsing json dict" -body {
    json2huddle {  {"key1":"value1", "key2": 0, "key3": true,"key4":null} } 
} -result {HUDDLE {D {key1 {s value1} key2 {num 0} key3 {b true} key4 null}}}


test json2huddle-6.2 "test of parsing json dict" -body {
    json2huddle {  {  } } 
} -result {HUDDLE {D {}}}


test json2huddle-7.1 "test of parsing json comments" -body {
	json2huddle { 
		// this is a solidus double comment
		 "this is a string"
	}
} -result {HUDDLE {s {this is a string}}}


test json2huddle-7.2 "test of parsing json comments" -body {
	json2huddle { 
		/* c style
				comment 
				*/
		 "this is a string"
	}
} -result {HUDDLE {s {this is a string}}}


test json2huddle-7.2 "test of parsing json comments" -body {
	json2huddle { 
		/* c style
				comment 
				*/
				// this is a solidus double comment
		 "this is a string"
		 /* c style comment */
		// this is a solidus double comment
	}
} -result {HUDDLE {s {this is a string}}}




test json2huddle-7.4 "test of parsing json comments" -body {
	json2huddle { 
		// this is a solidus double comment
		[
				//another comment here
			[], 
			{}, 
			/* c style
				comment 
				*/
		
		null, false, true,
		 -5.0e-4]
	}
} -result {HUDDLE {L {{L {}} {D {}} null {b false} {b true} {num -5.0e-4}}}}


test json2huddle-8.1 "test of parsing complex data structures in json" -body {
	json2huddle {  
    
		{"menu1": {
				"id": 234,
				"value": "File:",
				"unival": "\u6021:",
				"popup": {
					"menuitem": [
						{"value": "Open", "onclick": "OpenDoc()"},
						{"value": "Close", "onclick": "CloseDoc()"}
						]
				}
			},
		"menu2": {
				"selected": true,
				"texts": ["open", "close", "save as.."]
			
			}
    
		} 
	}
} -result {HUDDLE {D {menu1 {D {id {num 234} value {s File:} unival {s 怡:} popup {D {menuitem {L {{D {value {s Open} onclick {s OpenDoc()}}} {D {value {s Close} onclick {s CloseDoc()}}}}}}}}} menu2 {D {selected {b true} texts {L {{s open} {s close} {s {save as..}}}}}}}}}


test json2huddle-9.1 "test of no json" -body {
	json2huddle { }
} -returnCodes {error} -result "Nothing to read"


	
tcltest::cleanupTests

if {![package vsatisfies [package provide Tcl] 8.5]} {return}






package ifneeded yaml         0.3.8 [list source [file join $dir yaml.tcl]]
package ifneeded huddle       0.2.0 [list source [file join $dir huddle.tcl]]
package ifneeded huddle::json 0.1   [list source [file join $dir json2huddle.tcl]]

# -*- tcl -*-
# rb.test:  test samples for the yaml library.
# http://yaml4r.sourceforge.net/cookbook/
#

if {[lsearch [namespace children] ::tcltest] == -1} {
    # single test
    set selfrun 1

#   It is published with the terms of tcllib's BSD-style license.
#   See the file named license.terms.
#
# It currently supports a very limited subsection of the YAML spec.
#
#


package require Tcl 8.5


package provide yaml 0.3.8
package require cmdline
package require huddle 0.2.0


namespace eval ::yaml {
    namespace export load setOptions dict2dump list2dump
    variable data
    array set data {}

    # fixed value groups for some yaml-types.
    variable fixed

    # a plane scalar is worked for matching and converting to the specific type.
    # proc some_command {value} {
    #   return [list !!type $treatmented-value]
    #     or
    #   return ""
    # }
    variable parsers

    # scalar/collection treatment for matched specific yaml-tag
    # proc some_composer {type value} {
    #   return [list 1 $result-type $treatmented-value]
    #     or
    #   return ""
    # }
    variable composer

    variable defaults
    array set defaults {
        isfile   0
        validate 0
        types {timestamp int float null true false}
        composer {
            !!binary ::yaml::_composeBinary
        }

            null:Group  {null "" ~}
            true:Value  1
            true:Group  {true on + yes y}
            false:Value 0
            false:Group {false off - no n}
        }
    }

    variable _dumpIndent   2
    variable _dumpWordWrap 40

    variable opts [lrange [::cmdline::GetOptionDefaults {
        {file             {input is filename}}
        {stream           {input is stream}}
        {m.arg        ""  {fixed-modifiers bulk settings(null/true/false)}}
        {m:null.arg   ""  {null modifier settings(default {"" {null "" ~}})}}
        {m:true.arg   ""  {true modifier settings(default {1 {true on + yes y}})}}
        {m:false.arg  ""  {false modifier settings(default {0 {false off - no n}})}}
        {types.arg    ""  {modifier list settings(default {nop timestamp integer null true false})}}
        {validate         {to validate the input(not dumped tcl content)}}
    } result] 2 end] ;# Remove ? and help.

    variable errors
    array set errors {
        TAB_IN_PLAIN        {Tabs can be used only in comments, and in quoted "..." '...'.}
        AT_IN_PLAIN         {Reserved indicators {@} can't start a plain scalar.}
        BT_IN_PLAIN         {Reserved indicators {`} can't start a plain scalar.}
        SEQEND_NOT_IN_SEQ   {There is a flow-sequence end '\]' not in flow-sequence [v, ...].}
        MAPEND_NOT_IN_MAP   {There is a flow-mapping end '\}' not in flow-mapping {k: v, ...}.}
        ANCHOR_NOT_FOUND    {Could not find the anchor-name(current-version, "after refering" is not supported)}
        MALFORM_D_QUOTE     {Double quote "..." parsing error. end of quote is missing?}
        MALFORM_S_QUOTE     {Single quote '...' parsing error. end of quote is missing?}
        TAG_NOT_FOUND       {The "$p1" handle wasn't declared.}
        INVALID_MERGE_KEY   {merge-key "<<" is not impremented in not mapping scope(e.g. in sequence).}
        MALFORMED_MERGE_KEY {malformed merge-key "<<" using.}
    }
}


####################
# Public APIs
####################

proc ::yaml::yaml2dict {args} {
    _getOption $args

    set result [_parseBlockNode]

    set a [huddle get_stripped $result]

    if {$yaml::data(validate)} {
        set result [string map "{\n} {\\n}" $result]
    }

    return [huddle get_stripped $result]
}

proc ::yaml::yaml2huddle {args} {
    _getOption $args

    set result [_parseBlockNode]
    if {$yaml::data(validate)} {
        set result [string map "{\n} {\\n}" $result]
    }
    return $result
}

proc ::yaml::setOptions {argv} {
    variable defaults
    array set options [_imp_getOptions argv]
    array set defaults [array get options]
}

# Dump TCL List to YAML
#

proc ::yaml::list2yaml {list {indent 2} {wordwrap 40}} {
    return [huddle2yaml [huddle list {*}$list] $indent $wordwrap]
}

proc ::yaml::dict2yaml {dict {indent 2} {wordwrap 40}} {
    return [huddle2yaml [huddle create {*}$dict] $indent $wordwrap]
}

proc ::yaml::huddle2yaml {huddle {indent 2} {wordwrap 40}} {
    set yaml::_dumpIndent   $indent
    set yaml::_dumpWordWrap $wordwrap

    # Start at the base of the array and move through it.
    set out [join [list "---\n" [_imp_huddle2yaml $huddle] "\n"] ""]
    return $out
}


####################
# Option settings
####################

proc ::yaml::_getOption {argv} {
    variable data
    variable parsers
    variable fixed
    variable composer

    # default settings
    array set options [_imp_getOptions argv]

    array set fixed    $options(fixed)
    array set parsers  $options(parsers)
    array set composer $options(composer)
    array set data [list validate $options(validate) types $options(types)]
    set isfile $options(isfile)

    foreach {buffer} $argv break
    if {$isfile} {
        set fd [open $buffer r]
        set buffer [read $fd]
        close $fd
    }
    set data(buffer) $buffer
    set data(start)  0
    set data(length) [string length $buffer]
    set data(current) 0
    set data(finished) 0
}

proc ::yaml::_imp_getOptions {{argvvar argv}} {
    upvar 1 $argvvar argv

    variable defaults
    variable opts
    array set options [array get defaults]

    # default settings
    array set fixed $options(fixed)

    # parse argv
    set argc [llength $argv]
    while {[set err [::cmdline::getopt argv $opts opt arg]]} {
        if {$err eq -1} break
        switch -- $opt {

}

#########################
# Scalar/Block Composers
#########################
proc ::yaml::_composeTags {tag value} {
    if {$tag eq ""} {return $value}
    set value [huddle get_stripped $value]
    if {$tag eq "!!str"} {
        set pair [list $tag $value]
    } elseif {[info exists yaml::composer($tag)]} {
        set pair [$yaml::composer($tag) $value]
    } else {
        error [_getErrorMessage TAG_NOT_FOUND $tag]
    }
    return  [huddle wrap $pair]
}

proc ::yaml::_composeBinary {value} {
    package require base64
    return [list !!binary [::base64::decode $value]]
}

proc ::yaml::_composePlain {value} {
    if {$value ne ""} {
        if {[huddle type $value] ne "plain"} {return $value}
        set value [huddle get_stripped $value]
    }
    set pair [_toType $value]
    return  [huddle wrap $pair]
}

proc ::yaml::_toType {value} {
    if {$value eq ""} {return [list !!str ""]}

    set lowerval [string tolower $value]
    foreach {type} $yaml::data(types) {
        if {[info exists yaml::parsers($type)]} {
            set pair [$yaml::parsers($type) $value]
            if {$pair ne ""} {return $pair}
            continue
        }

        if {$type eq "-"} {
            set cc "[_getc][_getc]"
            if {"$type$cc" eq "---" && $current == 0} {
                set result {}
                continue
            } else {
                _ungetc 2

                # [Spec]
                # Since people perceive the�g-�hindicator as indentation,
                # nested block sequences may be indented by one less space
                # to compensate, except, of course,
                # if nested inside another block sequence.
                incr current
            }
        }
        if {$type eq "."} {
            set cc "[_getc][_getc]"
            if {"$type$cc" eq "..." && $current == 0} {
                set data(finished) 1
                break
            } else {
                _ungetc 2

#                 # [Spec]
#                 # Since people perceive the�g-�hindicator as indentation,
#                 # nested block sequences may be indented by one less space
#                 # to compensate, except, of course,
#                 # if nested inside another block sequence.
#                 incr current
            }
        }
        if {$type eq ""  || $current <= $indent} { ; # end document
            _ungetc
            break

        if {[info exists value]} {
            if {$status eq "NODE"} {return $value}
            foreach {result prev} [_pushValue $result $prev $status $value "BLOCK"] break
            unset value
        }
    }
    if {$status eq "SEQUENCE"} {
        set result [huddle sequence {*}$result]
    } elseif {$status eq "MAPPING"} {
        if {[llength $prev] == 2} {
            set result [_set_huddle_mapping $result $prev]
        }
    } else {
        if {[info exists prev]} {
            set result $prev
        }
        set result [lindex $result 0]
        set result [_composePlain $result]
        if {![huddle is_huddle $result]} {
            set result [huddle wrap [list !!str $result]]
        }
    }
    if {$tag ne ""} {
        set result [_composeTags $tag $result]
        unset tag
    }
    if {[info exists anchor]} {

    if {$prev ne ""} {
        if {[llength $prev] < 2} {error [_getErrorMessage MALFORMED_MERGE_KEY]}
        set result [_set_huddle_mapping $result $prev]
        set prev {}
    }

    set value [_parseBlockNode "" $pos]

    if {[huddle type $value]  eq "sequence"} {
        set len [huddle llength $value]
        for {set i 0} {$i < $len} {incr i} {
            set sub [huddle get $value $i]
            set result [huddle combine $result $sub]
        }

    } else {
        set result [huddle combine $result $value]
    }
    return [list $result $prev]
}


proc ::yaml::_parseSubBlock {pos statusnew} {
    upvar 1 status status
    set scalar 0
    set value ""
    if {[_next_is_blank]} {
        if {$statusnew ne ""} {
            set status $statusnew
            set value [_parseBlockNode "" $pos]
        }
    } else {
        _ungetc
        set scalar 1
    }
    return [list $scalar $value]
}

proc ::yaml::_set_huddle_mapping {result prev} {

    foreach {key val} $prev break

    set val [_composePlain $val]
    if {[huddle is_huddle $key]} {
        set key [huddle get_stripped $key]
    }


    if {$result eq ""} {
        set result [huddle mapping $key $val]
    } else {
        huddle update_children result $key $val
    }
    return $result
}


# remove duplications with saving key order
proc ::yaml::_remove_duplication {dict} {

}


# literal "|" (line separator is "\n")
# folding ">" (line separator is " ")
proc ::yaml::_parseBlockScalar {base separator} {
    foreach {explicit chomping} [_parseBlockIndicator] break

    set idch [string repeat " " $explicit]
    set sep $separator
    foreach {indent c line} [_getLine] break
    if {$indent < $base} {return ""}
    # the first line, NOT ignored comment (as a normal-string)
    set first $indent
    set value $line
    set stop 0

    while {![_eof]} {
        set pos [_getpos]
        foreach {indent c line} [_getLine] break
        if {$line eq ""} {
            regsub " " $sep "" sep
            append sep "\n"
            continue

        "keep" {
            append value $sep
        }
        "clip" {
            append value "\n"
        }
    }
    return [huddle wrap [list !!str $value]]
}

# in {> |}
proc ::yaml::_parseBlockIndicator {} {
    set chomping "clip"
    set explicit 0
    while {1} {

                return $result
            }
            "\[" { ; # starts a flow sequence
                 set value [_parseFlowNode "SEQUENCE"]
            }
            "\]" { ; # ends a flow sequence
                if {$status ne "SEQUENCE"} {error [_getErrorMessage SEQEND_NOT_IN_SEQ] }
                set result [huddle sequence {*}$result]
                return $result
            }
            "&" { ; # node's anchor property
                set anchor [_getToken]
            }
            "*" { ; # alias node
                set alias [_getToken]

                set value [_parsePlainScalarInFlow]
            } elseif {$scope eq "BLOCK"} {
                set value [_parsePlainScalarInBlock $pos]
            }
            set tag !!plain
        }
    }
    return [huddle wrap [list $tag $value]]
}

# [time scanning at JST]
# 2001-12-15T02:59:43.1Z       => 1008385183
# 2001-12-14t21:59:43.10-05:00 => 1008385183
# 2001-12-14 21:59:43.10 -5    => 1008385183
# 2001-12-15 2:59:43.10        => 1008352783

proc ::yaml::_parseDirective {} {
    variable data
    variable shorthands

    set directive [_getToken]

    if {[regexp {^%YAML} $directive]} {
        # YAML directive
        _skipSpaces
        set version [_getToken]
        set data(YAMLVersion) $version
        if {![regexp {^\d\.\d$} $version]}   { error [_getErrorMessage ILLEGAL_YAML_DIRECTIVE] }
    } elseif {[regexp {^%TAG} $directive]} {

        if {![regexp {^!$|^!\w*!$} $prefix]} { error [_getErrorMessage ILLEGAL_YAML_DIRECTIVE] }
        set shorthands(handle) $prefix
    }
}

proc ::yaml::_parseTagHandle {} {
    set token [_getToken]

    if {[regexp {^(!|!\w*!)(.*)} $token nop handle named]} {
        # shorthand or non-specific Tags
        switch -- $handle {
            ! { ;       # local or non-specific Tags
            }
            !! { ;      # yaml Tags
            }
            default { ; # shorthand Tags

            }
        }
        if {![info exists prefix($handle)]} { error [_getErrorMessage TAG_NOT_FOUND] }
    } elseif {[regexp {^!<(.+)>} $token nop uri]} {
        # Verbatim Tags
        if {![regexp {^[\w:/]$} $token nop uri]} { error [_getErrorMessage ILLEGAL_TAG_HANDLE] }
    } else {
        error [_getErrorMessage ILLEGAL_TAG_HANDLE]
    }

    return "!<$prefix($handle)$named>"
}


proc ::yaml::_parseDoubleQuoted {} {
    # capture quoted string with backslash sequences
    set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}

    # [126] nb-single-multi-line
    regsub -all {[ \t]*\n[\t ]*} $result "\r" result
    regsub -all {([^\r])\r} $result {\1 } result
    regsub -all { ?\r} $result "\n" result

    regsub -all {''} [string range $result 1 end-1] {'} chopped

    return $chopped
}


# [155]     nb-plain-char-in
proc ::yaml::_parsePlainScalarInFlow {} {
    set sep {\t \n,\[\]\{\}}

####################
proc ::yaml::_getFoldedString {reStr} {
    variable data

    set buff [string range $data(buffer) $data(start) end]
    regexp $reStr $buff token
    if {![info exists token]} {return}

    set len [string length $token]
    if {[string first "\n" $token] >= 0} { ; # multi-line
        set data(current) [expr {$len - [string last "\n" $token]}]
    } else {
        incr data(current) $len
    }
    incr data(start) $len

    return $token
}

# get a space separated token
proc ::yaml::_getToken {} {
    variable data

## Dumpers    ##
################

proc ::yaml::_imp_huddle2yaml {data {offset ""}} {
    set nextoff "$offset[string repeat { } $yaml::_dumpIndent]"
    switch -- [huddle type $data] {
        "string" {
            set data [huddle get_stripped $data]
            return [_dumpScalar $data $offset]
        }
        "list" {
            set inner {}
            set len [huddle llength $data]
            for {set i 0} {$i < $len} {incr i} {
                set sub [huddle get $data $i]

# Folds a string of text, if necessary
proc ::yaml::_doFolding {value offset} {
    variable _dumpWordWrap
    # Don't do anything if wordwrap is set to 0
    if {$_dumpWordWrap == 0} {
        return $value
    }

    if {[string length $value] > $_dumpWordWrap} {
        set wrapped [_simple_justify $value $_dumpWordWrap "\n$offset"]
        set value ">\n$offset$wrapped"
    }
    return $value
}

        }
        append result [string range $text 0 $brk] $wrap
    }
    return $result$text
}

########################
##    YAML TYPES      ##
########################

namespace eval ::yaml::types {
    namespace eval mapping {

    variable settings
        set settings {
        superclass dict
        publicMethods {mapping}
        tag !!map

        isContainer yes }


        proc mapping {args} {
            if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
            set resultL {}
            foreach {key value} $args {
                lappend resultL $key [argument_to_node $value !!str]
            }
            return [huddle wrap [list !!map $resultL]]
        }



    }

    namespace eval sequence {
        variable settings



        set settings {

        superclass list
        publicMethods {sequence}
        isContainer yes

        tag !!seq}


        proc sequence {args} {
            set resultL {}
            foreach {value} $args {
                lappend resultL [argument_to_node $value !!str]
            }
            return [wrap [list !!seq $resultL]]
        }



    }
}

proc ::yaml::_makeChildType {type tag} {
    set full_path_to_type ::yaml::types::$type
    namespace eval $full_path_to_type [string map [list @TYPE@ $type @TAG@ $tag] {

    variable settings
    set settings {
        superClass string
        publicMethods {}

        isContainer no
        tag @TAG@
    }
    }]



    return $full_path_to_type
}



huddle add_type ::yaml::types::mapping
huddle add_type ::yaml::types::sequence



huddle add_type [::yaml::_makeChildType str !!str]
huddle add_type [::yaml::_makeChildType timestamp !!timestamp]
huddle add_type [::yaml::_makeChildType float !!float]
huddle add_type [::yaml::_makeChildType int !!int]
huddle add_type [::yaml::_makeChildType null !!null]
huddle add_type [::yaml::_makeChildType true !!true]
huddle add_type [::yaml::_makeChildType false !!false]
huddle add_type [::yaml::_makeChildType binary !!binary]
huddle add_type [::yaml::_makeChildType plain !!plain]

} else {
    # all.tcl
    source [file join \
        [file dirname [file dirname [file join [pwd] [info script]]]] \
        devtools testutilities.tcl]

    testsNeedTcl     8.5
    testsNeedTcltest 2

    support {
	use      json/json.tcl json

        useLocal huddle.tcl    huddle

    }


    testing {

        useLocal yaml.tcl yaml
    }
}
proc dictsort2 {dict {pattern d}} {
    set cur  [lindex $pattern 0]
    set subs [lrange $pattern 1 end]
    foreach {tag sw} $cur break