NEM 18Mar2005 Been playing around with Haskell a bit recently, and in particular, looking at monads. (See [L1 ] 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