{-# LANGUAGE CPP #-}
#include "containers.h"
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Trustworthy #-}
#endif
#ifdef DEFINE_PATTERN_SYNONYMS
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}
#endif
{-# LANGUAGE PatternGuards #-}

{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Sequence.Internal
-- Copyright   :  (c) Ross Paterson 2005
--                (c) Louis Wasserman 2009
--                (c) Bertram Felgenhauer, David Feuer, Ross Paterson, and
--                    Milan Straka 2014
-- License     :  BSD-style
-- Maintainer  :  libraries@haskell.org
-- Portability :  portable
--
--
-- = WARNING
--
-- This module is considered __internal__.
--
-- The Package Versioning Policy __does not apply__.
--
-- The contents of this module may change __in any way whatsoever__
-- and __without any warning__ between minor versions of this package.
--
-- Authors importing this module are expected to track development
-- closely.
--
-- = Description
--
-- General purpose finite sequences.
-- Apart from being finite and having strict operations, sequences
-- also differ from lists in supporting a wider variety of operations
-- efficiently.
--
-- An amortized running time is given for each operation, with \( n \) referring
-- to the length of the sequence and \( i \) being the integral index used by
-- some operations. These bounds hold even in a persistent (shared) setting.
--
-- The implementation uses 2-3 finger trees annotated with sizes,
-- as described in section 4.2 of
--
--    * Ralf Hinze and Ross Paterson,
--      \"Finger trees: a simple general-purpose data structure\",
--      /Journal of Functional Programming/ 16:2 (2006) pp 197-217.
--      <http://staff.city.ac.uk/~ross/papers/FingerTree.html>
--
-- /Note/: Many of these operations have the same names as similar
-- operations on lists in the "Prelude". The ambiguity may be resolved
-- using either qualification or the @hiding@ clause.
--
-- /Warning/: The size of a 'Seq' must not exceed @maxBound::Int@.  Violation
-- of this condition is not detected and if the size limit is exceeded, the
-- behaviour of the sequence is undefined.  This is unlikely to occur in most
-- applications, but some care may be required when using '><', '<*>', '*>', or
-- '>>', particularly repeatedly and particularly in combination with
-- 'replicate' or 'fromFunction'.
--
-- @since 0.5.9
-----------------------------------------------------------------------------

module Data.Sequence.Internal (
    Elem(..), FingerTree(..), Node(..), Digit(..), Sized(..), MaybeForce,
#if defined(DEFINE_PATTERN_SYNONYMS)
    Seq (.., Empty, (:<|), (:|>)),
#else
    Seq (..),
#endif
    State(..),
    execState,
    foldDigit,
    foldNode,
    foldWithIndexDigit,
    foldWithIndexNode,

    -- * Construction
    empty,          -- :: Seq a
    singleton,      -- :: a -> Seq a
    (<|),           -- :: a -> Seq a -> Seq a
    (|>),           -- :: Seq a -> a -> Seq a
    (><),           -- :: Seq a -> Seq a -> Seq a
    fromList,       -- :: [a] -> Seq a
    fromFunction,   -- :: Int -> (Int -> a) -> Seq a
    fromArray,      -- :: Ix i => Array i a -> Seq a
    -- ** Repetition
    replicate,      -- :: Int -> a -> Seq a
    replicateA,     -- :: Applicative f => Int -> f a -> f (Seq a)
    replicateM,     -- :: Applicative m => Int -> m a -> m (Seq a)
    cycleTaking,    -- :: Int -> Seq a -> Seq a
    -- ** Iterative construction
    iterateN,       -- :: Int -> (a -> a) -> a -> Seq a
    unfoldr,        -- :: (b -> Maybe (a, b)) -> b -> Seq a
    unfoldl,        -- :: (b -> Maybe (b, a)) -> b -> Seq a
    -- * Deconstruction
    -- | Additional functions for deconstructing sequences are available
    -- via the 'Foldable' instance of 'Seq'.

    -- ** Queries
    null,           -- :: Seq a -> Bool
    length,         -- :: Seq a -> Int
    -- ** Views
    ViewL(..),
    viewl,          -- :: Seq a -> ViewL a
    ViewR(..),
    viewr,          -- :: Seq a -> ViewR a
    -- * Scans
    scanl,          -- :: (a -> b -> a) -> a -> Seq b -> Seq a
    scanl1,         -- :: (a -> a -> a) -> Seq a -> Seq a
    scanr,          -- :: (a -> b -> b) -> b -> Seq a -> Seq b
    scanr1,         -- :: (a -> a -> a) -> Seq a -> Seq a
    -- * Sublists
    tails,          -- :: Seq a -> Seq (Seq a)
    inits,          -- :: Seq a -> Seq (Seq a)
    chunksOf,       -- :: Int -> Seq a -> Seq (Seq a)
    -- ** Sequential searches
    takeWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a
    takeWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a
    dropWhileL,     -- :: (a -> Bool) -> Seq a -> Seq a
    dropWhileR,     -- :: (a -> Bool) -> Seq a -> Seq a
    spanl,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
    spanr,          -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
    breakl,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
    breakr,         -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
    partition,      -- :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
    filter,         -- :: (a -> Bool) -> Seq a -> Seq a
    -- * Indexing
    lookup,         -- :: Int -> Seq a -> Maybe a
    (!?),           -- :: Seq a -> Int -> Maybe a
    index,          -- :: Seq a -> Int -> a
    adjust,         -- :: (a -> a) -> Int -> Seq a -> Seq a
    adjust',        -- :: (a -> a) -> Int -> Seq a -> Seq a
    update,         -- :: Int -> a -> Seq a -> Seq a
    take,           -- :: Int -> Seq a -> Seq a
    drop,           -- :: Int -> Seq a -> Seq a
    insertAt,       -- :: Int -> a -> Seq a -> Seq a
    deleteAt,       -- :: Int -> Seq a -> Seq a
    splitAt,        -- :: Int -> Seq a -> (Seq a, Seq a)
    -- ** Indexing with predicates
    -- | These functions perform sequential searches from the left
    -- or right ends of the sequence, returning indices of matching
    -- elements.
    elemIndexL,     -- :: Eq a => a -> Seq a -> Maybe Int
    elemIndicesL,   -- :: Eq a => a -> Seq a -> [Int]
    elemIndexR,     -- :: Eq a => a -> Seq a -> Maybe Int
    elemIndicesR,   -- :: Eq a => a -> Seq a -> [Int]
    findIndexL,     -- :: (a -> Bool) -> Seq a -> Maybe Int
    findIndicesL,   -- :: (a -> Bool) -> Seq a -> [Int]
    findIndexR,     -- :: (a -> Bool) -> Seq a -> Maybe Int
    findIndicesR,   -- :: (a -> Bool) -> Seq a -> [Int]
    -- * Folds
    -- | General folds are available via the 'Foldable' instance of 'Seq'.
    foldMapWithIndex, -- :: Monoid m => (Int -> a -> m) -> Seq a -> m
    foldlWithIndex, -- :: (b -> Int -> a -> b) -> b -> Seq a -> b
    foldrWithIndex, -- :: (Int -> a -> b -> b) -> b -> Seq a -> b
    -- * Transformations
    mapWithIndex,   -- :: (Int -> a -> b) -> Seq a -> Seq b
    traverseWithIndex, -- :: Applicative f => (Int -> a -> f b) -> Seq a -> f (Seq b)
    reverse,        -- :: Seq a -> Seq a
    intersperse,    -- :: a -> Seq a -> Seq a
    liftA2Seq,      -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
    -- ** Zips and unzips
    zip,            -- :: Seq a -> Seq b -> Seq (a, b)
    zipWith,        -- :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
    zip3,           -- :: Seq a -> Seq b -> Seq c -> Seq (a, b, c)
    zipWith3,       -- :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
    zip4,           -- :: Seq a -> Seq b -> Seq c -> Seq d -> Seq (a, b, c, d)
    zipWith4,       -- :: (a -> b -> c -> d -> e) -> Seq a -> Seq b -> Seq c -> Seq d -> Seq e
    unzip,          -- :: Seq (a, b) -> (Seq a, Seq b)
    unzipWith,      -- :: (a -> (b, c)) -> Seq a -> (Seq b, Seq c)
#ifdef TESTING
    deep,
    node2,
    node3,
#endif
    ) where

import Prelude hiding (
    Functor(..),
#if MIN_VERSION_base(4,11,0)
    (<>),
#endif
#if MIN_VERSION_base(4,8,0)
    Applicative, (<$>), foldMap, Monoid,
#endif
    null, length, lookup, take, drop, splitAt, foldl, foldl1, foldr, foldr1,
    scanl, scanl1, scanr, scanr1, replicate, zip, zipWith, zip3, zipWith3,
    unzip, takeWhile, dropWhile, iterate, reverse, filter, mapM, sum, all)
import qualified Data.List
import Control.Applicative (Applicative(..), (<$>), (<**>),  Alternative,
                            liftA2, liftA3)
import qualified Control.Applicative as Applicative
import Control.DeepSeq (NFData(rnf))
import Control.Monad (MonadPlus(..))
import Data.Monoid (Monoid(..))
import Data.Functor (Functor(..))
import Utils.Containers.Internal.State (State(..), execState)
import Data.Foldable (Foldable(foldl, foldl1, foldr, foldr1, foldMap, foldl', foldr'), toList)

#if MIN_VERSION_base(4,9,0)
import qualified Data.Semigroup as Semigroup
import Data.Functor.Classes
#endif
import Data.Traversable
import Data.Typeable

-- GHC specific stuff
#ifdef __GLASGOW_HASKELL__
import GHC.Exts (build)
import Text.Read (Lexeme(Ident), lexP, parens, prec,
    readPrec, readListPrec, readListPrecDefault)
import Data.Data
import Data.String (IsString(..))
#endif
#if __GLASGOW_HASKELL__
import GHC.Generics (Generic, Generic1)
#endif

-- Array stuff, with GHC.Arr on GHC
import Data.Array (Ix, Array)
import qualified Data.Array
#ifdef __GLASGOW_HASKELL__
import qualified GHC.Arr
#endif

import Utils.Containers.Internal.Coercions ((.#), (.^#))
-- Coercion on GHC 7.8+
#if __GLASGOW_HASKELL__ >= 708
import Data.Coerce
import qualified GHC.Exts
#else
#endif

-- Identity functor on base 4.8 (GHC 7.10+)
#if MIN_VERSION_base(4,8,0)
import Data.Functor.Identity (Identity(..))
#endif

#if !MIN_VERSION_base(4,8,0)
import Data.Word (Word)
#endif

import Utils.Containers.Internal.StrictPair (StrictPair (..), toPair)
import Control.Monad.Zip (MonadZip (..))
import Control.Monad.Fix (MonadFix (..), fix)

default ()

-- We define our own copy here, for Monoid only, even though this
-- is now a Semigroup operator in base. The essential reason is that
-- we have absolutely no use for semigroups in this module. Everything
-- that needs to sum things up requires a Monoid constraint to deal
-- with empty sequences. I'm not sure if there's a risk of walking
-- through dictionaries to reach <> from Monoid, but I see no reason
-- to risk it.
infixr 6 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}

infixr 5 `consTree`
infixl 5 `snocTree`
infixr 5 `appendTree0`

infixr 5 ><
infixr 5 <|, :<
infixl 5 |>, :>

#ifdef DEFINE_PATTERN_SYNONYMS
infixr 5 :<|
infixl 5 :|>

#if __GLASGOW_HASKELL__ >= 801
{-# COMPLETE (:<|), Empty #-}
{-# COMPLETE (:|>), Empty #-}
#endif

-- | A bidirectional pattern synonym matching an empty sequence.
--
-- @since 0.5.8
pattern Empty :: Seq a
pattern Empty = Seq EmptyT

-- | A bidirectional pattern synonym viewing the front of a non-empty
-- sequence.
--
-- @since 0.5.8
pattern (:<|) :: a -> Seq a -> Seq a
pattern x :<| xs <- (viewl -> x :< xs)
  where
    x :<| xs = x <| xs

-- | A bidirectional pattern synonym viewing the rear of a non-empty
-- sequence.
--
-- @since 0.5.8
pattern (:|>) :: Seq a -> a -> Seq a
pattern xs :|> x <- (viewr -> xs :> x)
  where
    xs :|> x = xs |> x
#endif

class Sized a where
    size :: a -> Int

-- In much the same way that Sized lets us handle the
-- sizes of elements and nodes uniformly, MaybeForce lets
-- us handle their strictness (or lack thereof) uniformly.
-- We can `mseq` something and not have to worry about
-- whether it's an element or a node.
class MaybeForce a where
  maybeRwhnf :: a -> ()

mseq :: MaybeForce a => a -> b -> b
mseq a b = case maybeRwhnf a of () -> b
{-# INLINE mseq #-}

infixr 0 $!?
($!?) :: MaybeForce a => (a -> b) -> a -> b
f $!? a = case maybeRwhnf a of () -> f a
{-# INLINE ($!?) #-}

instance MaybeForce (Elem a) where
  maybeRwhnf _ = ()
  {-# INLINE maybeRwhnf #-}

instance MaybeForce (Node a) where
  maybeRwhnf !_ = ()
  {-# INLINE maybeRwhnf #-}

-- A wrapper making mseq = seq
newtype ForceBox a = ForceBox a
instance MaybeForce (ForceBox a) where
  maybeRwhnf !_ = ()
instance Sized (ForceBox a) where
  size _ = 1

-- | General-purpose finite sequences.
newtype Seq a = Seq (FingerTree (Elem a))

instance Functor Seq where
    fmap = fmapSeq
#ifdef __GLASGOW_HASKELL__
    x <$ s = replicate (length s) x
#endif

fmapSeq :: (a -> b) -> Seq a -> Seq b
fmapSeq f (Seq xs) = Seq (fmap (fmap f) xs)
#ifdef __GLASGOW_HASKELL__
{-# NOINLINE [1] fmapSeq #-}
{-# RULES
"fmapSeq/fmapSeq" forall f g xs . fmapSeq f (fmapSeq g xs) = fmapSeq (f . g) xs
 #-}
#endif
#if __GLASGOW_HASKELL__ >= 709
-- Safe coercions were introduced in 7.8, but did not work well with RULES yet.
{-# RULES
"fmapSeq/coerce" fmapSeq coerce = coerce
 #-}
#endif

getSeq :: Seq a -> FingerTree (Elem a)
getSeq (Seq xs) = xs

instance Foldable Seq where
    foldMap f = foldMap (f .# getElem) .# getSeq
    foldr f z = foldr (f .# getElem) z .# getSeq
    foldl f z = foldl (f .^# getElem) z .# getSeq

#if __GLASGOW_HASKELL__
    {-# INLINABLE foldMap #-}
    {-# INLINABLE foldr #-}
    {-# INLINABLE foldl #-}
#endif

    foldr' f z = foldr' (f .# getElem) z .# getSeq
    foldl' f z = foldl' (f .^# getElem) z .# getSeq

#if __GLASGOW_HASKELL__
    {-# INLINABLE foldr' #-}
    {-# INLINABLE foldl' #-}
#endif

    foldr1 f (Seq xs) = getElem (foldr1 f' xs)
      where f' (Elem x) (Elem y) = Elem (f x y)

    foldl1 f (Seq xs) = getElem (foldl1 f' xs)
      where f' (Elem x) (Elem y) = Elem (f x y)

#if MIN_VERSION_base(4,8,0)
    length = length
    {-# INLINE length #-}
    null   = null
    {-# INLINE null #-}
#endif

instance Traversable Seq where
#if __GLASGOW_HASKELL__
    {-# INLINABLE traverse #-}
#endif
    traverse _ (Seq EmptyT) = pure (Seq EmptyT)
    traverse f' (Seq (Single (Elem x'))) =
        (\x'' -> Seq (Single (Elem x''))) <$> f' x'
    traverse f' (Seq (Deep s' pr' m' sf')) =
        liftA3
            (\pr'' m'' sf'' -> Seq (Deep s' pr'' m'' sf''))
            (traverseDigitE f' pr')
            (traverseTree (traverseNodeE f') m')
            (traverseDigitE f' sf')
      where
        traverseTree
            :: Applicative f
            => (Node a -> f (Node b))
            -> FingerTree (Node a)
            -> f (FingerTree (Node b))
        traverseTree _ EmptyT = pure EmptyT
        traverseTree f (Single x) = Single <$> f x
        traverseTree f (Deep s pr m sf) =
            liftA3
                (Deep s)
                (traverseDigitN f pr)
                (traverseTree (traverseNodeN f) m)
                (traverseDigitN f sf)
        traverseDigitE
            :: Applicative f
            => (a -> f b) -> Digit (Elem a) -> f (Digit (Elem b))
        traverseDigitE f (One (Elem a)) =
            (\a' -> One (Elem a')) <$>
            f a
        traverseDigitE f (Two (Elem a) (Elem b)) =
            liftA2
                (\a' b' -> Two (Elem a') (Elem b'))
                (f a)
                (f b)
        traverseDigitE f (Three (Elem a) (Elem b) (Elem c)) =
            liftA3
                (\a' b' c' ->
                      Three (Elem a') (Elem b') (Elem c'))
                (f a)
                (f b)
                (f c)
        traverseDigitE f (Four (Elem a) (Elem b) (Elem c) (Elem d)) =
            liftA3
                (\a' b' c' d' -> Four (Elem a') (Elem b') (Elem c') (Elem d'))
                (f a)
                (f b)
                (f c) <*>
                (f d)
        traverseDigitN
            :: Applicative f
            => (Node a -> f (Node b)) -> Digit (Node a) -> f (Digit (Node b))
        traverseDigitN f t = traverse f t
        traverseNodeE
            :: Applicative f
            => (a -> f b) -> Node (Elem a) -> f (Node (Elem b))
        traverseNodeE f (Node2 s (Elem a) (Elem b)) =
            liftA2
                (\a' b' -> Node2 s (Elem a') (Elem b'))
                (f a)
                (f b)
        traverseNodeE f (Node3 s (Elem a) (Elem b) (Elem c)) =
            liftA3
                (\a' b' c' ->
                      Node3 s (Elem a') (Elem b') (Elem c'))
                (f a)
                (f b)
                (f c)
        traverseNodeN
            :: Applicative f
            => (Node a -> f (Node b)) -> Node (Node a) -> f (Node (Node b))
        traverseNodeN f t = traverse f t

instance NFData a => NFData (Seq a) where
    rnf (Seq xs) = rnf xs

instance Monad Seq where
    return = pure
    xs >>= f = foldl' add empty xs
      where add ys x = ys >< f x
    (>>) = (*>)

-- | @since 0.5.11
instance MonadFix Seq where
    mfix = mfixSeq

-- This is just like the instance for lists, but we can take advantage of
-- constant-time length and logarithmic-time indexing to speed things up.
-- Using fromFunction, we make this about as lazy as we can.
mfixSeq :: (a -> Seq a) -> Seq a
mfixSeq f = fromFunction (length (f err)) (\k -> fix (\xk -> f xk `index` k))
  where
    err = error "mfix for Data.Sequence.Seq applied to strict function"

-- | @since 0.5.4
instance Applicative Seq where
    pure = singleton
    xs *> ys = cycleNTimes (length xs) ys
    (<*>) = apSeq
#if MIN_VERSION_base(4,10,0)
    liftA2 = liftA2Seq
#endif

apSeq :: Seq (a -> b) -> Seq a -> Seq b
apSeq fs xs@(Seq xsFT) = case viewl fs of
  EmptyL -> empty
  firstf :< fs' -> case viewr fs' of
    EmptyR -> fmap firstf xs
    Seq fs''FT :> lastf -> case rigidify xsFT of
         RigidEmpty -> empty
         RigidOne (Elem x) -> fmap ($x) fs
         RigidTwo (Elem x1) (Elem x2) ->
            Seq $ ap2FT firstf fs''FT lastf (x1, x2)
         RigidThree (Elem x1) (Elem x2) (Elem x3) ->
            Seq $ ap3FT firstf fs''FT lastf (x1, x2, x3)
         RigidFull r@(Rigid s pr _m sf) -> Seq $
               Deep (s * length fs)
                    (fmap (fmap firstf) (nodeToDigit pr))
                    (aptyMiddle (fmap firstf) (fmap lastf) fmap fs''FT r)
                    (fmap (fmap lastf) (nodeToDigit sf))
{-# NOINLINE [1] apSeq #-}

{-# RULES
"ap/fmap1" forall f xs ys . apSeq (fmapSeq f xs) ys = liftA2Seq f xs ys
"ap/fmap2" forall f gs xs . apSeq gs (fmapSeq f xs) =
                              liftA2Seq (\g x -> g (f x)) gs xs
"fmap/ap" forall f gs xs . fmapSeq f (gs `apSeq` xs) =
                             liftA2Seq (\g x -> f (g x)) gs xs
"fmap/liftA2" forall f g m n . fmapSeq f (liftA2Seq g m n) =
                       liftA2Seq (\x y -> f (g x y)) m n
"liftA2/fmap1" forall f g m n . liftA2Seq f (fmapSeq g m) n =
                       liftA2Seq (\x y -> f (g x) y) m n
"liftA2/fmap2" forall f g m n . liftA2Seq f m (fmapSeq g n) =
                       liftA2Seq (\x y -> f x (g y)) m n
 #-}

ap2FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a) -> FingerTree (Elem b)
ap2FT firstf fs lastf (x,y) =
                 Deep (size fs * 2 + 4)
                      (Two (Elem $ firstf x) (Elem $ firstf y))
                      (mapMulFT 2 (\(Elem f) -> Node2 2 (Elem (f x)) (Elem (f y))) fs)
                      (Two (Elem $ lastf x) (Elem $ lastf y))

ap3FT :: (a -> b) -> FingerTree (Elem (a->b)) -> (a -> b) -> (a,a,a) -> FingerTree (Elem b)
ap3FT firstf fs lastf (x,y,z) = Deep (size fs * 3 + 6)
                        (Three (Elem $ firstf x) (Elem $ firstf y) (Elem $ firstf z))
                        (mapMulFT 3 (\(Elem f) -> Node3 3 (Elem (f x)) (Elem (f y)) (Elem (f z))) fs)
                        (Three (Elem $ lastf x) (Elem $ lastf y) (Elem $ lastf z))

lift2FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b) -> FingerTree (Elem c)
lift2FT f firstx xs lastx (y1,y2) =
                 Deep (size xs * 2 + 4)
                      (Two (Elem $ f firstx y1) (Elem $ f firstx y2))
                      (mapMulFT 2 (\(Elem x) -> Node2 2 (Elem (f x y1)) (Elem (f x y2))) xs)
                      (Two (Elem $ f lastx y1) (Elem $ f lastx y2))

lift3FT :: (a -> b -> c) -> a -> FingerTree (Elem a) -> a -> (b,b,b) -> FingerTree (Elem c)
lift3FT f firstx xs lastx (y1,y2,y3) =
                 Deep (size xs * 3 + 6)
                      (Three (Elem $ f firstx y1) (Elem $ f firstx y2) (Elem $ f firstx y3))
                      (mapMulFT 3 (\(Elem x) -> Node3 3 (Elem (f x y1)) (Elem (f x y2)) (Elem (f x y3))) xs)
                      (Three (Elem $ f lastx y1) (Elem $ f lastx y2) (Elem $ f lastx y3))

liftA2Seq :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
liftA2Seq f xs ys@(Seq ysFT) = case viewl xs of
  EmptyL -> empty
  firstx :< xs' -> case viewr xs' of
    EmptyR -> f firstx <$> ys
    Seq xs''FT :> lastx -> case rigidify ysFT of
      RigidEmpty -> empty
      RigidOne (Elem y) -> fmap (\x -> f x y) xs
      RigidTwo (Elem y1) (Elem y2) ->
        Seq $ lift2FT f firstx xs''FT lastx (y1, y2)
      RigidThree (Elem y1) (Elem y2) (Elem y3) ->
        Seq $ lift3FT f firstx xs''FT lastx (y1, y2, y3)
      RigidFull r@(Rigid s pr _m sf) -> Seq $
        Deep (s * length xs)
             (fmap (fmap (f firstx)) (nodeToDigit pr))
             (aptyMiddle (fmap (f firstx)) (fmap (f lastx)) (lift_elem f) xs''FT r)
             (fmap (fmap (f lastx)) (nodeToDigit sf))
  where
    lift_elem :: (a -> b -> c) -> a -> Elem b -> Elem c
#if __GLASGOW_HASKELL__ >= 708
    lift_elem = coerce
#else
    lift_elem f x (Elem y) = Elem (f x y)
#endif
{-# NOINLINE [1] liftA2Seq #-}


data Rigidified a = RigidEmpty
                  | RigidOne a
                  | RigidTwo a a
                  | RigidThree a a a
                  | RigidFull (Rigid a)
#ifdef TESTING
                  deriving Show
#endif

-- | A finger tree whose top level has only Two and/or Three digits, and whose
-- other levels have only One and Two digits. A Rigid tree is precisely what one
-- gets by unzipping/inverting a 2-3 tree, so it is precisely what we need to
-- turn a finger tree into in order to transform it into a 2-3 tree.
data Rigid a = Rigid {-# UNPACK #-} !Int !(Digit23 a) (Thin (Node a)) !(Digit23 a)
#ifdef TESTING
             deriving Show
#endif

-- | A finger tree whose digits are all ones and twos
data Thin a = EmptyTh
            | SingleTh a
            | DeepTh {-# UNPACK #-} !Int !(Digit12 a) (Thin (Node a)) !(Digit12 a)
#ifdef TESTING
            deriving Show
#endif

data Digit12 a = One12 a | Two12 a a
#ifdef TESTING
        deriving Show
#endif

-- | Sometimes, we want to emphasize that we are viewing a node as a top-level
-- digit of a 'Rigid' tree.
type Digit23 a = Node a

-- | 'aptyMiddle' does most of the hard work of computing @fs<*>xs@.  It
-- produces the center part of a finger tree, with a prefix corresponding to
-- the prefix of @xs@ and a suffix corresponding to the suffix of @xs@ omitted;
-- the missing suffix and prefix are added by the caller.  For the recursive
-- call, it squashes the prefix and the suffix into the center tree. Once it
-- gets to the bottom, it turns the tree into a 2-3 tree, applies 'mapMulFT' to
-- produce the main body, and glues all the pieces together.
--
-- @map23@ itself is a bit horrifying because of the nested types involved. Its
-- job is to map over the *elements* of a 2-3 tree, rather than the subtrees.
-- If we used a higher-order nested type with MPTC, we could probably use a
-- class, but as it is we have to build up @map23@ explicitly through the
-- recursion.
aptyMiddle
  :: (b -> c)
     -> (b -> c)
     -> (a -> b -> c)
     -> FingerTree (Elem a)
     -> Rigid b
     -> FingerTree (Node c)

-- Not at the bottom yet

aptyMiddle firstf
           lastf
           map23
           fs
           (Rigid s pr (DeepTh sm prm mm sfm) sf)
    = Deep (sm + s * (size fs + 1)) -- note: sm = s - size pr - size sf
           (fmap (fmap firstf) (digit12ToDigit prm))
           (aptyMiddle (fmap firstf)
                       (fmap lastf)
                       (fmap . map23)
                       fs
                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))
           (fmap (fmap lastf) (digit12ToDigit sfm))

-- At the bottom

aptyMiddle firstf
           lastf
           map23
           fs
           (Rigid s pr EmptyTh sf)
     = deep
            (One (fmap firstf sf))
            (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
            (One (fmap lastf pr))
   where converted = node2 pr sf

aptyMiddle firstf
           lastf
           map23
           fs
           (Rigid s pr (SingleTh q) sf)
     = deep
            (Two (fmap firstf q) (fmap firstf sf))
            (mapMulFT s (\(Elem f) -> fmap (fmap (map23 f)) converted) fs)
            (Two (fmap lastf pr) (fmap lastf q))
   where converted = node3 pr q sf

digit12ToDigit :: Digit12 a -> Digit a
digit12ToDigit (One12 a) = One a
digit12ToDigit (Two12 a b) = Two a b

-- Squash the first argument down onto the left side of the second.
squashL :: Digit23 a -> Digit12 (Node a) -> Digit23 (Node a)
squashL m (One12 n) = node2 m n
squashL m (Two12 n1 n2) = node3 m n1 n2

-- Squash the second argument down onto the right side of the first
squashR :: Digit12 (Node a) -> Digit23 a -> Digit23 (Node a)
squashR (One12 n) m = node2 n m
squashR (Two12 n1 n2) m = node3 n1 n2 m


-- | /O(m*n)/ (incremental) Takes an /O(m)/ function and a finger tree of size
-- /n/ and maps the function over the tree leaves. Unlike the usual 'fmap', the
-- function is applied to the "leaves" of the 'FingerTree' (i.e., given a
-- @FingerTree (Elem a)@, it applies the function to elements of type @Elem
-- a@), replacing the leaves with subtrees of at least the same height, e.g.,
-- @Node(Node(Elem y))@. The multiplier argument serves to make the annotations
-- match up properly.
mapMulFT :: Int -> (a -> b) -> FingerTree a -> FingerTree b
mapMulFT _ _ EmptyT = EmptyT
mapMulFT _mul f (Single a) = Single (f a)
mapMulFT mul f (Deep s pr m sf) = Deep (mul * s) (fmap f pr) (mapMulFT mul (mapMulNode mul f) m) (fmap f sf)

mapMulNode :: Int -> (a -> b) -> Node a -> Node b
mapMulNode mul f (Node2 s a b)   = Node2 (mul * s) (f a) (f b)
mapMulNode mul f (Node3 s a b c) = Node3 (mul * s) (f a) (f b) (f c)

-- | /O(log n)/ (incremental) Takes the extra flexibility out of a 'FingerTree'
-- to make it a genuine 2-3 finger tree. The result of 'rigidify' will have
-- only two and three digits at the top level and only one and two
-- digits elsewhere. If the tree has fewer than four elements, 'rigidify'
-- will simply extract them, and will not build a tree.
rigidify :: FingerTree (Elem a) -> Rigidified (Elem a)
-- The patterns below just fix up the top level of the tree; 'rigidify'
-- delegates the hard work to 'thin'.

rigidify EmptyT = RigidEmpty

rigidify (Single q) = RigidOne q

-- The left digit is Two or Three
rigidify (Deep s (Two a b) m sf) = rigidifyRight s (node2 a b) m sf
rigidify (Deep s (Three a b c) m sf) = rigidifyRight s (node3 a b c) m sf

-- The left digit is Four
rigidify (Deep s (Four a b c d) m sf) = rigidifyRight s (node2 a b) (node2 c d `consTree` m) sf

-- The left digit is One
rigidify (Deep s (One a) m sf) = case viewLTree m of
   ConsLTree (Node2 _ b c) m' -> rigidifyRight s (node3 a b c) m' sf
   ConsLTree (Node3 _ b c d) m' -> rigidifyRight s (node2 a b) (node2 c d `consTree` m') sf
   EmptyLTree -> case sf of
     One b -> RigidTwo a b
     Two b c -> RigidThree a b c
     Three b c d -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c d)
     Four b c d e -> RigidFull $ Rigid s (node3 a b c) EmptyTh (node2 d e)

-- | /O(log n)/ (incremental) Takes a tree whose left side has been rigidified
-- and finishes the job.
rigidifyRight :: Int -> Digit23 (Elem a) -> FingerTree (Node (Elem a)) -> Digit (Elem a) -> Rigidified (Elem a)

-- The right digit is Two, Three, or Four
rigidifyRight s pr m (Two a b) = RigidFull $ Rigid s pr (thin m) (node2 a b)
rigidifyRight s pr m (Three a b c) = RigidFull $ Rigid s pr (thin m) (node3 a b c)
rigidifyRight s pr m (Four a b c d) = RigidFull $ Rigid s pr (thin $ m `snocTree` node2 a b) (node2 c d)

-- The right digit is One
rigidifyRight s pr m (One e) = case viewRTree m of
    SnocRTree m' (Node2 _ a b) -> RigidFull $ Rigid s pr (thin m') (node3 a b e)
    SnocRTree m' (Node3 _ a b c) -> RigidFull $ Rigid s pr (thin $ m' `snocTree` node2 a b) (node2 c e)
    EmptyRTree -> case pr of
      Node2 _ a b -> RigidThree a b e
      Node3 _ a b c -> RigidFull $ Rigid s (node2 a b) EmptyTh (node2 c e)

-- | /O(log n)/ (incremental) Rejigger a finger tree so the digits are all ones
-- and twos.
thin :: Sized a => FingerTree a -> Thin a
-- Note that 'thin12' will produce a 'DeepTh' constructor immediately before
-- recursively calling 'thin'.
thin EmptyT = EmptyTh
thin (Single a) = SingleTh a
thin (Deep s pr m sf) =
  case pr of
    One a -> thin12 s (One12 a) m sf
    Two a b -> thin12 s (Two12 a b) m sf
    Three a b c  -> thin12 s (One12 a) (node2 b c `consTree` m) sf
    Four a b c d -> thin12 s (Two12 a b) (node2 c d `consTree` m) sf

thin12 :: Sized a => Int -> Digit12 a -> FingerTree (Node a) -> Digit a -> Thin a
thin12 s pr m (One a) = DeepTh s pr (thin m) (One12 a)
thin12 s pr m (Two a b) = DeepTh s pr (thin m) (Two12 a b)
thin12 s pr m (Three a b c) = DeepTh s pr (thin $ m `snocTree` node2 a b) (One12 c)
thin12 s pr m (Four a b c d) = DeepTh s pr (thin $ m `snocTree` node2 a b) (Two12 c d)

-- | \( O(n) \). Intersperse an element between the elements of a sequence.
--
-- @
-- intersperse a empty = empty
-- intersperse a (singleton x) = singleton x
-- intersperse a (fromList [x,y]) = fromList [x,a,y]
-- intersperse a (fromList [x,y,z]) = fromList [x,a,y,a,z]
-- @
--
-- @since 0.5.8
intersperse :: a -> Seq a -> Seq a
intersperse y xs = case viewl xs of
  EmptyL -> empty
  p :< ps -> p <| (ps <**> (const y <| singleton id))
-- We used to use
--
-- intersperse y xs = drop 1 $ xs <**> (const y <| singleton id)
--
-- but if length xs = ((maxBound :: Int) `quot` 2) + 1 then
--
-- length (xs <**> (const y <| singleton id)) will wrap around to negative
-- and the drop won't work. The new implementation can produce a result
-- right up to maxBound :: Int

instance MonadPlus Seq where
    mzero = empty
    mplus = (><)

-- | @since 0.5.4
instance Alternative Seq where
    empty = empty
    (<|>) = (><)

instance Eq a => Eq (Seq a) where
    xs == ys = length xs == length ys && toList xs == toList ys

instance Ord a => Ord (Seq a) where
    compare xs ys = compare (toList xs) (toList ys)

#ifdef TESTING
instance Show a => Show (Seq a) where
    showsPrec p (Seq x) = showsPrec p x
#else
instance Show a => Show (Seq a) where
    showsPrec p xs = showParen (p > 10) $
        showString "fromList " . shows (toList xs)
#endif

#if MIN_VERSION_base(4,9,0)
-- | @since 0.5.9
instance Show1 Seq where
  liftShowsPrec _shwsPrc shwList p xs = showParen (p > 10) $
        showString "fromList " . shwList (toList xs)

-- | @since 0.5.9
instance Eq1 Seq where
    liftEq eq xs ys = length xs == length ys && liftEq eq (toList xs) (toList ys)

-- | @since 0.5.9
instance Ord1 Seq where
    liftCompare cmp xs ys = liftCompare cmp (toList xs) (toList ys)
#endif

instance Read a => Read (Seq a) where
#ifdef __GLASGOW_HASKELL__
    readPrec = parens $ prec 10 $ do
        Ident "fromList" <- lexP
        xs <- readPrec
        return (fromList xs)

    readListPrec = readListPrecDefault
#else
    readsPrec p = readParen (p > 10) $ \ r -> do
        ("fromList",s) <- lex r
        (xs,t) <- reads s
        return (fromList xs,t)
#endif

#if MIN_VERSION_base(4,9,0)
-- | @since 0.5.9
instance Read1 Seq where
  liftReadsPrec _rp readLst p = readParen (p > 10) $ \r -> do
    ("fromList",s) <- lex r
    (xs,t) <- readLst s
    pure (fromList xs, t)
#endif

instance Monoid (Seq a) where
    mempty = empty
    mappend = (><)

#if MIN_VERSION_base(4,9,0)
-- | @since 0.5.7
instance Semigroup.Semigroup (Seq a) where
    (<>)    = (><)
    stimes = cycleNTimes . fromIntegral
#endif

INSTANCE_TYPEABLE1(Seq)

#if __GLASGOW_HASKELL__
instance Data a => Data (Seq a) where
    gfoldl f z s    = case viewl s of
        EmptyL  -> z empty
        x :< xs -> z (<|) `f` x `f` xs

    gunfold k z c   = case constrIndex c of
        1 -> z empty
        2 -> k (k (z (<|)))
        _ -> error "gunfold"

    toConstr xs
      | null xs     = emptyConstr
      | otherwise   = consConstr

    dataTypeOf _    = seqDataType

    dataCast1 f     = gcast1 f

emptyConstr, consConstr :: Constr
emptyConstr = mkConstr seqDataType "empty" [] Prefix
consConstr  = mkConstr seqDataType "<|" [] Infix

seqDataType :: DataType
seqDataType = mkDataType "Data.Sequence.Seq" [emptyConstr, consConstr]
#endif

-- Finger trees

data FingerTree a
    = EmptyT
    | Single a
    | Deep {-# UNPACK #-} !Int !(Digit a) (FingerTree (Node a)) !(Digit a)
#ifdef TESTING
    deriving Show
#endif

#ifdef __GLASGOW_HASKELL__
-- | @since 0.6.1
deriving instance Generic1 FingerTree

-- | @since 0.6.1
deriving instance Generic (FingerTree a)
#endif

instance Sized a => Sized (FingerTree a) where
    {-# SPECIALIZE instance Sized (FingerTree (Elem a)) #-}
    {-# SPECIALIZE instance Sized (FingerTree (Node a)) #-}
    size EmptyT             = 0
    size (Single x)         = size x
    size (Deep v _ _ _)     = v

instance Foldable FingerTree where
    foldMap _ EmptyT = mempty
    foldMap f' (Single x') = f' x'
    foldMap f' (Deep _ pr' m' sf') =
        foldMapDigit f' pr' <>
        foldMapTree (foldMapNode f') m' <>
        foldMapDigit f' sf'
      where
        foldMapTree :: Monoid m => (Node a -> m) -> FingerTree (Node a) -> m
        foldMapTree _ EmptyT = mempty
        foldMapTree f (Single x) = f x
        foldMapTree f (Deep _ pr m sf) =
            foldMapDigitN f pr <>
            foldMapTree (foldMapNodeN f) m <>
            foldMapDigitN f sf

        foldMapDigit :: Monoid m => (a -> m) -> Digit a -> m
        foldMapDigit f t = foldDigit (<>) f t

        foldMapDigitN :: Monoid m => (Node a -> m) -> Digit (Node a) -> m
        foldMapDigitN f t = foldDigit (<>) f t

        foldMapNode :: Monoid m => (a -> m) -> Node a -> m
        foldMapNode f t = foldNode (<>) f t

        foldMapNodeN :: Monoid m => (Node a -> m) -> Node (Node a) -> m
        foldMapNodeN f t = foldNode (<>) f t
#if __GLASGOW_HASKELL__
    {-# INLINABLE foldMap #-}
#endif

    foldr _ z' EmptyT = z'
    foldr f' z' (Single x') = x' `f'` z'
    foldr f' z' (Deep _ pr' m' sf') =
        foldrDigit f' (foldrTree (foldrNode f') (foldrDigit f' z' sf') m') pr'
      where
        foldrTree :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b
        foldrTree _ z EmptyT = z
        foldrTree f z (Single x) = x `f` z
        foldrTree f z (Deep _ pr m sf) =
            foldrDigitN f (foldrTree (foldrNodeN f) (foldrDigitN f z sf) m) pr

        foldrDigit :: (a -> b -> b) -> b -> Digit a -> b
        foldrDigit f z t = foldr f z t

        foldrDigitN :: (Node a -> b -> b) -> b -> Digit (Node a) -> b
        foldrDigitN f z t = foldr f z t

        foldrNode :: (a -> b -> b) -> Node a -> b -> b
        foldrNode f t z = foldr f z t

        foldrNodeN :: (Node a -> b -> b) -> Node (Node a) -> b -> b
        foldrNodeN f t z = foldr f z t
    {-# INLINE foldr #-}


    foldl _ z' EmptyT = z'
    foldl f' z' (Single x') = z' `f'` x'
    foldl f' z' (Deep _ pr' m' sf') =
        foldlDigit f' (foldlTree (foldlNode f') (foldlDigit f' z' pr') m') sf'
      where
        foldlTree :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b
        foldlTree _ z EmptyT = z
        foldlTree f z (Single x) = z `f` x
        foldlTree f z (Deep _ pr m sf) =
            foldlDigitN f (foldlTree (foldlNodeN f) (foldlDigitN f z pr) m) sf

        foldlDigit :: (b -> a -> b) -> b -> Digit a -> b
        foldlDigit f z t = foldl f z t

        foldlDigitN :: (b -> Node a -> b) -> b -> Digit (Node a) -> b
        foldlDigitN f z t = foldl f z t

        foldlNode :: (b -> a -> b) -> b -> Node a -> b
        foldlNode f z t = foldl f z t

        foldlNodeN :: (b -> Node a -> b) -> b -> Node (Node a) -> b
        foldlNodeN f z t = foldl f z t
    {-# INLINE foldl #-}

    foldr' _ z' EmptyT = z'
    foldr' f' z' (Single x') = f' x' z'
    foldr' f' z' (Deep _ pr' m' sf') =
        (foldrDigit' f' $! (foldrTree' (foldrNode' f') $! (foldrDigit' f' z') sf') m') pr'
      where
        foldrTree' :: (Node a -> b -> b) -> b -> FingerTree (Node a) -> b
        foldrTree' _ z EmptyT = z
        foldrTree' f z (Single x) = f x $! z
        foldrTree' f z (Deep _ pr m sf) =
            (foldr' f $! (foldrTree' (foldrNodeN' f) $! (foldr' f $! z) sf) m) pr

        foldrDigit' :: (a -> b -> b) -> b -> Digit a -> b
        foldrDigit' f z t = foldr' f z t

        foldrNode' :: (a -> b -> b) -> Node a -> b -> b
        foldrNode' f t z = foldr' f z t

        foldrNodeN' :: (Node a -> b -> b) -> Node (Node a) -> b -> b
        foldrNodeN' f t z = foldr' f z t
    {-# INLINE foldr' #-}

    foldl' _ z' EmptyT = z'
    foldl' f' z' (Single x') = f' z' x'
    foldl' f' z' (Deep _ pr' m' sf') =
        (foldlDigit' f' $!
         (foldlTree' (foldlNode' f') $! (foldlDigit' f' z') pr') m')
            sf'
      where
        foldlTree' :: (b -> Node a -> b) -> b -> FingerTree (Node a) -> b
        foldlTree' _ z EmptyT = z
        foldlTree' f z (Single xs) = f z xs
        foldlTree' f z (Deep _ pr m sf) =
            (foldl' f $! (foldlTree' (foldl' f) $! foldl' f z pr) m) sf

        foldlDigit' :: (b -> a -> b) -> b -> Digit a -> b
        foldlDigit' f z t = foldl' f z t

        foldlNode' :: (b -> a -> b) -> b -> Node a -> b
        foldlNode' f z t = foldl' f z t
    {-# INLINE foldl' #-}

    foldr1 _ EmptyT = error "foldr1: empty sequence"
    foldr1 _ (Single x) = x
    foldr1 f (Deep _ pr m sf) =
        foldr f (foldr (flip (foldr f)) (foldr1 f sf) m) pr

    foldl1 _ EmptyT = error "foldl1: empty sequence"
    foldl1 _ (Single x) = x
    foldl1 f (Deep _ pr m sf) =
        foldl f (foldl (foldl f) (foldl1 f pr) m) sf

instance Functor FingerTree where
    fmap _ EmptyT = EmptyT
    fmap f (Single x) = Single (f x)
    fmap f (Deep v pr m sf) =
        Deep v (fmap f pr) (fmap (fmap f) m) (fmap f sf)

instance Traversable FingerTree where
    traverse _ EmptyT = pure EmptyT
    traverse f (Single x) = Single <$> f x
    traverse f (Deep v pr m sf) =
        liftA3 (Deep v) (traverse f pr) (traverse (traverse f) m)
            (traverse f sf)

instance NFData a => NFData (FingerTree a) where
    rnf EmptyT = ()
    rnf (Single x) = rnf x
    rnf (Deep _ pr m sf) = rnf pr `seq` rnf sf `seq` rnf m

{-# INLINE deep #-}
deep            :: Sized a => Digit a -> FingerTree (Node a) -> Digit a -> FingerTree a
deep pr m sf    =  Deep (size pr + size m + size sf) pr m sf

{-# INLINE pullL #-}
pullL :: Int -> FingerTree (Node a) -> Digit a -> FingerTree a
pullL s m sf = case viewLTree m of
    EmptyLTree          -> digitToTree' s sf
    ConsLTree pr m'     -> Deep s (nodeToDigit pr) m' sf

{-# INLINE pullR #-}
pullR :: Int -> Digit a -> FingerTree (Node a) -> FingerTree a
pullR s pr m = case viewRTree m of
    EmptyRTree          -> digitToTree' s pr
    SnocRTree m' sf     -> Deep s pr m' (nodeToDigit sf)

-- Digits

data Digit a
    = One a
    | Two a a
    | Three a a a
    | Four a a a a
#ifdef TESTING
    deriving Show
#endif

#ifdef __GLASGOW_HASKELL__
-- | @since 0.6.1
deriving instance Generic1 Digit

-- | @since 0.6.1
deriving instance Generic (Digit a)
#endif

foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b
foldDigit _     f (One a) = f a
foldDigit (<+>) f (Two a b) = f a <+> f b
foldDigit (<+>) f (Three a b c) = f a <+> f b <+> f c
foldDigit (<+>) f (Four a b c d) = f a <+> f b <+> f c <+> f d
{-# INLINE foldDigit #-}

instance Foldable Digit where
    foldMap = foldDigit mappend

    foldr f z (One a) = a `f` z
    foldr f z (Two a b) = a `f` (b `f` z)
    foldr f z (Three a b c) = a `f` (b `f` (c `f` z))
    foldr f z (Four a b c d) = a `f` (b `f` (c `f` (d `f` z)))
    {-# INLINE foldr #-}

    foldl f z (One a) = z `f` a
    foldl f z (Two a b) = (z `f` a) `f` b
    foldl f z (Three a b c) = ((z `f` a) `f` b) `f` c
    foldl f z (Four a b c d) = (((z `f` a) `f` b) `f` c) `f` d
    {-# INLINE foldl #-}

    foldr' f z (One a) = f a z
    foldr' f z (Two a b) = f a $! f b z
    foldr' f z (Three a b c) = f a $! f b $! f c z
    foldr' f z (Four a b c d) = f a $! f b $! f c $! f d z
    {-# INLINE foldr' #-}

    foldl' f z (One a) = f z a
    foldl' f z (Two a b) = (f $! f z a) b
    foldl' f z (Three a b c) = (f $! (f $! f z a) b) c
    foldl' f z (Four a b c d) = (f $! (f $! (f $! f z a) b) c) d
    {-# INLINE foldl' #-}

    foldr1 _ (One a) = a
    foldr1 f (Two a b) = a `f` b
    foldr1 f (Three a b c) = a `f` (b `f` c)
    foldr1 f (Four a b c d) = a `f` (b `f` (c `f` d))

    foldl1 _ (One a) = a
    foldl1 f (Two a b) = a `f` b
    foldl1 f (Three a b c) = (a `f` b) `f` c
    foldl1 f (Four a b c d) = ((a `f` b) `f` c) `f` d

instance Functor Digit where
    {-# INLINE fmap #-}
    fmap f (One a) = One (f a)
    fmap f (Two a b) = Two (f a) (f b)
    fmap f (Three a b c) = Three (f a) (f b) (f c)
    fmap f (Four a b c d) = Four (f a) (f b) (f c) (f d)

instance Traversable Digit where
    {-# INLINE traverse #-}
    traverse f (One a) = One <$> f a
    traverse f (Two a b) = liftA2 Two (f a) (f b)
    traverse f (Three a b c) = liftA3 Three (f a) (f b) (f c)
    traverse f (Four a b c d) = liftA3 Four (f a) (f b) (f c) <*> f d

instance NFData a => NFData (Digit a) where
    rnf (One a) = rnf a
    rnf (Two a b) = rnf a `seq` rnf b
    rnf (Three a b c) = rnf a `seq` rnf b `seq` rnf c
    rnf (Four a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d

instance Sized a => Sized (Digit a) where
    {-# INLINE size #-}
    size = foldl1 (+) . fmap size

{-# SPECIALIZE digitToTree :: Digit (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE digitToTree :: Digit (Node a) -> FingerTree (Node a) #-}
digitToTree     :: Sized a => Digit a -> FingerTree a
digitToTree (One a) = Single a
digitToTree (Two a b) = deep (One a) EmptyT (One b)
digitToTree (Three a b c) = deep (Two a b) EmptyT (One c)
digitToTree (Four a b c d) = deep (Two a b) EmptyT (Two c d)

-- | Given the size of a digit and the digit itself, efficiently converts
-- it to a FingerTree.
digitToTree' :: Int -> Digit a -> FingerTree a
digitToTree' n (Four a b c d) = Deep n (Two a b) EmptyT (Two c d)
digitToTree' n (Three a b c) = Deep n (Two a b) EmptyT (One c)
digitToTree' n (Two a b) = Deep n (One a) EmptyT (One b)
digitToTree' !_n (One a) = Single a

-- Nodes

data Node a
    = Node2 {-# UNPACK #-} !Int a a
    | Node3 {-# UNPACK #-} !Int a a a
#ifdef TESTING
    deriving Show
#endif

#ifdef __GLASGOW_HASKELL__
-- | @since 0.6.1
deriving instance Generic1 Node

-- | @since 0.6.1
deriving instance Generic (Node a)
#endif

foldNode :: (b -> b -> b) -> (a -> b) -> Node a -> b
foldNode (<+>) f (Node2 _ a b) = f a <+> f b
foldNode (<+>) f (Node3 _ a b c) = f a <+> f b <+> f c
{-# INLINE foldNode #-}

instance Foldable Node where
    foldMap = foldNode mappend

    foldr f z (Node2 _ a b) = a `f` (b `f` z)
    foldr f z (Node3 _ a b c) = a `f` (b `f` (c `f` z))
    {-# INLINE foldr #-}

    foldl f z (Node2 _ a b) = (z `f` a) `f` b
    foldl f z (Node3 _ a b c) = ((z `f` a) `f` b) `f` c
    {-# INLINE foldl #-}

    foldr' f z (Node2 _ a b) = f a $! f b z
    foldr' f z (Node3 _ a b c) = f a $! f b $! f c z
    {-# INLINE foldr' #-}

    foldl' f z (Node2 _ a b) = (f $! f z a) b
    foldl' f z (Node3 _ a b c) = (f $! (f $! f z a) b) c
    {-# INLINE foldl' #-}

instance Functor Node where
    {-# INLINE fmap #-}
    fmap f (Node2 v a b) = Node2 v (f a) (f b)
    fmap f (Node3 v a b c) = Node3 v (f a) (f b) (f c)

instance Traversable Node where
    {-# INLINE traverse #-}
    traverse f (Node2 v a b) = liftA2 (Node2 v) (f a) (f b)
    traverse f (Node3 v a b c) = liftA3 (Node3 v) (f a) (f b) (f c)

instance NFData a => NFData (Node a) where
    rnf (Node2 _ a b) = rnf a `seq` rnf b
    rnf (Node3 _ a b c) = rnf a `seq` rnf b `seq` rnf c

instance Sized (Node a) where
    size (Node2 v _ _)      = v
    size (Node3 v _ _ _)    = v

{-# INLINE node2 #-}
node2           :: Sized a => a -> a -> Node a
node2 a b       =  Node2 (size a + size b) a b

{-# INLINE node3 #-}
node3           :: Sized a => a -> a -> a -> Node a
node3 a b c     =  Node3 (size a + size b + size c) a b c

nodeToDigit :: Node a -> Digit a
nodeToDigit (Node2 _ a b) = Two a b
nodeToDigit (Node3 _ a b c) = Three a b c

-- Elements

newtype Elem a  =  Elem { getElem :: a }
#ifdef TESTING
    deriving Show
#endif

#ifdef __GLASGOW_HASKELL__
-- | @since 0.6.1
deriving instance Generic1 Elem

-- | @since 0.6.1
deriving instance Generic (Elem a)
#endif

instance Sized (Elem a) where
    size _ = 1

instance Functor Elem where
#if __GLASGOW_HASKELL__ >= 708
-- This cuts the time for <*> by around a fifth.
    fmap = coerce
#else
    fmap f (Elem x) = Elem (f x)
#endif

instance Foldable Elem where
    foldr f z (Elem x) = f x z
#if __GLASGOW_HASKELL__ >= 708
    foldMap = coerce
    foldl = coerce
    foldl' = coerce
#else
    foldMap f (Elem x) = f x
    foldl f z (Elem x) = f z x
    foldl' f z (Elem x) = f z x
#endif

instance Traversable Elem where
    traverse f (Elem x) = Elem <$> f x

instance NFData a => NFData (Elem a) where
    rnf (Elem x) = rnf x

-------------------------------------------------------
-- Applicative construction
-------------------------------------------------------
#if !MIN_VERSION_base(4,8,0)
newtype Identity a = Identity {runIdentity :: a}

instance Functor Identity where
    fmap f (Identity x) = Identity (f x)

instance Applicative Identity where
    pure = Identity
    Identity f <*> Identity x = Identity (f x)
#endif

-- | 'applicativeTree' takes an Applicative-wrapped construction of a
-- piece of a FingerTree, assumed to always have the same size (which
-- is put in the second argument), and replicates it as many times as
-- specified.  This is a generalization of 'replicateA', which itself
-- is a generalization of many Data.Sequence methods.
{-# SPECIALIZE applicativeTree :: Int -> Int -> State s a -> State s (FingerTree a) #-}
{-# SPECIALIZE applicativeTree :: Int -> Int -> Identity a -> Identity (FingerTree a) #-}
-- Special note: the Identity specialization automatically does node sharing,
-- reducing memory usage of the resulting tree to /O(log n)/.
applicativeTree :: Applicative f => Int -> Int -> f a -> f (FingerTree a)
applicativeTree n !mSize m = case n of
    0 -> pure EmptyT
    1 -> fmap Single m
    2 -> deepA one emptyTree one
    3 -> deepA two emptyTree one
    4 -> deepA two emptyTree two
    5 -> deepA three emptyTree two
    6 -> deepA three emptyTree three
    _ -> case n `quotRem` 3 of
           (q,0) -> deepA three (applicativeTree (q - 2) mSize' n3) three
           (q,1) -> deepA two (applicativeTree (q - 1) mSize' n3) two
           (q,_) -> deepA three (applicativeTree (q - 1) mSize' n3) two
      where !mSize' = 3 * mSize
            n3 = liftA3 (Node3 mSize') m m m
  where
    one = fmap One m
    two = liftA2 Two m m
    three = liftA3 Three m m m
    deepA = liftA3 (Deep (n * mSize))
    emptyTree = pure EmptyT

------------------------------------------------------------------------
-- Construction
------------------------------------------------------------------------

-- | \( O(1) \). The empty sequence.
empty           :: Seq a
empty           =  Seq EmptyT

-- | \( O(1) \). A singleton sequence.
singleton       :: a -> Seq a
singleton x     =  Seq (Single (Elem x))

-- | \( O(\log n) \). @replicate n x@ is a sequence consisting of @n@ copies of @x@.
replicate       :: Int -> a -> Seq a
replicate n x
  | n >= 0      = runIdentity (replicateA n (Identity x))
  | otherwise   = error "replicate takes a nonnegative integer argument"

-- | 'replicateA' is an 'Applicative' version of 'replicate', and makes
-- \( O(\log n) \) calls to 'liftA2' and 'pure'.
--
-- > replicateA n x = sequenceA (replicate n x)
replicateA :: Applicative f => Int -> f a -> f (Seq a)
replicateA n x
  | n >= 0      = Seq <$> applicativeTree n 1 (Elem <$> x)
  | otherwise   = error "replicateA takes a nonnegative integer argument"
{-# SPECIALIZE replicateA :: Int -> State a b -> State a (Seq b) #-}

-- | 'replicateM' is a sequence counterpart of 'Control.Monad.replicateM'.
--
-- > replicateM n x = sequence (replicate n x)
--
-- For @base >= 4.8.0@ and @containers >= 0.5.11@, 'replicateM'
-- is a synonym for 'replicateA'.
#if MIN_VERSION_base(4,8,0)
replicateM :: Applicative m => Int -> m a -> m (Seq a)
replicateM = replicateA
#else
replicateM :: Monad m => Int -> m a -> m (Seq a)
replicateM n x
  | n >= 0      = Applicative.unwrapMonad (replicateA n (Applicative.WrapMonad x))
  | otherwise   = error "replicateM takes a nonnegative integer argument"
#endif

-- | /O(/log/ k)/. @'cycleTaking' k xs@ forms a sequence of length @k@ by
-- repeatedly concatenating @xs@ with itself. @xs@ may only be empty if
-- @k@ is 0.
--
-- prop> cycleTaking k = fromList . take k . cycle . toList

-- If you wish to concatenate a possibly empty sequence @xs@ with
-- itself precisely @k@ times, use @'stimes' k xs@ instead of this
-- function.
--
-- @since 0.5.8
cycleTaking :: Int -> Seq a -> Seq a
cycleTaking n !_xs | n <= 0 = empty
cycleTaking _n xs  | null xs = error "cycleTaking cannot take a positive number of elements from an empty cycle."
cycleTaking n xs = cycleNTimes reps xs >< take final xs
  where
    (reps, final) = n `quotRem` length xs

-- \( O(\log(kn)) \). @'cycleNTimes' k xs@ concatenates @k@ copies of @xs@. This
-- operation uses time and additional space logarithmic in the size of its
-- result.
cycleNTimes :: Int -> Seq a -> Seq a
cycleNTimes n !xs
  | n <= 0    = empty
  | n == 1    = xs
cycleNTimes n (Seq xsFT) = case rigidify xsFT of
             RigidEmpty -> empty
             RigidOne (Elem x) -> replicate n x
             RigidTwo x1 x2 -> Seq $
               Deep (n*2) pair
                    (runIdentity $ applicativeTree (n-2) 2 (Identity (node2 x1 x2)))
                    pair
               where pair = Two x1 x2
             RigidThree x1 x2 x3 -> Seq $
               Deep (n*3) triple
                    (runIdentity $ applicativeTree (n-2) 3 (Identity (node3 x1 x2 x3)))
                    triple
               where triple = Three x1 x2 x3
             RigidFull r@(Rigid s pr _m sf) -> Seq $
                   Deep (n*s)
                        (nodeToDigit pr)
                        (cycleNMiddle (n-2) r)
                        (nodeToDigit sf)

cycleNMiddle
  :: Int
     -> Rigid c
     -> FingerTree (Node c)

-- Not at the bottom yet

cycleNMiddle !n
           (Rigid s pr (DeepTh sm prm mm sfm) sf)
    = Deep (sm + s * (n + 1)) -- note: sm = s - size pr - size sf
           (digit12ToDigit prm)
           (cycleNMiddle n
                       (Rigid s (squashL pr prm) mm (squashR sfm sf)))
           (digit12ToDigit sfm)

-- At the bottom

cycleNMiddle n
           (Rigid s pr EmptyTh sf)
     = deep
            (One sf)
            (runIdentity $ applicativeTree n s (Identity converted))
            (One pr)
   where converted = node2 pr sf

cycleNMiddle n
           (Rigid s pr (SingleTh q) sf)
     = deep
            (Two q sf)
            (runIdentity $ applicativeTree n s (Identity converted))
            (Two pr q)
   where converted = node3 pr q sf


-- | \( O(1) \). Add an element to the left end of a sequence.
-- Mnemonic: a triangle with the single element at the pointy end.
(<|)            :: a -> Seq a -> Seq a
x <| Seq xs     =  Seq (Elem x `consTree` xs)

{-# SPECIALIZE consTree :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE consTree :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
consTree        :: Sized a => a -> FingerTree a -> FingerTree a
consTree a EmptyT       = Single a
consTree a (Single b)   = deep (One a) EmptyT (One b)
-- As described in the paper, we force the middle of a tree
-- *before* consing onto it; this preserves the amortized
-- bounds but prevents repeated consing from building up
-- gigantic suspensions.
consTree a (Deep s (Four b c d e) m sf) = m `seq`
    Deep (size a + s) (Two a b) (node3 c d e `consTree` m) sf
consTree a (Deep s (Three b c d) m sf) =
    Deep (size a + s) (Four a b c d) m sf
consTree a (Deep s (Two b c) m sf) =
    Deep (size a + s) (Three a b c) m sf
consTree a (Deep s (One b) m sf) =
    Deep (size a + s) (Two a b) m sf

cons' :: a -> Seq a -> Seq a
cons' x (Seq xs) = Seq (Elem x `consTree'` xs)

snoc' :: Seq a -> a -> Seq a
snoc' (Seq xs) x = Seq (xs `snocTree'` Elem x)

{-# SPECIALIZE consTree' :: Elem a -> FingerTree (Elem a) -> FingerTree (Elem a) #-}
{-# SPECIALIZE consTree' :: Node a -> FingerTree (Node a) -> FingerTree (Node a) #-}
consTree'        :: Sized a => a -> FingerTree a -> FingerTree a
consTree' a EmptyT       = Single a
consTree' a (Single b)   = deep (One a) EmptyT (One b)
-- As described in the paper, we force the middle of a tree
-- *before* consing onto it; this preserves the amortized
-- bounds but prevents repeated consing from building up
-- gigantic suspensions.
consTree' a (Deep s (Four b c d e) m sf) =
    Deep (size a + s) (Two a b) m' sf
  where !m' = abc `consTree'` m
        !abc = node3 c d e
consTree' a (Deep s (Three b c d) m sf) =
    Deep (size a + s) (Four a b c d) m sf
consTree' a (Deep s (Two b c) m sf) =
    Deep (size a + s) (Three a b c) m sf
consTree' a (Deep s (One b) m sf) =
    Deep (size a + s) (Two a b) m sf

-- | \( O(1) \). Add an element to the right end of a sequence.
-- Mnemonic: a triangle with the single element at the pointy end.
(|>)            :: Seq a -> a -> Seq a
Seq xs |> x     =  Seq (xs `snocTree` Elem x)

{-# SPECIALIZE snocTree :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
{-# SPECIALIZE snocTree :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
snocTree        :: Sized a => FingerTree a -> a -> FingerTree a
snocTree EmptyT a       =  Single a
snocTree (Single a) b   =  deep (One a) EmptyT (One b)
-- See note on `seq` in `consTree`.
snocTree (Deep s pr m (Four a b c d)) e = m `seq`
    Deep (s + size e) pr (m `snocTree` node3 a b c) (Two d e)
snocTree (Deep s pr m (Three a b c)) d =
    Deep (s + size d) pr m (Four a b c d)
snocTree (Deep s pr m (Two a b)) c =
    Deep (s + size c) pr m (Three a b c)
snocTree (Deep s pr m (One a)) b =
    Deep (s + size b) pr m (Two a b)

{-# SPECIALIZE snocTree' :: FingerTree (Elem a) -> Elem a -> FingerTree (Elem a) #-}
{-# SPECIALIZE snocTree' :: FingerTree (Node a) -> Node a -> FingerTree (Node a) #-}
snocTree'        :: Sized a => FingerTree a -> a -> FingerTree a
snocTree' EmptyT a       =  Single a
snocTree' (Single a) b   =  deep (One a) EmptyT (One b)
-- See note on `seq` in `consTree`.
snocTree' (Deep s pr m (Four a b c d)) e =
    Deep (s + size e) pr m' (Two d e)
  where !m' = m `snocTree'` abc
        !abc = node3 a b c
snocTree' (Deep s pr m (Three a b c)) d =
    Deep (s + size d) pr m (Four a b c d)
snocTree' (Deep s pr m (Two a b)) c =
    Deep (s + size c) pr m (Three a b c)
snocTree' (Deep s pr m (One a)) b =
    Deep (s + size b) pr m (Two a b)

-- | \( O(\log(\min(n_1,n_2))) \). Concatenate two sequences.
(><)            :: Seq a -> Seq a -> Seq a
Seq xs >< Seq ys = Seq (appendTree0 xs ys)

-- The appendTree/addDigits gunk below is machine generated

appendTree0 :: FingerTree (Elem a) -> FingerTree (Elem a) -> FingerTree (Elem a)
appendTree0 EmptyT xs =
    xs
appendTree0 xs EmptyT =
    xs
appendTree0 (Single x) xs =
    x `consTree` xs
appendTree0 xs (Single x) =
    xs `snocTree` x
appendTree0 (Deep s1 pr1 m1 sf1) (Deep s2 pr2 m2 sf2) =
    Deep (s1 + s2) pr1 m sf2
  where !m = addDigits0 m1 sf1 pr2 m2

addDigits0 :: FingerTree (Node (Elem a)) -> Digit (Elem a) -> Digit (Elem a) -> FingerTree (Node (Elem a)) -> FingerTree (Node (Elem a))
addDigits0 m1 (One a) (One b) m2 =
    appendTree1 m1 (node2 a b) m2
addDigits0 m1 (One a) (Two b c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (One a) (Three b c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (One a) (Four b c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (One c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits0 m1 (Two a b) (Two c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Two a b) (Three c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Two a b) (Four c d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits0 m1 (Three a b c) (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Three a b c) (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Three a b c) (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits0 m1 (Four a b c d) (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits0 m1 (Four a b c d) (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits0 m1 (Four a b c d) (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2

appendTree1 :: FingerTree (Node a) -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree1 EmptyT !a xs =
    a `consTree` xs
appendTree1 xs !a EmptyT =
    xs `snocTree` a
appendTree1 (Single x) !a xs =
    x `consTree` a `consTree` xs
appendTree1 xs !a (Single x) =
    xs `snocTree` a `snocTree` x
appendTree1 (Deep s1 pr1 m1 sf1) a (Deep s2 pr2 m2 sf2) =
    Deep (s1 + size a + s2) pr1 m sf2
  where !m = addDigits1 m1 sf1 a pr2 m2

addDigits1 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits1 m1 (One a) b (One c) m2 =
    appendTree1 m1 (node3 a b c) m2
addDigits1 m1 (One a) b (Two c d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (One a) b (Three c d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (One a) b (Four c d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits1 m1 (Two a b) c (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Two a b) c (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Two a b) c (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits1 m1 (Three a b c) d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Three a b c) d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Three a b c) d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits1 m1 (Four a b c d) e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits1 m1 (Four a b c d) e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2

appendTree2 :: FingerTree (Node a) -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree2 EmptyT !a !b xs =
    a `consTree` b `consTree` xs
appendTree2 xs !a !b EmptyT =
    xs `snocTree` a `snocTree` b
appendTree2 (Single x) a b xs =
    x `consTree` a `consTree` b `consTree` xs
appendTree2 xs a b (Single x) =
    xs `snocTree` a `snocTree` b `snocTree` x
appendTree2 (Deep s1 pr1 m1 sf1) a b (Deep s2 pr2 m2 sf2) =
    Deep (s1 + size a + size b + s2) pr1 m sf2
  where !m = addDigits2 m1 sf1 a b pr2 m2

addDigits2 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits2 m1 (One a) b c (One d) m2 =
    appendTree2 m1 (node2 a b) (node2 c d) m2
addDigits2 m1 (One a) b c (Two d e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (One a) b c (Three d e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (One a) b c (Four d e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits2 m1 (Two a b) c d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Two a b) c d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Two a b) c d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits2 m1 (Three a b c) d e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Three a b c) d e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (One g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits2 m1 (Four a b c d) e f (Two g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2

appendTree3 :: FingerTree (Node a) -> Node a -> Node a -> Node a -> FingerTree (Node a) -> FingerTree (Node a)
appendTree3 EmptyT !a !b !c xs =
    a `consTree` b `consTree` c `consTree` xs
appendTree3 xs !a !b !c EmptyT =
    xs `snocTree` a `snocTree` b `snocTree` c
appendTree3 (Single x) a b c xs =
    x `consTree` a `consTree` b `consTree` c `consTree` xs
appendTree3 xs a b c (Single x) =
    xs `snocTree` a `snocTree` b `snocTree` c `snocTree` x
appendTree3 (Deep s1 pr1 m1 sf1) a b c (Deep s2 pr2 m2 sf2) =
    Deep (s1 + size a + size b + size c + s2) pr1 m sf2
  where !m = addDigits3 m1 sf1 a b c pr2 m2

addDigits3 :: FingerTree (Node (Node a)) -> Digit (Node a) -> Node a -> Node a -> Node a -> Digit (Node a) -> FingerTree (Node (Node a)) -> FingerTree (Node (Node a))
addDigits3 m1 (One a) !b !c !d (One e) m2 =
    appendTree2 m1 (node3 a b c) (node2 d e) m2
addDigits3 m1 (One a) b c d (Two e f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (One a) b c d (Three e f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (One a) b c d (Four e f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) !c !d !e (One f) m2 =
    appendTree2 m1 (node3 a b c) (node3 d e f) m2
addDigits3 m1 (Two a b) c d e (Two f g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Two a b) c d e (Three f g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) !d !e !f (One g) m2 =
    appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2
addDigits3 m1 (Three a b c) d e f (Two g h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) !e !f !g (One h) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2
addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =
    appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2
addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =
    appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2
addDigits3 m1 (Four a b c d) e f g (Four h i j k