From 8b3a9b8f0d80e7dd789f363deb6bb36189a31f01 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rosehogenson@posteo.net>
Date: Sun, 18 May 2025 08:17:20 -0700
Subject: Add a typechecker

---
 Parser.sml | 34 ++++++++++++++++++++++++----------
 1 file changed, 24 insertions(+), 10 deletions(-)

(limited to 'Parser.sml')

diff --git a/Parser.sml b/Parser.sml
index 4e20c13..8a1e1f3 100644
--- a/Parser.sml
+++ b/Parser.sml
@@ -451,12 +451,25 @@ struct
       typedPat
       (List.tabulate (10, fn i => 9 - i)) st
 
+  fun makeConvolutedEDotSyntax ([i] : string list) : Syntax.expr = Syntax.EIdent i
+    | makeConvolutedEDotSyntax (i :: is) =
+        let
+          val structSelectors = List.take (is, length is - 1)
+          val exprSelector = List.last is
+        in
+          Syntax.EDot
+            ( foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent i) structSelectors
+            , exprSelector
+            )
+        end
+    | makeConvolutedEDotSyntax _ = raise Fail "bad identifier"
+
   val rec atom : Syntax.expr parser =
     fn st =>
       (Syntax.EInt <$> integer
       <|> Syntax.EStr <$> stringConstant
-      <|> Syntax.EIdent <$> longIdentifier
-      <|> (reserved "op" >> Syntax.EIdent <$> longInfixIdentifier)
+      <|> makeConvolutedEDotSyntax <$> longIdentifier
+      <|> (reserved "op" >> makeConvolutedEDotSyntax <$> longInfixIdentifier)
       <|> builtin
       <|> (reserved "let" >>
            bind (many dec) (fn decs =>
@@ -483,14 +496,14 @@ struct
             fun exprLeft expr1 =
               bind (leftOp i) (fn opEx =>
               bind exprLower (fn expr2 =>
-              let val app = Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, expr2])
+              let val app = Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, expr2])
               in exprLeft app <|> const app
               end))
             fun exprRight expr1 =
               bind (rightOp i) (fn opEx =>
               bind exprLower (fn expr2 =>
               bind (exprRight expr2 <|> const expr2) (fn rest =>
-              const (Syntax.EApp (Syntax.EIdent [opEx], Syntax.ETuple [expr1, rest])))))
+              const (Syntax.EApp (Syntax.EIdent opEx, Syntax.ETuple [expr1, rest])))))
           in
             bind exprLower (fn expr1 =>
             exprLeft expr1 <|> exprRight expr1 <|> const expr1)
@@ -550,9 +563,10 @@ struct
           end) >>
       const NONE)))
   <|> ((reserved "datatype" <|> reserved "and") >>
-          (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ","))
-      <|> (fn x => [x]) <$> tyvar
-      <|> const []) >>
+      bind
+            (between (symbol "(") (symbol ")") (sepBy1 tyvar (symbol ","))
+        <|> (fn x => [x]) <$> tyvar
+        <|> const []) (fn vars =>
       bind identifier (fn name =>
       reserved "=" >>
       bind
@@ -563,7 +577,7 @@ struct
               const (con, SOME ty)))
           <|> const (con, NONE)))
           (reserved "|")) (fn cons =>
-      const (SOME (Syntax.DDatatype (name, cons))))))
+      const (SOME (Syntax.DDatatype (vars, name, cons)))))))
   <|> (reserved "type" >>
       bind identifier (fn name =>
       reserved "=" >>
@@ -614,7 +628,7 @@ struct
         bind (many strdec) (fn bindings =>
         reserved "end" >>
         const (Syntax.SStruct (List.mapPartial (fn x => x) bindings))))
-    <|> Syntax.SIdent <$> longIdentifier) st
+    <|> (fn is => foldl (fn (x, acc) => Syntax.SDot (acc, x)) (Syntax.SIdent (hd is)) (tl is)) <$> longIdentifier) st
 
   (* There's ambiguity between pattern variables and constructors that can only
    * be resolved by checking for constructors in scope *)
@@ -626,7 +640,7 @@ struct
     | fixPatConstructors constructors (Syntax.PCon (con, arg)) = Syntax.PCon (con, fixPatConstructors constructors arg)
     | fixPatConstructors _ pat = pat
 
-  fun findConstructors (Syntax.DDatatype (_, cases)) : string list =
+  fun findConstructors (Syntax.DDatatype (_, _, cases)) : string list =
         List.mapPartial
           (fn (constructor, NONE) => SOME constructor
             | _ => NONE)
-- 
cgit v1.3.1