step7: Streamlined pattern matching with some active patterns.

[jackhill/mal.git] / fsharp / eval.fs

diff --git a/fsharp/eval.fs b/fsharp/eval.fs
index d275615..4d3e899 100644 (file)
--- a/fsharp/eval.fs
+++ b/fsharp/eval.fs
@@ -17,18 +17,36 @@ module Eval
                 loop ()
         loop ()
 
+    let quasiquoteForm nodes =
+        let transformNode f = function
+            | Elements 1 [|a|] -> f a
+            | _ -> raise <| Core.errArity ()
+        let singleNode = transformNode (fun n -> n)
+        let rec quasiquote node =
+            match node with
+            | Head(Symbol("unquote"), rest) -> rest |> singleNode
+            | Head(Head(Symbol("splice-unquote"), spliceRest), rest) ->
+                List([Symbol("concat"); singleNode spliceRest; quasiquote rest])
+            | Head(h, t) -> List([Symbol("cons"); quasiquote h; quasiquote t])
+            | n -> List([Symbol("quote"); n])
+        List(nodes) |> transformNode quasiquote
+
+    let quoteForm = function
+        | [node] -> node
+        | _ -> raise <| Core.errArity ()
+
     let rec eval_ast env = function
         | Symbol(sym) -> Env.get env sym
         | List(lst) -> lst |> List.map (eval env) |> List
-        | Vector(arr) -> arr |> Array.map (eval env) |> Vector
+        | Vector(seg) -> seg |> Seq.map (eval env) |> Array.ofSeq |> Node.ofArray
         | Map(map) -> map |> Map.map (fun k v -> eval env v) |> Map
         | node -> node
 
-    and defBang env = function
-        | sym::node::[] -> 
+    and defBangForm env = function
+        | [sym; form] ->
             match sym with
-            | Symbol(sym) -> 
-                let node = eval env node 
+            | Symbol(sym) ->
+                let node = eval env form
                 Env.set env sym node
                 node
             | _ -> raise <| errExpected "symbol"
@@ -41,23 +59,63 @@ module Eval
         let form = eval env second
         Env.set env s form
 
-    and letStar env = function
-        | bindings::form::[] ->
-            let newEnv = Env.makeNew env
-            let binder = setBinding newEnv
+    and letStarForm outer = function
+        | [bindings; form] ->
+            let inner = Env.makeNew outer [] []
+            let binder = setBinding inner
             match bindings with
             | List(lst) -> lst |> iterPairs binder
-            | Vector(vec) -> vec |> iterPairs binder
+            | Vector(seg) -> seg |> iterPairs binder
             | _ -> raise <| errExpected "list or vector"
-            eval newEnv form
+            inner, form
+        | _ -> raise <| Core.errArity ()
+
+    and ifForm env = function
+        | [condForm; trueForm; falseForm] -> ifForm3 env condForm trueForm falseForm
+        | [condForm; trueForm] -> ifForm3 env condForm trueForm Nil
+        | _ -> raise <| Core.errArity ()
+
+    and ifForm3 env condForm trueForm falseForm =
+        match eval env condForm with
+        | Bool(false) | Nil -> falseForm
+        | _ -> trueForm
+
+    and doForm env = function
+        | [a] -> a
+        | a::rest ->
+            eval env a |> ignore
+            doForm env rest
+        | _ -> raise <| Core.errArity ()
+
+    and fnStarForm outer nodes =
+        let makeFunc binds body =
+            let f = fun nodes ->
+                        let inner = Env.makeNew outer binds nodes
+                        eval inner body
+            Env.makeFunc f body binds outer
+
+        match nodes with
+        | [List(binds); body] -> makeFunc binds body
+        | [Vector(seg); body] -> makeFunc (List.ofSeq seg) body
+        | [_; _] -> raise <| errExpected "bindings of list or vector"
         | _ -> raise <| Core.errArity ()
 
     and eval env = function
-        | List(Symbol("def!")::rest) -> defBang env rest
-        | List(Symbol("let*")::rest) -> letStar env rest
+        | List(Symbol("def!")::rest) -> defBangForm env rest
+        | List(Symbol("let*")::rest) -> 
+            let inner, form = letStarForm env rest
+            form |> eval inner
+        | List(Symbol("if")::rest) -> ifForm env rest |> eval env
+        | List(Symbol("do")::rest) -> doForm env rest |> eval env
+        | List(Symbol("fn*")::rest) -> fnStarForm env rest
+        | List(Symbol("quote")::rest) -> quoteForm rest
+        | List(Symbol("quasiquote")::rest) -> quasiquoteForm rest |> eval env
         | List(_) as node ->
             let resolved = node |> eval_ast env
             match resolved with
-            | List(Func({F = f})::rest) -> f rest
+            | List(Func(_, f, _, _, [])::rest) -> f rest
+            | List(Func(_, _, body, binds, outer)::rest) ->
+                let inner = Env.makeNew outer binds rest
+                body |> eval inner
             | _ -> raise <| errExpected "function"
         | node -> node |> eval_ast env