From d7f72785ef47d79c9ab63acb2880268bfab01b1d Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Sun, 29 Oct 2023 17:51:08 +0200 Subject: [PATCH 1/6] Implement foreign definitions for `Data.Array.NonEmpty` --- src/Data/Array/NonEmpty/Internal.ss | 37 +++++++++++++++++++++++++++++ test/Test/Data/Array/NonEmpty.purs | 4 ++-- test/Test/Main.purs | 4 ++-- 3 files changed, 41 insertions(+), 4 deletions(-) create mode 100644 src/Data/Array/NonEmpty/Internal.ss diff --git a/src/Data/Array/NonEmpty/Internal.ss b/src/Data/Array/NonEmpty/Internal.ss new file mode 100644 index 00000000..3f06b527 --- /dev/null +++ b/src/Data/Array/NonEmpty/Internal.ss @@ -0,0 +1,37 @@ +(library (Data.Array.NonEmpty.Internal foreign) + (export foldr1Impl + foldl1Impl + traverse1Impl) + (import (only (rnrs base) define lambda cons let if) + (only (chezscheme) fx- fx< fx>= fx+) + (prefix (purs runtime lib) rt:) + (prefix (purs runtime srfi :214) srfi:214:)) + + (define foldr1Impl + (lambda (f xs) + (let loop ([acc (srfi:214:flexvector-back xs)] + [i (fx- (rt:array-length xs) 2)]) + (if (fx>= i 0) + (loop ((f (rt:array-ref xs i)) acc) (fx- i 1)) + acc)))) + + (define foldl1Impl + (lambda (f xs) + (let loop ([acc (rt:array-ref xs 0)] [i 1]) + (if (fx< i (rt:array-length xs)) + (loop ((f acc) (rt:array-ref xs i)) (fx+ i 1)) + acc)))) + + (define traverse1Impl + (lambda (apply map f) + + (define kons (lambda (x) (lambda (ys) (cons x ys)))) + (define singleton (lambda (x) (cons x '()))) + + (lambda (array) + ((map srfi:214:list->flexvector) + (srfi:214:flexvector-fold-right + (lambda (s x) ((apply ((map kons) (f x))) s)) + ((map singleton) (f (srfi:214:flexvector-back array))) + (srfi:214:flexvector-copy array 0 (fx- (rt:array-length array) 1))))))) +) diff --git a/test/Test/Data/Array/NonEmpty.purs b/test/Test/Data/Array/NonEmpty.purs index 0ee98550..da3b909b 100644 --- a/test/Test/Data/Array/NonEmpty.purs +++ b/test/Test/Data/Array/NonEmpty.purs @@ -19,7 +19,7 @@ import Effect (Effect) import Effect.Console (log) import Partial.Unsafe (unsafePartial) import Test.Assert (assert) -import Test.Data.UndefinedOr (defined, undefined) +-- import Test.Data.UndefinedOr (defined, undefined) testNonEmptyArray :: Effect Unit testNonEmptyArray = do @@ -247,7 +247,7 @@ testNonEmptyArray = do log "sort should reorder a list into ascending order based on the result of compare" assert $ NEA.sort (fromArray [1, 3, 2, 5, 6, 4]) == fromArray [1, 2, 3, 4, 5, 6] - assert $ NEA.sort (fromArray [defined 1, undefined, defined 2]) == fromArray [undefined, defined 1, defined 2] + -- assert $ NEA.sort (fromArray [defined 1, undefined, defined 2]) == fromArray [undefined, defined 1, defined 2] log "sortBy should reorder a list into ascending order based on the result of a comparison function" assert $ NEA.sortBy (flip compare) (fromArray [1, 3, 2, 5, 6, 4]) == fromArray [6, 5, 4, 3, 2, 1] diff --git a/test/Test/Main.purs b/test/Test/Main.purs index be733b68..86c40291 100644 --- a/test/Test/Main.purs +++ b/test/Test/Main.purs @@ -7,7 +7,7 @@ import Test.Data.Array (testArray) import Test.Data.Array.Partial (testArrayPartial) import Test.Data.Array.ST (testArrayST) import Test.Data.Array.ST.Partial (testArraySTPartial) --- import Test.Data.Array.NonEmpty (testNonEmptyArray) +import Test.Data.Array.NonEmpty (testNonEmptyArray) main :: Effect Unit main = do @@ -15,4 +15,4 @@ main = do testArrayST testArrayPartial testArraySTPartial - -- testNonEmptyArray + testNonEmptyArray From 4f6938cae04d9f04a9c3c8a035e8e8fc3e06718f Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Sun, 29 Oct 2023 17:52:32 +0200 Subject: [PATCH 2/6] Remove `UndefinedOr` test module --- test/Test/Data/UndefinedOr.js | 31 ------------------------------- test/Test/Data/UndefinedOr.purs | 17 ----------------- 2 files changed, 48 deletions(-) delete mode 100644 test/Test/Data/UndefinedOr.js delete mode 100644 test/Test/Data/UndefinedOr.purs diff --git a/test/Test/Data/UndefinedOr.js b/test/Test/Data/UndefinedOr.js deleted file mode 100644 index 18017cb2..00000000 --- a/test/Test/Data/UndefinedOr.js +++ /dev/null @@ -1,31 +0,0 @@ -const undefinedImpl = undefined; -export {undefinedImpl as undefined}; - -export function defined(x) { - return x; -} - -export function eqUndefinedOrImpl(eq) { - return function (a) { - return function (b) { - return (a === undefined && b === undefined) || eq(a)(b); - }; - }; -} - -export function compareUndefinedOrImpl(lt) { - return function (eq) { - return function (gt) { - return function (compare) { - return function (a) { - return function (b) { - if (a === undefined && b === undefined) return eq; - if (a === undefined) return lt; - if (b === undefined) return gt; - return compare(a)(b); - }; - }; - }; - }; - }; -} diff --git a/test/Test/Data/UndefinedOr.purs b/test/Test/Data/UndefinedOr.purs deleted file mode 100644 index 18c2e3b7..00000000 --- a/test/Test/Data/UndefinedOr.purs +++ /dev/null @@ -1,17 +0,0 @@ -module Test.Data.UndefinedOr where - -import Prelude - -foreign import data UndefinedOr :: Type -> Type - -foreign import undefined :: forall a. UndefinedOr a -foreign import defined :: forall a. a -> UndefinedOr a - -foreign import eqUndefinedOrImpl :: forall a. (a -> a -> Boolean) -> UndefinedOr a -> UndefinedOr a -> Boolean -foreign import compareUndefinedOrImpl :: forall a. Ordering -> Ordering -> Ordering -> (a -> a -> Ordering) -> UndefinedOr a -> UndefinedOr a -> Ordering - -instance eqUndefinedOr :: Eq a => Eq (UndefinedOr a) where - eq = eqUndefinedOrImpl eq - -instance ordUndefinedOr :: Ord a => Ord (UndefinedOr a) where - compare = compareUndefinedOrImpl LT EQ GT compare From 1f6d2887c20ef9b39defb73314a716f5ba1137a0 Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Sun, 29 Oct 2023 17:59:10 +0200 Subject: [PATCH 3/6] Import `quote` --- src/Data/Array/NonEmpty/Internal.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/NonEmpty/Internal.ss b/src/Data/Array/NonEmpty/Internal.ss index 3f06b527..9f1f6833 100644 --- a/src/Data/Array/NonEmpty/Internal.ss +++ b/src/Data/Array/NonEmpty/Internal.ss @@ -2,7 +2,7 @@ (export foldr1Impl foldl1Impl traverse1Impl) - (import (only (rnrs base) define lambda cons let if) + (import (only (rnrs base) define lambda cons let if quote) (only (chezscheme) fx- fx< fx>= fx+) (prefix (purs runtime lib) rt:) (prefix (purs runtime srfi :214) srfi:214:)) From d18f0731770146425362126357c61f6b27b6e205 Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Mon, 30 Oct 2023 07:13:33 +0200 Subject: [PATCH 4/6] Use `list` --- src/Data/Array/NonEmpty/Internal.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Array/NonEmpty/Internal.ss b/src/Data/Array/NonEmpty/Internal.ss index 9f1f6833..3e1e5055 100644 --- a/src/Data/Array/NonEmpty/Internal.ss +++ b/src/Data/Array/NonEmpty/Internal.ss @@ -2,7 +2,7 @@ (export foldr1Impl foldl1Impl traverse1Impl) - (import (only (rnrs base) define lambda cons let if quote) + (import (only (rnrs base) define lambda list cons let if quote) (only (chezscheme) fx- fx< fx>= fx+) (prefix (purs runtime lib) rt:) (prefix (purs runtime srfi :214) srfi:214:)) @@ -26,12 +26,11 @@ (lambda (apply map f) (define kons (lambda (x) (lambda (ys) (cons x ys)))) - (define singleton (lambda (x) (cons x '()))) (lambda (array) ((map srfi:214:list->flexvector) (srfi:214:flexvector-fold-right (lambda (s x) ((apply ((map kons) (f x))) s)) - ((map singleton) (f (srfi:214:flexvector-back array))) + ((map list) (f (srfi:214:flexvector-back array))) (srfi:214:flexvector-copy array 0 (fx- (rt:array-length array) 1))))))) ) From d41cf776869e1d0351bb396517f1eaf4083a60d2 Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Mon, 30 Oct 2023 07:18:45 +0200 Subject: [PATCH 5/6] Use increment functions --- src/Data/Array/NonEmpty/Internal.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Data/Array/NonEmpty/Internal.ss b/src/Data/Array/NonEmpty/Internal.ss index 3e1e5055..6843728d 100644 --- a/src/Data/Array/NonEmpty/Internal.ss +++ b/src/Data/Array/NonEmpty/Internal.ss @@ -3,7 +3,7 @@ foldl1Impl traverse1Impl) (import (only (rnrs base) define lambda list cons let if quote) - (only (chezscheme) fx- fx< fx>= fx+) + (only (chezscheme) fx- fx< fx>= fx1- fx1+) (prefix (purs runtime lib) rt:) (prefix (purs runtime srfi :214) srfi:214:)) @@ -12,14 +12,14 @@ (let loop ([acc (srfi:214:flexvector-back xs)] [i (fx- (rt:array-length xs) 2)]) (if (fx>= i 0) - (loop ((f (rt:array-ref xs i)) acc) (fx- i 1)) + (loop ((f (rt:array-ref xs i)) acc) (fx1- i)) acc)))) (define foldl1Impl (lambda (f xs) (let loop ([acc (rt:array-ref xs 0)] [i 1]) (if (fx< i (rt:array-length xs)) - (loop ((f acc) (rt:array-ref xs i)) (fx+ i 1)) + (loop ((f acc) (rt:array-ref xs i)) (fx1+ i)) acc)))) (define traverse1Impl @@ -32,5 +32,5 @@ (srfi:214:flexvector-fold-right (lambda (s x) ((apply ((map kons) (f x))) s)) ((map list) (f (srfi:214:flexvector-back array))) - (srfi:214:flexvector-copy array 0 (fx- (rt:array-length array) 1))))))) + (srfi:214:flexvector-copy array 0 (fx1- (rt:array-length array)))))))) ) From 4d841c807f5ff2abbf7271afd1854adf1881543b Mon Sep 17 00:00:00 2001 From: Antti Holvikari Date: Mon, 30 Oct 2023 11:31:47 +0200 Subject: [PATCH 6/6] No need to import `quote` --- src/Data/Array/NonEmpty/Internal.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Array/NonEmpty/Internal.ss b/src/Data/Array/NonEmpty/Internal.ss index 6843728d..d747beb8 100644 --- a/src/Data/Array/NonEmpty/Internal.ss +++ b/src/Data/Array/NonEmpty/Internal.ss @@ -2,7 +2,7 @@ (export foldr1Impl foldl1Impl traverse1Impl) - (import (only (rnrs base) define lambda list cons let if quote) + (import (only (rnrs base) define lambda list cons let if) (only (chezscheme) fx- fx< fx>= fx1- fx1+) (prefix (purs runtime lib) rt:) (prefix (purs runtime srfi :214) srfi:214:))