package require Tcl 8.6
package require TclOO
package provide TclOO::Annotation

namespace eval ::oo::Annotations {
    namespace export *annotation

    variable classInfo
    array set classInfo {}
    variable objInfo
    array set objInfo {}

    proc ::oo::InfoClass::annotations {className {annotationName {}} args} {
        variable ::oo::Annotations::classInfo
        set className [uplevel 1 [list namespace which $className]]
        if {$annotationName eq ""} {
            if {![info exists classInfo($className)]} {
                return {}
            }
            return [dict keys $classInfo($className)]
        }
        if {
            ![info exists classInfo($className)]
            || ![dict exists $classInfo($className) $annotationName]
        } then {
            return -code error "unknown annotation \"$annotationName\""
        }
        set result {}
        foreach handlerObj [dict get $classInfo($className) $annotationName] {
            try {
                $handlerObj describe result {*}$args
            } on error msg {
                return -code error $msg
            }
        }
        return $result
    }

    proc ::oo::InfoObject::annotations {objectName {annotationName {}} args} {
        variable ::oo::Annotations::objInfo
        set objectName [uplevel 1 [list namespace which $objectName]]
        if {$annotationName eq ""} {
            if {![info exists objInfo($objectName)]} {
                return {}
            }
            return [dict keys $objInfo($objectName)]
        }
        if {
            ![info exists objInfo($objectName)]
            || ![dict exists $objInfo($objectName) $annotationName]
        } then {
            return -code error "unknown annotation \"$annotationName\""
        }
        set result {}
        foreach handlerObj [dict get $objInfo($objectName) $annotationName] {
            try {
                $handlerObj describe result {*}$args
            } on error msg {
                return -code error $msg
            }
        }
        return $result
    }

    proc DefineUnknown {cmd args} {
        if {[string match @* $cmd]} {
            try {
                AnnotateClass [lindex [info level -1] 1] \
                    [string range $cmd 1 end] {*}$args
                return
            } on error msg {
                return -code error $msg
            }
        }
        tailcall ::oo::UnknownDefinition $cmd {*}$args
    }
    proc ObjdefineUnknown {cmd args} {
        if {[string match @* $cmd]} {
            if {[lindex [info level -1] 0] eq "self"} {
                set obj [lindex [info level -2] 1]
            } else {
                set obj [lindex [info level -1] 1]
            }
            try {
                AnnotateObject $obj [string range $cmd 1 end] {*}$args
                return
            } on error msg {
                return -code error $msg
            }
        }
        tailcall ::oo::UnknownDefinition $cmd {*}$args
    }

    namespace eval ::oo::define [list \
            namespace unknown [namespace which DefineUnknown]]
    namespace eval ::oo::objdefine [list \
            namespace unknown [namespace which ObjdefineUnknown]]

    namespace eval RealDefines {}
    namespace eval RealObjDefines {}
    apply [list {} {
        foreach cmd [info commands ::oo::define::*] {
            set tail [namespace tail $cmd]
            set target ::oo::Annotations::RealDefines::$tail
            rename $cmd $target
            proc $cmd args "
                ::oo::Annotations::ClassDefinition $tail {*}\$args
                tailcall [list $target] {*}\$args
            "
        }
        foreach cmd [info commands ::oo::objdefine::*] {
            set tail [namespace tail $cmd]
            set target ::oo::Annotations::RealObjDefines::$tail
            rename $cmd $target
            proc $cmd args "
                ::oo::Annotations::ObjectDefinition $tail {*}\$args
                tailcall [list $target] {*}\$args
            "
        }
    } [namespace current]]

    variable subject
    variable currentAnnotators
    proc AnnotateClass {subjectClass annotationType args} {
        variable subject $subjectClass
        variable currentAnnotators
        lappend currentAnnotators \
            [Annotation.$annotationType new class {*}$args]
    }
    proc AnnotateObject {subjectObject annotationType args} {
        variable subject $subjectObject
        variable currentAnnotators
        lappend currentAnnotators \
            [Annotation.$annotationType new object {*}$args]
    }
    proc ClassDefinition {operation args} {
        variable currentAnnotators
        if {![info exists currentAnnotators]} {
            return
        }
        variable subject
        variable classInfo
        try {
            foreach a $currentAnnotators {
                set name [$a name]
                $a register $operation {*}$args
                if {
                    ![info exists classInfo($subject)]
                    || ![dict exists $classInfo($subject) $name]
                } then {
                    dict set classInfo($subject) $name {}
                }
                dict lappend classInfo($subject) $name $a
                set currentAnnotators [lrange $currentAnnotators 1 end]
            }
        } on error msg {
            foreach a $currentAnnotators {
                $a destroy
            }
            return -level 2 $msg
        } finally {
            unset currentAnnotators
        }
    }
    proc ObjectDefinition {operation args} {
        variable currentAnnotators
        if {![info exists currentAnnotators]} {
            return
        }
        variable subject
        variable objInfo
        try {
            foreach a $currentAnnotators {
                set name [$a name]
                $a register $operation {*}$args
                if {
                    ![info exists objInfo($subject)]
                    || ![dict exists $objInfo($subject) $name]
                } then {
                    dict set objInfo($subject) $name {}
                }
                dict lappend objInfo($subject) $name $a
                set currentAnnotators [lrange $currentAnnotators 1 end]
            }
        } on error msg {
            foreach a $currentAnnotators {
                $a destroy
            }
            return -level 2 $msg
        } finally {
            unset currentAnnotators
        }
    }

