Back to Questions
5.1k
views19
comments
Syntax tree walking in a PEG metacompiler
f#functional

[FINAL version -- see link "walkwrap3.zip" above]

[Moved this from F# mail list -- fsharp@list.research.microsoft.com, so that it would stick around awhile -- I plan to add to this as the solution evolves.]

It was pointed out by Can Erten that I am taking a strictly OO approach, and that there are likely to be functional features in F# that would streamline this.

Here is my starting point:

Consider a very simple grammar, taken
from another post:

1
2
3

Exp <- Lit | Add
Lit <- ...non-negative integers...
Add <- Exp '+' Exp

My goal is to create a metacompiler. I view this as two parts:

  1. Parsing a grammar into a syntax tree, and
  2. Tree-node methods and top-level helper functions related to walking that syntax tree for various purposes.

In particular, (2) is to be designed such that additions and changes to the
grammar involve minimal rewriting of custom client-code using those syntax
trees and those helper functions.

This thread covers (2). The idea is to be clear how the tree will be used, as that might affect the design of the tree. Also, there is an abundance of material about constructing parsers, so (2) was the more uncertain topic for me; this thread is to work out details.

(1) will be covered in [TBD -- link will go here]. I am starting from Harry Pierson's (DevHawk) "Practical Parsing in F#: [link:devhawk.net] EDIT: Considering building on FParsec instead. In either approach, the challenge will be moving from "here's how to write a parser" to "here's how to write a parser generator".

(If you want to follow my progress in learning to make use of F#, you might be interested in my next thread, though it doesn't directly relate to building the metacompiler: "Using Reflection to Serialize F# data types to/from XML", [link:cs.hubfs.net] )

IMPLEMENTATION: The current design [on paper] is that the metacompiler spits
out F# source representing the tree node types; this is combined with the custom
snippets source file, and the project is recompiled.

Currently I am representing each node as a choice, and then using a match to
walk that node.
E.g.

1
2
3
4
5
6
7
8

type Exp =
| Lit of Lit
| Add of Add

...
match exp with
| Lit lit -> ...
| Add add -> ...

----------------------------------------------------------------------

ADDENDUM: A final post has been added, with a cleaned up version.

Jon Harrop (www.ffconsultancy.com) kindly continued to offer suggestions on code improvement. His suggestions were functional; the style can be seen in how eval is now split into eval_exp and eval_stmt, each of which is a function that understands one action (eval) on one type (exp or stmt).

For actions that will be part of the metacompiler output for each type, I have used OO style instead of functional in my implementation: see the methods that are now on type "node", and the implementation of those methods on each subclass -- which makes sense since each method is only associated with one type, and is known at the time the type is designed.

In some details, I have gone full-circle back to my original OO version. However, I make better use of F# functional features. Even the OO methods are made accessible functionally, via top-level functions "let children (n:#node) :node list", etc. A client of the metacompiler can program in a functional style, without awareness of the OO heirarchy, as demonstrated in the client code for printing and eval. This functional style is convenient for adding functionality independently of a class definition.

The "wrapNode" type is key: it provides a concise and efficient way to group a set of types for functional access and extension. Each node has an OO method to return itself wrapped.

This design is efficient and easy to work with, to maintain, and to extend -- utilizing the strengths of OO -with- the strengths of functional, in a statically typed language.

~TMSteve

.

Now I am scratching my head trying to retain the convenient ability to use match when I want to access alternative choices, yet put this into a more general Tree-Node structure, so that it is trivial to walk the whole tree.

Thinking about this, I want to be able to easily enumerate the children of a Node.

So I want each node to implement:

1
2
3
4

type Node =
  interface
    abstract children : system.Collections.Generic.IEnumerator<Node>
  end

Is it possible for Add to both be a choice (like the first post), and be a class that implements this interface?

By on 3/24/2008 2:23 PM ()

The syntax to do this is found in a link provided by Can Erten:

[link:www.strangelights.com:80]

The keyword is "with", the resulting declaration is:

1
2
3
4
5
6
7

type Exp =
  | Lit of Lit
  | Add of Add
  with
    interface Node with
      member it.children = ...
    end
By on 3/24/2008 3:48 PM ()

Here is what I came up with for the type declarations of the Lit, Exp, and Add nodes.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47

// ---------- Node Definitions ----------
 
type Node =
  interface
    abstract typeStr :string
    abstract children :seq<Node>
    abstract leafData :obj option
  end
 
let SeqOf0Nodes() :seq<Node> = Seq.empty
let SeqOf1Node(node:#Node) = Seq.singleton (node :> Node)
let SeqOf2Nodes(node1:#Node, node2:#Node) =
  List.to_seq( [ (node1 :> Node); (node2 :> Node) ] )
 
/// Expression <- Literal | Add
type Exp =
  | Lit of Lit
  | Add of Add with
  interface Node with
    member it.typeStr = "Exp"
    member it.children =
      let child:Node =
        match it with
          | Lit lit -> lit :> Node
          | Add add -> add :> Node
      SeqOf1Node(child)
    member it.leafData = None
    end
 
/// Literal <- Number
and Lit(v0:string) =
  member it.v = v0; // Get data.
  interface Node with
    member it.typeStr = "Lit"
    member it.children = SeqOf0Nodes()
    member it.leafData = Some( box(v0) )
  end
 
/// Add <- Expression '+' Expression
and Add(exp1a:Exp, exp2a:Exp) =
  member it.Exp1 = exp1a;
  member it.Exp2 = exp2a;
  interface Node with
    member it.typeStr = "Add"
    member it.children = SeqOf2Nodes(exp1a, exp2a)
    member it.leafData = None
  end

The class definitions are a bit more verbose than I would like; a realistic grammar will have a lot of rules, would be nice if each generated a very simple corresponding type, for ease of reading/understanding.

Since I know that all the choices of Exp contain one child, would be nice if could extract that child for "member children", without that "match" expression. [EDIT: It looks like the way I use Exp, the type of the child doesn't need to be known, so I can simplify "type Exp" to look similar to "type Neg" in a later post -- has one #Node child, no choice logic needed. The original reason for the choice logic was to match the grammar rule for Exp, which has 3 alternatives. Will investigate whether PEG parser can generate a simpler definition for Exp.]

I haven't looked into reflection to extract the name of each class, so I added a field for now, so that I could easily put its name into a print-out of its value.

By on 3/25/2008 11:47 AM ()

The idea is that a parser will generate a syntax tree of these nodes; before writing that parser, I am building trees by hand, then experimenting with them to make sure I can do what I want with them.

Building some simple trees:

1
2
3
4
5
6
7
8
9

let L s = Lit (new Lit(s))
let A exp1 exp2 = Add (new Add (exp1, exp2))

// "11"
let exp1 = (L "11")
// "11+22"
let add1 = A (L "11") (L "22")
// "11+(22+33)"
let add2 = A (L "11") (A (L "22") (L "33"))

It is trivial to write a tree walker, which applies a function to each node:

1
2
3
4
5

/// walk all nodes, starting with given node as root.
/// Apply function "f" to each node.
let rec walk f (root:Node) =
  f root
  Seq.iter (walk f) root.children

And that makes it easy to dump all the nodes of tree:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

/// string representing leaf data
let leaf_String (leaf:obj option) =
  match leaf with
    | Some leaf -> "=" + leaf.ToString()
    | None -> "<>"

let printLeaf (n:#Node) =
  printfn "%s" (n.typeStr + (leaf_String (n.leafData)))

/// print each node of tree.
let printTree (root:#Node) (name:string) =
  printfn "%s" ("----- tree " + name + " -----")
  walk printLeaf (root :> Node)

printTree exp1 "11"
printTree add1 "11+22"

== output ==> 

1
2
3
4
5
6
7
8
9
10
11

----- tree 11 -----
Exp<>
Lit=11

----- tree 11+22 -----
Exp<>
Add<>
Exp<>
Lit=11
Exp<>
Lit=22

...which doesn't show the tree structure very well, so here is a tree-walker that passes depth to the function:

1
2
3
4
5
6
7

/// walk all nodes, starting with given node as root.
/// Caller passes in depth=0 for root;

/// Depth is +1 for each level down the tree.
let rec walkDepth f (depth:int) (root:Node) =
  f depth root
  Seq.iter (walkDepth f (depth + 1)) root.children

and here is printing-out a tree, indenting for each node:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

let NOf (n:int) (a:'a) = { for i in [1 .. n] -> a }
let depthStr (depth:int) =
  String.concat "" (List.of_seq (NOf depth ". "))

let printLeafIndent (depth:int) (n:Node) =
  printfn "%s" ((depthStr depth) + n.typeStr + (leaf_String (n.leafData)))

/// print each node of tree, indenting as go deeper.
let printTreeIndent (root:#Node) (name:string) =
  let depth = 0
  printfn "%s" ("----- tree " + name + " -----")
  walkDepth printLeafIndent depth (root :> Node)

printTreeIndent exp1 "11"
printTreeIndent add1 "11+22"
printTreeIndent add2 "11+(22+33)"

== output ==>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21

----- tree 11 -----
Exp<>
. Lit=11
----- tree 11+22 -----
Exp<>
. Add<>
. . Exp<>
. . . Lit=11
. . Exp<>
. . . Lit=22
----- tree 11+(22+33) -----
Exp<>
. Add<>
. . Exp<>
. . . Lit=11
. . Exp<>
. . . Add<>
. . . . Exp<>
. . . . . Lit=22
. . . . Exp<>
. . . . . Lit=33

This gives a good sense of the syntax tree structure.

By on 3/25/2008 12:03 PM ()

The point of tree-walking is to perform operations, without having to modify the class definitions of the nodes. I demonstrated one operation, printing out a representation of the tree. Here is another, evaluating the value of a tree. In this simple grammar, all values are integers.

I reworked definition of Exp, to make it easier to get at the single child:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

/// Expression <- Literal | Add
type Exp =
  | Lit of Lit
  | Add of Add with

  member it.child:Node =
    match it with
      | Lit lit -> lit :> Node
      | Add add -> add :> Node

  interface Node with
    member it.typeStr = "Exp"
    member it.children =
      SeqOf1Node(it.child)
    member it.leafData = None
  end

The value of a literal is the number represented by the string; the value of an expression is the value of its only child; the value of adding two expressions is the addition operation on its two children:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

// ---------- Evaluator ----------

/// Recursively evaluate a Node.
let rec eval (root:Node) :int32 =
  match (root :> Node) with
  | :? Lit as lit -> (int32 lit.v)
  | :? Exp as exp -> (eval exp.child)
  | :? Add as a ->
    (eval (a.Exp1 :> Node)) +
    (eval (a.Exp2 :> Node))
  | _ -> failwith "Unknown Node type"

/// Print the result of recursively evaluating Node.
let printEval (root:#Node) (name:string) =
  printfn "%i=%s" (eval (root :> Node)) name

printEval (exp1 :> Node) "11"
printEval (add1 :> Node) "11+22"
printEval (add2 :> Node) "11+(22+33)"

== output ==>

1
2
3
4

11=11
33=11+22

66=11+(22+33)

ISSUE #1: To evaluate a node (without modifying the node class), I dynamically test the node type against the different Node types. Probably poor performance if were performing a lot of looping calculations. F# does have a mechanism for augmenting existing types with new methods, but here I want to add an abstract eval method to the Node interface [without touching the original definitions, because those are generated by the metacompiler, and might need to be re-generated again], and then implement that on each subclass. Would look something like this: 

1
2
3

/// Attempting to augment Node with new method.
type Node with
  abstract eval :int32 // *** Invalid Syntax ***

ISSUE #2: I want "eval" to accept any subclass, but I was unable to make the signature of eval be:

1

let rec eval (root:#Node) :int32

so I had to keep coercing nodes to Node. The problem with "#Node" was that the match choice "| :? Exp as exp -> (eval exp.child)" insisted that since "exp.child" was "Node", then "eval" itself required type "Node" [so that the recursive call is consistent with the definition], so it constrained the type of the declaration. That makes no sense, since "#Node" includes "Node" as an alternative. I think this is an F# bug.

By on 3/25/2008 1:05 PM ()

Going back to the first post, and TEST CASE #1, the Node definitions are kept in one file; that file can be re-generated by the metacompiler without touching the separate custom code that does the printing or evaluating. For instance, changing whether "a+b*c" means "(a+b)*c" or "a+(b*c)" would change the generated tree, but not change the custom code. Lets see what needs to be done when a new rule is added to grammar:

1
2

// Exp <- ... | Neg
// Neg <- '-' Exp

== changed Node definitions output by PEG parser =>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22

/// Expression <- Literal | Add | Neg
type Exp =
  | Lit of Lit
  | Add of Add
  | Neg of Neg
  with
  member it.child:Node =
    match it with
      | Lit lit -> lit :> Node
      | Add add -> add :> Node
      | Neg neg -> neg :> Node
  interface Node ...
  ...

/// Neg <- '-' Exp
and Neg(exp0:Exp) =
  member it.Exp = exp0;
  interface Node with
    member it.typeStr = "Neg"
    member it.children = SeqOf1Node(it.Exp)
    member it.leafData = None
  end

Printing these new trees can be done without any change to printTreeIndent:

1
2
3
4

let N exp = Neg (new Neg (exp))
// "11+(-22)"
let neg1 = A (L "11") (N (L "22"))
printTreeIndent neg1 "11+(-22)"

== output ==>

1
2
3
4
5
6
7
8
9

----- tree 11+(-22) -----
Exp<>
. Add<>
. . Exp<>
. . . Lit=11
. . Exp<>
. . . Neg<>
. . . . Exp<>
. . . . . Lit=22

and eval() can be done simply by adding a line to handle these new Neg nodes:

1
2
3
4
5
6
7
8

let rec eval (root:Node) :int32 =
  match ...
  ...
  | :? Neg as n -> (- (eval (n.Exp :> Node)))
  | _ -> failwith "Unknown Node type"
 
... 
printEval (neg1 :> Node) "11+(-22)"

== output ==>

1

-11=11+(-22)

NOTE: I've been "hand-waving" the parentheses in my examples. The actual parser rules will include them; I'm assuming the parser just uses them to determine operator precedence, and doesn't actually include them in the syntax tree. If this isn't the case, then there will be an additional Node type for parenthesized expression, which simply eval's its one child.

By on 3/25/2008 4:06 PM ()

In private correspondence, Jon Harrop suggested that the code would be much simpler if the OO Node approach were dropped, using pattern matching for everything, resulting in the type definitions seen below. Here is the complete program rewritten based around that suggestion:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92

#light
// ---------- Node Definitions ----------

type exp =
  | Lit of string
  | Add of exp * exp
  | Neg of exp

let typeStr = function
  | Lit _ -> "Lit"
  | Add _ -> "Add"
  | Neg _ -> "Neg"

let leafStr (n:exp) =
  match n with
  | Lit s -> s
  | Add _ -> ""
  | Neg _ -> ""

// ---------- Tree-Walking Functions ----------
// Instead of a general tree-walker, the match patterns
// are done directly in the custom code.
// TBD: Will this cause complications in a more complex grammar?
// (Currently, there is only one type, "exp")


// ---------- Print Functions, Indenting for Depth ----------
let ps (s:string) = s |> printfn "%s"

let leafStrWLead (n:exp) =
  match leafStr n with
  | "" -> "<>"
  | _ as ls -> " " + ls

let NOf (n:int) (a:'a) = { for i in [1 .. n] -> a }

let depthStr (depth:int) =
  String.concat "" (List.of_seq (NOf depth ". "))

/// print leaf indented
let prLfIn (depth:int) (n:exp) =
  ps ((depthStr depth) + (typeStr n) + (leafStrWLead n))

/// print node indented, including recursion
let rec prNdIn (depth:int) (n:exp) =
  prLfIn depth n
  let cd = depth + 1  // child depth
  match n with
  | Lit _ -> ignore 0
  | Add (e1, e2) -> (prNdIn cd e1); (prNdIn cd e2)
  | Neg e1 -> (prNdIn cd e1)

/// print each node of tree, indenting as go deeper.
let printTreeIndent (root:exp) (name:string) =
  let depth = 0
  printfn "%s" ("----- tree " + name + " -----")
  prNdIn depth root

// ---------- Evaluator ----------

/// Recursively evaluate a Node.
let rec eval (root:exp) :int32 =
  match root with
  | Lit s -> (int32 s)
  | Add (e1, e2) -> (eval e1) + (eval e2)
  | Neg e1 -> (- (eval e1))

/// Print the result of recursively evaluating Node.
let printEval (root:exp) (name:string) =
  printfn "%i=%s" (eval root) name

// ---------- Tests ----------
let L s = Lit s
let A e1 e2 = Add (e1, e2)
let N e1 = Neg e1

let exp1 = L "11"
let exp2 = A (L "11") (L "22")
let exp3 = A (L "11")  (A (L "22") (L "33"))
let exp4 = A (L "11") (N (L "22"))

printTreeIndent exp1 "11"
printTreeIndent exp2 "11+22"
printTreeIndent exp3 "11+(22+33)"
printTreeIndent exp4 "11+(-22)"

printfn "%s" "----------"
printEval exp1 "11"
printEval exp2 "11+22"
printEval exp3 "11+(22+33)"
printEval exp4 "11+(-22)"
printfn "%s" "----------"

== output ==>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

----- tree 11 -----
Lit 11
----- tree 11+22 -----
Add<>
. Lit 11
. Lit 22
----- tree 11+(22+33) -----
Add<>
. Lit 11
. Add<>
. . Lit 22
. . Lit 33
----- tree 11+(-22) -----
Add<>
. Lit 11
. Neg<>
. . Lit 22
----------
11=11
33=11+22
66=11+(22+33)
-11=11+(-22)
----------
By on 3/26/2008 2:35 AM ()

Here is an extended grammar, to see how to use pattern-matching once there are multiple types.

I added an interface "node" with no methods, that is used as a base type. This was the only way I found to get F# compiler to perform ':?' on my disparate node types. This continues to be more concise and readable than my original approach.

I added a "children" function that uses pattern matching to locate all the children of a node. So this approach is now up to the functionality that my OO approach had. The print function then becomes a simple recursion. I added one special case for if statements, to show that the pattern-matching approach makes it easy to add special logic.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202

 

#light
// ---------- Grammar ----------
// Stmt <- Exp | IfSt
// IfSt <- 'if' Exp 'then' Stmt ['else' Stmt]
// Exp <- Lit | Add | Neg | Paren
// Lit <- ..non-negative integer..
// Add <- Exp '+' Exp
// Neg <- '-' Exp
// Paren <- '(' Exp ')'

// ---------- Node Definitions ----------

/// To get ':?' accepted by F# compiler
type node =
  interface
  end

type stmt = // Exp | IfSt
  | Exp of exp
  | IfSt of ifSt
  with interface node

and ifSt =  // 'if' Exp 'then' Stmt ['else' Stmt]
  { Cond : exp; Then : stmt; Else : stmt option }

and exp =
  | Lit of string     // ..non-negative integer..
  | Add of exp * exp  // Exp '+' Exp
  | Neg of exp        // '-' Exp
  | Paren of exp      // '(' Exp ')'
  with interface node

let typeStr (n:node) =
  match n with
  | :? exp as e ->
    match e with
    | Lit _ -> "Lit"
    | Add _ -> "Add"
    | Neg _ -> "Neg"
    | Paren _ -> "()"
  | :? stmt as s ->
    match s with
    | Exp _ -> "Exp"
    | IfSt _ -> "IfSt"
  | _ -> failwith "typeStr- Unknown node type"

let leafStr (n:node) =
  match n with
  | :? exp as e ->
    match e with
    | Lit s -> s
    | _ -> ""
  | _ -> ""

let children (n:node) :node list =
  let EL (es:exp list) = List.map (fun e -> e :> node) es
  let SL (ss:stmt list) = List.map (fun s -> s :> node) ss
  match n with
  | :? exp as e ->
    match e with
    | Lit s -> []
    | Add (e1, e2) -> EL [e1; e2]
    | Neg e1 -> EL [e1]
    | Paren e1 -> EL [e1]
  | :? stmt as s ->
    match s with
    | Exp e1 -> EL [e1]
    | IfSt s ->
      let ct = (EL [s.Cond]) @ (SL [s.Then])
      match s.Else with
        | Some se -> ct @ (SL [se])
        | None -> ct
  | _ -> failwith "children - Unknown node type"

// ---------- Tree-Walking Functions ----------
// Instead of a general tree-walker, the match patterns
// are done directly in the custom code.

// ---------- Print Functions, Indenting for Depth ----------
let ps (s:string) = s |> printfn "%s"

let leafStrWLead (n:node) =
  match leafStr n with
  | "" -> "<>"
  | _ as ls -> " " + ls

/// Sequence of a, repeated n times.
let NOf (n:int) (a:'a) = { for i in [1 .. n] -> a }

/// e.g. 3 => ". . . "
let depthStr (depth:int) =
  String.concat "" (List.of_seq (NOf depth ". "))

/// print leaf indented
let prLfIn (depth:int) (n:node) (prefix:string) =
  ps ((depthStr depth) + prefix + (typeStr n) + (leafStrWLead n))

/// Special print of IfSt, to label the children.
let rec  printIfSt cd (i:ifSt) =
  let pnip cd (n:#node) pre = prNdIn cd (n :> node) pre
  pnip cd i.Cond "cond: "
  pnip cd i.Then "then: "
  match i.Else with
    | Some se -> pnip cd se "else: "
    | None -> ignore 0

/// print node indented, including recursion
/// prefix is passed in if parent wants something after indent, before child's dump
and prNdIn (depth:int) (n:node) (prefix:string) =
  prLfIn depth n prefix
  let cd = depth + 1  // child depth
  let pni n = prNdIn cd (n :> node) ""
  let isDone =
    match n with
      | :? stmt as s ->
        match s with
          | IfSt i -> printIfSt cd i; true
          | _ -> false
      | _ -> false
  if not isDone then
    for ch in children n do pni ch

/// print each node of tree, indenting as go deeper.
let printTreeIndent (root:#node) (name:string) =
  let depth = 0
  printfn "%s" ("----- tree " + name + " -----")
  prNdIn depth (root :> node) ""

// ---------- Evaluator ----------

/// Recursively evaluate a Node.
let rec eval (root:node) :int32 =
  let ev (n:#node) = eval (n :> node)
  match root with
  | :? exp as e ->
    match e with
    | Lit s -> (int32 s)
    | Add (e1, e2) -> (ev e1) + (ev e2)
    | Neg e1 -> (- (ev e1))
    | Paren e1 -> ev e1
  | :? stmt as s ->
    match s with
    | Exp e1 -> ev e1
    | IfSt s ->
      if (ev s.Cond) > 0  // Fake: 0==false
      then (ev s.Then)
      else
        match s.Else with
          | Some se -> ev se
          | None -> 0     // Fake: 0==nothing
  | _ -> failwith "eval - Unknown node type"

/// Print the result of recursively evaluating Node.
let printEval (root:#node) (name:string) =
  printfn "%i=%s" (eval (root :> node)) name

// ---------- Tests ----------
let E e = Exp e
let IT cond thSt = IfSt { Cond=cond; Then=thSt; Else=None }
let ITE cond thSt elSt = IfSt { Cond=cond; Then=thSt; Else=Some elSt }
let L s = Lit s
let A e1 e2 = Add (e1, e2)
let N e1 = Neg e1
let P e1 = Paren e1

let exp1 = L "11"
let exp2 = A (L "22") (L "33")
let exp3 = A (L "11") exp2
let exp4 = A (L "11") (N (L "22"))
let exp5 = A (P (L "11")) (N (L "22"))
let st1 = E exp1
let st2 = E exp5
let st3 = IT exp1 (E exp2)
let st4 = ITE exp1 (E exp2) (E exp4)
let st5 = ITE (L "0") (E exp2) (E exp4)

printTreeIndent exp1 "11"
printTreeIndent exp2 "22+33"
printTreeIndent exp3 "11+(22+33)"
printTreeIndent exp4 "11+(-22)"
printTreeIndent exp5 "(11)+(-22)"
printTreeIndent st1 "stmt=11"
printTreeIndent st2 "stmt=(11)+(-22)"
printTreeIndent st3 "if 11 then 22+33"
printTreeIndent st4 "if 11 then 22+33 else 11+(-22)"
printTreeIndent st5 "if 0 then 22+33 else 11+(-22)"

printfn "%s" "----------"
printEval exp1 "11"
printEval exp2 "11+22"
printEval exp3 "11+(22+33)"
printEval exp4 "11+(-22)"
printEval exp5 "(11)+(-22)"
printEval st1 "stmt=11"
printEval st2 "stmt=(11)+(-22)"
printEval st3 "if 11 then 22+33"
printEval st4 "if 11 then 22+33 else 11+(-22)"
printEval st5 "if 0 then 22+33 else 11+(-22)"
printfn "%s" "----------"

===== output =====>

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

 

----- tree 11 -----
Lit 11
----- tree 22+33 -----
Add<>
. Lit 22
. Lit 33
----- tree 11+(22+33) -----
Add<>
. Lit 11
. Add<>
. . Lit 22
. . Lit 33
----- tree 11+(-22) -----
Add<>
. Lit 11
. Neg<>
. . Lit 22
----- tree (11)+(-22) -----
Add<>
. ()<>
. . Lit 11
. Neg<>
. . Lit 22
----- tree stmt=11 -----
Exp<>
. Lit 11
----- tree stmt=(11)+(-22) -----
Exp<>
. Add<>
. . ()<>
. . . Lit 11
. . Neg<>
. . . Lit 22
----- tree if 11 then 22+33 -----
IfSt<>
. cond: Lit 11
. then: Exp<>
. . Add<>
. . . Lit 22
. . . Lit 33
----- tree if 11 then 22+33 else 11+(-22) -----
IfSt<>
. cond: Lit 11
. then: Exp<>
. . Add<>
. . . Lit 22
. . . Lit 33
. else: Exp<>
. . Add<>
. . . Lit 11
. . . Neg<>
. . . . Lit 22
----- tree if 0 then 22+33 else 11+(-22) -----
IfSt<>
. cond: Lit 0
. then: Exp<>
. . Add<>
. . . Lit 22
. . . Lit 33
. else: Exp<>
. . Add<>
. . . Lit 11
. . . Neg<>
. . . . Lit 22
----------
11=11
55=11+22
66=11+(22+33)
-11=11+(-22)
-11=(11)+(-22)
11=stmt=11
-11=stmt=(11)+(-22)
55=if 11 then 22+33
55=if 11 then 22+33 else 11+(-22)
-11=if 0 then 22+33 else 11+(-22)
----------
By on 3/26/2008 2:11 PM ()

You may be interested in checking out a technique known as catamorphisms. This is a generalization of "folds over lists" to any algebraic datatype. It is particularly applicable to cases like yours - there is no need to fight the type system or leverage OO by calling everything a "node" and using "?:" type tests. Rather you can leverage the types and have the data shape drive the computation. Below is a short example of how to write general fold functions, and then apply them to "evaluation" and "pretty-printing". I'm not sure how self-explanatory the code may be, so ask me if it doesn't make sense.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77

let rec foldExp (litFunc : string -> 'r) (addFunc : 'r -> 'r -> 'r) (negFunc : 'r -> 'r) (parenFunc : 'r -> 'r) (e : exp) =
    let self = foldExp litFunc addFunc negFunc parenFunc
    match e with
    | Lit(s) -> litFunc s
    | Add(e1,e2) -> addFunc (self e1) (self e2)
    | Neg(e) -> negFunc (self e)
    | Paren(e) -> parenFunc (self e)

let rec foldStmt (ifstFunc : 'r -> 'r -> 'r option -> 'r) (expFunc : exp -> 'r) (s : stmt) = 
    let self = foldStmt ifstFunc expFunc
    let liftOption f x =
        match x with
        | None -> None
        | Some(y) -> Some(f y)
    match s with
    | IfSt( { Cond=c; Then=t; Else=e } ) -> ifstFunc (expFunc c) (self t) ((liftOption self) e) 
    | Exp(e) -> expFunc(e)


 

let rec evalExp e = 
    // 'r = int
    foldExp (fun s -> int s)
            (fun l r -> l + r)
            (fun n -> -n)
            (fun p -> p)
            e

let myPrintEvalExp e =
  printfn "%i=%s" (evalExp e)

let rec evalStmt s =
    // 'r = int
    foldStmt (fun c t eo -> if c <> 0 then 
                                t 
                            else 
                                match eo with
                                | None -> 0
                                | Some e -> e)
             (fun e -> evalExp e)
             s

let myPrintEvalStmt s =
  printfn "%i=%s" (evalStmt s)


 

let showExp e depth = 
    // 'r = int -> string
    foldExp (fun s d -> (depthStr d) ^ "Lit " ^ s ^ "\n")
            (fun l r d -> (depthStr d) ^ "Add<>\n" ^ (l (d+1)) ^ (r (d+1)))
            (fun n d -> (depthStr d) ^ "Neg<>\n" ^ (n (d+1)))
            (fun p d -> (depthStr d) ^ "()<>\n" ^ (p (d+1)))
            e
            depth

let myShowExp e name =
    printfn "%s" ("----- tree " + name + " -----")
    printf "%s" (showExp e 0)

let showStmt s depth =
    // 'r = int -> string
    foldStmt (fun c t eo d -> (depthStr d) ^ "IfSt<>\n" 
                              ^ (depthStr (d+1)) ^ "cond: " ^ (c (d+1)) 
                              ^ (depthStr (d+1)) ^ "then: " ^ (t (d+1)) 
                              ^ match eo with 
                                | None -> ""
                                | Some(e) -> (depthStr (d+1)) ^ "else: " ^ (e (d+1)))
             (fun e d -> "Exp<>\n" ^ (showExp e (d+1)))
             s
             depth

let myShowStmt s name =
    printfn "%s" ("----- tree " + name + " -----")
    printf "%s" (showStmt s 0)
By on 3/26/2008 9:26 PM ()

Brian, that is very cool stuff. In order to understand catamorphism, I first recreate the wikipedia example:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40

#light
// catamorphism for simple tree.
type Tree<'a> =
  | Leaf of 'a
  | Branch of Tree<'a> * Tree<'a>

/// foldTree ('a->'b) * ('b->'b->'b) -> Tree<'a> -> 'b
/// : ('a->'r)*('r->'r->'r) -> Tree<'a> -> 'r
let rec foldTree (fL, fB) a =
  match a with
  | Leaf x -> fL x
  | Branch (l,r) ->
    fB (foldTree (fL,fB) l) (foldTree (fL,fB) r)

// ----- Calculate depth = deepest extent of tree. -----
let depthL x = 1
let depthB l r = l + r
let treeDepth a = foldTree (depthL, depthB) a

// ----- Calculate sum = sum of all leaves of tree. -----
let sumL x = x
// 'inline' to act as template for different types.
let inline sumB l r = l + r
let inline treeSum (a:Tree<'a>) = foldTree (sumL, sumB) a

// ---------- Tests ----------
let L x = Leaf x
let B l r = Branch (l, r)
let pa a msg = printfn "%A = %s" a msg

let t1 = (L "ab")
let t2 = (B (B (L 1) (L 2)) (L 3))
let t3 = (B (L "a") (B (L "b") (B (L "c") (L "d"))))
pa (treeDepth t1) "depth t1"
pa (treeDepth t2) "depth t2"
pa (treeDepth t3) "depth t3"
pa (treeSum t1) "sum t1"
pa (treeSum t2) "sum t2"
pa (treeSum t3) "sum t3"

== output ==>

1
2
3
4
5
6
7

1 = depth t1
3 = depth t2
4 = depth t3
"ab" = sum t1
6 = sum t2
"abcd" = sum t3

Though in this example, one could implement the equivalent of the fold directly in recursive match function for each use, without the treeFold:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17

let rec treeDepth = function
  | Leaf x -> 1
  | Branch (l,r) -> (treeDepth l) + (treeDepth r)

// 'inline' to use as template for different types.
// P: fsi error "inline .. value was incomplete".
(*let rec inline treeSum = function
  | Leaf x -> x
  | Branch (l,r) -> (treeSum l) + (treeSum r)*)
// Because of fsi inline limitation, create separate func per type.
let rec treeSumI :int = function
  | Leaf x -> x
  | Branch (l,r) -> (treeSumI l) + (treeSumI r)
let rec treeSumS :string = function
  | Leaf x -> x
  | Branch (l,r) -> (treeSumS l) + (treeSumS r)

NOTE: unfortunately hit a limitation of fsi when 'inline', so had to create separate copies of treeSum for each type. This would not have been an issue if I only used with one type of entity.

By on 3/27/2008 1:22 PM ()

I really like the idea of avoiding dynamic type tests. The clean way to do so is to turn it into a match, by creating a choice type that has all the node types as alternatives; in my grammar so far there are two node types, 'stmt' and 'exp':

1
2
3
4

type wrapNode =
  | WStmt of stmt
  | WExp of exp

This simple structure, used with 'match', does all that I need from a catamorphic algebra. That is, the algebra lets one apply an operation over a diverse set of entities. In F# we can do so easily, by applying a 'match' to a discriminated union whose alternatives are the entities, as shown above. In the full listing in my next post, "prNdIn" and "eval" are recursive matches, so they are performing a folding, equivalent to a catamorphic algebra on the set of nodes. Again, this works because the nodes are wrapped by "wrapNode", a construct that lets us reason about the various types of nodes.

Rather than shun OO, I prefer to use a smidgen of OO to complement functional. OO is good at declaring that an entity is known to support certain functionality. Here, we define an interface to make it easy and efficient to wrap the nodes into the wrapNode union:

1
2
3
4
5
6
7
8
9
10
11
12
13

/// base class
type node =
  interface
    // wrap self so can match node type w/o dynamic type test.
    abstract wrap : unit -> wrapNode
  end

and stmt = // Exp | IfSt
  | Exp of exp
  | IfSt of ifSt
  with interface node with
    member n.wrap() = WStmt n // wrap self

The result is easy to read & write, efficient, compile-time-verified code. It is a two-level match, using node's wrap member to get a wrapNode to work with:

1
2
3
4
5
6
7
8
9
10
11
12
13
14

let typeStr (n:#node) =
  // wrap self so can match node type w/o dynamic type test.
  match n.wrap() with
  | WExp e ->
    match e with
    | Lit _ -> "Lit"
    | Add _ -> "Add"
    | Neg _ -> "Neg"
    | Paren _ -> "()"
  | WStmt s ->
    match s with
    | Exp _ -> "Exp"
    | IfSt _ -> "IfSt"

Note that I no longer need a "catch-all" failwith case (compared to my previous post's version) -- it is known at compile-time that all cases are handled! Also, I no longer need to coerce nodes to their base type; "#node" now works as a parameter type. (Though I still hit limits of F# subtype type-inference in some recursive functions.)

Each node is a union, and wrapNode is a union; we can get at a single choice inside a node by making a two level test:

1
2
3
4
5

let leafStr (n:#node) =
  match n.wrap() with
  // Matching two levels deep: a WExp which has a Lit
  | WExp (Lit s) -> s
  | _ -> ""

The following post will contain the complete rewritten listing.

EDIT: There is an additional post after that, with some further re-organization, as described in its comments. Also see "ADDENDUM" edit added to first post of this thread, for a conceptual discussion.

By on 3/27/2008 1:48 PM ()
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154

#light
// ---------- Grammar ----------
// Stmt <- Exp | IfSt
// IfSt <- 'if' Exp 'then' Stmt ['else' Stmt]
// Exp <- Lit | Add | Neg | Paren
// Lit <- ..non-negative integer..
// Add <- Exp '+' Exp
// Neg <- '-' Exp
// Paren <- '(' Exp ')'

// ---------- Node Definitions ----------
/// base class
type node =
  interface
    // wrap self so can match node type w/o dynamic type test.
    abstract wrap : unit -> wrapNode
  end

/// all node types wrapped into a choice.
and wrapNode =
  | WStmt of stmt
  | WExp of exp

and stmt = // Exp | IfSt
  | Exp of exp
  | IfSt of ifSt
  with interface node with
    member n.wrap() = WStmt n // wrap self

and ifSt =  // 'if' Exp 'then' Stmt ['else' Stmt]
  { Cond : exp; Then : stmt; Else : stmt option }

and exp =
  | Lit of string     // ..non-negative integer..
  | Add of exp * exp  // Exp '+' Exp
  | Neg of exp        // '-' Exp
  | Paren of exp      // '(' Exp ')'
  with interface node with
    member n.wrap() = WExp n // wrap self

let typeStr (n:#node) =
  // wrap self so can match node type w/o dynamic type test.
  match n.wrap() with
  | WExp e ->
    match e with
    | Lit _ -> "Lit"
    | Add _ -> "Add"
    | Neg _ -> "Neg"
    | Paren _ -> "()"
  | WStmt s ->
    match s with
    | Exp _ -> "Exp"
    | IfSt _ -> "IfSt"

let leafStr (n:#node) =
  match n.wrap() with
  // Matching two levels deep: a WExp which has a Lit
  | WExp (Lit s) -> s
  | _ -> ""

let children (n:#node) :node list =
  let EL (es:exp list) = List.map (fun e -> e :> node) es
  let SL (ss:stmt list) = List.map (fun s -> s :> node) ss
  match n.wrap() with
  | WExp e ->
    match e with
    | Lit s -> []
    | Add (e1, e2) -> EL [e1; e2]
    | Neg e1 -> EL [e1]
    | Paren e1 -> EL [e1]
  | WStmt s ->
    match s with
    | Exp e1 -> EL [e1]
    | IfSt s ->
      let ct = (EL [s.Cond]) @ (SL [s.Then])
      match s.Else with
        | Some se -> ct @ (SL [se])
        | None -> ct

// ---------- Tree-Walking Functions ----------
// Instead of a general tree-walker, the match patterns
// are done directly in the custom code.

// ---------- Print Functions, Indenting for Depth ----------
let ps (s:string) = s |> printfn "%s"

let leafStrWLead (n:#node) =
  match leafStr n with
  | "" -> "<>"
  | _ as ls -> " " + ls

/// Sequence of a, repeated n times.
let NOf (n:int) (a:'a) = { for i in [1 .. n] -> a }

/// e.g. 3 => ". . . "
let depthStr (depth:int) =
  String.concat "" (List.of_seq (NOf depth ". "))

/// print leaf indented
let prLfIn (depth:int) (n:#node) (prefix:string) =
  ps ((depthStr depth) + prefix + (typeStr n) + (leafStrWLead n))

/// Special print of IfSt, to label the children.
let rec  printIfSt cd (i:ifSt) =
  let pnip (n:#node) pre = prNdIn cd (n :> node) pre
  pnip i.Cond "cond: "
  pnip i.Then "then: "
  match i.Else with
  | Some se -> pnip se "else: "
  | None -> ignore 0

/// print node indented, including recursion
/// prefix is passed in if parent wants something after indent, before child's dump
and prNdIn (depth:int) (n:node) (prefix:string) =
  prLfIn depth n prefix
  let cd = depth + 1  // child depth
  let pni n = prNdIn cd (n :> node) ""
  match n.wrap() with
  | WStmt (IfSt i) -> printIfSt cd i
  | _ -> for ch in children n do pni ch

/// print each node of tree, indenting as go deeper.
let printTreeIndent (root:#node) (name:string) =
  let depth = 0
  printfn "%s" ("----- tree " + name + " -----")
  prNdIn depth (root :> node) ""

// ---------- Evaluator ----------

/// Recursively evaluate a Node.
let rec eval (root:node) :int32 =
  let ev (n:#node) = eval (n :> node)
  match root.wrap() with
  | WExp e ->
    match e with
    | Lit s -> (int32 s)
    | Add (e1, e2) -> (ev e1) + (ev e2)
    | Neg e1 -> (- (ev e1))
    | Paren e1 -> ev e1
  | WStmt s ->
    match s with
    | Exp e1 -> ev e1
    | IfSt s ->
      if (ev s.Cond) > 0  // Fake: 0==false
      then (ev s.Then)
      else
        match s.Else with
          | Some se -> ev se
          | None -> 0     // Fake: 0==nothing

/// Print the result of recursively evaluating Node.
let printEval (root:#node) (name:string) =
  printfn "%i=%s" (eval (root :> node)) name
By on 3/27/2008 1:50 PM ()
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205

#light
// ---------- a slightly re-worked version. ----------
// VERSION: Most of the double-nested matches now broken into
// smaller functions. This is for easier maintenance for large grammar,
// with many classes.
// Each function is a member of the corresponding class,
// if it is known at the time the metacompiler spits out the code.
// See "wrap", "typeStr", and "children".
//
// HOWEVER public usage is intended to still be done by the
// top-level functions. See "functional access" section.
//
// "module NodeDefinitions" is the portion spit out by the metacompiler.
//
// A trivial "tree-walker" was also added. Again, this could be automatically
// generated by the metacompiler. The intent is that more powerful
// tree walkers be automatically generated, if that is found to be useful.
//
// Other minor code cleanup also done.

// ---------- Grammar ----------
// Stmt <- Exp | IfSt
// IfSt <- 'if' Exp 'then' Stmt ['else' Stmt]
// Exp <- Lit | Add | Neg | Paren
// Lit <- ..non-negative integer..
// Add <- Exp '+' Exp
// Neg <- '-' Exp
// Paren <- '(' Exp ')'

// ---------- Node Definitions ----------
//  See "functional access" section.
module NodeDefinitions =

  /// base class
  type node =
    interface
      // wrap self so can match node type w/o dynamic type test.
      abstract wrap : wrapNode
      abstract typeStr :string
      abstract children :node list
      //DEFER abstract leafData :obj option
    end

  /// all node types wrapped into a choice.
  and wrapNode =
    | WStmt of stmt
    | WExp of exp
  
  and N = // Convenience: cast a #node down to node.
    static member inline E (e:exp) :node = (e :> node)
    static member inline S (s:stmt) :node = (s :> node)
  
  and stmt = // Exp | IfSt
    | Exp of exp
    | IfSt of ifSt
    with interface node with
      member n.wrap = WStmt n // wrap self
      member it.typeStr =
        match it with
        | Exp _ -> "Exp"
        | IfSt _ -> "IfSt"
      member it.children =
        match it with
        | Exp e1 -> [N.E e1]
        | IfSt s ->
          let ct = [N.E s.Cond; N.S s.Then]
          match s.Else with
          | Some se -> ct @ [N.S se]
          | None -> ct

  and ifSt =  // 'if' Exp 'then' Stmt ['else' Stmt]
    { Cond : exp; Then : stmt; Else : stmt option }

  and exp =
    | Lit of string     // ..non-negative integer..
    | Add of exp * exp  // Exp '+' Exp
    | Neg of exp        // '-' Exp
    | Paren of exp      // '(' Exp ')'
    with interface node with
      member n.wrap = WExp n // wrap self
      member it.typeStr =
        match it with
        | Lit _ -> "Lit"
        | Add _ -> "Add"
        | Neg _ -> "Neg"
        | Paren _ -> "()"
      member it.children =
        match it with
        | Lit s -> []
        | Add (e1, e2) -> [N.E e1; N.E e2]
        | Neg e1 -> [N.E e1]
        | Paren e1 -> [N.E e1]

  // ---------- functional access ----------
  // Access to node features, in a functional style.
  // wrap, typeStr, children, leafStr.
  
  let wrap (n:#node) :wrapNode = n.wrap

  let typeStr (n:#node) :string = n.typeStr

  let children (n:#node) :node list = n.children

  // NOTE: Once there are many node types,
  // it would be easier to maintain if implement this as
  // a method call on each node type.
  let leafStr (n:#node) :string =
    match wrap n with
    // Matching two levels deep: a WExp which has a Lit
    | WExp (Lit s) -> s
    | _ -> ""

  // ---------- Tree-Walker ----------
  // This shows the simplest use of the tree,
  // applying a function to each node, presumably
  // for some side-effect (unseen by us).
  // In practice, want more elaborate versions that
  // do more, such as collect information.
  let rec walkTree (f:node -> unit) (n:node) =
    f n
    for ch in children n do walkTree f ch
//-------------------- end module NodeDefinitions --------------------

open NodeDefinitions  // for use by client code, which is everything below.


// ---------- Print Functions, Indenting for Depth ----------
let ps (s:string) = s |> printfn "%s"  // This form prints strings w/o quote-marks.
let pa _ = printfn "%A" // This form prints anything (but strings get quote-marks).

let leafStrWLead (n:#node) =
  match leafStr n with
  | "" -> "<>"
  | _ as ls -> " " + ls

/// Sequence of a, repeated n times.
let NOf (n:int) (a:'a) = { for i in [1 .. n] -> a }

/// e.g. 3 => ". . . "
let depthStr (depth:int) =
  String.concat "" (List.of_seq (NOf depth ". "))

/// print leaf indented
let prLfIn (depth:int) (n:#node) (prefix:string) =
  ps ((depthStr depth) + prefix + (typeStr n) + (leafStrWLead n))

/// Special print of IfSt, to label the children.
let rec  printIfSt cd (i:ifSt) =
  let pnip (n:#node) pre = prNdIn cd (n :> node) pre
  pnip i.Cond "cond: "
  pnip i.Then "then: "
  match i.Else with
  | Some se -> pnip se "else: "
  | None -> ignore 0

/// print node indented, including recursion
/// prefix is passed in if parent wants something after indent, before child's dump
and prNdIn (depth:int) (n:node) (prefix:string) =
  prLfIn depth n prefix
  let cd = depth + 1  // child depth
  let pni n = prNdIn cd (n :> node) ""
  match wrap n with
  | WStmt (IfSt i) -> printIfSt cd i
  | _ -> for ch in children n do pni ch

/// print each node of tree, indenting as go deeper.
let printTreeIndent (root:#node) (name:string) =
  let depth = 0
  printfn "%s" ("----- tree " + name + " -----")
  prNdIn depth (root :> node) ""

// ---------- Evaluator ----------

let rec eval_exp (e:exp) :int32 =
  let ev e = eval_exp e
  match e with
  | Lit s -> (int32 s)
  | Add (e1, e2) -> (ev e1) + (ev e2)
  | Neg e1 -> (- (ev e1))
  | Paren e1 -> ev e1

// NOTE: Fake stuff because my primitive grammar
// only understands "number" -- it doesn't yet have
// concepts "boolean" or "unit/void".
// That is also why returns "int32".
let rec eval_stmt (s:stmt) :int32 =
  match s with
  | Exp e1 -> eval_exp e1
  | IfSt s ->
    if (eval_exp s.Cond) > 0  // Fake bool: 0==false
    then (eval_stmt s.Then)
    else
      match s.Else with
        | Some se -> eval_stmt se
        | None -> 0     // Fake unit: 0==nothing

/// Recursively evaluate a Node.
let eval (root:node) :int32 =
  match wrap root with
  | WExp e -> eval_exp e
  | WStmt s -> eval_stmt s

/// Print the result of recursively evaluating Node.
let printEval (root:#node) (name:string) =
  printfn "%i=%s" (eval (root :> node)) name
By on 3/30/2008 2:03 AM ()

I tried to rewrite using a base class that took function parameters; but it hadn't occurred to me that I don't have a class hierarchy, rather I have discriminated unions that have member augmentations. So the following code won't work. Which is fine, because the function passing in this case becomes unbearably obscure:

1. It loses the benefit of the previous version, where each member is clearly labeled. Instead, you have to wade through the large inline "fun" declarations to see what member is being referred to.

2. The inline "fun" declaration in general is unpleasant here. A normal OO declarative form reads more nicely in this case.

Summary: while I love directly declaring each type as a DU for the sake of match, it has cost me something -- the convenience of abstract base classes. Which in F# doesn't allow the most convenient declaration syntax for this situation anyway.

==> If I were programming in a language that supported the OO syntax I wanted --and-- supported DUs (a future version of C#?), I would have programmed this by making a DU that was a member of the interface, and hence of each class, in order to have BOTH benefits.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64

 
/// base class
  type node =
    interface
      // wrap self so can match node type w/o dynamic type test.
      abstract wrap : wrapNode
      abstract typeStr :string
      abstract children :node list
      abstract leafData :obj option
    end
  
  // Thanks to David Frese for function parameters idiom.
  and wrapGetter = node -> wrapNode
  and typeStrGetter = unit -> string
  and childrenGetter = unit -> node list
  and leafDataGetter = unit -> obj option

  /// all node types wrapped into a choice.
  and wrapNode =
    | WStmt of stmt
    | WExp of exp

  and NodeBase
    (getWrapNode :wrapGetter, getTypeStr :typeStrGetter,
      getLeafData :leafDataGetter, getChildren :childrenGetter) =
    interface node with
      member it.wrap = getWrapNode (it :> node) // wrap self
      member it.typeStr = getTypeStr ()
      member it.leafData = getLeafData ()
      member it.children = getChildren ()

  and LeafNode
    ( getWrapNode :wrapGetter, getTypeStr :typeStrGetter,
      getLeafData :leafDataGetter) =
    inherit NodeBase(getWrapNode, getTypeStr, getLeafData, fun () -> [])

  and GroupNode
    ( getWrapNode :wrapGetter, getTypeStr :typeStrGetter,
      getChildren : childrenGetter) =
    inherit NodeBase(getWrapNode, getTypeStr, (fun () -> None), getChildren)
  
  and N = // Convenience: cast a #node down to node.
    static member inline E (e:exp) :node = (e :> node)
    static member inline S (s:stmt) :node = (s :> node)

  and stmt = // Exp | IfSt
    | Exp of exp
    | IfSt of ifSt
    with
==>    inherit GroupNode   // *** ERROR: NOT PERMITTED *** <==
      ( (fun () -> WStmt n), // wrap self
        (fun () ->
          match it with
          | Exp _ -> "Exp"
          | IfSt _ -> "IfSt"),
        (fun () ->
          match it with
          | Exp e1 -> [N.E e1]
          | IfSt s ->
            let ct = [N.E s.Cond; N.S s.Then]
            match s.Else with
            | Some se -> ct @ [N.S se]
            | None -> ct))
...
By on 4/12/2008 11:49 AM ()

NOTE: In the interests of exploring alternative, non-OO, best practices, I've tried re-writing this WITHOUT declaring the interface "node" at all, hence without any "member" declarations.

I ran into trouble trying to write the tree-walker, because it inherently wants the notion of "node" -- see its uses in counting nodes, and in recreating source.

I think this could be done with active patterns, but I didn't pursue that yet.

It sure looks to me like the mixed "OO + match" approach is more straightforward than a completely non-OO approach. If so, this runs against the suggestion that tree walking is an activity that a functional language is particularly suited for. My point here is that adding OO to functional brings just the benefit one would expect: an organizational benefit as scale problems up to greater complexity.

I would love to see counter-evidence to this, in order to better know how to use functional idioms.

By on 4/12/2008 12:04 PM ()

Before going further, what you are saying is a bit confused me.

My goal is to create a metacompiler. I view this as two parts: (1) parsing a
grammar into a syntax tree, and (2) helper functions related to walking that
syntax tree for various purposes.

I'm sure you are aware of metaprogramming features of F#, especially quotations. With quotations you can skip the (1) as it is provided for free by the compiler and go to (2).

Or you can use fsyacc and fslex for more grammar syntax oriented solution.

Have you considered using those libraries and tools ?

By on 3/24/2008 6:33 PM ()

certen, thank you for taking an interest in what I am writing about. I will explain more.

First, I want to compile source written in languages OTHER than F#. I have two uses for that:

  1. Domain Specific Languages. Inventing a concise notation for a given task. [link:en.wikipedia.org]
  2. Proposed ECMAScript 4 ("ES4") ("Javascript 2"). [link:www.ecmascript.org] I want to translate from that into F#, to the degree that makes sense. I can say more about why I want to do that.

I think quotations are only useful as snippets of F# code. There may be a use for them at the tail end of what I am doing -- but first I have to work with the ES4 or DSL.

Second, you are correct that fsyacc & fslex are tools for grammar parsing. However, they form a "bottom-up parser", which is not what I want to work with. So I have decided to implement a PEG parser:

[link:en.wikipedia.org]

And in combination with that parser, I want to do some extra work up-front that will make it easier to maintain any custom work, as the input grammar evolves.

By on 3/24/2008 11:25 PM ()

Hi Steve,

In case you don't yet know: the FParsec ([link:www.quanttec.com]) parser combinator library for F# contains a PEG parser as a sample application.

Best regards,
Stephan

By on 3/25/2008 12:48 AM ()

Stephan -- Awesome, I didn't know about that! I will definitely take a look at that.

By on 3/25/2008 11:31 AM ()

    Topic tags

    IntelliFactory Offices Copyright (c) 2011-2012 IntelliFactory. All rights reserved.
    Home | Products | Consulting | Trainings | Blogs | Jobs | Contact Us | Terms of Use | Privacy Policy | Cookie Policy     		Built with WebSharper