[NEM] '''18Mar2005''' Been playing around with Haskell a bit recently, and in particular, looking at monads. (See [http://www.nomaware.com/monads/html/index.html] for an introduction). This is a first stab at writing monads using [TOOT]. It's a bit ad-hoc at the moment, but I think it demonstrates the basic approach. Also, the sharp-eyed among you may notice an implementation of algebraic pattern-matching in this code...

 # Install TOOT unknown handler
 if {[llength [info commands ::__toot_unknown]] == 0} {
    rename ::unknown ::__toot_unknown
    proc ::unknown {cmd args} {
	if {[llength $cmd] > 1} {
	    uplevel 1 $cmd $args
	} else {
	    uplevel 1 [linsert $args 0 ::__toot_unknown $cmd]
	}
    }
 }

 # Create a type command
 namespace eval type {
    namespace export constructor method match
 
    proc create {name body} {
	set body "
	    namespace import ::type::*
	    $body
	    namespace ensemble create
	"
	uplevel 1 [list namespace eval $name $body]
	uplevel 1 [list proc ${name}: {self method args} \
	    [string map [list %N [list $name]] {
	    uplevel 1 [linsert $args 0 \
		%N::$method $self]
	}]]
    }
 
    proc constructor {name args} {
	set tname [uplevel 1 [list namespace current]]
	uplevel 1 [list \
	interp alias {} $name {} ::type::Construct $tname $name $args
	]
    }
 
    proc Construct {type con params args} {
	if {[llength $args] != [llength $params]} {
	    return -code error \
	    "wrong # args: should be \"$type $con $params\""
	}
	return [list ${type}: [linsert $args 0 $con]]
    }
 
    proc method {name arglist body} {
	uplevel 1 [list proc $name [linsert $arglist 0 self] $body]
    }
 
    proc match {value options} {
	upvar 1 __dict dict
	set dict [dict create]
	foreach {pattern -> script} $options {
	    if {[Match $pattern $value dict]} {
		return [uplevel 1 [list dict with __dict $script]]
	    }
	}
	return -code error "'$value' doesn't match type"
    }
 
    proc Match {pattern value var} {
	upvar 1 $var dict
	if {[llength $pattern] != [llength $value]} {
	    return 0
	}
	foreach pat $pattern word $value {
	    if {[string match {[A-Z]*} $pat]} {
		if {![string equal $pat $word]} {
		    return 0
		}
	    } else {
		dict set dict $pat $word
	    }
	}
	return 1
    }
 }
 
 # The Maybe monad
 type::create Maybe {
    constructor Nothing
    constructor Just a
 
    # Inject a value into the monad
    # Return 	:: a -> Maybe a
    proc Return {a} {
	Just $a
    }
 
    # >>=	:: Maybe a -> (a -> Maybe b) -> Maybe b
    proc >>= {ma atomb} {
	type::match $ma {
	    Nothing	-> Nothing
	    {Just a}	-> { uplevel 1 $atomb [list $a] }
	}
    }
 
    proc >> {_ fmb} {
	uplevel 1 $fmb
    }
 }

And some tests...

 # Take the head of a list -- returns Nothing if the list is empty
 # head 	:: [a] -> Maybe a
 proc head {list} {
    if {[llength $list]} {
	Just [lindex $list 0]
    } else {
	Nothing
    }
 }
 
 # double an integer, if it is less than 1000
 # double :: Int -> Maybe Int
 proc double {a} {
    if {$a < 1000} {
	Just [expr {$a * 2}]
    } else {
	Nothing
    }
 }
 
 # double the first item in a list, and print the result
 proc printdouble {list} {
    [[head $list] >>= double] >>= puts
 }
 
 printdouble {1 2 3}
 printdouble {} 	;# empty list, should produce no output
 printdouble {2000 3000 4000}
 
 # iterate:
 # repeatedly apply a function to successive numbers until it produces
 # Nothing
 # iterate :: (a -> Maybe a) -> [a]
 proc iterate {func init} {
    set res [uplevel 1 $func [list $init]]
    $res match {
	Nothing		-> { return }
	{Just a}	-> {
	    concat $a [iterate $func $a]
	}
    }
 }
 
 # mmap:
 # Like "map", but doesn't append if function returns Nothing
 # mmap (a -> Maybe b) -> [a] -> [b]
 proc mmap {func list} {
    set ret [list]
    foreach item $list {
	set r [uplevel 1 $func [list $item]]
	$r match {
	    Nothing	-> { }
	    {Just a}	-> { lappend ret $a }
	}
    }
    return $ret
 }
 
 puts [iterate double 2]
 puts [mmap double {2 4 5 1000 2000 70 80}]

----
[[ Category ... ]]