Add experimental support for macro "functions"

src/Visp.Compiler/Transforms/SyntaxMacroExpander.fs

@@ -25,6 +25,18 @@ let (|DiscardPredicate|Not|) (pat: SynMacroPat) =
     | SynMacroPat.List([ MatchingText "?discard" true ], _) -> DiscardPredicate
     | _ -> Not
 
+let (|SymText|_|) (pat: SynMacroBody) =
+    match pat with
+    | SynMacroBody.Symbol it -> Some(it.Text)
+    | _ -> None
+
+let (|SpecialCall|_|) call (pat: SynMacroBody) =
+    match pat with
+    | SynMacroBody.List(k, (SynMacroBody.Symbol sym) :: rest, r) when sym.Text = call ->
+        Some(k, rest, r)
+    | _ -> None
+
+
 let rec private matchesPat (args: SynMacroBody list) (pats: SynMacroPat list) =
     // printfn "looking for\n%A\nin\n%A" args pats
     // TODO: Determine pattern matching
@@ -142,38 +154,90 @@ type private TokenizeArgs =
                 t.mode <- TokenizeMode.Default
                 t.depth <- 0
 
-let private evaluatePatterns
-    (body: SynMacroBody)
-    (pats: Dictionary<string, BoundPatternBody>)
-    (range: range)
-    : SynExpr =
+type private BoundPats = Dictionary<string, BoundPatternBody>
+
+let private evaluatePatterns (body: SynMacroBody) (pats: BoundPats) (range: range) : SynExpr =
 
 
-    let findPattern bod (pats: Dictionary<string, BoundPatternBody>) =
+    let findPattern (pats: BoundPats) bod =
         match bod with
         | SynMacroBody.Symbol sym ->
             match pats.TryGetValue(sym.Text) with
             | false, _ -> None
             | true, n -> Some(n)
         | _ -> None
 
+    let rec getBody (pats: BoundPats) bod =
+        match findPattern pats bod with
+        | Some(it) ->
+            match it with
+            | BoundPatternBody.Item it -> getBody pats it
+            | BoundPatternBody.List lst -> lst |> List.map (getBody pats) |> List.concat
+        | None -> [ bod ]
+
     let rec tokenize
-        (pats: Dictionary<string, BoundPatternBody>)
+        (pats: BoundPats)
         (res: ResizeArray<token>)
         (args: TokenizeArgs)
-        (f: SynMacroBody)
+        (currentBody: SynMacroBody)
         =
 
+        let handleSymbol args text =
+            match args.mode with
+            | TokenizeMode.Macro -> res.Add(SYMBOL text)
+            | TokenizeMode.Default ->
+                let tok = LexHelpers.symbolOrKeyword text
+
+                match tok with
+                | MACRO_NAME _
+                | SYNTAX_MACRO -> args.StartMacro()
+                | _ -> ()
+
+                res.Add(tok)
+
         let bound_tokenize = tokenize pats res args
 
-        match findPattern f pats with
+        match findPattern pats currentBody with
         | Some(pat) ->
             match pat with
             | BoundPatternBody.Item(it) -> bound_tokenize it
             | BoundPatternBody.List(lst) -> lst |> List.iter bound_tokenize
 
         | None ->
-            match f with
+            match currentBody with
+            | SpecialCall "m-concat-id" (_, call_args, _) ->
+                match call_args with
+                | arg1 :: arg2 :: [] ->
+                    match ((getBody pats arg1), (getBody pats arg2)) with
+                    | ([ SymText lhs ], [ SymText rhs ]) -> handleSymbol args (lhs + rhs)
+                    | _ -> failwithf "todo concat id %A" call_args
+
+                | _ -> failwithf "todo concat id %A" call_args
+
+                ()
+            | SpecialCall "m-map" (_, call_args, _) ->
+                match call_args with
+                | (SymText method) :: (SynMacroBody.List(_, list, _)) :: [] ->
+                    let argz = list |> List.map (getBody pats) |> List.concat
+
+                    match method with
+                    | "m-name" ->
+                        let names =
+                            argz
+                            |> List.choose (function
+                                | SynMacroBody.Symbol it -> Some(it)
+                                | SynMacroBody.List(_, SynMacroBody.Symbol it :: _, _) -> Some(it)
+                                | SynMacroBody.Ellipsis _ -> None
+                                | it -> failwithf "unsupported m-map %A" it)
+                            |> List.map _.Text
+
+                        names |> List.iter (handleSymbol args)
+
+                    | _ -> failwithf "unsupported m-map method: %A %A" method call_args
+
+                | _ -> failwithf "todo concat id %A" call_args
+
+                ()
             | SynMacroBody.List(kind, lst, _) ->
                 res.Add(openToken kind)
 
@@ -218,18 +282,7 @@ let private evaluatePatterns
 
                 ()
 
