From c467d45fe7a3e735f1adaedffee2521a7dace221 Mon Sep 17 00:00:00 2001
From: Markus Westerlind <marwes91@gmail.com>
Date: Wed, 19 Aug 2020 09:41:23 +0200
Subject: [PATCH] fix: Prevent zero-argument functions from being created in
 Rust

These cannot be called from the gluon side, instead a one argument
function that takes `()` should be used.

Fixes #873
---
 check/tests/pass.rs    | 47 ++++++++++++++++++++++++++++++++++++++++++
 vm/src/api/function.rs | 36 +++++++++++++++++++-------------
 2 files changed, 69 insertions(+), 14 deletions(-)

diff --git a/check/tests/pass.rs b/check/tests/pass.rs
index f230cc4f5f..8e5d8a0bb6 100644
--- a/check/tests/pass.rs
+++ b/check/tests/pass.rs
@@ -1135,3 +1135,50 @@ match writer with
     "#,
     "test.List String"
 }
+
+test_check! {
+    issue_842,
+    r#"
+type Digit a =
+    | One a
+    | Two a a
+    | Three a a a
+    | Four a a a a
+
+type Node b =
+    | Node2 b b
+    | Node3 b b b
+
+type FingerTree c =
+    | Empty
+    | Single c
+    | Deep (Digit c) (FingerTree (Node c)) (Digit c)
+
+type View d =
+    | Nil
+    | View d (FingerTree d)
+
+rec
+let viewl xs : FingerTree e -> View e =
+    match xs with
+    | Empty -> Nil
+    | Single x -> View x Empty
+    | Deep (One a) deeper suffix ->
+        match viewl deeper with
+        | View (Node2 b c) rest -> View a (Deep (Two b c) rest suffix)
+        | View (Node3 b c d) rest -> View a (Deep (Three b c d) rest suffix)
+        | Nil ->
+            match suffix with
+            | One w -> View a (Single w)
+            | Two w x -> View a (Deep (One w) Empty (One x))
+            | Three w x y -> View a (Deep (Two w x) Empty (One y))
+            | Four w x y z -> View a (Deep (Three w x y) Empty (One z))
+    | Deep (Two a b) deeper suffix -> View a (Deep (One b) deeper suffix)
+    | Deep (Three a b c) deeper suffix -> View a (Deep (Two b c) deeper suffix)
+    | Deep (Four a b c d) deeper suffix -> View a (Deep (Three b c d) deeper suffix)
+in
+
+viewl
+    "#,
+    "test.List String"
+}
diff --git a/vm/src/api/function.rs b/vm/src/api/function.rs
index aea36deb06..e48f29538d 100644
--- a/vm/src/api/function.rs
+++ b/vm/src/api/function.rs
@@ -270,11 +270,11 @@ where
 }
 
 macro_rules! vm_function_impl {
-    ([$($f:tt)*] $($args:ident),*) => {
+    ([$($f:tt)*] $($args:ident),* -> $ret: ident, $ret_ty: ty) => {
 
-impl <'vm, $($args,)* R> VmFunction<'vm> for $($f)* ($($args),*) -> R
+impl <'vm, $($args,)* $ret> VmFunction<'vm> for $($f)* ($($args),*) -> $ret_ty
 where $($args: Getable<'vm, 'vm> + 'vm,)*
-      R: AsyncPushable<'vm> + VmType + 'vm
+      $ret: AsyncPushable<'vm> + VmType + 'vm
 {
     #[allow(non_snake_case, unused_mut, unused_assignments, unused_variables, unused_unsafe)]
     fn unpack_and_call(&self, vm: &'vm Thread) -> Status {
@@ -341,35 +341,43 @@ where
 }
 
 macro_rules! make_vm_function {
-    ($($args:ident),*) => (
-impl <$($args: VmType,)* R: VmType> VmType for fn ($($args),*) -> R {
+    ($($args:ident),*) => {
+        make_vm_function_inner!($($args),* -> R, R);
+    }
+}
+macro_rules! make_vm_function_inner {
+    ($($args:ident),* -> $ret: ident, $ret_ty: ty) => (
+impl <$($args: VmType,)* $ret: VmType> VmType for fn ($($args),*) -> $ret_ty
+where
+    <$ret_ty as VmType>::Type: Sized,
+{
     #[allow(non_snake_case)]
-    type Type = fn ($($args::Type),*) -> R::Type;
+    type Type = fn ($($args::Type),*) -> <$ret_ty as VmType>::Type;
 
     #[allow(non_snake_case)]
     fn make_type(vm: &Thread) -> ArcType {
         let args = vec![$(make_type::<$args>(vm)),*];
-        vm.global_env().type_cache().function(args, make_type::<R>(vm))
+        vm.global_env().type_cache().function(args, make_type::<$ret_ty>(vm))
     }
 }
 
-vm_function_impl!([fn] $($args),*);
-vm_function_impl!([dyn Fn] $($args),*);
+vm_function_impl!([fn] $($args),* -> $ret, $ret_ty);
+vm_function_impl!([dyn Fn] $($args),* -> $ret, $ret_ty);
 
-impl <'vm, $($args,)* R: VmType> FunctionType for fn ($($args),*) -> R {
+impl <'vm, $($args,)* $ret: VmType> FunctionType for fn ($($args),*) -> R {
     fn arguments() -> VmIndex {
         count!($($args),*) + R::EXTRA_ARGS
     }
 }
 
-impl <'s, $($args,)* R: VmType> FunctionType for dyn Fn($($args),*) -> R + 's {
+impl <'s, $($args,)* $ret: VmType> FunctionType for dyn Fn($($args),*) -> R + 's {
     fn arguments() -> VmIndex {
         count!($($args),*) + R::EXTRA_ARGS
     }
 }
 
-impl <'s, $($args: VmType,)* R: VmType> VmType for dyn Fn($($args),*) -> R + 's {
-    type Type = fn ($($args::Type),*) -> R::Type;
+impl <'s, $($args: VmType,)* $ret: VmType> VmType for dyn Fn($($args),*) -> R + 's {
+    type Type = fn ($($args::Type),*) -> $ret::Type;
 
     #[allow(non_snake_case)]
     fn make_type(vm: &Thread) -> ArcType {
@@ -444,7 +452,7 @@ impl<T, $($args,)* R> Function<T, fn($($args),*) -> R>
     )
 }
 
-make_vm_function!();
+make_vm_function_inner!( -> R, crate::api::IO<R>);
 make_vm_function!(A);
 make_vm_function!(A, B);
 make_vm_function!(A, B, C);