Match implementation (#127)

cogs/match/match-tests.scm

@@ -0,0 +1,117 @@
+(provide __module__)
+(define __module__ 'match-tests)
+
+(define (test name input expected)
+  (assert! (equal? input expected))
+  (if (equal? input expected)
+      (begin
+        (display "> ")
+        (display name)
+        (display " ... ")
+        (display "OK")
+        (newline))
+      (begin
+        (display "> ")
+        (display name)
+        (display " ... ")
+        (display "FAILED")
+        (newline)
+        (display "    Expected: ")
+        (display expected)
+        (display ", Found ")
+        (displayln input))))
+
+; ;; a => 1
+; ;; x => '(2 3 4 5)
+(test "Basic ellipses matching works"
+      (match '(1 2 3 4 5)
+        [(list a x ...) x])
+      (list 2 3 4 5))
+
+(test "Ellipses matches until next value"
+      (match (list 1 2 3 4 5)
+        [(list first rest ... last) rest])
+      (list 2 3 4))
+
+(test "match list of constants"
+      (match (list 1 2 3 4 5)
+        [(list 1 2 3 4 5) 'case1])
+      'case1)
+
+(test "match binds free vars"
+      (match (list 1 2 3 4 5)
+        [(list x 2 y 4 z) (+ x y z)])
+      (+ 1 3 5))
+
+(test "match binds to first matching case"
+      (match (list 1 2 3 4 5)
+        [?x 'case1]
+        [(list ?a ?b ?c ?d ?e) 'case2])
+      'case1)
+
+(test "match constant"
+      (match 10
+        [10 'case1])
+      'case1)
+
+(test "takes else case when nothing matches"
+      (match (list 1 (list 2 (list 3)))
+        [(list x y z) 'case1]
+        [24 'case2]
+        [else 'case3])
+      'case3)
+
+(test "Empty list matches empty list"
+      (match '()
+        [() 'found-empty-list!]
+        [(list x xs...) 'found-list!])
+      'found-empty-list!)
+
+(test "match nested list"
+      (match (list (list 1 2) 3 (list 4 (list 5 6)))
+        [(list (list a 2) b (list c (list 5 6))) (+ a b c)])
+      (+ 1 3 4))
+
+(test "wildcards work"
+      (match (list 1 2 3 4 5)
+        [(list 1 2 _ _ a) a])
+      5)
+
+;; Generic optimization passes?
+(test "pattern matching against anonymous function application"
+      (match '((lambda (x) 10) 20)
+
+        [(list (list 'lambda (list var) body) arg) body])
+      10)
+
+(define (quoted? x)
+  (and (list? x) (not (null? x)) (equal? (car x) 'quote)))
+
+(define (constant? x)
+  (or (number? x) (quoted? x)))
+
+(define (identify-sequential-maps expr)
+  (match expr
+    ;; Matching against quasiquotes, should help with real pattern matching?
+    [`(map ,func1 (map ,func2 ,lst))
+     `(map (lambda (x)
+
+             (,func2 (,func1 x)))
+           ,lst)]
+    [_ expr]))
+
+(identify-sequential-maps '(map add1 (range 0 100)))
+(identify-sequential-maps '(map add1 (map sub1 (range 0 100))))
+
+(define my-expr
+  '(define (foo-bar x)
+     ((lambda (y) 100) x)))
+
+(define (remove-constant-anonymous-functions expr)
+  (match expr
+    [`((lambda (,var) ,body) ,@args) (if (constant? body) body expr)]
+    [(list args ...) (map remove-constant-anonymous-functions args)]
+    [_ expr]))
+
+; Nano pass framework for rewriting and incrementally lowering!
+(remove-constant-anonymous-functions my-expr)

cogs/match/match.scm

@@ -0,0 +1,21 @@
+(provide match-let*)
+
+(define-syntax match-let*
+  (syntax-rules ()
+    [(match-let* ()
+       body ...)
+
+     (begin
+       body ...)]
+
+    [(match-let* ([pat expr] rest ...)
+       body ...)
+
+     (match expr
+       [pat
+        (match-let* (rest ...)
+          body ...)])]))
+
+;; Example:
+; (match-let* ([(list a b) '(1 2)] [(list x ...) (list 1 2 3 4)])
+;   (list b a x))

crates/steel-core/src/compiler/modules.rs

@@ -97,16 +97,19 @@ declare_builtins!(
     "#%private/steel/print" => "../scheme/print.scm",
     "#%private/steel/control" => "../scheme/modules/parameters.scm",
     "#%private/steel/reader" => "../scheme/modules/reader.scm",
-    "#%private/steel/stdlib" => "../scheme/stdlib.scm"
+    "#%private/steel/stdlib" => "../scheme/stdlib.scm",
+    "#%private/steel/match" => "../scheme/modules/match.scm"
 );
 
 create_prelude!(
     "#%private/steel/control",
     "#%private/steel/contract",
     "#%private/steel/print",
     "#%private/steel/reader",
+    "#%private/steel/match",
     for_syntax "#%private/steel/control",
     for_syntax "#%private/steel/contract"
+    // for_syntax "#%private/steel/match"
 );
 
 pub static STEEL_HOME: Lazy<Option<String>> = Lazy::new(|| std::env::var("STEEL_HOME").ok());
@@ -538,6 +541,39 @@ impl ModuleManager {
             let kernel_macros_in_scope: HashSet<_> =
                 module.provides_for_syntax.iter().cloned().collect();
 
+            // let defmacros_exported: HashSet<_> = module.
+
+            // dbg!(&kernel_macros_in_scope);
+
+            let module_name = module.name.to_str().unwrap().to_string();
+
+            if let Some(kernel) = kernel.as_mut() {
+                if kernel.exported_defmacros(&module_name).is_some() {
+                    lifted_kernel_environments.insert(
+                        module_name.clone(),
+                        KernelDefMacroSpec {
+                            env: module_name,
+                            exported: None,
+                            name_mangler: name_mangler.clone(),
+                        },
+                    );
+                }
+            }
+
+            // TODO: This isn't right - only check if there are defmacro things
+            // that we need to lift - just check the values that are in the defmacros
+            // environment in the kernel
+            // if !kernel_macros_in_scope.is_empty() {
+            //     lifted_kernel_environments.insert(
+            //         module_name.clone(),
+            //         KernelDefMacroSpec {
+            //             env: module_name,
+            //             exported: None,
+            //             name_mangler: name_mangler.clone(),
+            //         },
+            //     );
+            // }
+
             ast = ast
                 .into_iter()
                 .map(|x| {
@@ -612,14 +648,14 @@ impl ModuleManager {
                             name_mangler.visit(&mut first_round_expanded);
                         }
 
-                        lifted_kernel_environments.insert(
-                            module_name.clone(),
-                            KernelDefMacroSpec {
-                                env: module_name,
-                                exported: None,
-                                name_mangler: name_mangler.clone(),
-                            },
-                        );
+                        // lifted_kernel_environments.insert(
+                        //     module_name.clone(),
+                        //     KernelDefMacroSpec {
+                        //         env: module_name,
+                        //         exported: None,
+                        //         name_mangler: name_mangler.clone(),
+                        //     },
+                        // );
 
                         Ok(first_round_expanded)
                     } else {

crates/steel-core/src/parser/kernel.rs

@@ -25,9 +25,7 @@ use steel_parser::expr_list;
 use super::{
     ast::{ExprKind, TryFromSteelValVisitorForExprKind},
     interner::InternedString,
-    replace_idents::RewriteSpan,
     span_visitor::get_span,
-    visitors::ConsumingVisitor,
 };
 
 thread_local! {
@@ -459,6 +457,15 @@ impl Kernel {
         // todo!("Run through every expression, and memoize them by calling (set! <ident> (make-memoize <ident>))")
     }
 
+    pub fn exported_defmacros(&self, environment: &str) -> Option<HashSet<InternedString>> {
+        self.transformers
+            .set
+            .read()
+            .unwrap()
+            .get(environment)
+            .cloned()
+    }
+
     pub fn contains_syntax_object_macro(
         &self,
         ident: &InternedString,
@@ -539,9 +546,18 @@ impl Kernel {
             .call_function_with_args(function, vec![syntax_objects])
             .map_err(|x| x.set_span(span))?;
 
+        // dbg!(&result);
+
         // This shouldn't be lowering all the way. It should just be back to list right?
         TryFromSteelValVisitorForExprKind::root(&result)
-            // TODO: We don't want this forever, but for now its okay
-            .and_then(|x| RewriteSpan::new(span).visit(x))
+
+        // let span = result.as_ref().map(get_span);
+
+        // dbg!(&span);
+
+        // result
+
+        // TODO: We don't want this forever, but for now its okay
+        // .and_then(|x| RewriteSpan::new(span).visit(x))
     }
 }

crates/steel-core/src/parser/replace_idents.rs

@@ -141,6 +141,10 @@ impl<'a> ReplaceExpressions<'a> {
 
     fn expand_ellipses(&mut self, vec_exprs: Vec<ExprKind>) -> Result<Vec<ExprKind>> {
         if let Some(ellipses_pos) = vec_exprs.iter().position(check_ellipses) {
+            if ellipses_pos == 0 {
+                return Ok(vec_exprs);
+            }
+
             let variable_to_lookup = vec_exprs.get(ellipses_pos - 1).ok_or_else(
                 throw!(BadSyntax => "macro expansion failed, could not find variable when expanding ellipses")
             )?;
@@ -153,14 +157,27 @@ impl<'a> ReplaceExpressions<'a> {
                             ..
                         },
                 }) => {
-                    let rest = self.bindings.get(var).ok_or_else(throw!(BadSyntax => format!("macro expansion failed at finding the variable when expanding ellipses: {var}")))?;
+                    // let rest = self.bindings.get(var).ok_or_else(throw!(BadSyntax => format!("macro expansion failed at finding the variable when expanding ellipses: {var}")))?;
+
+                    let rest = if let Some(rest) = self.bindings.get(var) {
+                        rest
+                    } else {
+                        return Ok(vec_exprs);
+                    };
 
                     let list_of_exprs = if let ExprKind::List(list_of_exprs) = rest {
                         list_of_exprs
                     } else {
-                        let res = self.fallback_bindings.get(var).ok_or_else(throw!(BadSyntax => format!("macro expansion failed at finding the variable when expanding ellipses: {var}")))?.list_or_else(
-                        throw!(BadSyntax => "macro expansion failed, expected list of expressions, found: {}, within {}", rest, super::ast::List::new(vec_exprs.clone()))
-                    )?;
+                        let res = if let Some(res) = self.fallback_bindings.get(var) {
+                            res.list_or_else(
+                        throw!(BadSyntax => "macro expansion failed, expected list of expressions, found: {}, within {}", rest, super::ast::List::new(vec_exprs.clone())))?
+                        } else {
+                            return Ok(vec_exprs);
+                        };
+
+                        //     let res = self.fallback_bindings.get(var).ok_or_else(throw!(BadSyntax => format!("macro expansion failed at finding the variable when expanding ellipses: {var}")))?.list_or_else(
+                        //     throw!(BadSyntax => "macro expansion failed, expected list of expressions, found: {}, within {}", rest, super::ast::List::new(vec_exprs.clone()))
+                        // )?;
 
                         res
                     };

crates/steel-core/src/primitives.rs

@@ -28,6 +28,7 @@ pub use lists::UnRecoverableResult;
 
 use crate::values::closed::HeapRef;
 use crate::values::lists::List;
+use crate::values::structs::UserDefinedStruct;
 pub use control::ControlOperations;
 pub use fs::fs_module;
 pub use io::IoFunctions;
@@ -417,6 +418,22 @@ impl<'a, L: PrimitiveAsRef<'a>, R: PrimitiveAsRef<'a>> PrimitiveAsRef<'a> for Ei
     }
 }
 
+impl<'a> PrimitiveAsRef<'a> for &'a UserDefinedStruct {
+    fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result<Self> {
+        Self::maybe_primitive_as_ref(val).ok_or_else(
+            crate::throw!(ConversionError => format!("Cannot convert value to struct: {}", val)),
+        )
+    }
+
+    fn maybe_primitive_as_ref(val: &'a SteelVal) -> Option<Self> {
+        if let SteelVal::CustomStruct(s) = val {
+            Some(s)
+        } else {
+            None
+        }
+    }
+}
+
 impl<'a> PrimitiveAsRef<'a> for &'a Gc<RefCell<SteelVal>> {
     #[inline(always)]
     fn primitive_as_ref(val: &'a SteelVal) -> crate::rvals::Result<Self> {

crates/steel-core/src/rvals.rs

@@ -546,6 +546,7 @@ impl<T: CustomType + 'static> AsRefMutSteelVal for T {
 impl ast::TryFromSteelValVisitorForExprKind {
     pub fn visit_syntax_object(&mut self, value: &Syntax) -> Result<ExprKind> {
         let span = value.span;
+        // dbg!(&span);
         // let source = self.source.clone();
         match &value.syntax {
             // Mutual recursion case

crates/steel-core/src/scheme/kernel.scm

@@ -109,7 +109,10 @@
       ; (displayln raw)
       (if (empty? raw) raw (map syntax->datum raw))))
 
-  (struct-impl struct-name fields options))
+  (define result (struct-impl struct-name fields options))
+
+  (syntax/loc result
+    (syntax-span expr)))
 
 ;; Macro for creating a new struct, in the form of:
 ;; `(struct <struct-name> (fields ...) options ...)`