#
# LAMBDA IMPLEMENTATION (TIP 187-alike)
#

#
# Invoking
#
#     proc $argList $body 
#
# returns a string 
#
#     "%NS::%Prefix {$argList} {$body}"
#
# which is a token for the corresponding anonymous function
# in canonical form. Note that canonical anon functions live
# in the global namespace ::
#
# %Prefix determines the "flavor" of lambda. Some of the suggested 
# variants are:
#    %Prefix is lambda ;# closest to the TIP
#    %Prefix is apply  ;# as in http://mini.net/tcl/11141
#    %Prefix is .
# In order to make name collisions extremely unlikely, one could
# also let the Prefix start with #
#    %Prefix #
#    %Prefix #lambda
#
# The Prefix should not include any double-colon; if you want the 
# lambdas to live in a special namespace, set %NS to 
# the corresponding namespace - without trailing double-colon.
# 
# The name %NS of the service NS determines where the procs and
# variables that implement the new behaviour will live.
#
# The variable %Auto controls if auto-expansion should be done
# for all multi-word commands.
#

# The body of a lambda runs in its own environment (identical to a 
# proc-body environment), with namespace context given by its name:
#   {::ns1::ns2::%Prefix $argList $body}
# ie, %NS by default.
#
# [map], [filter], and other higher-order functions should evaluate
# in their caller's context (ie, uplevel 1).


set LambdaMap [list    \
    %Prefix   lambda   \
    %NS       {}       \
    %LambdaNS ::lambda \
    %Auto     1        \
]


# 
# The code tries to interpret as lambda expressions the command 
# names that satisfy
#        (0) set tail [namespace tail $cmdName]
#        (1) [llength $tail] == 3
#        (1) [lindex $tail 0] == %Prefix
#        (2) proc $cmdName [lindex $tail 1] [lindex $tail 2]
#              succeeds

#
# Cleanup, useful for reloading
#

catch [string map $LambdaMap {
    if {[info exists %LambdaNS::OrigUnknownBody]} {
	proc ::unknown args $%LambdaNS::OrigUnknownBody
    }
    if {[info command %LambdaNS::OrigProc] ne {}} {
	rename proc {}
	rename %LambdaNS::OrigProc proc
    }
    namespace delete %LambdaNS
}]