    # The root class of annotations
    ::oo::class create annotation {
        unexport create
        variable annotation Type Operation
        constructor {type args} {
            set Type $type
            my MayApplyToType $type
            my RememberAnnotationArguments $args
        }

        method MayApplyToType type {
            throw ANNOTATION {may not apply this annotation to that type}
        }
        method MayApplyToOperation operation {
            throw ANNOTATION {may not apply that annotation to this operation}
        }

        method RememberAnnotationArguments values {
            set annotation $values
        }
        method QualifyAnnotation args {
            # Do nothing by default
        }

        method name {} {
            set name [namespace tail [info object class [self]]]
            return [regsub {^Annotation.} $name @]
        }
        method register {operation args} {
            set Operation $operation
            my MayApplyToOperation $operation
            my QualifyAnnotation {*}$args
        }
        method describe {varName} {
            upvar 1 $varName v
            lappend v $annotation
        }
    }

    # Convenience classes that make it easier to define annotations
    # that only work on classes or objects
    ::oo::class create classannotation {
        superclass annotation
        method MayApplyToType type {
            if {$type ne "class"} {next $type}
        }
    }
    ::oo::class create objectannotation {
        superclass annotation
        method MayApplyToType type {
            if {$type ne "object"} {next $type}
        }
    }

    #-----------------------------------------
    # Make some annotation classes.

    oo::class create Annotation.Describe {
        superclass oo::Annotations::classannotation oo::Annotations::objectannotation
        variable annotation Operation method
        method MayApplyToOperation operation {
            if {$operation ni {method forward constructor}} {next $operation}
        }
        method QualifyAnnotation {name args} {
            if {$Operation eq "constructor"} {
                set method <<constructor>>
            } else {
                set method $name
            }
        }
        method describe {varName {name {}}} {
            upvar 1 $varName v
            if {[llength [info level 0]] == 3} {
                dict set v $method [join $annotation]
            } elseif {$method eq $name} {
                set v [join $annotation]
                return -code break
            }
        }
    }

    oo::class create Annotation.Result {
        superclass Annotation.Describe
        method MayApplyToOperation operation {
            if {$operation eq "constructor"} {
                throw ANNOTATE "not on a constructor"
            }
            next $operation
        }
    }

    oo::class create Annotation.SideEffects {
        superclass Annotation.Describe
    }

    oo::class create Annotation.Argument {
        superclass oo::Annotations::classannotation oo::Annotations::objectannotation
        variable annotation Operation method argument
        constructor {type argName args} {
            set argument $argName
            next $type {*}$args
        }
        method MayApplyToOperation operation {
            if {$operation ni {method forward constructor}} {next $operation}
        }
        method QualifyAnnotation {name args} {
            if {$Operation eq "constructor"} {
                set method <<constructor>>
            } else {
                set method $name
            }
        }
        method describe {varName {name {}} {argname {}}} {
            upvar 1 $varName v
            if {[llength [info level 0]] == 3} {
                lappend v $method
            } elseif {$method eq $name} {
                if {[llength [info level 0]] == 4} {
                    lappend v $argument
                } elseif {$argument eq $argname} {
                    set v [join $annotation]
                    return -code break
                }
            }
        }
    }
}

oo::class create example {
    @Describe            This is the foo method. It has multiple annotations \
        attached to it.
    @Argument   x        The first argument to the method.
    @Argument   args        The list of remaining arguments to the method.
    @Result            None.
    @SideEffects    Prints to stdout.
    method foo {x args} { puts foo }

    @Describe This is the bar method.
    method bar args { puts bar }
}

puts annotations:\t[info class annotation example]
puts desc-foo:\t[info class annotation example @Describe foo]
puts args-foo:\t[info class annotation example @Argument foo]
foreach a [info class annotation example @Argument foo] {
    puts args-foo-${a}:\t[info class annotation example @Argument foo $a]
}
puts result-foo:\t[info class annotation example @Result foo]
puts effects-foo:\t[info class annotation example @SideEffects foo]

annotations:        @Describe @Argument @Result @SideEffects
desc-foo:        This is the foo method. It has multiple annotations attached to it.
args-foo:        x args
args-foo-x:        The first argument to the method.
args-foo-args:        The list of remaining arguments to the method.
result-foo:        None.
effects-foo:        Prints to stdout.