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...
# 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
"
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}]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:
# error monad
# source monad.tcl
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 ;# errorOK - so, it still looks pretty involved, all this >>= business. Well, in Haskell, they define a new "do" keyword syntax form, which converts code automatically to this form. So, here is a 'mdo' command which does just that. Separate items with "|" (think UNIX pipe):
# 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
}
mdo {
head {7 6 5 4 3} | double | puts
}