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
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 ... ]