Version 2 of Algebraic Types

Updated 2003-08-06 00:17:42

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.

 package require Tclx

 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 [lassign $c constrname]
                        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:
        # $<varname> - 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
                        lassign [matchbind $expr $p] ok bindlist
                        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 [lassign $pattern pattconstr]
                set subexprs [lassign $expr exprconstr]
                # 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
                        lassign [matchbind $e $p] ok bindadd
                        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
 }


 # tests:
 if 1 {
        catch {rename match {}}
        catch {rename atype {}}
        namespace import atypes::*
        # 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 GenerateError

This is perfectly Ok and I mean it from the start. Everything is a string