compact-sequences 0.1.0.0 → 0.2.0.0

raw patch · 19 files changed

+1976/−463 lines, 19 filesdep +QuickCheckdep +compact-sequencesdep +mtldep −containersdep ~basedep ~primitivePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, compact-sequences, mtl, tasty, tasty-quickcheck

Dependencies removed: containers

Dependency ranges changed: base, primitive

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• compact-sequences.cabal +47/−10
• src/Data/CompactSequence/Deque/Internal.hs +649/−0
• src/Data/CompactSequence/Deque/Simple.hs +23/−0
• src/Data/CompactSequence/Deque/Simple/Internal.hs +165/−0
• src/Data/CompactSequence/Internal/Array.hs +41/−31
• src/Data/CompactSequence/Internal/Array/Safe.hs +2/−6
• src/Data/CompactSequence/Internal/Numbers.hs +63/−0
• src/Data/CompactSequence/Internal/Size.hs +107/−0
• src/Data/CompactSequence/Queue/Internal.hs +143/−86
• src/Data/CompactSequence/Queue/Simple.hs +5/−173
• src/Data/CompactSequence/Queue/Simple/Internal.hs +219/−0
• src/Data/CompactSequence/Stack/Internal.hs +9/−9
• src/Data/CompactSequence/Stack/Simple.hs +6/−144
• src/Data/CompactSequence/Stack/Simple/Internal.hs +173/−0
• test/Deque.hs +105/−0
• test/MyLibTest.hs +0/−4
• test/Queue.hs +107/−0
• test/Stack.hs +104/−0

@@ -1,5 +1,13 @@ # Revision history for compact-sequences +## 0.2.0.0 -- 2020-09-01++* Add deques.+* Change operator precedence.+* Add a test suite. Thanks to David Himmelstrup for setting up the test and CI framework.+* Clean up internals somewhat.+* Add a proof of amortized bounds for the stack implementation. Thanks, Li-Yao Xia.+ ## 0.1.0.0 -- 2020-08-11  * First version. Released on an unsuspecting world.

@@ -5,10 +5,10 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/  name:                compact-sequences-version:             0.1.0.0-synopsis: Stacks and queues with compact representations.+version:             0.2.0.0+synopsis: Stacks, queues, and deques with compact representations. description:-  Stacks and queues that take n + O(log n) space at the cost of+  Stacks, queues, and deques that take n + O(log n) space at the cost of   having amortized O(log n) time complexity for basic operations. bug-reports: https://github.com/treeowl/compact-sequences/issues homepage: https://github.com/treeowl/compact-sequences/@@ -16,7 +16,7 @@ license-file:        LICENSE author:              David Feuer maintainer:          David.Feuer@gmail.com-copyright: 2020 David Feuer+copyright:           2020 David Feuer category:            Data extra-source-files:  CHANGELOG.md @@ -26,23 +26,60 @@  library   exposed-modules: Data.CompactSequence.Stack.Simple+                 , Data.CompactSequence.Stack.Simple.Internal                  , Data.CompactSequence.Stack.Internal                  , Data.CompactSequence.Queue.Simple+                 , Data.CompactSequence.Queue.Simple.Internal                  , Data.CompactSequence.Queue.Internal+                 , Data.CompactSequence.Deque.Simple+                 , Data.CompactSequence.Deque.Simple.Internal+                 , Data.CompactSequence.Deque.Internal                  , Data.CompactSequence.Internal.Array+                 , Data.CompactSequence.Internal.Size+                 , Data.CompactSequence.Internal.Numbers                  , Data.CompactSequence.Internal.Array.Safe   -- other-modules:   -- other-extensions:-  build-depends:       base >=4.10.0.0 && < 5.0-                     , primitive-                     , containers+  build-depends:+                       -- Lower bound for Semigroup in the Prelude; we could adjust this.+                       base >=4.11.0.0 && < 5.0+                       -- Lower bound for runSmallArray+                     , primitive >= 0.6.4.0+                       -- We use these for State.+                     , mtl                      , transformers   hs-source-dirs:      src   default-language:    Haskell2010 -test-suite compact-sequences-test+test-suite stack-test   default-language:    Haskell2010   type:                exitcode-stdio-1.0   hs-source-dirs:      test-  main-is:             MyLibTest.hs-  build-depends:       base >=4.10.0.0+  main-is:             Stack.hs+  build-depends:       base >=4.10.0.0,+                       compact-sequences,+                       QuickCheck,+                       tasty,+                       tasty-quickcheck++test-suite queue-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Queue.hs+  build-depends:       base >=4.10.0.0,+                       compact-sequences,+                       QuickCheck,+                       tasty,+                       tasty-quickcheck++test-suite deque-test+  default-language:    Haskell2010+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Deque.hs+  build-depends:       base >=4.10.0.0,+                       compact-sequences,+                       QuickCheck,+                       tasty,+                       tasty-quickcheck