-            | SynMacroBody.Symbol sym ->
-                match args.mode with
-                | TokenizeMode.Macro -> res.Add(SYMBOL sym.Text)
-                | TokenizeMode.Default ->
-                    let tok = LexHelpers.symbolOrKeyword sym.Text
-
-                    match tok with
-                    | MACRO_NAME _
-                    | SYNTAX_MACRO -> args.StartMacro()
-                    | _ -> ()
-
-                    res.Add(tok)
+            | SynMacroBody.Symbol sym -> handleSymbol args sym.Text
 
     use pooled = PooledList.GetPooled<token>()
     let res = pooled.Value

tests/Visp.Compiler.UnitTests/ParsingTests.generated.fs

@@ -210,6 +210,11 @@ module ``tests_macros_cond-macro-1`` =
     [<Fact>]
     let ``can parse`` () = TestUtils.runTest "tests/macros/cond-macro-1.visp"
 
+[<VerifyXunit.UsesVerify>]
+module ``tests_macros_struct-macro-2`` =
+    [<Fact>]
+    let ``can parse`` () = TestUtils.runTest "tests/macros/struct-macro-2.visp"
+
 [<VerifyXunit.UsesVerify>]
 module ``tests_macros_chars-in-macros-0`` =
     [<Fact>]

tests/Visp.Compiler.UnitTests/snapshots/tests_macros_struct-macro-2.can parse.verified.txt

@@ -0,0 +1,51 @@
+// This file is auto-generated
+
+#nowarn "0020"  // unused results from functions
+
+open Visp.Runtime.Library
+
+let state = { Todo = () }
+// line 8 @"struct-macro-2.visp"
+let macro_MyStruct2 = "__MACRO_INIT__"
+// line 22 @"struct-macro-2.visp"
+
+[<Struct()>]
+// line 22 @"struct-macro-2.visp"
+type Example (x: int, y: int) =
+  // line 22 @"struct-macro-2.visp"
+  member _.X =
+        x
+  // line 22 @"struct-macro-2.visp"
+  member _.Y =
+        y
+  // line 22 @"struct-macro-2.visp"
+  member d.Sum () =
+    // line 22 @"struct-macro-2.visp"
+    CoreMethods.``add``((d.X), (d.Y))
+
+// line 22 @"struct-macro-2.visp"
+let mkExample x y =
+  // line 22 @"struct-macro-2.visp"
+  (new Example(x, y))
+
+// line 28 @"struct-macro-2.visp"
+let instance =
+  // line 28 @"struct-macro-2.visp"
+  mkExample (1) (2)
+// line 30 @"struct-macro-2.visp"
+printfn ("Example Struct is %A") (instance)
+// line 31 @"struct-macro-2.visp"
+printfn ("Example IsValueType %A") (instance
+  |> (fun a1 ->
+    // line 31 @"struct-macro-2.visp"
+    (a1.GetType()))
+  |> (fun a1 ->
+    // line 31 @"struct-macro-2.visp"
+    (a1.IsValueType)))
+// line 32 @"struct-macro-2.visp"
+let visp_result_todo =
+  // line 32 @"struct-macro-2.visp"
+  printfn ("Example Result is %i") ((instance.Sum()))
+// line 32 @"struct-macro-2.visp"
+printfn ("%A") (visp_result_todo)
+

tests/Visp.ExecutionTests/ExecutionTests.generated.fs

@@ -210,6 +210,11 @@ module ``tests_macros_cond-macro-1`` =
     [<Fact>]
     let ``can execute`` () = TestUtils.runTest "tests/macros/cond-macro-1.visp"
 
+[<VerifyXunit.UsesVerify>]
+module ``tests_macros_struct-macro-2`` =
+    [<Fact>]
+    let ``can execute`` () = TestUtils.runTest "tests/macros/struct-macro-2.visp"
+
 [<VerifyXunit.UsesVerify>]
 module ``tests_macros_chars-in-macros-0`` =
     [<Fact>]

tests/Visp.ExecutionTests/snapshots/tests_macros_struct-macro-2.can execute.verified.txt

@@ -0,0 +1,6 @@
+Example Struct is struct-macro-2+Example
+Example IsValueType true
+Example Result is 3
+()
+
+ExitCode: 0

visp/tests/macros/struct-macro-2.visp

@@ -0,0 +1,32 @@
+;; Copyright 2023 Ville Penttinen
+;; Distributed under the MIT License.
+;; https://github.com/vipentti/visp-fs/blob/main/LICENSE.md
+;;
+;; for basic syntax highlighting
+;; vim: set syntax=clojure:
+
+(syntax-macro MyStruct2
+  [(_ typ (arg ctor ...) body ...)
+    (begin
+      (#[Struct]
+        type typ (arg ctor ...)
+        body ...
+      )
+
+      (fn (m-concat-id mk typ)
+        ((m-map m-name (arg ctor ...)))
+        (new typ (m-map m-name (arg ctor ...))))
+    )
+  ])
+
+(MyStruct2 Example ([x: int] [y: int])
+  (member _.X x)
+  (member _.Y y)
+
+  (member fn d.Sum () (+ (+X d) (+Y d))))
+
+(let instance (mkExample 1 2))
+
+(printfn "Example Struct is %A" instance)
+(printfn "Example IsValueType %A" (->> instance .GetType +IsValueType))
+(printfn "Example Result is %i" (.Sum instance))