diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +## Unreleased + +- Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,11 @@ +Copyright 2023-2024 Mitchell Rosen, Travis Staton + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# `queues` + +[![GitHub CI](https://github.com/awkward-squad/queues/workflows/Haskell-CI/badge.svg)](https://github.com/awkward-squad/queues/actions) +[![Hackage](https://img.shields.io/hackage/v/queues.svg)](https://hackage.haskell.org/package/queues) +[![Stackage LTS](https://stackage.org/package/queues/badge/lts)](https://www.stackage.org/lts/package/queues) +[![Stackage Nightly](https://stackage.org/package/queues/badge/nightly)](https://www.stackage.org/nightly/package/queues) +[![Dependencies](https://img.shields.io/hackage-deps/v/queues)](https://packdeps.haskellers.com/reverse/queues) diff --git a/bench/ephemeral-queue/Main.hs b/bench/ephemeral-queue/Main.hs new file mode 100644 --- /dev/null +++ b/bench/ephemeral-queue/Main.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module Main (main) where + +import Queue.Ephemeral (EphemeralQueue) +import Queue.Ephemeral qualified +import Test.Tasty.Bench (bench, defaultMain, whnf) + +main :: IO () +main = do + let n = 100000 :: Int + defaultMain [bench "EphemeralQueue" (whnf theBenchmark n)] + +theBenchmark :: Int -> Int +theBenchmark num = + loop1 0 0 (Queue.Ephemeral.enqueue 0 Queue.Ephemeral.empty) + where + loop1 :: Int -> Int -> EphemeralQueue Int -> Int + loop1 !n !acc queue + | n == num = loop2 acc queue + | otherwise = + case Queue.Ephemeral.dequeue queue of + Just (m, queue') -> loop1 (n + 1) (acc + m) (Queue.Ephemeral.enqueue n (Queue.Ephemeral.enqueue (n + 1) queue')) + + loop2 :: Int -> EphemeralQueue Int -> Int + loop2 !n queue = + case Queue.Ephemeral.dequeue queue of + Nothing -> n + Just (m, queue') -> loop2 (n + m) queue' diff --git a/bench/real-time-queue/Main.hs b/bench/real-time-queue/Main.hs new file mode 100644 --- /dev/null +++ b/bench/real-time-queue/Main.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module Main (main) where + +import Queue (Queue) +import Queue qualified +import Test.Tasty.Bench (bench, defaultMain, whnf) + +main :: IO () +main = do + let n = 100000 :: Int + defaultMain [bench "Queue" (whnf theBenchmark n)] + +theBenchmark :: Int -> Int +theBenchmark num = + loop1 0 0 (Queue.enqueue 0 Queue.empty) + where + loop1 :: Int -> Int -> Queue Int -> Int + loop1 !n !acc queue + | n == num = loop2 acc queue + | otherwise = + case Queue.dequeue queue of + Just (m, queue') -> loop1 (n + 1) (acc + m) (Queue.enqueue n (Queue.enqueue (n + 1) queue')) + + loop2 :: Int -> Queue Int -> Int + loop2 !n queue = + case Queue.dequeue queue of + Nothing -> n + Just (m, queue') -> loop2 (n + m) queue' diff --git a/bench/sequence-queue/Main.hs b/bench/sequence-queue/Main.hs new file mode 100644 --- /dev/null +++ b/bench/sequence-queue/Main.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} + +module Main (main) where + +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Test.Tasty.Bench (bench, defaultMain, whnf) + +main :: IO () +main = do + let n = 100000 :: Int + defaultMain [bench "Seq" (whnf theBenchmark n)] + +theBenchmark :: Int -> Int +theBenchmark num = + loop1 0 0 (Seq.empty Seq.|> 0) + where + loop1 :: Int -> Int -> Seq Int -> Int + loop1 !n !acc queue + | n == num = loop2 acc queue + | otherwise = + case queue of + m Seq.:<| queue' -> loop1 (n + 1) (acc + m) ((queue' Seq.|> (n + 1)) Seq.|> n) + + loop2 :: Int -> Seq Int -> Int + loop2 !n = \case + Seq.Empty -> n + m Seq.:<| queue' -> loop2 (n + m) queue' diff --git a/queues.cabal b/queues.cabal new file mode 100644 --- /dev/null +++ b/queues.cabal @@ -0,0 +1,149 @@ +cabal-version: 2.2 + +author: Mitchell Rosen, Travis Staton +bug-reports: https://github.com/awkward-squad/queues/issues +category: Data +copyright: Copyright (C) 2023-2024 Mitchell Rosen, Travis Staton +homepage: https://github.com/awkward-squad/queues +license: BSD-3-Clause +license-file: LICENSE +maintainer: Mitchell Rosen , Travis Staton +name: queues +synopsis: Queue data structures. +tested-with: GHC == 9.4.8, GHC == 9.6.4, GHC == 9.8.2 +version: 1.0.0 + +description: + Queue data structures, as described in + . + * Okasaki, Chris. "Simple and efficient purely functional queues and deques." /Journal of functional programming/ 5.4 (1995): 583-592. + * Okasaki, Chris. /Purely Functional Data Structures/. Diss. Princeton University, 1996. + . + A queue has a \"back\" where new elements are enqueued, and a \"front\" where elements are dequeued in the order that + they were enqueued (last in, first out). + . + The queues provided in this library also support an \"enqueue at front\" operation, because the underlying + representations happen to support it, so you might technically refer to these data structures as + /output-restricted deques/. + . + In this library, it is helpful to think of the \"front\" being on the /left/, because (though the direction is + arbitrary) we are consistent throughout, where it matters: + . + * List conversion functions associate the head of a list with the front of a queue. + * The append operator @xs <> ys@ creates a queue with @xs@ in front of @ys@. + * The `Show` instances draw the front of the queue on the left. + . + Under \"ephemeral\" (or \"single-threaded\", or \"linear\") usage, wherein one does not need to refer to an old + version of a data structure after mutating it: + . + * @EphemeralQueue@ is __2.5x faster__ than and __allocates 0.50x as much__ memory as @Queue@. + * @Queue@ is __2.6x faster__ than and __allocates 0.40x as much__ memory as @Seq@ (from @containers@). + . + (These numbers vary from benchmark to benchmark and machine to machine. Always perform your own experiments!) + . + While it is certainly common to use a queue ephemerally, it is unusual for a Haskell data structure to require + ephemeral usage to achieve its stated bounds. A refactoring or change in requirements might cause surprising changes + in performance. That is why @EphemeralQueue@ has a longer name and module name. When in doubt, use @Queue@. + +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/awkward-squad/queues.git + +common component + default-extensions: + BangPatterns + BlockArguments + ConstraintKinds + DataKinds + DeriveFunctor + DerivingStrategies + DuplicateRecordFields + ExistentialQuantification + GeneralizedNewtypeDeriving + ImportQualifiedPost + InstanceSigs + LambdaCase + NamedFieldPuns + OverloadedStrings + PatternSynonyms + QuantifiedConstraints + RankNTypes + ScopedTypeVariables + StandaloneKindSignatures + TypeOperators + ViewPatterns + default-language: Haskell2010 + ghc-options: + -Weverything + -Wno-all-missed-specialisations + -Wno-implicit-prelude + -Wno-missed-specialisations + -Wno-missing-import-lists + -Wno-missing-safe-haskell-mode + -Wno-prepositive-qualified-module + -Wno-safe + -Wno-unsafe + if impl(ghc >= 9.2) + ghc-options: + -Wno-missing-kind-signatures + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + +library + import: component + build-depends: + base ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19, + exposed-modules: + Queue + Queue.Ephemeral + hs-source-dirs: src + +test-suite test + import: component + build-depends: + base, + containers ^>= 0.6.7 || ^>= 0.7, + hedgehog ^>= 1.4, + queues, + ghc-options: -rtsopts -threaded "-with-rtsopts=-N4" + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + +benchmark bench-ephemeral-queue + import: component + build-depends: + base, + queues, + tasty-bench ^>= 0.3.5, + ghc-options: -fproc-alignment=64 -rtsopts -threaded + hs-source-dirs: bench/ephemeral-queue + main-is: Main.hs + type: exitcode-stdio-1.0 + +benchmark bench-real-time-queue + import: component + build-depends: + base, + queues, + tasty-bench ^>= 0.3.5, + ghc-options: -fproc-alignment=64 -rtsopts -threaded + hs-source-dirs: bench/real-time-queue + main-is: Main.hs + type: exitcode-stdio-1.0 + +benchmark bench-sequence-queue + import: component + build-depends: + base, + containers ^>= 0.6.7 || ^>= 0.7, + tasty-bench ^>= 0.3.5, + ghc-options: -fproc-alignment=64 -rtsopts -threaded + hs-source-dirs: bench/sequence-queue + main-is: Main.hs + type: exitcode-stdio-1.0 diff --git a/src/Queue.hs b/src/Queue.hs new file mode 100644 --- /dev/null +++ b/src/Queue.hs @@ -0,0 +1,226 @@ +-- | A queue data structure with \(\mathcal{O}(1)\) (worst-case) operations, as described in +-- +-- * Okasaki, Chris. \"Simple and efficient purely functional queues and deques.\" /Journal of functional programming/ 5.4 (1995): 583-592. +-- * Okasaki, Chris. /Purely Functional Data Structures/. Diss. Princeton University, 1996. +module Queue + ( -- * Queue + Queue (Empty, Full), + + -- ** Initialization + empty, + singleton, + fromList, + + -- * Basic interface + enqueue, + dequeue, + + -- ** Extended interface + enqueueFront, + + -- * Queries + isEmpty, + + -- * Transformations + map, + traverse, + + -- * Conversions + toList, + ) +where + +import Data.Foldable qualified as Foldable +import Data.List qualified as List +import Data.Traversable qualified as Traversable +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) +import Prelude hiding (foldMap, length, map, span, traverse) + +------------------------------------------------------------------------------------------------------------------------ +-- Queue type and instances + +-- | A queue data structure with \(\mathcal{O}(1)\) (worst-case) operations. +data Queue a + = Q + -- The front of the queue. + -- Invariant: not shorter than the back + [a] + -- The back of the queue, in reverse order. + [a] + -- Some tail of the front of the queue. + -- Invariant: length = length of front - length of back + Schedule + -- fmap loses exact sharing of front of queue and schedule, but the schedule still works, forcing cons cells of the + -- original front (before fmap) + deriving stock (Functor) + +instance (Eq a) => Eq (Queue a) where + (==) :: Queue a -> Queue a -> Bool + xs == ys = + Queue.toList xs == Queue.toList ys + +instance Foldable Queue where + foldMap :: (Monoid m) => (a -> m) -> Queue a -> m + foldMap f = + go + where + go = \case + Empty -> mempty + Full x xs -> f x <> go xs + + null :: Queue a -> Bool + null = + isEmpty + + toList :: Queue a -> [a] + toList = + Queue.toList + +instance Monoid (Queue a) where + mempty :: Queue a + mempty = + empty + +-- | \(\mathcal{O}(n)\), where \(n\) is the size of the second argument. +instance Semigroup (Queue a) where + (<>) :: Queue a -> Queue a -> Queue a + xs <> Empty = xs + xs <> Full y ys = enqueue y xs <> ys + +instance (Show a) => Show (Queue a) where + show :: Queue a -> String + show = + show . Queue.toList + +instance Traversable Queue where + traverse :: (Applicative f) => (a -> f b) -> Queue a -> f (Queue b) + traverse = + Queue.traverse + +------------------------------------------------------------------------------------------------------------------------ +-- Patterns + +-- | An empty queue. +pattern Empty :: Queue a +pattern Empty <- (dequeue -> Nothing) + +-- | The front of a queue, and the rest of it. +pattern Full :: a -> Queue a -> Queue a +pattern Full x xs <- (dequeue -> Just (x, xs)) + +{-# COMPLETE Empty, Full #-} + +------------------------------------------------------------------------------------------------------------------------ +-- Internal smart constructor utils + +-- `queue xs ys schedule` is always called when |schedule| = |xs| - |ys| + 1 (i.e. just after a enqueue or dequeue) +makeQueue :: [a] -> [a] -> Schedule -> Queue a +makeQueue xs ys = \case + Z -> Queue.fromList (rotate xs ys []) + S schedule -> Q xs ys schedule + +-- rotate xs ys zs = xs ++ reverse ys ++ zs +-- Precondition: |ys| = |xs| + 1 +rotate :: [a] -> NonEmptyList a -> [a] -> [a] +rotate [] (y :| _) zs = y : zs +rotate (x : xs) (y :| ys) zs = x : rotate xs ys (y : zs) + +------------------------------------------------------------------------------------------------------------------------ +-- Initialization + +-- | An empty queue. +empty :: Queue a +empty = + Q [] [] Z + +-- | A singleton queue. +singleton :: a -> Queue a +singleton x = + Queue.fromList [x] + +-- | \(\mathcal{O}(1)\). Construct a queue from a list. The head of the list corresponds to the front of the queue. +fromList :: [a] -> Queue a +fromList xs = + Q xs [] (unsafeCoerce xs) + +------------------------------------------------------------------------------------------------------------------------ +-- Basic interface + +-- | \(\mathcal{O}(1)\). Enqueue an element at the back of a queue, to be dequeued last. +enqueue :: a -> Queue a -> Queue a +enqueue y (Q xs ys schedule) = + makeQueue xs (y : ys) schedule + +-- | \(\mathcal{O}(1)\) front, \(\mathcal{O}(1)\) rest. Dequeue an element from the front of a queue. +dequeue :: Queue a -> Maybe (a, Queue a) +dequeue = \case + Q [] _ _ -> Nothing + Q (x : xs) ys schedule -> Just (x, makeQueue xs ys schedule) + +------------------------------------------------------------------------------------------------------------------------ +-- Extended interface + +-- | \(\mathcal{O}(1)\). Enqueue an element at the front of a queue, to be dequeued next. +enqueueFront :: a -> Queue a -> Queue a +enqueueFront x (Q xs ys schedule) = + -- smart constructor not needed here + -- we also add useless work to the schedule to maintain the convenient rotate-on-empty-schedule trigger + Q (x : xs) ys (unsafeCoerce x : schedule) + +------------------------------------------------------------------------------------------------------------------------ +-- Queries + +-- | \(\mathcal{O}(1)\). Is a queue empty? +isEmpty :: Queue a -> Bool +isEmpty = \case + Q [] _ _ -> True + _ -> False + +------------------------------------------------------------------------------------------------------------------------ +-- Transformations + +-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue. +map :: (a -> b) -> Queue a -> Queue b +map = + fmap + +-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue. +traverse :: (Applicative f) => (a -> f b) -> Queue a -> f (Queue b) +traverse f = + -- FIXME can we do better here? + fmap fromList . Traversable.traverse f . toList + +------------------------------------------------------------------------------------------------------------------------ +-- Conversions + +-- | \(\mathcal{O}(n)\). Construct a list from a queue. The head of the list corresponds to the front of the queue. +toList :: Queue a -> [a] +toList = + List.unfoldr dequeue + +------------------------------------------------------------------------------------------------------------------------ +-- Schedule utils + +type Schedule = + [Any] + +pattern Z :: Schedule +pattern Z = [] + +pattern S :: Schedule -> Schedule +pattern S xs <- _ : xs + +{-# COMPLETE Z, S #-} + +------------------------------------------------------------------------------------------------------------------------ +-- Non-empty list utils + +-- A list that we know is non-empty somehow. +type NonEmptyList a = + [a] + +pattern (:|) :: a -> [a] -> NonEmptyList a +pattern (:|) x xs = x : xs + +{-# COMPLETE (:|) #-} diff --git a/src/Queue/Ephemeral.hs b/src/Queue/Ephemeral.hs new file mode 100644 --- /dev/null +++ b/src/Queue/Ephemeral.hs @@ -0,0 +1,186 @@ +-- | A queue data structure with \(\mathcal{O}(1)^*\) (amortized under ephemeral usage only) operations, as described in +-- +-- * Okasaki, Chris. \"Simple and efficient purely functional queues and deques.\" /Journal of functional programming/ 5.4 (1995): 583-592. +-- * Okasaki, Chris. /Purely Functional Data Structures/. Diss. Princeton University, 1996. +module Queue.Ephemeral + ( -- * Ephemeral queue + EphemeralQueue (Empty, Full), + + -- ** Initialization + empty, + singleton, + fromList, + + -- * Basic interface + enqueue, + dequeue, + + -- ** Extended interface + enqueueFront, + + -- * Queries + isEmpty, + + -- * Transformations + map, + traverse, + + -- * Conversions + toList, + ) +where + +import Data.Foldable qualified as Foldable +import Data.List qualified as List +import Data.Traversable qualified as Traversable +import Prelude hiding (foldMap, length, map, span, traverse) + +------------------------------------------------------------------------------------------------------------------------ +-- Queue type and instances + +-- | A queue data structure with \(\mathcal{O}(1)^*\) (amortized under ephemeral usage only) operations. +data EphemeralQueue a + = Q [a] [a] + deriving stock (Functor) + +instance (Eq a) => Eq (EphemeralQueue a) where + (==) :: EphemeralQueue a -> EphemeralQueue a -> Bool + xs == ys = + Queue.Ephemeral.toList xs == Queue.Ephemeral.toList ys + +instance Foldable EphemeralQueue where + foldMap :: (Monoid m) => (a -> m) -> EphemeralQueue a -> m + foldMap f = + go + where + go = \case + Empty -> mempty + Full x xs -> f x <> go xs + + elem :: (Eq a) => a -> EphemeralQueue a -> Bool + elem x (Q xs ys) = + List.elem x xs || List.elem x ys + + null :: EphemeralQueue a -> Bool + null = + isEmpty + + toList :: EphemeralQueue a -> [a] + toList = + Queue.Ephemeral.toList + +instance Monoid (EphemeralQueue a) where + mempty :: EphemeralQueue a + mempty = + empty + +-- | \(\mathcal{O}(n)\), where \(n\) is the size of the second argument. +instance Semigroup (EphemeralQueue a) where + (<>) :: EphemeralQueue a -> EphemeralQueue a -> EphemeralQueue a + Q as bs <> Q cs ds = + Q as (ds ++ reverse cs ++ bs) + +instance (Show a) => Show (EphemeralQueue a) where + show :: EphemeralQueue a -> String + show = + show . Queue.Ephemeral.toList + +instance Traversable EphemeralQueue where + traverse :: (Applicative f) => (a -> f b) -> EphemeralQueue a -> f (EphemeralQueue b) + traverse = + Queue.Ephemeral.traverse + +------------------------------------------------------------------------------------------------------------------------ +-- Patterns + +-- | An empty queue. +pattern Empty :: EphemeralQueue a +pattern Empty <- (dequeue -> Nothing) + +-- | The front of a queue, and the rest of it. +pattern Full :: a -> EphemeralQueue a -> EphemeralQueue a +pattern Full x xs <- (dequeue -> Just (x, xs)) + +{-# COMPLETE Empty, Full #-} + +------------------------------------------------------------------------------------------------------------------------ +-- Initialization + +-- | An empty queue. +empty :: EphemeralQueue a +empty = + Q [] [] + +-- | A singleton queue. +singleton :: a -> EphemeralQueue a +singleton x = + Q [x] [] + +-- | \(\mathcal{O}(1)\). Construct a queue from a list. The head of the list corresponds to the front of the queue. +fromList :: [a] -> EphemeralQueue a +fromList xs = + Q xs [] + +------------------------------------------------------------------------------------------------------------------------ +-- Basic interface + +-- | \(\mathcal{O}(1)\). Enqueue an element at the back of a queue, to be dequeued last. +enqueue :: a -> EphemeralQueue a -> EphemeralQueue a +enqueue y (Q xs ys) = + Q xs (y : ys) + +-- | \(\mathcal{O}(1)^*\) front, \(\mathcal{O}(1)^*\) rest. Dequeue an element from the front of a queue. +dequeue :: EphemeralQueue a -> Maybe (a, EphemeralQueue a) +dequeue = \case + Q [] ys -> + case reverse ys of + [] -> Nothing + x : xs -> Just (x, Q xs []) + Q (x : xs) ys -> Just (x, Q xs ys) + +------------------------------------------------------------------------------------------------------------------------ +-- Extended interface + +-- | \(\mathcal{O}(1)\). Enqueue an element at the front of a queue, to be dequeued next. +enqueueFront :: a -> EphemeralQueue a -> EphemeralQueue a +enqueueFront x (Q xs ys) = + Q (x : xs) ys + +------------------------------------------------------------------------------------------------------------------------ +-- Queries + +-- | \(\mathcal{O}(1)\). Is a queue empty? +isEmpty :: EphemeralQueue a -> Bool +isEmpty = \case + Q [] [] -> True + _ -> False + +------------------------------------------------------------------------------------------------------------------------ +-- Transformations + +-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue. +map :: (a -> b) -> EphemeralQueue a -> EphemeralQueue b +map = + fmap + +-- | \(\mathcal{O}(n)\). Apply a function to every element in a queue. +traverse :: (Applicative f) => (a -> f b) -> EphemeralQueue a -> f (EphemeralQueue b) +traverse f (Q xs ys) = + Q + <$> Traversable.traverse f xs + <*> backwards ys + where + backwards = + go + where + go = \case + [] -> pure [] + z : zs -> flip (:) <$> go zs <*> f z + +------------------------------------------------------------------------------------------------------------------------ +-- Conversions + +-- | \(\mathcal{O}(n)\). Construct a list from a queue. The head of the list corresponds to the front of the queue. +toList :: EphemeralQueue a -> [a] +toList (Q xs ys) = + xs ++ reverse ys diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,207 @@ +module Main (main) where + +import Data.Bifunctor (second) +import Data.Foldable qualified as Foldable +import Data.Function ((&)) +import Data.List qualified as List +import Data.Sequence (Seq) +import Data.Sequence qualified as Seq +import Data.Word (Word8) +import Hedgehog + ( Gen, + Group (Group), + Property, + PropertyName, + PropertyT, + checkParallel, + forAll, + property, + withTests, + (===), annotateShow, + ) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Main qualified as Hedgehog (defaultMain) +import Hedgehog.Range qualified as Range +import Queue qualified +import Queue.Ephemeral (EphemeralQueue) +import Queue.Ephemeral qualified + +main :: IO () +main = do + Hedgehog.defaultMain + [ checkParallel (Group "tests" tests) + ] + +tests :: [(PropertyName, Property)] +tests = + [ ( "toList . fromList = id", + (withTests 200 . property) do + let test :: (Eq a, Show a) => Iface a -> [a] -> PropertyT IO () + test Iface {fromList, toList} list = + toList (fromList list) === list + list <- forAll generateList + test realTimeQueueIface list + test ephemeralQueueIface list + ), + ( "fromList (xs ++ ys) = fromList xs <> fromList ys", + (withTests 200 . property) do + let test :: (Eq a) => Iface a -> [a] -> [a] -> PropertyT IO () + test Iface {fromList} xs ys = + fromList (xs ++ ys) === fromList xs <> fromList ys + xs <- forAll generateList + ys <- forAll generateList + test realTimeQueueIface xs ys + test ephemeralQueueIface xs ys + ), + ( "toList (xs <> ys) = toList xs <> toList ys", + (withTests 200 . property) do + let test :: (Eq a, Show a) => Iface a -> [a] -> [a] -> PropertyT IO () + test Iface {fromList, toList} xs ys = + toList (fromList xs <> fromList ys) === (xs ++ ys) + xs <- forAll generateList + ys <- forAll generateList + test realTimeQueueIface xs ys + test ephemeralQueueIface xs ys + ), + ( "isEmpty empty = True", + (withTests 1 . property) do + let test :: Iface () -> PropertyT IO () + test Iface {isEmpty, empty} = + isEmpty empty === True + test realTimeQueueIface + test ephemeralQueueIface + ), + ( "isEmpty (singleton ()) = False", + (withTests 1 . property) do + let test :: Iface () -> PropertyT IO () + test Iface {isEmpty, singleton} = + isEmpty (singleton ()) === False + test realTimeQueueIface + test ephemeralQueueIface + ), + ( "EphemeralQueue: traverse traverses in order", + (withTests 1 . property) do + -- Make a queue that looks like: Q [1,2,3] [6,5,4] + let queue :: EphemeralQueue Int + queue = + Queue.Ephemeral.fromList [1, 2, 3] + & Queue.Ephemeral.enqueue 4 + & Queue.Ephemeral.enqueue 5 + & Queue.Ephemeral.enqueue 6 + annotateShow queue + let (elems, _) = Queue.Ephemeral.traverse (\x -> ([x], ())) queue + elems === [1, 2, 3, 4, 5, 6] + ), + ( "state machine tests", + (withTests 1 . property) do + actions <- forAll (generateQueueActions 1000) + let expected = applyQueueActions seqIface actions + applyQueueActions ephemeralQueueIface actions === expected + applyQueueActions realTimeQueueIface actions === expected + ) + ] + +------------------------------------------------------------------------------------------------------------------------ +-- Queue interface + +data Iface a = forall queue. + (Show (queue a), forall x. (Eq x) => Eq (queue x), forall x. Semigroup (queue x)) => + Iface + { dequeue :: queue a -> Maybe (a, queue a), + empty :: queue a, + enqueue :: a -> queue a -> queue a, + enqueueFront :: a -> queue a -> queue a, + isEmpty :: queue a -> Bool, + fromList :: [a] -> queue a, + singleton :: a -> queue a, + toList :: queue a -> [a] + } + +realTimeQueueIface :: (Show a) => Iface a +realTimeQueueIface = + Iface + Queue.dequeue + Queue.empty + Queue.enqueue + Queue.enqueueFront + Queue.isEmpty + Queue.fromList + Queue.singleton + Queue.toList + +ephemeralQueueIface :: (Show a) => Iface a +ephemeralQueueIface = + Iface + Queue.Ephemeral.dequeue + Queue.Ephemeral.empty + Queue.Ephemeral.enqueue + Queue.Ephemeral.enqueueFront + Queue.Ephemeral.isEmpty + Queue.Ephemeral.fromList + Queue.Ephemeral.singleton + Queue.Ephemeral.toList + +seqIface :: (Show a) => Iface a +seqIface = + Iface + seqDequeue + Seq.empty + seqEnqueue + seqEnqueueFront + Seq.null + Seq.fromList + Seq.singleton + Foldable.toList + where + seqEnqueue :: a -> Seq a -> Seq a + seqEnqueue = + flip (Seq.|>) + + seqDequeue :: Seq a -> Maybe (a, Seq a) + seqDequeue = \case + Seq.Empty -> Nothing + x Seq.:<| xs -> Just (x, xs) + + seqEnqueueFront :: a -> Seq a -> Seq a + seqEnqueueFront = + (Seq.<|) + +------------------------------------------------------------------------------------------------------------------------ +-- Generators + +generateList :: Gen [Word8] +generateList = + Gen.list (Range.linear 0 200) generateWord8 + +data QueueAction + = QueueActionEnqueue !Word8 + | QueueActionEnqueueFront !Word8 + | QueueActionDequeue + deriving stock (Show) + +generateQueueActions :: Int -> Gen [QueueAction] +generateQueueActions n = + Gen.list + (Range.linear 0 n) + ( Gen.frequency + [ (8, QueueActionEnqueue <$> generateWord8), + (2, QueueActionEnqueueFront <$> generateWord8), + (2, pure QueueActionDequeue) + ] + ) + +applyQueueActions :: Iface Word8 -> [QueueAction] -> ([Maybe Word8], [Word8]) +applyQueueActions Iface {empty, enqueue, dequeue, enqueueFront, toList} = + second toList . List.foldl' apply ([], empty) + where + apply (dequeues, queue) = \case + QueueActionEnqueue x -> (dequeues, enqueue x queue) + QueueActionEnqueueFront x -> (dequeues, enqueueFront x queue) + QueueActionDequeue -> + case dequeue queue of + Nothing -> (Nothing : dequeues, queue) + Just (x, queue1) -> (Just x : dequeues, queue1) + +generateWord8 :: Gen Word8 +generateWord8 = + Gen.word8 Range.constantBounded