[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... '''Step 1: TOOT''' As I haven't actually got round to releasing TOOT yet, here is a hacked up definition of types that TOOT provides. This version supports algebraic pattern matching (much like [Algebraic Types]): # Install TOOT's unknown command 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] } } } namespace eval type { namespace export constructor method match proc create {name body} { set body " namespace import -force ::type::* $body " uplevel 1 [list namespace eval $name $body] } proc constructor {name args} { set tname [uplevel 1 [list namespace current]] uplevel 1 [list interp alias {} ::$name {} \ ::type::Construct $name $args] set body { uplevel 1 [linsert $args 0 } append body ${tname}:: append body {$method [list } append body "${name}: " foreach item $args { append body $ "$item " } append body {]]} uplevel 1 [list proc ::${name}: \ [linsert $args end method args] $body] return $name } proc Construct {con params args} { if {[llength $args] != [llength $params]} { return -code error \ "wrong # args: should be \"$type $con $params\"" } return [linsert $args 0 ${con}:] } proc method {name arglist body} { uplevel 1 [list proc $name [linsert $arglist 0 self] $body] } # Algebraic pattern matching 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 } } Now, let's define our first monad: The Maybe monad. Useful for when you might return a value, or might not. (e.g. taking the head of an empty list might return Nothing, whereas a non-empty list would return Just the first element): 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 } } 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}] Now, let's check that our monad satisfies the Monad Laws. These are: 1. (return x) >>= f == f x 2. m >>= return == m 3. (m >>= f) >>= g == m >>= (\x -> f x >>= g) In Tcl with TOOT, we can check these easily enough. First, define some helpers: proc lambda {arglist body} { return [list apply: $arglist $body] } proc apply: {arglist body args} { uplevel 1 "lassign $args {expand}$arglist; $body" } That's a lambda with dynamic scope. Lexical scope would be nicer, but dynamic scope will suffice for this demonstration. set x [list 2 3 4] set m [Just $x] set f head set g double # 1. expr {[[Maybe::Return $x] >>= $f] == [$f $x]} # 2. expr {[$m >>= Maybe::Return] == $m} # 3. expr {[[$m >>= $f] >>= $g] == [$m >>= [lambda x { [$f $x] >>= $g }]]} These do indeed all evaluate to true, showing that our monad satisfies the laws, at least, for these tests. (It should also work for any other test, but I don't have a proof of correctness). To make this a bit more convenient, here's a first cut at Haskell's "do" notation, which adds some syntactic sugar (see [Salt and Sugar]) for the bind (>>=) operations. This version isn't entirely correct, but it illustrates the point: monads + a little sugar are extremely powerful. # Do notation proc mdo {script} { foreach item [split $script "|"] { if {[info exists res]} { set res [$res >>= [list uplevel 1 $item]] } else { set res [uplevel 1 $item] } } return $res } # A test: mdo { head {7 6 5 4 3} | double | puts } [NEM] Here's a more complicated example, using an Error monad, which perhaps illustrates things a bit better. Imagine a world where Tcl didn't have built-in exception handling. In this world you might have operations which could either return a result, or might not in some error condition. One way to get around this is to return a return code and a potential result as a tuple (list). This is essentially what Tcl does at the C-level: the int return code signals TCL_OK, TCL_ERROR, etc, and the actual result (or error message) is stored in the interpreter. Now, what this means at the C-level is that you have a lot of code which does: if (Tcl_SomeFunc(interp, ...) != TCL_OK) { return TCL_ERROR; } which gets a bit tedious to keep typing, but generally works ok. What a monad allows you to do is to package up this boiler-plate code into an Error monad which does the right thing. Now, all you need to do is sequence your actions using the Error monad operations, and use throw/catch and everything should work ok. To demonstrate: type::create Error { constructor Error msg constructor Ok result proc Return {a} { Ok $result } proc >>= {ea atoeb} { type::match $ea { {Error: msg} -> { Error $msg } {Ok: res} -> { uplevel 1 $atoeb [list $res] } } } proc >> {ea feb} { # still check result and propagate type::match $ea { {Error: msg} -> { Error $msg } {Ok: _} -> { uplevel 1 $feb } } } proc throw {message} { Error $message } proc catch {res handler} { $res match { {Error: msg} -> { return [uplevel 1 $handler [list $msg]] } {Ok: res} -> { return $res } } } proc Return {val} { Ok $val } } # lrange $list 1 end, if list has at least one element, else error proc tail {list} { if {[llength $list]} { Error::Return [lrange $list 1 end] } else { Error::throw "empty list" } } # A monadic puts function proc eputs {item} { puts $item Error::Return $item } # Print each successive sub-list of a list, then error :) proc printevery {list} { [[tail $list] >>= eputs] >>= printevery } proc Handle {errormsg} { puts "ERROR: $errormsg" } Error::catch [printevery {1 2 3 4 5 6}] Handle Error::catch [tail {1 2 3}] Handle ;# should be fine Error::catch [tail {}] Handle ;# error Note, in particular, that the printevery function doesn't have to know anything about the Error monad. So long as it uses the >>=, and >> sequence operators to string things together, then it will work fine. More subtlely, you could replace the Error monad with a different monad (for instance, one which does tracing, or one which does [result caching]), and the same code will keep working. Monads encapsulate methods of combining computations into larger computations. ---- [Category Concept]