NEM 18Mar2005 Been playing around with Haskell a bit recently, and in particular, looking at monads. (See [1] 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: TOOTAs 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 {
[uplevel 1 $func [list $item]] >>= {lappend ret}
}
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:- (return x) >>= f == f x
- m >>= return == m
- (m >>= f) >>= g == m >>= (\x -> f x >>= g)
proc lambda {arglist body} { return [list apply: $arglist $body] }
proc apply: {arglist body args} {
uplevel 1 "lassign $args {*}$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 ;# errorNote, 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.One of the key points about monads is that operations which use the monad sequencing operations will generalise over different types of monad. To illustrate this, recall our "mmap" function (a sort of map/filter combined, much like Jim's lmap): proc mmap {func list} {
set ret [list]
foreach item $list {
[uplevel 1 $func [list $item]] >>= {lappend ret}
}
return $ret
}We used this function to map the "double" function over lists, using the Maybe monad to allow us to both perform a transformation (map), and filter. Well, we can also do exactly the same using the Error monad, without changing the mmap function. To show this, let's define an edouble function that does the same as double, but throws an error (using the Error monad) for numbers greater than 999: proc edouble {num} {
if {$num < 1000} {
Error::Return [expr {$num * 2}]
} else {
Error::throw "number too large: $num"
}
}
set list [list 1 2 3 4 999 1002 12]
puts [mmap double $list] ;# Using Maybe monad
puts [mmap edouble $list] ;# Using Error monadThe result should be the same.NEM: More concretely, monads can be used for creating Parser Combinators.