namespace eval [string map $LambdaMap %LambdaNS] [string map $LambdaMap  {

    #
    # Cmd names cannot contain double-colon, so
    # that we are forced to quote them.
    #

    proc Quote body {string map {: {\:}} $body}
    proc Unquote body {string map {{\:} :} $body}
    proc SingleQuote body {Quote [Unquote $body]}

    #
    # Some service procs
    #

    # AutoCleaningProc: implements the auto-GC behaviour

    if {[info command ::tcl::unsupported::AutoCleaningCmd] ne {}} {
	interp alias {} %LambdaNS::AutoCleaningCmd {} ::tcl::unsupported::AutoCleaningCmd
    } else {
	proc AutoCleaningCmd args {}
    }

    proc MakeAutoCleaningProc {name argList body} {
	if {[uplevel 1 [list info command $name]] == {}} {
	    uplevel 1 [list proc $name $argList $body]
	}
	uplevel 1 [list %LambdaNS::AutoCleaningCmd $name 1]
    }

    # IsLambda

    proc IsLambda name {
	# CAREFUL: do not shimmer
	set name [namespace tail ::$name]; # NO SHIMMER
	if {[catch {set len [llength $name]}] \
		|| ($len < 3) \
		|| ([lindex $name 0] ne "%Prefix")} {
	    return 0
	}
	set argList [lindex $name 1]
	foreach val $argList {
	    if {[llength $val] > 2} {
		return 0
	    }
	}
	return 1
    }

    # SetCleanupTraces: used to manage lifetime of 
    #     some dependent lambdas

    namespace eval %LambdaNS::refs {}

    proc SetCleanupTraces {name lambdas} {
	set refName %LambdaNS::refs::[namespace tail ::$name]
	set $refName $lambdas
	trace add command $name delete \
	    [list unset -nocomplain $refName]
    }

    #
    # MakeCmdFromLambda: the main lambda and curry processor,
    #     invoked from ::unknown
    #

    proc MakeCmdFromLambda cmdName {
	set OK 0
	set ns [namespace qualifiers $cmdName]
	if {$ns ne {}} {
	    append ns ::
	}
	set tail [namespace tail ::$cmdName]; # NO SHIMMER
	if {[IsLambda $cmdName]} {
	    set curry [lassign $tail prefix argList body]
	    if {[llength $curry]} {
		set name $ns[proc $argList $body]
	    } else {
		set name $cmdName
	    }
	    if {[uplevel 1 [list info command $name]] eq {}} {
		set script [list %LambdaNS::MakeAutoCleaningProc $name \
				$argList [Unquote $body]]
		set OK [expr {![catch {uplevel 1 $script}]}]
	    } else {
		set OK 1
	    }
	    if {$OK && [llength $curry]} {
		set script [list %LambdaNS::MakeAutoCleaningProc $cmdName \
				args "[list $name] {expand}$curry \{expand\}\$args"]
		set OK [expr {![catch {uplevel 1 $script}]}]
		if {$OK} {
		    SetCleanupTraces $cmdName [list $name]
		}
	    }
	} elseif %Auto {
	    #
	    # Curry (or autoexpand) a command?
	    #

	    set curry [lassign $tail name]
	    set name ${ns}$name
	    if {[llength $curry]} {
		set script [list %LambdaNS::MakeAutoCleaningProc $cmdName \
				args "[list $name] {expand}$curry \{expand\}\$args"]
		set OK [expr {![catch {uplevel 1 $script}]}]
	    }
	}
	set OK
    }

    #
    # Defined only so that auto-expansion is emulated also for
    # lambda expressions
    #

    if %Auto {
	proc ::apply {argList body args} {
	    # FIXME: to be done
	}
    }


    #
    # Redefine::unknown to obtain the behaviour
    #

    proc Unknown args {
	set cmdName [lindex $args 0]
	if {[llength [namespace tail $cmdName]] > 1} {
	    if {[uplevel 2 [list %LambdaNS::MakeCmdFromLambda $cmdName]]} {
		return -code return [uplevel 2 $args]
	    }
	}
    }

    set OrigUnknownBody [info body ::unknown]

    proc ::unknown args "
	%LambdaNS::Unknown \{expand\}\$args
        $OrigUnknownBody
    "


    #
    # Replace the original proc to implement the
    # new behaviour.
    #

    catch {rename OrigProc {}}
    rename ::proc OrigProc
    OrigProc ::proc args {
	if {[llength $args] == 2} {
	    #
	    # Anonymous fuction request; just produce the
	    # string, and let [unknown] handle the rest at
	    # first use.
	    #
	    lassign $args argList body
	    return "%NS::%Prefix {$argList} {[%LambdaNS::Quote $body]}"
	}

	#
	# Normal tcl proc
	#

	uplevel 1 [list %LambdaNS::OrigProc {expand}$args]
    }


    #
    # Some useful thingies
    #

    # OPTIMISATION: to reduce recompilation when shimmering, you
    # may choose to manage the existence of the lambda under script 
    # control. The following commands convert a lambda to a proc, 
    # and viceversa - insuring the survival of the bytecodes.

    proc preserve lam {
	if {([uplevel 1[list info command $lam]] ne {}) \
		|| (([%LambdaNS::IsLambda $lam]) \
			&& ([uplevel 1 [list %LambdaNS::MakeCmdFromLambda $lam]]))} {
	    uplevel 1 [list %LambdaNS::AutoCleaningCmd $lam 0]
	}
    }

    proc release lam {
	if {([uplevel 1 [list info command $lam]] ne {}) \
		&& ([%LambdaNS::IsLambda $lam])} {
	    uplevel 1 [list %LambdaNS::AutoCleaningCmd $lam 1]
	}
    }


    # map

    proc map {func lst} {
	preserve $func
	set ret [list]
	foreach item $lst {
	    lappend ret [uplevel 1 [list $func $item]]]
	}
	release $func
	set ret
    }


    # Function composition; takes a list of procs or lambdas, creates the 
    # composite function as a lambda. It keeps references to the internal
    # lambdas, in order to provide lifetime management.
    #
    # Note: all but the last function should be able to handle a single
    # argument.
    #

    proc o {x y args} {
	set args [linsert $args 0 $x $y]
	set num [llength $args]
	set lambdas [list]
	set body {}
	foreach fun $args {
	    if {[IsLambda $fun]} {
		lappend lambdas $fun
		if {[uplevel 1 [list info command $fun]] eq {}} {
		    uplevel 1 [list %LambdaNS::MakeCmdFromLambda $fun]
		}
	    }
	    append body "uplevel 1 \[list [list $fun] \["
	}
	set num [expr {2*$num-1}]
	set body [string replace $body  end end \
		      " \{expand\}\$args [string repeat \] $num]"]
	set cmdName [proc args $body]
	if {[uplevel 1 [list %LambdaNS::MakeCmdFromLambda $cmdName]] \
		&& [llength $lambdas]} {
	    SetCleanupTraces $cmdName $lambdas
	}
	set cmdName
    }

}]

unset LambdaMap
