diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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.
diff --git a/compact-sequences.cabal b/compact-sequences.cabal
--- a/compact-sequences.cabal
+++ b/compact-sequences.cabal
@@ -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
diff --git a/src/Data/CompactSequence/Deque/Internal.hs b/src/Data/CompactSequence/Deque/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Deque/Internal.hs
@@ -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
diff --git a/src/Data/CompactSequence/Deque/Simple.hs b/src/Data/CompactSequence/Deque/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Deque/Simple.hs
@@ -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 ()
diff --git a/src/Data/CompactSequence/Deque/Simple/Internal.hs b/src/Data/CompactSequence/Deque/Simple/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Deque/Simple/Internal.hs
@@ -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
diff --git a/src/Data/CompactSequence/Internal/Array.hs b/src/Data/CompactSequence/Internal/Array.hs
--- a/src/Data/CompactSequence/Internal/Array.hs
+++ b/src/Data/CompactSequence/Internal/Array.hs
@@ -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)
diff --git a/src/Data/CompactSequence/Internal/Array/Safe.hs b/src/Data/CompactSequence/Internal/Array/Safe.hs
--- a/src/Data/CompactSequence/Internal/Array/Safe.hs
+++ b/src/Data/CompactSequence/Internal/Array/Safe.hs
@@ -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
diff --git a/src/Data/CompactSequence/Internal/Numbers.hs b/src/Data/CompactSequence/Internal/Numbers.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Internal/Numbers.hs
@@ -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 #-}
diff --git a/src/Data/CompactSequence/Internal/Size.hs b/src/Data/CompactSequence/Internal/Size.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Internal/Size.hs
@@ -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
diff --git a/src/Data/CompactSequence/Queue/Internal.hs b/src/Data/CompactSequence/Queue/Internal.hs
--- a/src/Data/CompactSequence/Queue/Internal.hs
+++ b/src/Data/CompactSequence/Queue/Internal.hs
@@ -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.
diff --git a/src/Data/CompactSequence/Queue/Simple.hs b/src/Data/CompactSequence/Queue/Simple.hs
--- a/src/Data/CompactSequence/Queue/Simple.hs
+++ b/src/Data/CompactSequence/Queue/Simple.hs
@@ -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 ()
diff --git a/src/Data/CompactSequence/Queue/Simple/Internal.hs b/src/Data/CompactSequence/Queue/Simple/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Queue/Simple/Internal.hs
@@ -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
diff --git a/src/Data/CompactSequence/Stack/Internal.hs b/src/Data/CompactSequence/Stack/Internal.hs
--- a/src/Data/CompactSequence/Stack/Internal.hs
+++ b/src/Data/CompactSequence/Stack/Internal.hs
@@ -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
diff --git a/src/Data/CompactSequence/Stack/Simple.hs b/src/Data/CompactSequence/Stack/Simple.hs
--- a/src/Data/CompactSequence/Stack/Simple.hs
+++ b/src/Data/CompactSequence/Stack/Simple.hs
@@ -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 ()
diff --git a/src/Data/CompactSequence/Stack/Simple/Internal.hs b/src/Data/CompactSequence/Stack/Simple/Internal.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/CompactSequence/Stack/Simple/Internal.hs
@@ -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)
diff --git a/test/Deque.hs b/test/Deque.hs
new file mode 100644
--- /dev/null
+++ b/test/Deque.hs
@@ -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
diff --git a/test/MyLibTest.hs b/test/MyLibTest.hs
deleted file mode 100644
--- a/test/MyLibTest.hs
+++ /dev/null
@@ -1,4 +0,0 @@
-module Main (main) where
-
-main :: IO ()
-main = putStrLn "Test suite not yet implemented."
diff --git a/test/Queue.hs b/test/Queue.hs
new file mode 100644
--- /dev/null
+++ b/test/Queue.hs
@@ -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
diff --git a/test/Stack.hs b/test/Stack.hs
new file mode 100644
--- /dev/null
+++ b/test/Stack.hs
@@ -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