From e5034d3a668fbf0a4367bb582d759ba82b5576a3 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rosehogenson@posteo.net>
Date: Wed, 22 Jan 2025 19:45:12 -0800
Subject: Support struct expressions

---
 Elab.sml | 47 +++++++++++++++++++++++++++++++++--------------
 1 file changed, 33 insertions(+), 14 deletions(-)

(limited to 'Elab.sml')

diff --git a/Elab.sml b/Elab.sml
index 60760cd..74e331b 100644
--- a/Elab.sml
+++ b/Elab.sml
@@ -186,6 +186,7 @@ struct
     in (patterns, occurrences, actions)
     end
 
+  (* https://compiler.club/compiling-pattern-matching/ *)
   fun compilePatternMatching (env : env) ([] : Syntax.pat list list, _ : Syntax.lexp list, _ : Syntax.lexp list) : Syntax.lexp =
         raise Fail "nonexhaustive match"
     | compilePatternMatching env (patterns as firstRow :: rows, occurrences, actions) =
@@ -245,12 +246,21 @@ struct
 
   fun structBoundVars (decls : Syntax.dec list) : string list = List.concatMap declBoundVars decls
 
-  fun bindStructType (name : string) (decls : Syntax.dec list) (Env env) : env =
+  fun bindStruct (name : string) (structEnv : env) (Env { vars, types, structTypes }) : env =
+    Env { vars = vars, types = types, structTypes = StringMap.insert name structEnv structTypes }
+
+  fun bindStructType (name : string) (decls : Syntax.dec list) (env : env) : env =
     let
       val structEnv =
         foldl
           (fn (Syntax.DDatatype (_, cons), env) => bindDataCons cons env
-            | (Syntax.DStruct (name, decls), env) => bindStructType name decls env
+            | (Syntax.DStruct (name, Syntax.SStruct decls), env) => bindStructType name decls env
+            | (Syntax.DStruct (name, Syntax.SIdent ident), env) =>
+                let
+                  fun lookup [name] env = lookupStructType name env
+                    | lookup (name :: names) env = lookup names (lookupStructType name env)
+                    | lookup _ _ = raise Fail "invalid struct identifier"
+                in lookup ident env end
             | (_, env) => env)
           emptyEnv
           decls
@@ -260,7 +270,7 @@ struct
           structEnv
           (enumerate (structBoundVars decls))
     in
-      Env { vars = #vars env, types = #types env, structTypes = StringMap.insert name structEnv (#structTypes env) }
+      bindStruct name structEnv env
     end
 
   fun actionVector (env : env) (expr : Syntax.lexp) (arms : (Syntax.pat * Syntax.expr) list) : Syntax.lexp list =
@@ -313,8 +323,7 @@ struct
           fun go env [i] acc = Syntax.LSelect (lookupVar i env, acc)
             | go env (accessor :: accessors) acc =
                 let val env = lookupStructType accessor env
-                in go env accessors (Syntax.LSelect (lookupVar accessor env, acc))
-                end
+                in go env accessors (Syntax.LSelect (lookupVar accessor env, acc)) end
             | go _ [] _ = raise Fail "go empty"
         in go env accessors s
         end
@@ -395,25 +404,35 @@ struct
               ]
             , elab env (Syntax.ELet (decls, body))
             )
-        end
-        end
-    | Syntax.ELet (Syntax.DStruct (name, structDecls) :: decls, body) =>
+        end end
+    | Syntax.ELet (Syntax.DStruct (name, Syntax.SStruct structDecls) :: decls, body) =>
         let
           val names = structBoundVars structDecls
           val tuple = elab env (Syntax.ELet (structDecls, Syntax.ETuple (map (fn n => Syntax.EIdent [n]) names)))
           val v = GenSym.new ()
           val env = bindStructType name structDecls env
           val env = bindVar name v env
-        in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple)
-        end
+        in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), tuple) end
+    | Syntax.ELet (Syntax.DStruct (name, Syntax.SIdent (structName :: accessors)) :: decls, body) =>
+        let
+          val s = Syntax.LVar (lookupVar structName env)
+          fun go env [] acc = (env, acc)
+            | go env (accessor :: accessors) acc =
+                go
+                  (lookupStructType accessor env)
+                  accessors
+                  (Syntax.LSelect (lookupVar accessor env, acc))
+          val (structEnv, structExpr) = go (lookupStructType structName env) accessors s
+          val v = GenSym.new ()
+          val env = bindStruct name structEnv env
+          val env = bindVar name v env
+        in Syntax.LApp (Syntax.LFn (v, elab env (Syntax.ELet (decls, body))), structExpr) end
     | Syntax.ELambda body =>
         let val v = GenSym.new ()
-        in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body])
-        end
+        in Syntax.LFn (v, elabCase env (Syntax.LVar v) [body]) end
     | Syntax.ECase (expr, arms) =>
         let val v = GenSym.new ()
-        in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr)
-        end
+        in Syntax.LApp (Syntax.LFn (v, elabCase env (Syntax.LVar v) arms), elab env expr) end
 
   fun elaborate (p : Syntax.expr) : Syntax.lexp = elab emptyEnv p
 end
-- 
cgit v1.3.1