149 lines with little testing code and comments. That's why I like Tcl - complex language flow control construct in such a snippet. Actually, it was my second attempt. First was a lot uglier and bigger. ---- # Algebraic types. # Creating constructors and deconstruction by pattern matching. namespace eval atypes { # List of defined constructors. # Actually, it is an map from constructor names to their typenames, # and used to keep track of constructor name uniqueness. array set defcons {} # Create algebraic type. # Argument 'typename' is useless, but FP languages need it. # 'args' argument is a list of constructor # descriptions. They are in the form # ConstructorName ?param? ?param ...?. # ConstructorName should be unique. # # At the end we create a bunch of commands. proc atype {typename args} { variable defcons # Defining constructors for type. foreach c $args { # Split constructor definition into name and args set cvars [lrange $c 1 end] set constrname [lindex $c 0] if {![string is upper [string range $constrname 0 0]]} { error "Incorrect constructor name '$constrname' for type $typename" } if {[info exists defcons($constrname)]} { error "Constructor $constrname (type $typename) was already defined for type $defcons($constrname)" } # We ought to create constructor header and # construction part. Constructor header is a list # of variables. set construction [list $constrname] foreach cv $cvars { if {[llength $cv]!=1} { error "Improper argument name $cv for $constrname (type $typename)" } lappend construction "\[set $cv\]" } set construction [join $construction " "] proc ::$constrname $cvars "return \[list $construction\]" } } # Match a constructed value against pattern(s). # Pattern can be: # $ - if element starts from $, then [string range 1 end] # is considered variable name to bind. # _ - for dummy variable (expression is matched but dropped from # assignment) # {ConstrName ?pattern pattern ...?} - match of constructed expression proc match {expr patterns} { foreach {p pcode} $patterns { # Try to match foreach {ok bindlist} [matchbind $expr $p] break if {$ok} { foreach {var val} $bindlist { uplevel 1 [list set $var $val] } set rcode [catch {uplevel 1 $pcode} result] return -code $rcode $result } } error "$expr does not match patterns $patterns" } # Auxillary function. # Actually tries to match expression and pattern. # Returns [list 1 bindlist] for success and [list 0 {}] for failure. proc matchbind {expr pattern} { # pattern might be a '_': if {[string equal _ $pattern]} { return {1 {}} } # pattern might be a $var: if {[string equal \$ [string range $pattern 0 0]]} { return [list 1 [list [string range $pattern 1 end] $expr]] } # Complex structural match case. # First, 'shape' of pattern binding and # expression should match: if {[llength $expr]!=[llength $pattern]} { return {0 {}} } # Split pattern and expression into respective constructors # and arguments. set subps [lrange $pattern 1 end] set pattconstr [lindex $pattern 0] set subexprs [lrange $expr 1 end] set exprconstr [lindex $expr 0] # Second, head of expression and pattern should be equal. if {![string equal $pattconstr $exprconstr]} { return {0 {}} } # Okay, then we should match every expression with # every pattern, going recursively, if needed. set binds {} ;# bind list foreach p $subps e $subexprs { # Match subexpression with subpattern foreach {ok bindadd} [matchbind $e $p] break if {!$ok} { # If not matched - fail. return {0 {}} } # Otherwise - grow bind pars list. set binds [concat $binds $bindadd] } # Return success return [list 1 $binds] } # Export such a useful command: namespace export atype match } catch {rename match {}} catch {rename atype {}} namespace import atypes::* # tests: if 1 { # Maybe type (single element list) atype Maybe {Nothing} {Just a} # List as it should be: atype List {Nil} {List head tail} # Verifying construction: puts [Nothing] puts [Just "hello, world!"] puts [List ? [List ! Nil]] # Verifying matching. proc testmatch {e} { match $e { {Just $x} {puts "Just x branch: $x"} {Nothing} {puts "Nothing branch"} {List $head {List $head2 $tail2}} { puts "Complex list branch." puts "head '$head', head2 '$head2', tail2 '$tail2'" } {List $head $tail} { puts "List branch: head '$head' tail '$tail'" } {generate error} { puts "We will generate an error" error "Error was generated" } _ { puts "Unknown expression $e" } } } testmatch [Just "what?"] testmatch [Nothing] testmatch [List ? [List ! Nil]] testmatch [List ? Nil] testmatch ??? testmatch "generate error" } ---- You may see that we testing a match with arbitrary string in testmatch "generate error" This is perfectly Ok and I mean it from the start. "[Everything is a string]", isn't it? I eliminated use of lassign so it doesn't need Tclx anymore. So I (and you) can use it on my (or your) Linux notebook without any upgrades. Take a look at [Simple BDD] for demonstration of capabilities. I've used algebraic types for expression manipulation. An example could be found here: [Expression Tree Package].