@@ -0,0 +1,649 @@+{-# language CPP #-}+{-# language BangPatterns, ScopedTypeVariables, UnboxedTuples, MagicHash #-}+{-# language DeriveTraversable, StandaloneDeriving #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language FlexibleContexts #-}+{- OPTIONS_GHC -Wall #-}+{- OPTIONS_GHC -ddump-simpl #-}++module Data.CompactSequence.Deque.Internal where+import qualified Data.CompactSequence.Internal.Array as A+import Data.CompactSequence.Internal.Array (Array)+import qualified Data.CompactSequence.Internal.Size as Sz+import Data.CompactSequence.Internal.Size (Size, Twice)+import qualified Data.CompactSequence.Internal.Numbers as N+import qualified Data.Foldable as F+import Control.Monad.Trans.State.Strict+import Data.Function (on)++data Deque n a+  = Empty+  | Shallow !(Array n a)+  | Deep11 !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a)+  | Deep12 !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a)+  | Deep13 !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a)+  | Deep14 !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a) !(Array n a)++  | Deep21 !(Array n a) !(Array n a) +           !(Deque (Twice n) a)+           !(Array n a)+  | Deep22 !(Array n a) !(Array n a) +           (Deque (Twice n) a)+           !(Array n a) !(Array n a) +  | Deep23 !(Array n a) !(Array n a) +           (Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a)+  | Deep24 !(Array n a) !(Array n a) +           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a) !(Array n a)++  | Deep31 !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a)+  | Deep32 !(Array n a) !(Array n a) !(Array n a)+           (Deque (Twice n) a)+           !(Array n a) !(Array n a) +  | Deep33 !(Array n a) !(Array n a) !(Array n a)+           (Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a)+  | Deep34 !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a) !(Array n a)++  | Deep41 !(Array n a) !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a)+  | Deep42 !(Array n a) !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) +  | Deep43 !(Array n a) !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a)+  | Deep44 !(Array n a) !(Array n a) !(Array n a) !(Array n a)+           !(Deque (Twice n) a)+           !(Array n a) !(Array n a) !(Array n a) !(Array n a)+  deriving (Functor, Foldable, Traversable)++instance Eq a => Eq (Deque n a) where+  (==) = (==) `on` F.toList++instance Ord a => Ord (Deque n a) where+  compare = compare `on` F.toList++empty :: Deque n a+empty = Empty++consA :: Size n -> Array n a -> Deque n a -> Deque n a+consA !_ !sa Empty = Shallow sa+consA !_ !sa1 (Shallow sa2) = Deep11 sa1 Empty sa2++consA !_ !x (Deep11 sa m ta)+  = Deep21 x sa m ta+consA !_ !x (Deep12 sa m ta1 ta2)+  = Deep22 x sa m ta1 ta2+consA !_ !x (Deep13 sa m ta1 ta2 ta3)+  = Deep23 x sa m ta1 ta2 ta3+consA !_ !x (Deep14 sa m ta1 ta2 ta3 ta4)+  = Deep24 x sa m ta1 ta2 ta3 ta4++consA !_ !x (Deep21 sa1 sa2 m ta)+  = Deep31 x sa1 sa2 m ta+consA !_ !x (Deep22 sa1 sa2 m ta1 ta2)+  = Deep32 x sa1 sa2 m ta1 ta2+consA !_ !x (Deep23 sa1 sa2 m ta1 ta2 ta3)+  = Deep33 x sa1 sa2 m ta1 ta2 ta3+consA !_ !x (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4)+  = Deep34 x sa1 sa2 m ta1 ta2 ta3 ta4++consA !_ !x (Deep31 sa1 sa2 sa3 m ta)+  = Deep41 x sa1 sa2 sa3 m ta+consA !_ !x (Deep32 sa1 sa2 sa3 m ta1 ta2)+  = Deep42 x sa1 sa2 sa3 m ta1 ta2+consA !_ !x (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3)+  = Deep43 x sa1 sa2 sa3 m ta1 ta2 ta3+consA !_ !x (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4)+  = Deep44 x sa1 sa2 sa3 m ta1 ta2 ta3 ta4++consA !n !x (Deep41 sa1 sa2 sa3 sa4 m ta)+  | ShiftedR m' me1 me2 <- shiftRA n sa3 sa4 m+  = Deep33 x sa1 sa2 m' me1 me2 ta+consA !n !x (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2)+  = Deep32 x sa1 sa2 (consA (Sz.twice n) (A.append n sa3 sa4) m) ta1 ta2+consA !n !x (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3)+  = Deep33 x sa1 sa2 (consA (Sz.twice n) (A.append n sa3 sa4) m) ta1 ta2 ta3+consA !n !x (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)+  = Deep32 x sa1 sa2 (consSnocA (Sz.twice n) (A.append n sa3 sa4) m (A.append n ta1 ta2)) ta3 ta4++snocA :: Size n -> Deque n a -> Array n a -> Deque n a+snocA !_ Empty x = Shallow x+snocA !_ (Shallow sa) x = Deep11 sa Empty x++snocA !_ (Deep11 sa m ta) x+  = Deep12 sa m ta x+snocA !_ (Deep21 sa1 sa2 m ta) x+  = Deep22 sa1 sa2 m ta x+snocA !_ (Deep31 sa1 sa2 sa3 m ta) x+  = Deep32 sa1 sa2 sa3 m ta x+snocA !_ (Deep41 sa1 sa2 sa3 sa4 m ta) x+  = Deep42 sa1 sa2 sa3 sa4 m ta x++snocA !_ (Deep12 sa m ta1 ta2) x+  = Deep13 sa m ta1 ta2 x+snocA !_ (Deep22 sa1 sa2 m ta1 ta2) x+  = Deep23 sa1 sa2 m ta1 ta2 x+snocA !_ (Deep32 sa1 sa2 sa3 m ta1 ta2) x+  = Deep33 sa1 sa2 sa3 m ta1 ta2 x+snocA !_ (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2) x+  = Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 x++snocA !_ (Deep13 sa m ta1 ta2 ta3) x+  = Deep14 sa m ta1 ta2 ta3 x+snocA !_ (Deep23 sa1 sa2 m ta1 ta2 ta3) x+  = Deep24 sa1 sa2 m ta1 ta2 ta3 x+snocA !_ (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3) x+  = Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 x+snocA !_ (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3) x+  = Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 x++snocA !n (Deep14 sa1 m ta1 ta2 ta3 ta4) x+  | ShiftedL mb1 mb2 m' <- shiftLA n m ta1 ta2+  = Deep33 sa1 mb1 mb2 m' ta3 ta4 x+snocA !n (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4) x+  = Deep23 sa1 sa2 (snocA (Sz.twice n) m (A.append n ta1 ta2)) ta3 ta4 x+snocA !n (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4) x+  = Deep33 sa1 sa2 sa3 (snocA (Sz.twice n) m (A.append n ta1 ta2)) ta3 ta4 x+snocA !n (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4) x+  = Deep23 sa1 sa2+           (consSnocA (Sz.twice n)+                      (A.append n sa3 sa4)+                      m+                      (A.append n ta1 ta2))+           ta3 ta4 x++data ViewL n a+  = EmptyL+  | ConsL !(Array n a) (Deque n a)++data ViewR n a+  = EmptyR+  | SnocR (Deque n a) !(Array n a)++viewLA :: Size n -> Deque n a -> ViewL n a+viewLA !_ Empty = EmptyL+viewLA !_ (Shallow sa) = ConsL sa Empty++viewLA !_ (Deep41 sa1 sa2 sa3 sa4 m ta1)+  = ConsL sa1 (Deep31 sa2 sa3 sa4 m ta1)+viewLA !_ (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2)+  = ConsL sa1 (Deep32 sa2 sa3 sa4 m ta1 ta2)+viewLA !_ (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3)+  = ConsL sa1 (Deep33 sa2 sa3 sa4 m ta1 ta2 ta3)+viewLA !_ (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)+  = ConsL sa1 (Deep34 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)++viewLA !_ (Deep31 sa1 sa2 sa3 m ta1)+  = ConsL sa1 (Deep21 sa2 sa3 m ta1)+viewLA !_ (Deep32 sa1 sa2 sa3 m ta1 ta2)+  = ConsL sa1 (Deep22 sa2 sa3 m ta1 ta2)+viewLA !_ (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3)+  = ConsL sa1 (Deep23 sa2 sa3 m ta1 ta2 ta3)+viewLA !_ (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4)+  = ConsL sa1 (Deep24 sa2 sa3 m ta1 ta2 ta3 ta4)++viewLA !_ (Deep21 sa1 sa2 m ta1)+  = ConsL sa1 (Deep11 sa2 m ta1)+viewLA !_ (Deep22 sa1 sa2 m ta1 ta2)+  = ConsL sa1 (Deep12 sa2 m ta1 ta2)+viewLA !_ (Deep23 sa1 sa2 m ta1 ta2 ta3)+  = ConsL sa1 (Deep13 sa2 m ta1 ta2 ta3)+viewLA !_ (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4)+  = ConsL sa1 (Deep14 sa2 m ta1 ta2 ta3 ta4)++viewLA !n (Deep11 sa1 m ta1)+  = ConsL sa1 $ case unconsUnsnocA (Sz.twice n) m of+      EmptyUCUS -> Shallow ta1+      OneUCUS mb+        | (mb1, mb2) <- A.splitArray n mb+        -> Deep21 mb1 mb2 Empty ta1+      UCUS mb m' me+        | (mb1, mb2) <- A.splitArray n mb+        , (me1, me2) <- A.splitArray n me+        -> Deep23 mb1 mb2 m' me1 me2 ta1+viewLA !n (Deep12 sa1 m ta1 ta2)+  = ConsL sa1 $ case viewLA (Sz.twice n) m of+      EmptyL -> Deep11 ta1 Empty ta2+      ConsL mb m'+        | (mb1, mb2) <- A.splitArray n mb+        -> Deep22 mb1 mb2 m' ta1 ta2+viewLA !n (Deep13 sa1 m ta1 ta2 ta3)+  = ConsL sa1 $ case viewLA (Sz.twice n) m of+      EmptyL -> Deep21 ta1 ta2 Empty ta3+      ConsL mb m'+        | (mb1, mb2) <- A.splitArray n mb+        -> Deep23 mb1 mb2 m' ta1 ta2 ta3+viewLA !n (Deep14 sa1 m ta1 ta2 ta3 ta4)+  = ConsL sa1 $ case shiftLA n m ta1 ta2 of+      ShiftedL mb1 mb2 m' -> Deep22 mb1 mb2 m' ta3 ta4++viewRA :: Size n -> Deque n a -> ViewR n a+viewRA !_ Empty = EmptyR+viewRA !_ (Shallow sa) = SnocR Empty sa++viewRA !_ (Deep14 sa1 m ta1 ta2 ta3 ta4)+  = SnocR (Deep13 sa1 m ta1 ta2 ta3) ta4+viewRA !_ (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4)+  = SnocR (Deep23 sa1 sa2 m ta1 ta2 ta3) ta4+viewRA !_ (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4)+  = SnocR (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3) ta4+viewRA !_ (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)+  = SnocR (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3) ta4++viewRA !_ (Deep13 sa1 m ta1 ta2 ta3)+  = SnocR (Deep12 sa1 m ta1 ta2) ta3+viewRA !_ (Deep23 sa1 sa2 m ta1 ta2 ta3)+  = SnocR (Deep22 sa1 sa2 m ta1 ta2) ta3+viewRA !_ (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3)+  = SnocR (Deep32 sa1 sa2 sa3 m ta1 ta2) ta3+viewRA !_ (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3)+  = SnocR (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2) ta3++viewRA !_ (Deep12 sa1 m ta1 ta2)+  = SnocR (Deep11 sa1 m ta1) ta2+viewRA !_ (Deep22 sa1 sa2 m ta1 ta2)+  = SnocR (Deep21 sa1 sa2 m ta1) ta2+viewRA !_ (Deep32 sa1 sa2 sa3 m ta1 ta2)+  = SnocR (Deep31 sa1 sa2 sa3 m ta1) ta2+viewRA !_ (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2)+  = SnocR (Deep41 sa1 sa2 sa3 sa4 m ta1) ta2++viewRA !n (Deep11 sa1 m ta1)+  = flip SnocR ta1 $ case unconsUnsnocA (Sz.twice n) m of+      EmptyUCUS -> Shallow sa1+      OneUCUS mb+        | (m1, m2) <- A.splitArray n mb+        -> Deep21 sa1 m1 Empty m2+      UCUS mb m' me+        | (mb1, mb2) <- A.splitArray n mb+        , (me1, me2) <- A.splitArray n me+        -> Deep32 sa1 mb1 mb2 m' me1 me2+viewRA !n (Deep21 sa1 sa2 m ta1)+  = flip SnocR ta1 $ case viewRA (Sz.twice n) m of+      EmptyR -> Deep11 sa1 Empty sa2+      SnocR m' me+        | (me1, me2) <- A.splitArray n me+        -> Deep22 sa1 sa2 m' me1 me2+viewRA !n (Deep31 sa1 sa2 sa3 m ta1)+  = flip SnocR ta1 $ case viewRA (Sz.twice n) m of+      EmptyR -> Deep21 sa1 sa2 Empty sa3+      SnocR m' me+        | (me1, me2) <- A.splitArray n me+        -> Deep32 sa1 sa2 sa3 m' me1 me2+viewRA !n (Deep41 sa1 sa2 sa3 sa4 m ta1)+  = flip SnocR ta1 $ case shiftRA n sa3 sa4 m of+      ShiftedR m' me1 me2 -> Deep22 sa1 sa2 m' me1 me2++data ShiftedL n a = ShiftedL !(Array n a) !(Array n a) (Deque (Twice n) a)+data ShiftedR n a = ShiftedR (Deque (Twice n) a) !(Array n a) !(Array n a)++shiftLA :: Size n -> Deque (Twice n) a -> Array n a -> Array n a -> ShiftedL n a+shiftLA !_ Empty !sa1 !sa2 = ShiftedL sa1 sa2 Empty+shiftLA !n (Shallow sa) !ta1 !ta2+  = shriftL n sa (Shallow (A.append n ta1 ta2))++shiftLA !n (Deep11 sa1 m ta1) !x !y+  = shriftL n sa1 $ case viewLA (Sz.twice (Sz.twice n)) m of+      EmptyL -> Deep11 ta1 Empty (A.append n x y)+      ConsL mb m'+        | (mb1, mb2) <- A.splitArray (Sz.twice n) mb+        -> Deep22 mb1 mb2 m' ta1 (A.append n x y)+shiftLA !n (Deep12 sa1 m ta1 ta2) !x !y+  = shriftL n sa1 $ case viewLA (Sz.twice (Sz.twice n)) m of+      EmptyL -> Deep21 ta1 ta2 Empty (A.append n x y)+      ConsL mb m'+        | (mb1, mb2) <- A.splitArray (Sz.twice n) mb+        -> Deep23 mb1 mb2 m' ta1 ta2 (A.append n x y)+shiftLA !n (Deep13 sa1 m ta1 ta2 ta3) !x !y+  = shriftL n sa1 $ case shiftLA (Sz.twice n) m ta1 ta2 of+      ShiftedL mb1 mb2 m' -> Deep22 mb1 mb2 m' ta3 (A.append n x y)+shiftLA !n (Deep14 sa1 m ta1 ta2 ta3 ta4) !x !y+  = shriftL n sa1 $ case shiftLA (Sz.twice n) m ta1 ta2 of+      ShiftedL mb1 mb2 m' -> Deep23 mb1 mb2 m' ta3 ta4 (A.append n x y)++shiftLA !n (Deep21 sa1 sa2 m ta1) !x !y+  = shriftL n sa1 $ Deep12 sa2 m ta1 (A.append n x y)+shiftLA !n (Deep22 sa1 sa2 m ta1 ta2) !x !y+  = shriftL n sa1 $ Deep13 sa2 m ta1 ta2 (A.append n x y)+shiftLA !n (Deep23 sa1 sa2 m ta1 ta2 ta3) !x !y+  = shriftL n sa1 $ Deep14 sa2 m ta1 ta2 ta3 (A.append n x y)+shiftLA !n (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4) !x !y+  = shriftL n sa1 $ case shiftLA (Sz.twice n) m ta1 ta2 of+      ShiftedL mb1 mb2 m' -> Deep33 sa2 mb1 mb2 m' ta3 ta4 (A.append n x y)++shiftLA !n (Deep31 sa1 sa2 sa3 m ta1) !x !y+  = shriftL n sa1 $ Deep22 sa2 sa3 m ta1 (A.append n x y)+shiftLA !n (Deep32 sa1 sa2 sa3 m ta1 ta2) !x !y+  = shriftL n sa1 $ Deep23 sa2 sa3 m ta1 ta2 (A.append n x y)+shiftLA !n (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3) !x !y+  = shriftL n sa1 $ Deep24 sa2 sa3 m ta1 ta2 ta3 (A.append n x y)+shiftLA !n (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4) !x !y+  = shriftL n sa1 $+      Deep23 sa2 sa3+             (snocA (Sz.twice (Sz.twice n)) m (A.append (Sz.twice n) ta1 ta2))+             ta3 ta4 (A.append n x y)++shiftLA !n (Deep41 sa1 sa2 sa3 sa4 m ta1) !x !y+  = shriftL n sa1 $ Deep32 sa2 sa3 sa4 m ta1 (A.append n x y)+shiftLA !n (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2) !x !y+  = shriftL n sa1 $ Deep33 sa2 sa3 sa4 m ta1 ta2 (A.append n x y)+shiftLA !n (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3) !x !y+  = shriftL n sa1 $ Deep34 sa2 sa3 sa4 m ta1 ta2 ta3 (A.append n x y)+shiftLA !n (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4) !x !y+  = shriftL n sa1 $+      Deep33 sa2 sa3 sa4+             (snocA (Sz.twice (Sz.twice n)) m (A.append (Sz.twice n) ta1 ta2))+             ta3 ta4 (A.append n x y)++shriftL :: Size n -> Array (Twice n) a -> Deque (Twice n) a -> ShiftedL n a+shriftL !n !sa d+  | (sa1, sa2) <- A.splitArray n sa+  = ShiftedL sa1 sa2 d++shiftRA :: Size n -> Array n a -> Array n a -> Deque (Twice n) a -> ShiftedR n a+shiftRA !_ !sa1 !sa2 Empty = ShiftedR Empty sa1 sa2+shiftRA n sa1 sa2 (Shallow ta)+  = shriftR n ta (Shallow (A.append n sa1 sa2))+shiftRA n x y (Deep11 sa1 m ta1)+  = shriftR n ta1 $ case viewRA (Sz.twice (Sz.twice n)) m of+      EmptyR -> Deep11 (A.append n x y) Empty sa1+      SnocR m' me+        | (me1, me2) <- A.splitArray (Sz.twice n) me+        -> Deep22 (A.append n x y) sa1 m' me1 me2+shiftRA n x y (Deep12 sa1 m ta1 ta2)+  = shriftR n ta2 $ Deep21 (A.append n x y) sa1 m ta1+shiftRA n x y (Deep13 sa1 m ta1 ta2 ta3)+  = shriftR n ta3 $ Deep22 (A.append n x y) sa1 m ta1 ta2+shiftRA n x y (Deep14 sa1 m ta1 ta2 ta3 ta4)+  = shriftR n ta4 $ Deep23 (A.append n x y) sa1 m ta1 ta2 ta3++shiftRA n x y (Deep21 sa1 sa2 m ta1)+  = shriftR n ta1 $ case viewRA (Sz.twice (Sz.twice n)) m of+      EmptyR -> Deep21 (A.append n x y) sa1 Empty sa2+      SnocR m' me+        | (me1, me2) <- A.splitArray (Sz.twice n) me+        -> Deep32 (A.append n x y) sa1 sa2 m' me1 me2+shiftRA n x y (Deep22 sa1 sa2 m ta1 ta2)+  = shriftR n ta2 $+      Deep31 (A.append n x y) sa1 sa2 m ta1+shiftRA n x y (Deep23 sa1 sa2 m ta1 ta2 ta3)+  = shriftR n ta3 $+      Deep32 (A.append n x y) sa1 sa2 m ta1 ta2+shiftRA n x y (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4)+  = shriftR n ta4 $+      Deep33 (A.append n x y) sa1 sa2 m ta1 ta2 ta3++shiftRA n x y (Deep31 sa1 sa2 sa3 m ta1)+  = shriftR n ta1 $ case shiftRA (Sz.twice n) sa2 sa3 m of+      ShiftedR m' me1 me2 -> Deep22 (A.append n x y) sa1 m' me1 me2+shiftRA n x y (Deep32 sa1 sa2 sa3 m ta1 ta2)+  = shriftR n ta2 $ Deep41 (A.append n x y) sa1 sa2 sa3 m ta1+shiftRA n x y (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3)+  = shriftR n ta3 $ Deep42 (A.append n x y) sa1 sa2 sa3 m ta1 ta2+shiftRA n x y (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4)+  = shriftR n ta4 $ Deep43 (A.append n x y) sa1 sa2 sa3 m ta1 ta2 ta3++shiftRA n x y (Deep41 sa1 sa2 sa3 sa4 m ta1)+  = shriftR n ta1 $ case shiftRA (Sz.twice n) sa3 sa4 m of+      ShiftedR m' me1 me2 -> Deep32 (A.append n x y) sa1 sa2 m' me1 me2+shiftRA n x y (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2)+  = shriftR n ta2 $ case shiftRA (Sz.twice n) sa3 sa4 m of+      ShiftedR m' me1 me2 -> Deep33 (A.append n x y) sa1 sa2 m' me1 me2 ta1+shiftRA n x y (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3)+  = shriftR n ta3 $+      Deep32 (A.append n x y) sa1 sa2+           (consA (Sz.twice (Sz.twice n)) (A.append (Sz.twice n) sa3 sa4) m)+           ta1 ta2+shiftRA n x y (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)+  = shriftR n ta4 $+      Deep33 (A.append n x y) sa1 sa2+           (consA (Sz.twice (Sz.twice n)) (A.append (Sz.twice n) sa3 sa4) m)+           ta1 ta2 ta3++shriftR :: Size n -> Array (Twice n) a -> Deque (Twice n) a -> ShiftedR n a+shriftR !n !sa d+  | (sa1, sa2) <- A.splitArray n sa+  = ShiftedR d sa1 sa2++consSnocA :: Size n -> Array n a -> Deque n a -> Array n a -> Deque n a+consSnocA !_ !sa1 Empty !sa2 = Deep11 sa1 Empty sa2+consSnocA !_ !sa1 (Shallow sa2) !sa3 = Deep21 sa1 sa2 Empty sa3+consSnocA !_ !x (Deep11 sa1 m ta1) !y+  = Deep22 x sa1 m ta1 y+consSnocA !_ !x (Deep12 sa1 m ta1 ta2) !y+  = Deep23 x sa1 m ta1 ta2 y+consSnocA !_ !x (Deep13 sa1 m ta1 ta2 ta3) !y+  = Deep24 x sa1 m ta1 ta2 ta3 y+consSnocA !n !x (Deep14 sa1 m ta1 ta2 ta3 ta4) !y+  = Deep23 x sa1 (snocA (Sz.twice n) m (A.append n ta1 ta2)) ta3 ta4 y++consSnocA !_ !x (Deep21 sa1 sa2 m ta1) !y+  = Deep32 x sa1 sa2 m ta1 y+consSnocA !_ !x (Deep22 sa1 sa2 m ta1 ta2) !y+  = Deep33 x sa1 sa2 m ta1 ta2 y+consSnocA !_ !x (Deep23 sa1 sa2 m ta1 ta2 ta3) !y+  = Deep34 x sa1 sa2 m ta1 ta2 ta3 y+consSnocA !n !x (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4) !y+  = Deep33 x sa1 sa2 (snocA (Sz.twice n) m (A.append n ta1 ta2)) ta3 ta4 y++consSnocA !_ !x (Deep31 sa1 sa2 sa3 m ta1) !y+  = Deep42 x sa1 sa2 sa3 m ta1 y+consSnocA !_ !x (Deep32 sa1 sa2 sa3 m ta1 ta2) !y+  = Deep43 x sa1 sa2 sa3 m ta1 ta2 y+consSnocA !_ !x (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3) !y+  = Deep44 x sa1 sa2 sa3 m ta1 ta2 ta3 y+consSnocA !n !x (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4) !y+  = Deep23 x sa1+           (consSnocA (Sz.twice n) (A.append n sa2 sa3) m (A.append n ta1 ta2))+           ta3 ta4 y++consSnocA n !x (Deep41 sa1 sa2 sa3 sa4 m ta1) !y+  = Deep32 x sa1 sa2 (consA (Sz.twice n) (A.append n sa3 sa4) m) ta1 y+consSnocA n !x (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2) !y+  = Deep33 x sa1 sa2 (consA (Sz.twice n) (A.append n sa3 sa4) m) ta1 ta2 y+consSnocA n !x (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3) !y+  = Deep32 x sa1 sa2 (consSnocA (Sz.twice n) (A.append n sa3 sa4) m (A.append n ta1 ta2)) ta3 y+consSnocA n !x (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4) !y+  = Deep33 x sa1 sa2 (consSnocA (Sz.twice n) (A.append n sa3 sa4) m (A.append n ta1 ta2)) ta3 ta4 y++data UCUS n a+  = EmptyUCUS+  | OneUCUS !(Array n a)+  | UCUS !(Array n a) (Deque n a) !(Array n a)++unconsUnsnocA :: Size n -> Deque n a -> UCUS n a+unconsUnsnocA !_ Empty = EmptyUCUS+unconsUnsnocA !_ (Shallow sa) = OneUCUS sa+unconsUnsnocA n (Deep11 sa1 m ta1)+  = flip (UCUS sa1) ta1 $+      case unconsUnsnocA (Sz.twice n) m of+        EmptyUCUS -> Empty+        OneUCUS mm+          | (m1, m2) <- A.splitArray n mm+          -> Deep11 m1 Empty m2+        UCUS mb m' me+          | (mb1, mb2) <- A.splitArray n mb+          , (me1, me2) <- A.splitArray n me+          -> Deep22 mb1 mb2 m' me1 me2+unconsUnsnocA n (Deep12 sa1 m ta1 ta2)+  = flip (UCUS sa1) ta2 $+      case unconsUnsnocA (Sz.twice n) m of+        EmptyUCUS -> Shallow ta1+        OneUCUS mm+          | (m1, m2) <- A.splitArray n mm+          -> Deep21 m1 m2 Empty ta1+        UCUS mb m' me+          | (mb1, mb2) <- A.splitArray n mb+          , (me1, me2) <- A.splitArray n me+          -> Deep23 mb1 mb2 m' me1 me2 ta1+unconsUnsnocA n (Deep13 sa1 m ta1 ta2 ta3)+  = flip (UCUS sa1) ta3 $+      case viewLA (Sz.twice n) m of+        EmptyL -> Deep11 ta1 Empty ta2+        ConsL mb m'+          | (mb1, mb2) <- A.splitArray n mb+          -> Deep22 mb1 mb2 m' ta1 ta2+unconsUnsnocA n (Deep14 sa1 m ta1 ta2 ta3 ta4)+  = flip (UCUS sa1) ta4 $+      case viewLA (Sz.twice n) m of+        EmptyL -> Deep12 ta1 Empty ta2 ta3+        ConsL mb m'+          | (mb1, mb2) <- A.splitArray n mb+          -> Deep23 mb1 mb2 m' ta1 ta2 ta3++unconsUnsnocA !n (Deep21 sa1 sa2 m ta1)+  = flip (UCUS sa1) ta1 $+      case unconsUnsnocA (Sz.twice n) m of+        EmptyUCUS -> Shallow sa2+        OneUCUS mm+          | (m1, m2) <- A.splitArray n mm+          -> Deep21 sa2 m1 Empty m2+        UCUS mb m' me+          | (mb1, mb2) <- A.splitArray n mb+          , (me1, me2) <- A.splitArray n me+          -> Deep32 sa2 mb1 mb2 m' me1 me2+unconsUnsnocA !_ (Deep22 sa1 sa2 m ta1 ta2)+  = UCUS sa1 (Deep11 sa2 m ta1) ta2+unconsUnsnocA !_ (Deep23 sa1 sa2 m ta1 ta2 ta3)+  = UCUS sa1 (Deep12 sa2 m ta1 ta2) ta3+unconsUnsnocA !_ (Deep24 sa1 sa2 m ta1 ta2 ta3 ta4)+  = UCUS sa1 (Deep13 sa2 m ta1 ta2 ta3) ta4++unconsUnsnocA !n (Deep31 sa1 sa2 sa3 m ta1)+  = flip (UCUS sa1) ta1 $+      case viewRA (Sz.twice n) m of+        EmptyR -> Deep11 sa2 Empty sa3+        SnocR m' me+          | (me1, me2) <- A.splitArray n me+          -> Deep22 sa2 sa3 m' me1 me2+unconsUnsnocA !_ (Deep32 sa1 sa2 sa3 m ta1 ta2)+  = UCUS sa1 (Deep21 sa2 sa3 m ta1) ta2+unconsUnsnocA !_ (Deep33 sa1 sa2 sa3 m ta1 ta2 ta3)+  = UCUS sa1 (Deep22 sa2 sa3 m ta1 ta2) ta3+unconsUnsnocA !_ (Deep34 sa1 sa2 sa3 m ta1 ta2 ta3 ta4)+  = UCUS sa1 (Deep23 sa2 sa3 m ta1 ta2 ta3) ta4++unconsUnsnocA !n (Deep41 sa1 sa2 sa3 sa4 m ta1)+  = flip (UCUS sa1) ta1 $+      case viewRA (Sz.twice n) m of+        EmptyR -> Deep21 sa2 sa3 Empty sa4+        SnocR m' me+          | (me1, me2) <- A.splitArray n me+          -> Deep32 sa2 sa3 sa4 m' me1 me2+unconsUnsnocA !_ (Deep42 sa1 sa2 sa3 sa4 m ta1 ta2)+  = UCUS sa1 (Deep31 sa2 sa3 sa4 m ta1) ta2+unconsUnsnocA !_ (Deep43 sa1 sa2 sa3 sa4 m ta1 ta2 ta3)+  = UCUS sa1 (Deep32 sa2 sa3 sa4 m ta1 ta2) ta3+unconsUnsnocA !_ (Deep44 sa1 sa2 sa3 sa4 m ta1 ta2 ta3 ta4)+  = UCUS sa1 (Deep33 sa2 sa3 sa4 m ta1 ta2 ta3) ta4+++data Deque_ n a+  = Empty_+  | Shallow_ !(Array n a)+  | Deep_ !(Digit n a) (Deque (Twice n) a) !(Digit n a)++matchDeep :: Deque n a -> Deque_ n a+matchDeep q = case q of+  Empty -> Empty_+  Shallow sa -> Shallow_ sa+  Deep11 x m a -> Deep_ (One x) m (One a)+  Deep12 x m a b -> Deep_ (One x) m (Two a b)+  Deep13 x m a b c -> Deep_ (One x) m (Three a b c)+  Deep14 x m a b c d -> Deep_ (One x) m (Four a b c d)+  Deep21 x y m a -> Deep_ (Two x y) m (One a)+  Deep22 x y m a b -> Deep_ (Two x y) m (Two a b)+  Deep23 x y m a b c -> Deep_ (Two x y) m (Three a b c)+  Deep24 x y m a b c d -> Deep_ (Two x y) m (Four a b c d)+  Deep31 x y z m a -> Deep_ (Three x y z) m (One a)+  Deep32 x y z m a b -> Deep_ (Three x y z) m (Two a b)+  Deep33 x y z m a b c -> Deep_ (Three x y z) m (Three a b c)+  Deep34 x y z m a b c d -> Deep_ (Three x y z) m (Four a b c d)+  Deep41 x y z w m a -> Deep_ (Four x y z w) m (One a)+  Deep42 x y z w m a b -> Deep_ (Four x y z w) m (Two a b)+  Deep43 x y z w m a b c -> Deep_ (Four x y z w) m (Three a b c)+  Deep44 x y z w m a b c d -> Deep_ (Four x y z w) m (Four a b c d)+{-# INLINE matchDeep #-}++pattern Deep :: Digit n a -> Deque (Twice n) a -> Digit n a -> Deque n a+pattern Deep pr m sf <- (matchDeep -> Deep_ pr m sf)+  where+    Deep (One x) m (One a) = Deep11 x m a+    Deep (One x) m (Two a b) = Deep12 x m a b+    Deep (One x) m (Three a b c) = Deep13 x m a b c+    Deep (One x) m (Four a b c d) = Deep14 x m a b c d+    Deep (Two x y) m (One a) = Deep21 x y m a+    Deep (Two x y) m (Two a b) = Deep22 x y m a b+    Deep (Two x y) m (Three a b c) = Deep23 x y m a b c+    Deep (Two x y) m (Four a b c d) = Deep24 x y m a b c d+    Deep (Three x y z) m (One a) = Deep31 x y z m a+    Deep (Three x y z) m (Two a b) = Deep32 x y z m a b+    Deep (Three x y z) m (Three a b c) = Deep33 x y z m a b c+    Deep (Three x y z) m (Four a b c d) = Deep34 x y z m a b c d++    Deep (Four x y z w) m (One a) = Deep41 x y z w m a+    Deep (Four x y z w) m (Two a b) = Deep42 x y z w m a b+    Deep (Four x y z w) m (Three a b c) = Deep43 x y z w m a b c+    Deep (Four x y z w) m (Four a b c d) = Deep44 x y z w m a b c d++{-# COMPLETE Empty, Shallow, Deep #-}++data Digit n a+  = One !(Array n a)+  | Two !(Array n a) !(Array n a)+  | Three !(Array n a) !(Array n a) !(Array n a)+  | Four !(Array n a) !(Array n a) !(Array n a) !(Array n a)++-- Converts a list of sz * n elements to a deque.+-- Unlike a queue, we *can't* convert incrementally,+-- so there's not much use being polymorphic in the state+-- monad.+fromListNM :: Size sz -> Int -> State [a] (Deque sz a)+fromListNM sz n = fromListNS sz (N.toBin45 n)++fromListNS :: Size sz -> N.Bin45 -> State [a] (Deque sz a)+fromListNS !_ N.End45 = pure Empty+fromListNS sz N.OneEnd45 = do+  sa1 <- state (A.arraySplitListN sz)+  pure $! Shallow sa1+fromListNS sz N.TwoEnd45 = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  pure $! Deep11 sa1 Empty sa2+fromListNS sz N.ThreeEnd45 = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  sa3 <- state (A.arraySplitListN sz)+  pure $! Deep21 sa1 sa2 Empty sa3+fromListNS sz (N.Four45 n) = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  m <- fromListNS (Sz.twice sz) n+  ta1 <- state (A.arraySplitListN sz)+  ta2 <- state (A.arraySplitListN sz)+  pure $ Deep22 sa1 sa2 m ta1 ta2+fromListNS sz (N.Five45 n) = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  sa3 <- state (A.arraySplitListN sz)+  m <- fromListNS (Sz.twice sz) n+  ta1 <- state (A.arraySplitListN sz)+  ta2 <- state (A.arraySplitListN sz)+  pure $ Deep32 sa1 sa2 sa3 m ta1 ta2

@@ -0,0 +1,23 @@+{-# language Safe #-}++{- |+Space-efficient queues with amortized \( O(\log n) \) operations.  These+directly use an underlying array-based implementation, without doing any+special optimization for the first few and last few elements of the queue.+-}++module Data.CompactSequence.Deque.Simple+  ( Deque (Empty, (:<), (:>))+  , (|>)+  , empty+  , cons+  , snoc+  , uncons+  , unsnoc+--  , take+  , fromList+  , fromListN+  ) where++import Data.CompactSequence.Deque.Simple.Internal+import Prelude ()

@@ -0,0 +1,165 @@+{-# language DeriveTraversable #-}+{-# language ScopedTypeVariables #-}+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language Trustworthy #-}+{-# language TypeFamilies #-}+{-# language FlexibleContexts #-}+{-# language LambdaCase #-}+{- OPTIONS_GHC -Wall #-}+{- OPTIONS_GHC -ddump-simpl #-}++{- |+Space-efficient deques with amortized \( O(\log n) \) operations.  These+directly use an underlying array-based implementation, without doing any+special optimization for the first few and last few elements of the deque.+-}++module Data.CompactSequence.Deque.Simple.Internal+  ( Deque (.., Empty, (:<), (:>))+  , (|>)+  , (<|)+  , empty+  , cons+  , snoc+  , uncons+  , unsnoc+--  , take+  , fromList+  , fromListN+  ) where++import qualified Data.CompactSequence.Deque.Internal as D+import qualified Data.CompactSequence.Internal.Array as A+import qualified Data.CompactSequence.Internal.Size as Sz+import Data.CompactSequence.Internal.Size (Size)+import qualified Data.CompactSequence.Internal.Numbers as N+import qualified Data.Foldable as F+import qualified GHC.Exts as Exts+import Control.Monad.State.Strict+import qualified Prelude as P+import Prelude hiding (take)++-- | A deque.+newtype Deque a = Deque (D.Deque Sz.Sz1 a)+  deriving (Functor, Traversable, Eq, Ord)++-- | The empty deque.+empty :: Deque a+empty = Deque D.empty++-- | Enqueue an element at the front of a deque.+cons :: a -> Deque a -> Deque a+cons a (Deque q) = Deque $ D.consA Sz.one (A.singleton a) q++-- | Enqueue an element at the rear of a deque.+snoc :: Deque a -> a -> Deque a+snoc (Deque q) a = Deque $ D.snocA Sz.one q (A.singleton a)++-- | An infix synonym for 'snoc'.+(|>) :: Deque a -> a -> Deque a+(|>) = snoc++-- | An infix synonym for 'cons'.+(<|) :: a -> Deque a -> Deque a+(<|) = cons++-- | Dequeue an element from the front of a deque.+uncons :: Deque a -> Maybe (a, Deque a)+uncons (Deque q) = case D.viewLA Sz.one q of+  D.EmptyL -> Nothing+  D.ConsL sa q'+    | (# a #) <- A.getSingleton# sa+    -> Just (a, Deque q')++-- | Dequeue an element from the rear of a deque.+unsnoc :: Deque a -> Maybe (Deque a, a)+unsnoc (Deque q) = case D.viewRA Sz.one q of+  D.EmptyR -> Nothing+  D.SnocR q' ta+    | (# a #) <- A.getSingleton# ta+    -> Just (Deque q', a)++infixr 5 :<, `cons`+infixl 4 `snoc`, |>++-- | A bidirectional pattern synonym for manipulating the+-- front of a deque.+pattern (:<) :: a -> Deque a -> Deque a+pattern x :< xs <- (uncons -> Just (x, xs))+  where+    x :< xs = x `cons` xs++-- | A bidirectional pattern synonym for manipulating the+-- rear of a deque.+pattern (:>) :: Deque a -> a -> Deque a+pattern xs :> x <- (unsnoc -> Just (xs, x))+  where+    xs :> x = xs `snoc` x++-- | A bidirectional pattern synonym for the empty deque.+pattern Empty :: Deque a+pattern Empty = Deque D.Empty+{-# COMPLETE (:<), Empty #-}+{-# COMPLETE (:>), Empty #-}++instance Foldable Deque where+  -- TODO: Implement more methods?+  foldMap f (Deque q) = foldMap f q+  foldr c n (Deque q) = foldr c n q+  foldr' c n (Deque q) = F.foldr' c n q+  foldl f b (Deque q) = foldl f b q+  foldl' f b (Deque q) = F.foldl' f b q++  null (Deque D.Empty) = True+  null _ = False++  -- Note: length only does O(log n) *unshared* work, but it does O(n) amortized+  -- work because it has to force the entire spine. We could avoid+  -- this, of course, by storing the size with the dequeue.+  length (Deque q) = go 0 Sz.one q+    where+      go :: Int -> Size m -> D.Deque m a -> Int+      go !acc !_s D.Empty = acc+      go !acc !s (D.Shallow _) = acc + Sz.getSize s+      go !acc !s (D.Deep pr m sf) = go (acc + ld pr + ld sf) (Sz.twice s) m+        where+          ld = \case+                  D.One{} -> Sz.getSize s+                  D.Two{} -> 2*Sz.getSize s+                  D.Three{} -> 3*Sz.getSize s+                  D.Four{} -> 4*Sz.getSize s++instance Show a => Show (Deque a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)++instance Exts.IsList (Deque a) where+  type Item (Deque a) = a+  toList = F.toList+  fromList = fromList+  fromListN = fromListN++instance Semigroup (Deque a) where+  -- This gives us O(m + n) append. Can we do better?+  -- I suspect O(min(m,n)) might be possible.+  Empty <> q = q+  q <> Empty = q+  q <> r = fromListN (length q + length r) (F.toList q ++ F.toList r)++instance Monoid (Deque a) where+  mempty = empty++-- | \( O(n \log n) \). Convert a list to a 'Deque', with the head of the+-- list at the front of the deque.+fromList :: [a] -> Deque a+fromList = F.foldl' snoc empty++-- | \( O(n) \). Convert a list of the given size to a 'Deque', with the+-- head of the list at the front of the deque.+fromListN :: Int -> [a] -> Deque a+fromListN n xs+  = Deque $ evalState (D.fromListNM Sz.one n) xs

@@ -1,45 +1,24 @@-{-# language DataKinds #-}-{-# language TypeOperators #-} {-# language KindSignatures #-} {-# language BangPatterns #-} {-# language RoleAnnotations #-} {-# language MagicHash #-} {-# language UnboxedTuples #-}-{-# language NoStarIsType #-} {-# language RankNTypes #-} {-# language DeriveTraversable #-} {-# language Unsafe #-}+{- OPTIONS_GHC -ddump-simpl #-}  module Data.CompactSequence.Internal.Array where+import Data.CompactSequence.Internal.Size import Data.Primitive.SmallArray import Control.Monad.ST.Strict---- fixed-vector--- unpacked-containers--- contiguous--data Mult = Twice Mult | Mul1+import GHC.Exts (SmallArray#) -newtype Array (n :: Mult) a = Array (SmallArray a)+newtype Array n a = Array (SmallArray a)   deriving (Functor, Foldable, Traversable) type role Array nominal representational -newtype Size (n :: Mult) = Size Int-type role Size nominal--getSize :: Size n -> Int-getSize (Size n) = n----halve :: Size (Twice m) -> Size m---halve (Size n) = Size (n `quot` 2)--one :: Size Mul1-one = Size 1--twice :: Size n -> Size (Twice n)-twice (Size n) = Size (2*n)--singleton :: a -> Array Mul1 a+singleton :: a -> Array Sz1 a singleton x = Array (pure x)  -- | Unsafely convert a 'SmallArray' of size @n@@@ -52,19 +31,35 @@ arrayToSmallArray :: Array n a -> SmallArray a arrayToSmallArray (Array sa) = sa -getSingleton# :: Array Mul1 a -> (# a #)+getSingleton# :: Array Sz1 a -> (# a #) getSingleton# (Array sa) = indexSmallArray## sa 0 -getSingletonA :: Applicative f => Array Mul1 a -> f a+getSingletonA :: Applicative f => Array Sz1 a -> f a getSingletonA (Array sa)   | (# a #) <- indexSmallArray## sa 0   = pure a  splitArray :: Size n -> Array (Twice n) a -> (Array n a, Array n a)-splitArray (Size len) (Array sa1) = (Array sa2, Array sa3)+splitArray (Size len) (Array sa)+  | (# sa1, sa2 #) <- splitSmallArray# len sa+  = (Array (SmallArray sa1), Array (SmallArray sa2))+{-# INLINE splitArray #-}++-- Bleh. We use this gunk to prevent coercions from getting+-- in the way of worker/wrapper, and also to deal with the+-- nested CPR challenge. GHC, please fix yourself.+-- We want everything unboxed, but it seems unlikely that we'll+-- win significantly by inlining two calls to an out-of-line+-- primop. The giant mutually recursive group of 8 functions+-- that implement the basic deque operations needs to be as+-- small as we can possibly make it if there's to be any hope+-- for the instruction cache.+splitSmallArray# :: Int -> SmallArray a -> (# SmallArray# a, SmallArray# a #)+splitSmallArray# len sa1 = (# sa2, sa3 #)   where-    !sa2 = cloneSmallArray sa1 0 len-    !sa3 = cloneSmallArray sa1 len len+    !(SmallArray sa2) = cloneSmallArray sa1 0 len+    !(SmallArray sa3) = cloneSmallArray sa1 len len+{-# NOINLINE splitSmallArray# #-}  -- | Append two arrays of the same size. We take the size -- of the argument arrays so we can build the result array@@ -73,10 +68,22 @@ -- want to just use `<>`, because  append :: Size n -> Array n a -> Array n a -> Array (Twice n) a append (Size n) (Array xs) (Array ys) = Array $+  appendSmallArrays n xs ys++-- WAT. For some reason, if I put the actual machinery of this in 'append' and+-- say NOINLINE, GHC (8.6.3 and 8.8.1 at least) doesn't perform worker-wrapper!+-- Ugh.+appendSmallArrays :: Int -> SmallArray a -> SmallArray a -> SmallArray a+appendSmallArrays n xs ys =     createSmallArray (2*n)       (error "Data.CompactSequence.Internal.Array.append: Internal error")       $ \sma -> copySmallArray sma 0 xs 0 n         *> copySmallArray sma n ys 0 n+-- Small though this is, I don't really see much point in inlining it; it calls+-- several out-of-line primops that aren't super-cheap anyway. I'd rather cut+-- code size. This will change completely, of course, once GHC gets a primop+-- for appending arrays.+{-# NOINLINE appendSmallArrays #-}  -- Shamelessly stolen from primitive. createSmallArray@@ -110,3 +117,6 @@           sa <- unsafeFreezeSmallArray sma           pure (sa, xss)   go 0 l++fromList :: Size n -> [a] -> Array n a+fromList (Size n) xs = Array (smallArrayFromListN n xs)

@@ -2,12 +2,7 @@ {-# language Trustworthy #-}  module Data.CompactSequence.Internal.Array.Safe-  ( Mult (..)-  , Array-  , Size-  , getSize-  , one-  , twice+  ( Array   , singleton   , getSingleton#   , getSingletonA@@ -15,5 +10,6 @@   , splitArray   , append   , arraySplitListN+  , fromList   ) where import Data.CompactSequence.Internal.Array

@@ -0,0 +1,63 @@+module Data.CompactSequence.Internal.Numbers where+import Data.Bits++-- A representation of 1-2 binary numbers. We use this to build stacks or stack+-- fragments of known size.+data Dyadic = DOne !Dyadic | DTwo !Dyadic | DEnd+  deriving (Eq, Show)++toDyadic :: Int -> Dyadic+toDyadic n0 = go (n0 + 1)+  where+    go 1 = DEnd+    go n = case n .&. 1 of+      0 -> DOne $ go (unsafeShiftR n 1)+      _ -> DTwo $ go (unsafeShiftR n 1)+{-# NOINLINE toDyadic #-}++{-+-- We'll have to figure out how to write something+-- like this to append stacks more efficiently.+incDyadic :: Dyadic -> Dyadic+incDyadic DEnd = DOne DEnd+incDyadic (DOne n) = DTwo n+incDyadic (DTwo n) = DOne (incDyadic n)++addDyadic :: Dyadic -> Dyadic -> Dyadic+addDyadic = go 0+  where+    go 0 DEnd !n = n+    go 1 DEnd !n = incDyadic n+    go _ DEnd !n = incDyadic (incDyadic n)+    go !c !n DEnd = go c DEnd n+    go !c +-}++-- A representation of 2-3 binary numbers, where the most significant digit may+-- also be 1. We use this to build stacks or stack fragments of known size.+data Bin23 = Two23 !Bin23 | Three23 !Bin23 | End23 | OneEnd23+  deriving (Eq, Show)++toBin23 :: Int -> Bin23+toBin23 n0 = go (n0 + 2)+  where+    go 2 = End23+    go 3 = OneEnd23+    go n = case n .&. 1 of+      0 -> Two23 $ go (unsafeShiftR n 1)+      _ -> Three23 $ go (unsafeShiftR n 1)+{-# NOINLINE toBin23 #-}++data Bin45 = Four45 !Bin45 | Five45 !Bin45 | End45 | OneEnd45 | TwoEnd45 | ThreeEnd45++toBin45 :: Int -> Bin45+toBin45 n0 = go (n0 + 4)+  where+    go 4 = End45+    go 5 = OneEnd45+    go 6 = TwoEnd45+    go 7 = ThreeEnd45+    go n = case n .&. 1 of+      0 -> Four45 $ go (unsafeShiftR n 1)+      _ -> Five45 $ go (unsafeShiftR n 1)+{-# NOINLINE toBin45 #-}

@@ -0,0 +1,107 @@+{-# language BangPatterns #-}+{-# language RoleAnnotations #-}+{-# language Safe #-}+{- OPTIONS_GHC -ddump-simpl #-}++{- |+Array sizes with phantom types. We use a very primitive+arrangement because that's all we need for now: the base+type is 'Sz1', 'Sz2', etc., and it's doubled as many times+as necessary by applying+the @Twice@ constructor. The base value is 'sz1', 'sz2',+etc., and it's doubled by applying the 'twice' function.+-}+module Data.CompactSequence.Internal.Size where++data Twice a+data Sz1+data Sz2+data Sz3+data Sz4+data Sz5+data Sz6+data Sz7+data Sz8+data Sz9+data Sz10+data Sz11+data Sz12+data Sz13+data Sz14+data Sz15+data Sz16+data Sz17+data Sz18+data Sz19++newtype Size n = Size Int+type role Size nominal++getSize :: Size n -> Int+getSize (Size n) = n++twice :: Size n -> Size (Twice n)+twice (Size n) = Size (2*n)++half :: Size (Twice m) -> Size m+half (Size n) = Size (n `quot` 2)++one :: Size Sz1+one = Size 1++sz1 :: Size Sz1+sz1 = Size 1++sz2 :: Size Sz2+sz2 = Size 2++sz3 :: Size Sz3+sz3 = Size 3++sz4 :: Size Sz4+sz4 = Size 4++sz5 :: Size Sz5+sz5 = Size 5++sz6 :: Size Sz6+sz6 = Size 6++sz7 :: Size Sz7+sz7 = Size 7++sz8 :: Size Sz8+sz8 = Size 8++sz9 :: Size Sz9+sz9 = Size 9++sz10 :: Size Sz10+sz10 = Size 10++sz11 :: Size Sz11+sz11 = Size 11++sz12 :: Size Sz12+sz12 = Size 12++sz13 :: Size Sz13+sz13 = Size 13++sz14 :: Size Sz14+sz14 = Size 14++sz15 :: Size Sz15+sz15 = Size 15++sz16 :: Size Sz16+sz16 = Size 16++sz17 :: Size Sz17+sz17 = Size 17++sz18 :: Size Sz18+sz18 = Size 18++sz19 :: Size Sz19+sz19 = Size 19

@@ -1,14 +1,17 @@ {-# language CPP #-} {-# language BangPatterns, ScopedTypeVariables, UnboxedTuples, MagicHash #-} {-# language DeriveTraversable, StandaloneDeriving #-}-{-# language DataKinds #-}--- {-# OPTIONS_GHC -Wall #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language LambdaCase #-}+{- OPTIONS_GHC -Wall #-}+{- OPTIONS_GHC -ddump-simpl #-}  module Data.CompactSequence.Queue.Internal where---import Data.Primitive.SmallArray (SmallArray)---import qualified Data.Primitive.SmallArray as A import qualified Data.CompactSequence.Internal.Array as A-import Data.CompactSequence.Internal.Array (Array, Size, Mult (..))+import Data.CompactSequence.Internal.Array (Array)+import qualified Data.CompactSequence.Internal.Size as Sz+import Data.CompactSequence.Internal.Size (Size, Twice) import qualified Data.Foldable as F import Data.Function (on) @@ -16,20 +19,55 @@   = FD1 !(Array n a)   | FD2 !(Array n a) !(Array n a)   | FD3 !(Array n a) !(Array n a) !(Array n a)-  deriving (Functor, Foldable, Traversable) -- FD2 and FD3 are safe; FD1 is dangerous.  data RD n a   = RD0   | RD1 !(Array n a)   | RD2 !(Array n a) !(Array n a)-  deriving (Functor, Foldable, Traversable) -- RD0 and RD1 are safe; RD2 is dangerous. +-- Conceptually, we want something like+--+--   data Queue n a = Empty | Node !(FD n a) (Queue n a) !(RD n a)+--+-- Unfortunately, this is rather wasteful. The Node itself takes+-- 4 words, and the digits combined take between 2 and 7. Total:+-- between 6 and 11 words. By manually "unpacking" the digits, expanding+-- the Queue to 10 constructors, we now have nodes taking+-- between 3 and 7 words, a considerable improvement. This kind of+-- unpacking, in general, can risk a loss of sharing, leading to+-- increased allocation and (in the presence of persistence) increased+-- residency. But that doesn't happen here! The worst case for the+-- unpacked representation relative to the conceptual one is when+-- the frost digit is 3 and we modify the rear digit. In that case,+-- we have to copy the three front array pointers rather than a single+-- front digit pointer. Consider, for example, changing a 0 digit+-- to a 1 digit in the rear. For the conceptual representation, that+-- allocates 4 words for the new Node plus 2 words for the new rear+-- digit, for a total of 6 words. The unpacked representation+-- allocates one word for the new node header, three words to copy the+-- front, one word to copy the middle, and one word for the new rear.+-- Total: 6. So in the case that's *worst* for the unpacked version,+-- the unpacked version still breaks even in allocation, while+-- winning the indirection game. So unpacked is the way to go.+-- As long as we're doing it this way, we can bake the "no debits+-- on children of unsafe nodes" invariant right into the constructors,+-- preventing us from messing that up and as a side benefit avoiding+-- some double forcing.+ data Queue n a   = Empty-  | Node !(FD n a) (Queue ('Twice n) a) !(RD n a)-  deriving (Functor, Traversable)+  | Node10 !(Array n a) !(Queue (Twice n) a)+  | Node11 !(Array n a) !(Queue (Twice n) a) !(Array n a)+  | Node12 !(Array n a) !(Queue (Twice n) a) !(Array n a) !(Array n a)+  | Node20 !(Array n a) !(Array n a) (Queue (Twice n) a)+  | Node21 !(Array n a) !(Array n a) (Queue (Twice n) a) !(Array n a)+  | Node22 !(Array n a) !(Array n a) !(Queue (Twice n) a) !(Array n a) !(Array n a)+  | Node30 !(Array n a) !(Array n a) !(Array n a) (Queue (Twice n) a)+  | Node31 !(Array n a) !(Array n a) !(Array n a) (Queue (Twice n) a) !(Array n a)+  | Node32 !(Array n a) !(Array n a) !(Array n a) !(Queue (Twice n) a) !(Array n a) !(Array n a)+  deriving (Functor, Foldable, Traversable) -- An Empty node is safe. -- A Node node is safe if both its digits are safe. We require that the child queue of an unsafe -- node be in WHNF, and allow no debits on it.@@ -51,6 +89,45 @@ -- -- We allow the child queue of a safe node four times its safety value (for some value of four). +++-- Gunk to define a `Node` pattern synonym to pretend we+-- have real digits. Sadly, where we really want this most,+-- it throws GHC's optimizer for a loop and it makes garbage+-- code.+data Queue_ n a+  = Empty_+  | Node_ !(FD n a) (Queue (Twice n) a) !(RD n a)++matchNode :: Queue n a -> Queue_ n a+matchNode q = case q of+  Empty -> Empty_+  Node10 x m -> Node_ (FD1 x) m RD0+  Node11 x m a -> Node_ (FD1 x) m (RD1 a)+  Node12 x m a b -> Node_ (FD1 x) m (RD2 a b)+  Node20 x y m -> Node_ (FD2 x y) m RD0+  Node21 x y m a -> Node_ (FD2 x y) m (RD1 a)+  Node22 x y m a b -> Node_ (FD2 x y) m (RD2 a b)+  Node30 x y z m -> Node_ (FD3 x y z) m RD0+  Node31 x y z m a -> Node_ (FD3 x y z) m (RD1 a)+  Node32 x y z m a b -> Node_ (FD3 x y z) m (RD2 a b)+{-# INLINE matchNode #-}++pattern Node :: FD n a -> Queue (Twice n) a -> RD n a -> Queue n a+pattern Node pr m sf <- (matchNode -> Node_ pr m sf)+  where+    Node (FD1 x) m RD0 = Node10 x m+    Node (FD1 x) m (RD1 a) = Node11 x m a+    Node (FD1 x) m (RD2 a b) = Node12 x m a b+    Node (FD2 x y) m RD0 = Node20 x y m+    Node (FD2 x y) m (RD1 a) = Node21 x y m a+    Node (FD2 x y) m (RD2 a b) = Node22 x y m a b+    Node (FD3 x y z) m RD0 = Node30 x y z m+    Node (FD3 x y z) m (RD1 a) = Node31 x y z m a+    Node (FD3 x y z) m (RD2 a b) = Node32 x y z m a b++{-# COMPLETE Empty, Node #-}+ data ViewA n a   = EmptyA   | ConsA !(Array n a) (Queue n a)@@ -66,15 +143,14 @@ -- Non-cascading viewA !_ Empty = EmptyA viewA !_ (Node (FD3 sa1 sa2 sa3) m sf) = ConsA sa1 $ Node (FD2 sa2 sa3) m sf-viewA !_ (Node (FD2 sa1 sa2) m sf) = ConsA sa1 $ m `seq` Node (FD1 sa2) m sf+viewA !_ (Node (FD2 sa1 sa2) m sf) = ConsA sa1 $ Node (FD1 sa2) m sf -- Potentially cascading viewA !n (Node (FD1 sa1) m (RD2 sa2 sa3)) = ConsA sa1 $-  case shiftA (A.twice n) m (A.append n sa2 sa3) of-    ShiftedA sam m'-      | (sam1, sam2) <- A.splitArray n sam+  case shiftA n m sa2 sa3 of+    ShiftedA sam1 sam2 m'       -> Node (FD2 sam1 sam2) m' RD0 viewA !n (Node (FD1 sa1) m sf) = ConsA sa1 $-  case viewA (A.twice n) m of+  case viewA (Sz.twice n) m of     EmptyA -> case sf of       RD2 sa2 sa3 -> Node (FD2 sa2 sa3) Empty RD0       RD1 sa2 -> singletonA sa2@@ -83,15 +159,6 @@       | (sam1, sam2) <- A.splitArray n sam       -> Node (FD2 sam1 sam2) m' sf -{--viewA2 :: Size n -> Queue n a -> ViewA2 n a-viewA2 n q = case viewA n q of-  EmptyA -> EmptyA2-  ConsA sa q'-    | (sa1, sa2) <- A.splitArray n sa-    -> ConsA2 sa1 sa2 q'--}- empty :: Queue n a empty = Empty @@ -112,15 +179,15 @@  snocA :: Size n -> Queue n a -> Array n a -> Queue n a snocA !_ Empty sa = Node (FD1 sa) empty RD0-snocA !_ (Node pr m RD0) sa = Node pr m (RD1 sa)-snocA !_ (Node pr m (RD1 sa1)) sa2 = m `seq` Node pr m (RD2 sa1 sa2) snocA !n (Node (FD1 sa0) m (RD2 sa1 sa2)) sa3-  | ShiftedA sam m' <- shiftA (A.twice n) m (A.append n sa1 sa2)-  , (sam1, sam2) <- A.splitArray n sam+  | ShiftedA sam1 sam2 m' <- shiftA n m sa1 sa2   = Node (FD3 sa0 sam1 sam2) m' (RD1 sa3)+snocA !_ (Node pr m RD0) sa = Node pr m (RD1 sa)+snocA !_ (Node pr m (RD1 sa1)) sa2 = Node pr m (RD2 sa1 sa2) snocA !n (Node pr m (RD2 sa1 sa2)) sa3-  = Node pr (snocA (A.twice n) m (A.append n sa1 sa2)) (RD1 sa3)+  = Node pr (snocA (Sz.twice n) m (A.append n sa1 sa2)) (RD1 sa3) + -- | Uncons from a node and snoc onto it. Ensure that if the operation is -- expensive then it leaves the node in a safe configuration. Why do we need -- this? Suppose we have@@ -153,58 +220,59 @@ -- -- we have to do the opposite: snoc then view. We might as well -- just write a dedicated shifting operation.-shiftA :: Size n -> Queue n a -> Array n a -> ShiftedA n a+shiftA :: Size n -> Queue (Twice n) a -> Array n a -> Array n a -> ShiftedA n a++-- BLAST AND DARN. I started out using the Node pattern synonym all+-- through here. Sadly, GHC was *way* too eager with join point+-- transformations and decided to actually pass around front+-- and rear digits to make things slow. GRRR. So in this function,+-- we use the raw constructors by hand.+ -- Non-cascading cases-shiftA !_ Empty sa = ShiftedA sa Empty-shiftA !_ (Node (FD2 sa1 sa2) m RD0) sa3-  = ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD1 sa3)-shiftA !_ (Node (FD2 sa1 sa2) m (RD1 sa3)) sa4-  = ShiftedA sa1 $ m `seq` Node (FD1 sa2) m (RD2 sa3 sa4)-shiftA !_ (Node (FD3 sa1 sa2 sa3) m RD0) sa4-  = ShiftedA sa1 $ Node (FD2 sa2 sa3) m (RD1 sa4)-shiftA !_ (Node (FD3 sa1 sa2 sa3) m (RD1 sa4)) sa5-  = ShiftedA sa1 $ m `seq` Node (FD2 sa2 sa3) m (RD2 sa4 sa5)+shiftA !_ Empty !sa1 !sa2 = ShiftedA sa1 sa2 Empty+shiftA !n (Node20 sa1 sa2 m) !sa3 !sa4+  = shrift n sa1 $ Node11 sa2 m (A.append n sa3 sa4)+shiftA !n (Node21 sa1 sa2 m  sa3) !sa4 !sa5+  = shrift n sa1 $ Node12 sa2 m sa3 (A.append n sa4 sa5)+shiftA !n (Node30 sa1 sa2 sa3 m) !sa4 !sa5+  = shrift n sa1 $ Node21 sa2 sa3 m (A.append n sa4 sa5)+shiftA !n (Node31 sa1 sa2 sa3 m sa4) !sa5 !sa6+  = shrift n sa1 $ Node22 sa2 sa3 m sa4 (A.append n sa5 sa6) -- cascading cases-shiftA !n (Node (FD1 sa1) m RD0) sa3-  = ShiftedA sa1 $-      case viewA (A.twice n) m of-        EmptyA -> singletonA sa3+shiftA !n (Node10 sa1 m) !sa3 !sa4+  = shrift n sa1 $+      case viewA (Sz.twice (Sz.twice n)) m of+        EmptyA -> Node10 (A.append n sa3 sa4) Empty         ConsA sam m'-          | (sam1, sam2) <- A.splitArray n sam-          -> Node (FD2 sam1 sam2) m' (RD1 sa3)-shiftA !n (Node (FD1 sa1) m (RD1 sa2)) sa3-    -- We force sa3 here to avoid forming a chain of thunks if-    -- we have a bunch of FD1+RD1 nodes in a row.-  = ShiftedA sa1 $ sa3 `seq`-      case shiftA (A.twice n) m (A.append n sa2 sa3) of-        ShiftedA sam m'-          | (sam1, sam2) <- A.splitArray n sam-          -> Node (FD2 sam1 sam2) m' RD0-shiftA n (Node (FD1 sa1) m (RD2 sa2 sa3)) sa4-  = ShiftedA sa1 $-      case shiftA (A.twice n) m (A.append n sa2 sa3) of-        ShiftedA sam m'-          | (sam1, sam2) <- A.splitArray n sam-          -> Node (FD2 sam1 sam2) m' (RD1 sa4)-shiftA n (Node (FD2 sa1 sa2) m (RD2 sa3 sa4)) sa5-  = ShiftedA sa1 $-      case shiftA (A.twice n) m (A.append n sa3 sa4) of-        ShiftedA sam m'-          | (sam1, sam2) <- A.splitArray n sam-          -> Node (FD3 sa2 sam1 sam2) m' (RD1 sa5)-shiftA n (Node (FD3 sa1 sa2 sa3) m (RD2 sa4 sa5)) sa6-  = ShiftedA sa1 $ Node (FD2 sa2 sa3) (snocA (A.twice n) m (A.append n sa4 sa5)) (RD1 sa6)+          | (sam1, sam2) <- A.splitArray (Sz.twice n) sam+          -> Node21 sam1 sam2 m' (A.append n sa3 sa4)+shiftA !n (Node11 sa1 m sa2) !sa3 !sa4+  = shrift n sa1 $+      case shiftA (Sz.twice n) m sa2 (A.append n sa3 sa4) of+        ShiftedA sam1 sam2 m'+          -> Node20 sam1 sam2 m'+shiftA n (Node12 sa1 m sa2 sa3) !sa4 !sa5+  = shrift n sa1 $+      case shiftA (Sz.twice n) m sa2 sa3 of+        ShiftedA sam1 sam2 m'+          -> Node21 sam1 sam2 m' (A.append n sa4 sa5)+shiftA n (Node22 sa1 sa2 m sa3 sa4) !sa5 !sa6+  = shrift n sa1 $+      case shiftA (Sz.twice n) m sa3 sa4 of+        ShiftedA sam1 sam2 m'+          -> Node31 sa2 sam1 sam2 m' (A.append n sa5 sa6)+shiftA n (Node32 sa1 sa2 sa3 m sa4 sa5) !sa6 !sa7+  = shrift n sa1 $+      Node21 sa2 sa3+           (snocA (Sz.twice (Sz.twice n)) m (A.append (Sz.twice n) sa4 sa5))+           (A.append n sa6 sa7) -data ShiftedA n a = ShiftedA !(Array n a) (Queue n a)+shrift :: Size n -> Array (Twice n) a -> Queue (Twice n) a -> ShiftedA n a+shrift n sa q+  | (sa1, sa2) <- A.splitArray n sa+  = ShiftedA sa1 sa2 q -{--splitArray :: SmallArray a -> (SmallArray a, SmallArray a)-splitArray sa1 = (sa2, sa3)-  where-    !len' = A.sizeofSmallArray sa1 `quot` 2-    !sa2 = A.cloneSmallArray sa1 0 len'-    !sa3 = A.cloneSmallArray sa1 len' len'--}+data ShiftedA n a = ShiftedA !(Array n a) !(Array n a) (Queue (Twice n) a)  instance Show a => Show (Queue n a) where     showsPrec p xs = showParen (p > 10) $@@ -215,14 +283,3 @@  instance Ord a => Ord (Queue n a) where   compare = compare `on` F.toList--instance Foldable (Queue n) where-  foldMap _f Empty = mempty-  foldMap f (Node pr m sf) = foldMap f pr <> foldMap f m <> foldMap f sf--  null Empty = True-  null _ = False--  -- TODO: Once the size type has really stabilized,-  -- we should find a way to write a custom length.-  -- Until then, we leave that to the wrapper implementation.

@@ -1,14 +1,4 @@-{-# language DeriveTraversable #-}-{-# language ScopedTypeVariables #-}-{-# language BangPatterns #-}-{-# language MagicHash #-}-{-# language UnboxedTuples #-}-{-# language DataKinds #-}-{-# language PatternSynonyms #-}-{-# language ViewPatterns #-}-{-# language Trustworthy #-}-{-# language TypeFamilies #-}--- {-# OPTIONS_GHC -Wall #-}+{-# language Safe #-}  {- | Space-efficient queues with amortized \( O(\log n) \) operations.  These@@ -22,169 +12,11 @@   , empty   , snoc   , uncons+  , take   , fromList   , fromListN+  , fromListNIncremental   ) where -import qualified Data.CompactSequence.Queue.Internal as Q-import qualified Data.CompactSequence.Internal.Array as A-import qualified Data.Foldable as F-import qualified GHC.Exts as Exts-import Control.Monad.Trans.State.Strict--newtype Queue a = Queue (Q.Queue 'A.Mul1 a)-  deriving (Functor, Traversable, Eq, Ord)--empty :: Queue a-empty = Queue Q.empty--snoc :: Queue a -> a -> Queue a-snoc (Queue q) a = Queue $ Q.snocA A.one q (A.singleton a)--(|>) :: Queue a -> a -> Queue a-(|>) = snoc--uncons :: Queue a -> Maybe (a, Queue a)-uncons (Queue q) = case Q.viewA A.one q of-  Q.EmptyA -> Nothing-  Q.ConsA sa q'-    | (# a #) <- A.getSingleton# sa-    -> Just (a, Queue q')--infixr 4 :<-infixl 4 `snoc`--pattern (:<) :: a -> Queue a -> Queue a-pattern x :< xs <- (uncons -> Just (x, xs))--pattern Empty :: Queue a-pattern Empty = Queue Q.Empty-{-# COMPLETE (:<), Empty #-}--instance Foldable Queue where-  -- TODO: Implement more methods.-  foldMap f (Queue q) = foldMap f q-  foldr c n (Queue q) = foldr c n q-  foldl' f b (Queue q) = F.foldl' f b q-  -- Note: length only does O(log n) *unshared* work, but it does O(n) amortized-  -- work because it has to force the entire spine. We could avoid-  -- this, of course, by storing the size with the queue.-  length (Queue q) = go 0 A.one q-    where-      go :: Int -> A.Size m -> Q.Queue m a -> Int-      go !acc !_s Q.Empty = acc-      go !acc !s (Q.Node pr m sf) = go (acc + lpr + lsf) (A.twice s) m-        where-          lpr = case pr of-                  Q.FD1{} -> A.getSize s-                  Q.FD2{} -> 2*A.getSize s-                  Q.FD3{} -> 3*A.getSize s-          lsf = case sf of-                  Q.RD0 -> 0-                  Q.RD1{} -> A.getSize s-                  Q.RD2{} -> 2*A.getSize s--instance Show a => Show (Queue a) where-    showsPrec p xs = showParen (p > 10) $-        showString "fromList " . shows (F.toList xs)--instance Exts.IsList (Queue a) where-  type Item (Queue a) = a-  toList = F.toList-  fromList = fromList-  fromListN = fromListN--instance Semigroup (Queue a) where-  -- This gives us O(m + n) append, which I believe is the best we can do in-  -- general.-  ---  -- TODO: detect when the second queue is short enough that it's better to-  -- just insert all its elements into the first queue. This happens around-  -- when n log m < k (m + n), but finding the appropriate k requires-  -- benchmarking. Can we make that decision without fully calculating-  -- m or log m (using successive lower bounds)?-  Empty <> q = q-  q <> Empty = q-  q <> r = fromListN (length q + length r) (F.toList q ++ F.toList r)--instance Monoid (Queue a) where-  mempty = empty---- | \( O(n \log n) \). Convert a list to a 'Queue', with the head of the--- list at the front of the queue.-fromList :: [a] -> Queue a-fromList = F.foldl' snoc empty---- | \( O(n) \). Convert a list of the given size to a 'Queue', with the--- head of the list at the front of the queue.-fromListN :: Int -> [a] -> Queue a-fromListN n xs-  | (q,[]) <- runState (fromListQN A.one (intToQueueNum n)) xs-  = Queue q-  | otherwise-  = error "Data.CompactSequence.Queue.fromListN: list too long"---- We use a similar approach to the one we use for stacks.  We should be able--- to speed up the calculation of the QueueNum, perhaps even reducing its order--- of growth, but this is sufficient to get linear-time conversion. Every node--- of the resulting queue will be safe, except possibly the last one. This--- should make the resulting queue cheap to work with initially.--data QueueNum-  = EmptyNum-  | NodeNum !FNum !QueueNum !RNum-data FNum = FN1 | FN2 | FN3-data RNum = RN0 | RN1 | RN2--fromListQN :: A.Size n -> QueueNum -> State [a] (Q.Queue n a)-fromListQN !_ EmptyNum = pure Q.empty-fromListQN !n (NodeNum prn mn sfn)-  = case prn of-      FN1 -> do-        sa <- state (A.arraySplitListN n)-        m  <- fromListQN (A.twice n) mn-        sf <- fromListRearQN n sfn-        pure (Q.Node (Q.FD1 sa) m sf)-      FN2 -> do-        sa1 <- state (A.arraySplitListN n)-        sa2 <- state (A.arraySplitListN n)-        m  <- fromListQN (A.twice n) mn-        sf <- fromListRearQN n sfn-        pure (Q.Node (Q.FD2 sa1 sa2) m sf)-      FN3 -> do-        sa1 <- state (A.arraySplitListN n)-        sa2 <- state (A.arraySplitListN n)-        sa3 <- state (A.arraySplitListN n)-        m  <- fromListQN (A.twice n) mn-        sf <- fromListRearQN n sfn-        pure (Q.Node (Q.FD3 sa1 sa2 sa3) m sf)-               -fromListRearQN :: A.Size n -> RNum -> State [a] (Q.RD n a)-fromListRearQN !_ RN0 = pure Q.RD0-fromListRearQN !n RN1 = do-    sa <- state (A.arraySplitListN n)-    pure (Q.RD1 sa)-fromListRearQN !n RN2 = do-    sa1 <- state (A.arraySplitListN n)-    sa2 <- state (A.arraySplitListN n)-    pure (Q.RD2 sa1 sa2)--intToQueueNum :: Int -> QueueNum-intToQueueNum = go EmptyNum-  where-    go !qn 0 = qn-    go !qn n = go (incQueueNum qn) (n - 1)---- Note: this is not structured at all like `snoc`, because it makes no--- semantic difference whether an increment occurs at the front or at the rear.--- We ensure that every node is safe, except possibly the last one. We also--- lean toward placing elements in the front.-incQueueNum :: QueueNum -> QueueNum-incQueueNum EmptyNum = NodeNum FN1 EmptyNum RN0-incQueueNum (NodeNum FN1 m sf) = NodeNum FN2 m sf-incQueueNum (NodeNum FN2 m sf) = NodeNum FN3 m sf-incQueueNum (NodeNum FN3 m RN0) = NodeNum FN3 m RN1-incQueueNum (NodeNum FN3 m RN1) = NodeNum FN3 (incQueueNum m) RN0--- The last case is never used by intToQueueNum, because--- incQueueNum never produces RN2 if it's not given it.-incQueueNum (NodeNum FN3 m RN2) = NodeNum FN3 (incQueueNum m) RN1+import Data.CompactSequence.Queue.Simple.Internal+import Prelude ()

@@ -0,0 +1,219 @@+{-# language DeriveTraversable #-}+{-# language ScopedTypeVariables #-}+{-# language BangPatterns #-}+{-# language MagicHash #-}+{-# language UnboxedTuples #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language Trustworthy #-}+{-# language TypeFamilies #-}+{-# language FlexibleContexts #-}+{- OPTIONS_GHC -Wall #-}+{- OPTIONS_GHC -ddump-simpl #-}++{- |+Space-efficient queues with amortized \( O(\log n) \) operations.  These+directly use an underlying array-based implementation, without doing any+special optimization for the first few and last few elements of the queue.+-}++module Data.CompactSequence.Queue.Simple.Internal+  ( Queue (.., Empty, (:<))+  , (|>)+  , empty+  , snoc+  , uncons+  , take+  , fromList+  , fromListN+  , fromListNIncremental+  ) where++import qualified Data.CompactSequence.Queue.Internal as Q+import Data.CompactSequence.Internal.Size (Size, Twice)+import qualified Data.CompactSequence.Internal.Size as Sz+import qualified Data.CompactSequence.Internal.Array as A+import qualified Data.CompactSequence.Internal.Numbers as N+import qualified Data.Foldable as F+import qualified GHC.Exts as Exts+import Control.Monad.State.Strict+import qualified Control.Monad.State.Lazy as LS+import qualified Prelude as P+import Prelude hiding (take)++-- | A queue.+newtype Queue a = Queue (Q.Queue Sz.Sz1 a)+  deriving (Functor, Traversable, Eq, Ord)++-- | The empty queue.+empty :: Queue a+empty = Queue Q.empty++-- | Enqueue an element at the rear of a queue.+snoc :: Queue a -> a -> Queue a+snoc (Queue q) a = Queue $ Q.snocA Sz.one q (A.singleton a)++-- | An infix synonym for 'snoc'.+(|>) :: Queue a -> a -> Queue a+(|>) = snoc++-- | Dequeue an element from the front of a queue.+uncons :: Queue a -> Maybe (a, Queue a)+uncons (Queue q) = case Q.viewA Sz.one q of+  Q.EmptyA -> Nothing+  Q.ConsA sa q'+    | (# a #) <- A.getSingleton# sa+    -> Just (a, Queue q')++infixr 5 :<+infixl 4 `snoc`, |>++-- | A unidirectional pattern synonym for viewing the+-- front of a queue.+pattern (:<) :: a -> Queue a -> Queue a+pattern x :< xs <- (uncons -> Just (x, xs))++-- | A bidirectional pattern synonym for the empty queue.+pattern Empty :: Queue a+pattern Empty = Queue Q.Empty+{-# COMPLETE (:<), Empty #-}++instance Foldable Queue where+  -- TODO: Implement more methods?+  foldMap f (Queue q) = foldMap f q+  foldr c n (Queue q) = foldr c n q+  foldr' c n (Queue q) = F.foldr' c n q+  foldl f b (Queue q) = foldl f b q+  foldl' f b (Queue q) = F.foldl' f b q++  null (Queue Q.Empty) = True+  null _ = False+  -- Note: length only does O(log n) *unshared* work, but it does O(n) amortized+  -- work because it has to force the entire spine. We could avoid+  -- this, of course, by storing the size with the queue.+  length (Queue q) = go 0 Sz.one q+    where+      go :: Int -> Size m -> Q.Queue m a -> Int+      go !acc !_s Q.Empty = acc+      go !acc !s (Q.Node pr m sf) = go (acc + lpr + lsf) (Sz.twice s) m+        where+          lpr = case pr of+                  Q.FD1{} -> Sz.getSize s+                  Q.FD2{} -> 2*Sz.getSize s+                  Q.FD3{} -> 3*Sz.getSize s+          lsf = case sf of+                  Q.RD0 -> 0+                  Q.RD1{} -> Sz.getSize s+                  Q.RD2{} -> 2*Sz.getSize s++instance Show a => Show (Queue a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)++instance Exts.IsList (Queue a) where+  type Item (Queue a) = a+  toList = F.toList+  fromList = fromList+  fromListN = fromListN++instance Semigroup (Queue a) where+  -- This gives us O(m + n) append. Can we do better?+  -- I suspect O(min(m,n)) might be possible.+  Empty <> q = q+  q <> Empty = q+  q <> r = fromListN (length q + length r) (F.toList q ++ F.toList r)++instance Monoid (Queue a) where+  mempty = empty++-- | Take up to the given number of elements from the front+-- of a queue to form a new queue. \( O(\min (k, n)) \), where+-- \( k \) is the integer argument and \( n \) is the size of+-- the queue.+take :: Int -> Queue a -> Queue a+take n s+  | n <= 0 = Empty+  | compareLength n s == LT+  = fromListN n (P.take n (F.toList s))+  | otherwise = s++-- | \( O(\min(m, n)) \). Compare an 'Int' to the length of a 'Queue'.+--+-- @compareLength n xs = compare n (length xs)@+compareLength :: Int -> Queue a -> Ordering+compareLength n0 (Queue que0) = go Sz.one n0 que0+  where+    go :: Size n -> Int -> Q.Queue n a -> Ordering+    go !_sz n Q.Empty = compare n 0+    go _sz n _ | n <= 0 = LT+    go sz n (Q.Node pr m sf)+      = go (Sz.twice sz) (n - frontLen sz pr - rearLen sz sf) m++frontLen :: Size n -> Q.FD n a -> Int+frontLen s Q.FD1{} = Sz.getSize s+frontLen s Q.FD2{} = 2 * Sz.getSize s+frontLen s Q.FD3{} = 3 * Sz.getSize s++rearLen :: Size n -> Q.RD n a -> Int+rearLen s Q.RD0{} = 0+rearLen s Q.RD1{} = Sz.getSize s+rearLen s Q.RD2{} = 2 * Sz.getSize s++-- | \( O(n \log n) \). Convert a list to a 'Queue', with the head of the+-- list at the front of the queue.+fromList :: [a] -> Queue a+fromList = F.foldl' snoc empty++-- | \( O(n) \). Convert a list of the given size to a 'Queue', with the+-- head of the list at the front of the queue.+fromListN :: Int -> [a] -> Queue a+fromListN n xs+  = Queue $ evalState (fromListQN Sz.one (N.toBin23 n)) xs++-- | \( O(n) \). Convert a list of the given size to a 'Queue', with the+-- head of the list at the front of the queue. Unlike 'fromListN',+-- the conversion is performed incrementally. This is generally+-- beneficial if the list is represented compactly (e.g., an enumeration)+-- or when it's otherwise not important to consume the entire list+-- immediately.+fromListNIncremental :: Int -> [a] -> Queue a+fromListNIncremental n xs+  = Queue $ LS.evalState (fromListQN Sz.one (N.toBin23 n)) xs++-- We use a similar approach to the one we use for stacks.  Every node of the+-- resulting queue will be safe, except possibly the last one. This should make+-- the resulting queue cheap to work with initially. In particular, each front+-- digit (except possibly the last) will be 2 or 3, and each rear digit will be+-- 0. This arrangement also lets us offer an incremental version of fromListN.++-- Without these SPECIALIZE pragmas, this doesn't get specialized+-- for some reason. Bleh!+{-# SPECIALIZE+  fromListQN :: Size n -> N.Bin23 -> State [a] (Q.Queue n a)+ #-}+{-# SPECIALIZE+  fromListQN :: Size n -> N.Bin23 -> LS.State [a] (Q.Queue n a)+ #-}+fromListQN :: MonadState [a] m => Size n -> N.Bin23 -> m (Q.Queue n a)+fromListQN !_ N.End23 = do+  remains <- get+  if null remains+    then pure Q.empty+    else error "Data.CompactSequence.Queue.Simple.fromListQN: List too long"+fromListQN !sz N.OneEnd23 = do+  sa <- state (A.arraySplitListN sz)+  remains <- get+  if null remains+    then pure $! Q.Node (Q.FD1 sa) Q.Empty Q.RD0+    else error "Data.CompactSequence.Queue.Simple.fromListQN: List too long"+fromListQN !sz (N.Two23 mn) = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  m <- fromListQN (Sz.twice sz) mn+  pure $! Q.Node (Q.FD2 sa1 sa2) m Q.RD0+fromListQN !sz (N.Three23 mn) = do+  sa1 <- state (A.arraySplitListN sz)+  sa2 <- state (A.arraySplitListN sz)+  sa3 <- state (A.arraySplitListN sz)+  m <- fromListQN (Sz.twice sz) mn+  pure $! Q.Node (Q.FD3 sa1 sa2 sa3) m Q.RD0

@@ -1,24 +1,24 @@ {-# language BangPatterns, DeriveTraversable #-} {-# language TypeFamilies #-}-{-# language DataKinds #-}-{-# language TypeOperators #-}-{-# language NoStarIsType #-} {-# language Safe #-} {-# language ScopedTypeVariables #-} {-# language InstanceSigs #-} module Data.CompactSequence.Stack.Internal where import qualified Data.Foldable as F+import Data.CompactSequence.Internal.Size (Size, Twice)+import qualified Data.CompactSequence.Internal.Size as Sz import qualified Data.CompactSequence.Internal.Array.Safe as A-import Data.CompactSequence.Internal.Array.Safe (Array, Size)+import Data.CompactSequence.Internal.Array.Safe (Array)+import Data.CompactSequence.Internal.Size () import Data.Function (on) import Data.Traversable (foldMapDefault) import Prelude  data Stack n a   = Empty-  | One !(Array n a) !(Stack ('A.Twice n) a)-  | Two !(Array n a) !(Array n a) (Stack ('A.Twice n) a)-  | Three !(Array n a) !(Array n a) !(Array n a) !(Stack ('A.Twice n) a)+  | One !(Array n a) !(Stack (Twice n) a)+  | Two !(Array n a) !(Array n a) (Stack (Twice n) a)+  | Three !(Array n a) !(Array n a) !(Array n a) !(Stack (Twice n) a)   deriving (Functor, Traversable) {- Debit invariant: We allow the Stack in each Two node as many debits as there@@ -83,7 +83,7 @@ consA !_ sa Empty = One sa Empty consA !_ sa1 (One sa2 more) = Two sa1 sa2 more consA !_ sa1 (Two sa2 sa3 more) = Three sa1 sa2 sa3 more-consA n sa1 (Three sa2 sa3 sa4 more) = Two sa1 sa2 (consA (A.twice n) (A.append n sa3 sa4) more)+consA n sa1 (Three sa2 sa3 sa4 more) = Two sa1 sa2 (consA (Sz.twice n) (A.append n sa3 sa4) more)  {- Empty is always trivial.@@ -145,7 +145,7 @@ unconsA !_ (Three sa1 sa2 sa3 more) = ConsA sa1 (Two sa2 sa3 more) unconsA !_ (Two sa1 sa2 more) = ConsA sa1 (One sa2 more) unconsA n (One sa more) = ConsA sa $-  case unconsA (A.twice n) more of+  case unconsA (Sz.twice n) more of     EmptyA -> Empty     ConsA sa1 more' -> Two sa2 sa3 more'       where

@@ -1,11 +1,4 @@-{-# language DataKinds #-}-{-# language BangPatterns #-}-{-# language PatternSynonyms #-}-{-# language ViewPatterns #-}-{-# language TypeFamilies #-}-{-# language DeriveTraversable #-}--- We need Trustworthy for the IsList instance. *sigh*-{-# language Trustworthy #-}+{-# language Safe #-}  {- | Space-efficient stacks with amortized \( O(\log n) \) operations.@@ -20,142 +13,11 @@   , cons   , (<|)   , uncons+  , compareLength+  , take+  , fromList   , fromListN   ) where -import qualified Data.CompactSequence.Stack.Internal as S-import Data.CompactSequence.Stack.Internal (consA, unconsA, ViewA (..))-import qualified Data.CompactSequence.Internal.Array.Safe as A-import qualified Data.Foldable as F-import qualified GHC.Exts as Exts--newtype Stack a = Stack {unStack :: S.Stack A.Mul1 a}-  deriving (Functor, Traversable, Eq, Ord)-  -- TODO: Write a custom Traversable instance to avoid-  -- an extra fmap at the top.--empty :: Stack a-empty = Stack S.empty--infixr 4 `cons`, :<, <|-cons :: a -> Stack a -> Stack a-cons a (Stack s) = Stack $ consA A.one (A.singleton a) s--uncons :: Stack a -> Maybe (a, Stack a)-uncons (Stack stk) = do-  ConsA sa stk' <- pure $ unconsA A.one stk-  hd <- A.getSingletonA sa-  Just (hd, Stack stk')--(<|) :: a -> Stack a -> Stack a-(<|) = cons--pattern (:<) :: a -> Stack a -> Stack a-pattern x :< xs <- (uncons -> Just (x, xs))-  where-    (:<) = cons--pattern Empty :: Stack a-pattern Empty = Stack S.Empty--{-# COMPLETE (:<), Empty #-}--instance Foldable Stack where-  -- TODO: implement more methods.-  foldMap f (Stack s) = foldMap f s-  foldr c n (Stack s) = foldr c n s-  foldl' f b (Stack s) = F.foldl' f b s-  null (Stack s) = null s--  -- length does O(log n) *unshared* work, but since-  -- it forces the spine it does O(n) *amortized* work.-  -- The right way to get stack sizes efficiently is to track-  -- them separately.-  length (Stack xs) = go 1 0 xs-    where-      go :: Int -> Int -> S.Stack m a -> Int-      go !_s acc S.Empty = acc-      go s acc (S.One _ more) = go (2*s) (acc + s) more-      go s acc (S.Two _ _ more) = go (2*s) (acc + 2*s) more-      go s acc (S.Three _ _ _ more) = go (2*s) (acc + 3*s) more--instance Semigroup (Stack a) where-  -- This gives us O(m + n) append, which I believe is the best we can do in-  -- general.-  -- TODO: when the first stack is small enough, it's better to-  -- just push all its elements, in reverse, onto the second-  -- stack. Let's take advantage of that.-  Empty <> s = s-  s <> Empty = s-  s <> t = fromListN (length s + length t) (F.toList s ++ F.toList t)--instance Monoid (Stack a) where-  mempty = empty--instance Exts.IsList (Stack a) where-  type Item (Stack a) = a-  toList = F.toList-  fromList = fromList-  fromListN = fromListN---- | \( O(n \log n) \). Convert a list to a stack, with the--- first element of the list as the top of the stack.-fromList :: [a] -> Stack a-fromList = foldr cons empty---- | \( O(n) \). Convert a list of known length to a stack,--- with the first element of the list as the top of the stack.-fromListN :: Int -> [a] -> Stack a-fromListN s xs = Stack $ fromListSN A.one (intToStackNum s) xs---- We implement fromListN using a sort of abstract interpretation.  The--- StackNum type is a representation of the *shape* of a stack.  Incrementing--- it takes O(1) amortized time and O(log n) worst-case time. We count up with--- it all the way to the desired size and then build a stack with the shape it--- indicates. ------ TODO: find a faster way. While this approach is much, much better than the--- naive O(n log n) one, it's not great. The smallest improvement would be to--- represent StackNum as a bitstring, with two bits per digit.  But it would be--- much nicer to find a way to reduce the order of growth.--data StackNum-  = EmptyNum-  | OneNum !StackNum-  | TwoNum !StackNum-  | ThreeNum !StackNum--fromListSN :: A.Size n -> StackNum -> [a] -> S.Stack n a-fromListSN !_ EmptyNum xs-  | F.null xs = S.Empty-  | otherwise = error "Data.CompactSequence.Stack.fromListN: List too long."-fromListSN s (OneNum n') xs-  | (ar, xs') <- A.arraySplitListN s xs-  = S.One ar (fromListSN (A.twice s) n' xs')-fromListSN s (TwoNum n') xs-  | (ar1, xs') <- A.arraySplitListN s xs-  , (ar2, xs'') <- A.arraySplitListN s xs'-    -- We build eagerly to dispose of the list as soon as-    -- possible.-  = S.Two ar1 ar2 $! fromListSN (A.twice s) n' xs''-fromListSN s (ThreeNum n') xs-  | (ar1, xs') <- A.arraySplitListN s xs-  , (ar2, xs'') <- A.arraySplitListN s xs'-  , (ar3, xs''') <- A.arraySplitListN s xs''-  = S.Three ar1 ar2 ar3 (fromListSN (A.twice s) n' xs''')--intToStackNum :: Int -> StackNum-intToStackNum = go EmptyNum-  where-    go !sn 0 = sn-    go !sn n = go (incStackNum sn) (n - 1)--incStackNum :: StackNum -> StackNum-incStackNum EmptyNum = OneNum EmptyNum-incStackNum (OneNum n) = TwoNum n-incStackNum (TwoNum n) = ThreeNum n-incStackNum (ThreeNum n) = TwoNum (incStackNum n)--instance Show a => Show (Stack a) where-    showsPrec p xs = showParen (p > 10) $-        showString "fromList " . shows (F.toList xs)+import Data.CompactSequence.Stack.Simple.Internal+import Prelude ()

@@ -0,0 +1,173 @@+{-# language BangPatterns #-}+{-# language PatternSynonyms #-}+{-# language ViewPatterns #-}+{-# language TypeFamilies #-}+{-# language DeriveTraversable #-}+-- We need Trustworthy for the IsList instance. *sigh*+{-# language Trustworthy #-}++{- |+Space-efficient stacks with amortized \( O(\log n) \) operations.+These directly use an underlying array-based implementation,+without doing any special optimization for the very top of the+stack.+-}++module Data.CompactSequence.Stack.Simple.Internal+  ( Stack (.., Empty, (:<))+  , empty+  , cons+  , (<|)+  , uncons+  , compareLength+  , take+  , fromList+  , fromListN+  ) where++import qualified Data.CompactSequence.Stack.Internal as S+import Data.CompactSequence.Stack.Internal (consA, unconsA, ViewA (..))+import Data.CompactSequence.Internal.Size (Size, Twice)+import qualified Data.CompactSequence.Internal.Size as Sz+import qualified Data.CompactSequence.Internal.Array.Safe as A+import qualified Data.CompactSequence.Internal.Numbers as N+import qualified Data.Foldable as F+import qualified GHC.Exts as Exts+import qualified Prelude as P+import Prelude hiding (take)++-- | A stack.+newtype Stack a = Stack {unStack :: S.Stack Sz.Sz1 a}+  deriving (Functor, Traversable, Eq, Ord)+  -- TODO: Write a custom Traversable instance to avoid+  -- an extra fmap at the top.++-- | The empty stack.+empty :: Stack a+empty = Stack S.empty++infixr 5 `cons`, :<, <|++-- | Push an element onto the front of a stack.+--+-- \( O(\log n) \)+cons :: a -> Stack a -> Stack a+cons a (Stack s) = Stack $ consA Sz.one (A.singleton a) s++-- | Pop an element off the front of a stack.+--+-- Accessing the first element is \( O(1) \). Accessing the rest is+-- \( O(\log n) \).+uncons :: Stack a -> Maybe (a, Stack a)+uncons (Stack stk) = do+  ConsA sa stk' <- pure $ unconsA Sz.one stk+  hd <- A.getSingletonA sa+  Just (hd, Stack stk')++-- | An infix synonym for 'cons'.+(<|) :: a -> Stack a -> Stack a+(<|) = cons++-- | A bidirectional pattern synonym for working with+-- the front of a stack.+pattern (:<) :: a -> Stack a -> Stack a+pattern x :< xs <- (uncons -> Just (x, xs))+  where+    (:<) = cons++-- | A bidirectional pattern synonym for the empty stack.+pattern Empty :: Stack a+pattern Empty = Stack S.Empty++{-# COMPLETE (:<), Empty #-}++instance Foldable Stack where+  -- TODO: implement more methods.+  foldMap f (Stack s) = foldMap f s+  foldr c n (Stack s) = foldr c n s+  foldl' f b (Stack s) = F.foldl' f b s+  null (Stack s) = null s++  -- length does O(log n) *unshared* work, but since+  -- it forces the spine it does O(n) *amortized* work.+  -- The right way to get stack sizes efficiently is to track+  -- them separately.+  length (Stack xs) = go 1 0 xs+    where+      go :: Int -> Int -> S.Stack m a -> Int+      go !_s acc S.Empty = acc+      go s acc (S.One _ more) = go (2*s) (acc + s) more+      go s acc (S.Two _ _ more) = go (2*s) (acc + 2*s) more+      go s acc (S.Three _ _ _ more) = go (2*s) (acc + 3*s) more++-- | \( O(\min(m, n)) \). Compare an 'Int' to the length of a 'Stack'.+--+-- @compareLength n xs = compare n (length xs)@+compareLength :: Int -> Stack a -> Ordering+compareLength n0 (Stack stk0) = go Sz.one n0 stk0+  where+    go :: Size n -> Int -> S.Stack n a -> Ordering+    go !_sz n S.Empty = compare n 0+    go _sz n _ | n <= 0 = LT+    go sz n (S.One _ more) = go (Sz.twice sz) (n - Sz.getSize sz) more+    go sz n (S.Two _ _ more) = go (Sz.twice sz) (n - 2*Sz.getSize sz) more+    go sz n (S.Three _ _ _ more) = go (Sz.twice sz) (n - 3*Sz.getSize sz) more++-- | Take up to the given number of elements from the front+-- of a stack to form a new stack. \( O(\min (k, n)) \), where+-- \( k \) is the integer argument and \( n \) is the size of+-- the stack.+take :: Int -> Stack a -> Stack a+take n s+  | n <= 0 = Empty+  | compareLength n s == LT+  = fromListN n (P.take n (F.toList s))+  | otherwise = s++instance Semigroup (Stack a) where+  -- This gives us O(m + n) append. I believe it's possible to+  -- achieve O(m). See #12 for a sketch.+  Empty <> s = s+  s <> Empty = s+  s <> t = fromListN (length s + length t) (F.toList s ++ F.toList t)++instance Monoid (Stack a) where+  mempty = empty++instance Exts.IsList (Stack a) where+  type Item (Stack a) = a+  toList = F.toList+  fromList = fromList+  fromListN = fromListN++-- | \( O(n \log n) \). Convert a list to a stack, with the+-- first element of the list as the top of the stack.+fromList :: [a] -> Stack a+fromList = foldr cons empty++-- | \( O(n) \). Convert a list of known length to a stack,+-- with the first element of the list as the top of the stack.+fromListN :: Int -> [a] -> Stack a+fromListN n !_+  | n < 0 = error "Data.CompactSequence.Stack.fromListN: Negative argument."+fromListN s xs = Stack $ fromListSN Sz.one (N.toDyadic s) xs++-- We convert the size to a dyadic representation+-- (1-2 binary) and use that as the shape of the stack.+fromListSN :: Size n -> N.Dyadic -> [a] -> S.Stack n a+fromListSN !_ N.DEnd xs+  | F.null xs = S.Empty+  | otherwise = error "Data.CompactSequence.Stack.fromListN: List too long."+fromListSN s (N.DOne n') xs+  | (ar, xs') <- A.arraySplitListN s xs+  = S.One ar (fromListSN (Sz.twice s) n' xs')+fromListSN s (N.DTwo n') xs+  | (ar1, xs') <- A.arraySplitListN s xs+  , (ar2, xs'') <- A.arraySplitListN s xs'+    -- We build eagerly to dispose of the list as soon as+    -- possible.+  = S.Two ar1 ar2 $! fromListSN (Sz.twice s) n' xs''++instance Show a => Show (Stack a) where+    showsPrec p xs = showParen (p > 10) $+        showString "fromList " . shows (F.toList xs)

@@ -0,0 +1,105 @@+{-# language TemplateHaskell #-}+{-# language TypeApplications #-}+{-# language ScopedTypeVariables #-}+{-# language LambdaCase #-}+{-# language BangPatterns #-}+module Main (main) where++import Data.Foldable+import Test.QuickCheck+import Test.QuickCheck.Poly+import Test.Tasty+import Test.Tasty.QuickCheck++import Data.CompactSequence.Deque.Simple.Internal+import qualified Data.CompactSequence.Deque.Simple.Internal as D+import qualified Data.CompactSequence.Deque.Internal as DI+import qualified Data.CompactSequence.Internal.Array.Safe as A+import qualified Data.CompactSequence.Internal.Size as Sz+import Prelude as P++instance Arbitrary a => Arbitrary (Deque a) where+  -- Generate stacks whose size is at most on the same order+  -- of magnitude as the size parameter, with any shape.+  arbitrary = sized $ \sz0 -> do+    sz <- choose (0, sz0)+    Deque <$> go Sz.one sz+    where+      go :: Sz.Size n -> Int -> Gen (DI.Deque n a)+      go !ars n+        | n <= 0 = pure DI.Empty+        | n <= Sz.getSize ars = DI.Shallow <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+      go !ars n = do+        frontSize <- choose (1,4 :: Int)+        rearSize <- choose (1,4 :: Int)+        m <- go (Sz.twice ars) (n - (frontSize + rearSize) * Sz.getSize ars)+        DI.Deep <$> dig ars frontSize <*> pure m <*> dig ars rearSize++      dig !ars = \case+        1 -> DI.One <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        2 -> DI.Two <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        3 -> DI.Three <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        _ -> DI.Four <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)++{-+  -- We shrink by trimming the spine. Any other shrinks will+  -- be tricky.+  shrink (Deque que) = [ Deque (takeSpine k que) | k <- [0..depth que]]+    where+      depth :: DI.Deque n a -> Int+      depth DI.Empty = 0+      depth (DI.Node _ m _) = 1 + depth m++      takeSpine :: Int -> DI.Deque n a -> DI.Deque n a+      takeSpine 0 !_ = DI.Empty+      takeSpine _ DI.Empty+        = DI.Empty+      takeSpine n (DI.Node pr m sf)+        = DI.Node pr (takeSpine (n - 1) m) sf+-}++prop_identityA :: [A] -> Property+prop_identityA lst = toList (fromList lst) === lst++prop_identityB :: Deque A -> Property+prop_identityB stk = fromList (toList stk) === stk++prop_identityC :: [A] -> Property+prop_identityC lst = toList (fromListN (length lst) lst) === lst++prop_identityD :: Deque A -> Property+prop_identityD stk = fromListN (length stk) (toList stk) === stk++prop_snoc :: Deque A -> A -> Property+prop_snoc xs x = toList (xs |> x) === toList xs ++ [x]++prop_uncons :: Deque A -> Property+prop_uncons xs = case xs of+  Empty -> toList xs === []+  y :< ys -> toList xs === y : toList ys++prop_uncons_of_empty :: Property+prop_uncons_of_empty = uncons (Empty @(Deque A)) === Nothing++prop_append :: Deque A -> Deque A -> Property+prop_append xs ys = toList (xs <> ys) === toList xs ++ toList ys++--prop_compareLength :: Int -> Deque () -> Property+--prop_compareLength n s = compareLength n s === compare n (length s)++--prop_take :: Int -> Deque A -> Property+--prop_take n s = toList (D.take n s) === P.take n (toList s)++return [] -- This makes sure the above properties are seen by $allProperties++all_props :: TestTree+all_props = testProperties "properties" $allProperties++main :: IO ()+main = defaultMain all_props

@@ -1,4 +0,0 @@-module Main (main) where--main :: IO ()-main = putStrLn "Test suite not yet implemented."

@@ -0,0 +1,107 @@+{-# language TemplateHaskell #-}+{-# language TypeApplications #-}+{-# language ScopedTypeVariables #-}+{-# language LambdaCase #-}+{-# language BangPatterns #-}+module Main (main) where++import Data.Foldable+import Test.QuickCheck+import Test.QuickCheck.Poly+import Test.Tasty+import Test.Tasty.QuickCheck++import Data.CompactSequence.Queue.Simple.Internal+import qualified Data.CompactSequence.Queue.Simple.Internal as Q+import qualified Data.CompactSequence.Queue.Internal as QI+import qualified Data.CompactSequence.Internal.Array.Safe as A+import qualified Data.CompactSequence.Internal.Size as Sz+import Prelude as P++instance Arbitrary a => Arbitrary (Queue a) where+  -- Generate stacks whose size is at most on the same order+  -- of magnitude as the size parameter, with any shape.+  arbitrary = sized $ \sz0 -> do+    sz <- choose (0, sz0)+    Queue <$> go Sz.one sz+    where+      go :: Sz.Size n -> Int -> Gen (QI.Queue n a)+      go !_ars n+        | n <= 0 = pure QI.Empty+      go !ars n = do+        frontSize <- choose (1,3 :: Int)+        rearSize <- choose (0,2 :: Int)+        m <- go (Sz.twice ars) (n - (frontSize + rearSize) * Sz.getSize ars)+        QI.Node <$> pr ars frontSize <*> pure m <*> sf ars rearSize++      pr !ars = \case+        1 -> QI.FD1 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        2 -> QI.FD2 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        _ -> QI.FD3 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)++      sf !ars = \case+        0 -> pure QI.RD0+        1 -> QI.RD1 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+        _ -> QI.RD2 <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)++  -- We shrink by trimming the spine. Any other shrinks will+  -- be tricky.+  shrink (Queue que) = [ Queue (takeSpine k que) | k <- [0..depth que]]+    where+      depth :: QI.Queue n a -> Int+      depth QI.Empty = 0+      depth (QI.Node _ m _) = 1 + depth m++      takeSpine :: Int -> QI.Queue n a -> QI.Queue n a+      takeSpine 0 !_ = QI.Empty+      takeSpine _ QI.Empty+        = QI.Empty+      takeSpine n (QI.Node pr m sf)+        = QI.Node pr (takeSpine (n - 1) m) sf++prop_identityA :: [A] -> Property+prop_identityA lst = toList (fromList lst) === lst++prop_identityB :: Queue A -> Property+prop_identityB stk = fromList (toList stk) === stk++prop_identityC :: [A] -> Property+prop_identityC lst = toList (fromListN (length lst) lst) === lst++prop_identityD :: Queue A -> Property+prop_identityD stk = fromListN (length stk) (toList stk) === stk++prop_identityE :: [A] -> Property+prop_identityE lst = toList (fromListNIncremental (length lst) lst) === lst++prop_snoc :: Queue A -> A -> Property+prop_snoc xs x = toList (xs |> x) === toList xs ++ [x]++prop_uncons :: Queue A -> Property+prop_uncons xs = case xs of+  Empty -> toList xs === []+  y :< ys -> toList xs === y : toList ys++prop_uncons_of_empty :: Property+prop_uncons_of_empty = uncons (Empty @(Queue A)) === Nothing++prop_append :: Queue A -> Queue A -> Property+prop_append xs ys = toList (xs <> ys) === toList xs ++ toList ys++--prop_compareLength :: Int -> Queue () -> Property+--prop_compareLength n s = compareLength n s === compare n (length s)++prop_take :: Int -> Queue A -> Property+prop_take n s = toList (Q.take n s) === P.take n (toList s)++return [] -- This makes sure the above properties are seen by $allProperties++all_props :: TestTree+all_props = testProperties "properties" $allProperties++main :: IO ()+main = defaultMain all_props

@@ -0,0 +1,104 @@+{-# language TemplateHaskell #-}+{-# language TypeApplications #-}+{-# language ScopedTypeVariables #-}+{-# language LambdaCase #-}+{-# language BangPatterns #-}+module Main (main) where++import Data.Foldable+import Test.QuickCheck+import Test.QuickCheck.Poly+import Test.Tasty+import Test.Tasty.QuickCheck++import Data.CompactSequence.Stack.Simple.Internal+import qualified Data.CompactSequence.Stack.Simple.Internal as S+import qualified Data.CompactSequence.Stack.Internal as SI+import qualified Data.CompactSequence.Internal.Array.Safe as A+import qualified Data.CompactSequence.Internal.Size as Sz+import Prelude as P++instance Arbitrary a => Arbitrary (Stack a) where+  -- Generate stacks whose size is at most on the same order+  -- of magnitude as the size parameter, with any shape.+  arbitrary = sized $ \sz0 -> do+    sz <- choose (0, sz0)+    Stack <$> go Sz.one sz+    where+      go :: Sz.Size n -> Int -> Gen (SI.Stack n a)+      go !_ars n+        | n <= 0 = pure SI.Empty+      go !ars n = choose (1,3 :: Int) >>= \case+        1 -> SI.One <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> go (Sz.twice ars) (n - Sz.getSize ars)+        2 -> SI.Two <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                    <*> go (Sz.twice ars) (n - 2 * Sz.getSize ars)+        3 -> SI.Three <$> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                      <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                      <*> (A.fromList ars <$> vectorOf (Sz.getSize ars) arbitrary)+                      <*> go (Sz.twice ars) (n - 3 * Sz.getSize ars)++  -- We shrink by trimming the spine. Any other shrinks will+  -- be tricky.+  shrink (Stack stk) = [ Stack (takeSpine k stk) | k <- [0..depth stk]]+    where+      depth :: SI.Stack n a -> Int+      depth SI.Empty = 0+      depth (SI.One _ m) = 1 + depth m+      depth (SI.Two _ _ m) = 1 + depth m+      depth (SI.Three _ _ _ m) = 1 + depth m++      takeSpine :: Int -> SI.Stack n a -> SI.Stack n a+      takeSpine 0 !_ = SI.Empty+      takeSpine _ SI.Empty+        = SI.Empty+      takeSpine n (SI.One sa1 m)+        = SI.One sa1 $ takeSpine (n - 1) m+      takeSpine n (SI.Two sa1 sa2 m)+        = SI.Two sa1 sa2 $ takeSpine (n - 1) m+      takeSpine n (SI.Three sa1 sa2 sa3 m)+        = SI.Three sa1 sa2 sa3 $ takeSpine (n - 1) m+++prop_identityA :: [A] -> Property+prop_identityA lst = toList (fromList lst) === lst++prop_identityB :: Stack A -> Property+prop_identityB stk = fromList (toList stk) === stk++prop_identityC :: [A] -> Property+prop_identityC lst = toList (fromListN (length lst) lst) === lst++prop_identityD :: Stack A -> Property+prop_identityD stk = fromListN (length stk) (toList stk) === stk++prop_cons :: A -> Stack A -> Property+prop_cons x xs = toList (x :< xs) === x : toList xs++prop_uncons :: Stack A -> Property+prop_uncons xs = case xs of+  Empty -> toList xs === []+  y :< ys -> toList xs === y : toList ys++prop_uncons_of_empty :: Property+prop_uncons_of_empty = uncons (Empty @(Stack A)) === Nothing++prop_uncons_of_cons :: A -> Stack A -> Property+prop_uncons_of_cons x xs = uncons (x :< xs) === Just (x, xs)++prop_append :: Stack A -> Stack A -> Property+prop_append xs ys = toList (xs <> ys) === toList xs ++ toList ys++prop_compareLength :: Int -> Stack () -> Property+prop_compareLength n s = compareLength n s === compare n (length s)++prop_take :: Int -> Stack A -> Property+prop_take n s = toList (S.take n s) === P.take n (toList s)++return [] -- This makes sure the above properties are seen by $allProperties+all_props :: TestTree+all_props = testProperties "properties" $allProperties++main :: IO ()+main = defaultMain all_props