{-# LANGUAGE FlexibleContexts #-}
module Data.NonEmptyPrivate where

import qualified Data.NonEmpty.Foldable as FoldU
import qualified Data.NonEmpty.Class as C
import qualified Data.Empty as Empty

import qualified Data.Sequence as Seq
import Data.Sequence (Seq, )

import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Data.List.Match as Match
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import qualified Data.Ix as Ix
import Data.Traversable (Traversable, mapAccumL, mapAccumR)
import Data.Foldable (Foldable, )
import Control.Monad.HT (void, )
import Control.Monad (Monad, return, (=<<), )
import Control.Applicative (Applicative, liftA2, pure, (<*>), )
import Control.DeepSeq (NFData, rnf, )

import Data.Functor (Functor, fmap, )
import Data.Function (flip, const, ($), (.), )
import Data.Either (Either(Left, Right), )
import Data.Maybe (Maybe(Just, Nothing), maybe, mapMaybe, )
import Data.Bool.HT (if', )
import Data.Bool (Bool(True), (&&), )
import Data.Ord (Ord, Ordering(GT), (<=), (>), compare, comparing, )
import Data.Eq ((==), )
import Data.Tuple.HT (mapFst, mapSnd, swap, )
import Data.Tuple (fst, snd, )
import qualified Prelude as P
import Prelude (Eq, Show, Num, Int, uncurry, ($!), (*), (+), )

import qualified Test.QuickCheck as QC


{- $setup
>>> import qualified Data.NonEmpty as NonEmpty
>>> import qualified Data.Empty as Empty
>>> import qualified Data.Either.HT as EitherHT
>>> import qualified Control.Functor.HT as FuncHT
>>> import qualified Data.Ix as Ix
>>> import Data.NonEmpty ((!:))
>>> import Data.Tuple.HT (swap)
>>> import Data.Maybe (mapMaybe)
>>> import Control.Applicative (liftA2)
>>> import Control.Functor.HT (void)
>>> import qualified Test.QuickCheck as QC
>>>
>>> forRange :: (QC.Testable test) => ((Char,Char) -> test) -> QC.Property
>>> forRange =
>>>    QC.forAll (liftA2 (,) (QC.choose ('a','h')) (QC.choose ('a','h')))
-}

{-
We could also have (:!) as constructor,
but in order to import it unqualified we have to import 'T' unqualified, too,
and this would cause name clashes with locally defined types with name @T@.
-}
{- |
The type 'T' can be used for many kinds of list-like structures
with restrictions on the size.

* @T [] a@ is a lazy list containing at least one element.

* @T (T []) a@ is a lazy list containing at least two elements.

* @T Vector a@ is a vector with at least one element.
  You may also use unboxed vectors but the first element will be stored in a box
  and you will not be able to use many functions from this module.

* @T Maybe a@ is a list that contains one or two elements.

* @Maybe@ is isomorphic to @Optional Empty@.

* @T Empty a@ is a list that contains exactly one element.

* @T (T Empty) a@ is a list that contains exactly two elements.

* @Optional (T Empty) a@ is a list that contains zero or two elements.

* You can create a list type for every finite set of allowed list length
  by nesting Optional and NonEmpty constructors.
  If list length @n@ is allowed, then place @Optional@ at depth @n@,
  if it is disallowed then place @NonEmpty@.
  The maximum length is marked by @Empty@.
-}
data T f a = Cons { forall (f :: * -> *) a. T f a -> a
head :: a, forall (f :: * -> *) a. T f a -> f a
tail :: f a }
   deriving (T f a -> T f a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (f :: * -> *) a. (Eq a, Eq (f a)) => T f a -> T f a -> Bool
/= :: T f a -> T f a -> Bool
$c/= :: forall (f :: * -> *) a. (Eq a, Eq (f a)) => T f a -> T f a -> Bool
== :: T f a -> T f a -> Bool
$c== :: forall (f :: * -> *) a. (Eq a, Eq (f a)) => T f a -> T f a -> Bool
Eq, T f a -> T f a -> Bool
T f a -> T f a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {f :: * -> *} {a}. (Ord a, Ord (f a)) => Eq (T f a)
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Bool
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Ordering
forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> T f a
min :: T f a -> T f a -> T f a
$cmin :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> T f a
max :: T f a -> T f a -> T f a
$cmax :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> T f a
>= :: T f a -> T f a -> Bool
$c>= :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Bool
> :: T f a -> T f a -> Bool
$c> :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Bool
<= :: T f a -> T f a -> Bool
$c<= :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Bool
< :: T f a -> T f a -> Bool
$c< :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Bool
compare :: T f a -> T f a -> Ordering
$ccompare :: forall (f :: * -> *) a.
(Ord a, Ord (f a)) =>
T f a -> T f a -> Ordering
Ord)


instance (C.NFData f, NFData a) => NFData (T f a) where
   rnf :: T f a -> ()
rnf = forall (f :: * -> *) a. (NFData f, NFData a) => f a -> ()
C.rnf

instance (C.NFData f) => C.NFData (T f) where
   rnf :: forall a. NFData a => T f a -> ()
rnf (Cons a
x f a
xs) = forall a. NFData a => a -> ()
rnf (a
x, forall (f :: * -> *) a. (NFData f, NFData a) => f a -> ()
C.rnf f a
xs)


instance (C.Show f, Show a) => Show (T f a) where
   showsPrec :: Int -> T f a -> ShowS
showsPrec = forall (f :: * -> *) a. (Show f, Show a) => Int -> f a -> ShowS
C.showsPrec

instance (C.Show f) => C.Show (T f) where
   showsPrec :: forall a. Show a => Int -> T f a -> ShowS
showsPrec Int
p (Cons a
x f a
xs) =
      Bool -> ShowS -> ShowS
P.showParen (Int
pforall a. Ord a => a -> a -> Bool
>Int
5) forall a b. (a -> b) -> a -> b
$
      forall a. Show a => Int -> a -> ShowS
P.showsPrec Int
6 a
x forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
P.showString String
"!:" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Show f, Show a) => Int -> f a -> ShowS
C.showsPrec Int
5 f a
xs


infixr 5 !:, `append`, `appendRight`, `appendLeft`

(!:) :: a -> f a -> T f a
!: :: forall a (f :: * -> *). a -> f a -> T f a
(!:) = forall (f :: * -> *) a. a -> f a -> T f a
Cons


{- |
Force immediate generation of Cons.
-}
force :: T f a -> T f a
force :: forall (f :: * -> *) a. T f a -> T f a
force T f a
x = forall (f :: * -> *) a. a -> f a -> T f a
Cons (forall (f :: * -> *) a. T f a -> a
head T f a
x) (forall (f :: * -> *) a. T f a -> f a
tail T f a
x)


instance Functor f => Functor (T f) where
   fmap :: forall a b. (a -> b) -> T f a -> T f b
fmap a -> b
f (Cons a
x f a
xs) = a -> b
f a
x forall a (f :: * -> *). a -> f a -> T f a
!: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
xs

instance Foldable f => Foldable (T f) where
   foldr :: forall a b. (a -> b -> b) -> b -> T f a -> b
foldr a -> b -> b
f b
y (Cons a
x f a
xs) = a -> b -> b
f a
x forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Fold.foldr a -> b -> b
f b
y f a
xs
   foldl1 :: forall a. (a -> a -> a) -> T f a -> a
foldl1 = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1
   foldr1 :: forall a. (a -> a -> a) -> T f a -> a
foldr1 a -> a -> a
f (Cons a
x f a
xs) =
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
x (a -> a -> a
f a
x) forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
Fold.foldr (\a
y -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe a
y (a -> a -> a
f a
y)) forall a. Maybe a
Nothing f a
xs
{-
   foldr1 f (Cons x xs) =
      case xs of
         [] -> x
         y:ys -> f x $ Fold.foldr1 f (Cons y ys)
-}


instance Traversable f => Traversable (T f) where
   sequenceA :: forall (f :: * -> *) a. Applicative f => T f (f a) -> f (T f a)
sequenceA (Cons f a
x f (f a)
xs) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. a -> f a -> T f a
Cons f a
x forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
Trav.sequenceA f (f a)
xs

instance
   (Applicative f, C.Empty f, C.Cons f, C.Append f) =>
      Applicative (T f) where
   pure :: forall a. a -> T f a
pure = forall (f :: * -> *) a. Empty f => a -> T f a
singleton
   <*> :: forall a b. T f (a -> b) -> T f a -> T f b
(<*>) = forall (f :: * -> *) a b.
(Applicative f, Cons f, Append f) =>
T f (a -> b) -> T f a -> T f b
apply

instance (Monad f, C.Empty f, C.Cons f, C.Append f) =>
      Monad (T f) where
   return :: forall a. a -> T f a
return = forall (f :: * -> *) a. Empty f => a -> T f a
singleton
   >>= :: forall a b. T f a -> (a -> T f b) -> T f b
(>>=) = forall (f :: * -> *) a b.
(Monad f, Cons f, Append f) =>
T f a -> (a -> T f b) -> T f b
bind


instance (C.Arbitrary f) => C.Arbitrary (T f) where
   arbitrary :: forall a. Arbitrary a => Gen (T f a)
arbitrary = forall a (f :: * -> *). (Arbitrary a, Arbitrary f) => Gen (T f a)
arbitrary
   shrink :: forall a. Arbitrary a => T f a -> [T f a]
shrink = forall a (f :: * -> *).
(Arbitrary a, Arbitrary f) =>
T f a -> [T f a]
shrink

instance (QC.Arbitrary a, C.Arbitrary f) => QC.Arbitrary (T f a) where
   arbitrary :: Gen (T f a)
arbitrary = forall a (f :: * -> *). (Arbitrary a, Arbitrary f) => Gen (T f a)
arbitrary
   shrink :: T f a -> [T f a]
shrink = forall a (f :: * -> *).
(Arbitrary a, Arbitrary f) =>
T f a -> [T f a]
shrink

arbitrary :: (QC.Arbitrary a, C.Arbitrary f) => QC.Gen (T f a)
arbitrary :: forall a (f :: * -> *). (Arbitrary a, Arbitrary f) => Gen (T f a)
arbitrary = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a. Arbitrary a => Gen a
QC.arbitrary forall (f :: * -> *) a. (Arbitrary f, Arbitrary a) => Gen (f a)
C.arbitrary

shrink :: (QC.Arbitrary a, C.Arbitrary f) => T f a -> [T f a]
shrink :: forall a (f :: * -> *).
(Arbitrary a, Arbitrary f) =>
T f a -> [T f a]
shrink (Cons a
x f a
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
y, Aux f a
ys) -> forall (f :: * -> *) a. a -> f a -> T f a
Cons a
y f a
ys) forall a b. (a -> b) -> a -> b
$ forall a. Arbitrary a => a -> [a]
QC.shrink (a
x, forall (f :: * -> *) a. f a -> Aux f a
Aux f a
xs)

newtype Aux f a = Aux (f a)

instance (C.Arbitrary f, QC.Arbitrary a) => QC.Arbitrary (Aux f a) where
   arbitrary :: Gen (Aux f a)
arbitrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f a -> Aux f a
Aux forall (f :: * -> *) a. (Arbitrary f, Arbitrary a) => Gen (f a)
C.arbitrary
   shrink :: Aux f a -> [Aux f a]
shrink (Aux f a
x) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f a -> Aux f a
Aux forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Arbitrary f, Arbitrary a) => f a -> [f a]
C.shrink f a
x


instance (C.Gen f) => C.Gen (T f) where
   genOf :: forall a. Gen a -> Gen (T f a)
genOf Gen a
gen = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. a -> f a -> T f a
Cons Gen a
gen forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Gen f => Gen a -> Gen (f a)
C.genOf Gen a
gen


{- |
Implementation of 'Applicative.<*>' without the 'C.Empty' constraint
that is needed for 'Applicative.pure'.
-}
apply ::
   (Applicative f, C.Cons f, C.Append f) =>
   T f (a -> b) -> T f a -> T f b
apply :: forall (f :: * -> *) a b.
(Applicative f, Cons f, Append f) =>
T f (a -> b) -> T f a -> T f b
apply (Cons a -> b
f f (a -> b)
fs) (Cons a
x f a
xs) =
   forall (f :: * -> *) a. a -> f a -> T f a
Cons (a -> b
f a
x) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
xs forall (f :: * -> *) a. Append f => f a -> f a -> f a
`C.append` (f (a -> b)
fs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons a
x f a
xs))

{- |
Implementation of 'Monad.>>=' without the 'C.Empty' constraint
that is needed for 'Monad.return'.
-}
bind ::
   (Monad f, C.Cons f, C.Append f) =>
   T f a -> (a -> T f b) -> T f b
bind :: forall (f :: * -> *) a b.
(Monad f, Cons f, Append f) =>
T f a -> (a -> T f b) -> T f b
bind (Cons a
x f a
xs) a -> T f b
k =
   forall (f :: * -> *) a. Append f => T f a -> f a -> T f a
appendRight (a -> T f b
k a
x) (forall (f :: * -> *) a. Cons f => T f a -> f a
flatten forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> T f b
k forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< f a
xs)


toList :: Foldable f => T f a -> [a]
toList :: forall (f :: * -> *) a. Foldable f => T f a -> [a]
toList (Cons a
x f a
xs) = a
x forall a. a -> [a] -> [a]
: forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList f a
xs

flatten :: C.Cons f => T f a -> f a
flatten :: forall (f :: * -> *) a. Cons f => T f a -> f a
flatten (Cons a
x f a
xs) = forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons a
x f a
xs

fetch :: C.ViewL f => f a -> Maybe (T f a)
fetch :: forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
fetch = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. ViewL f => f a -> Maybe (a, f a)
C.viewL


{- |
Caution:
@viewL (NonEmpty.Cons x []) = Nothing@
because the tail is empty, and thus cannot be NonEmpty!

This instance mainly exist to allow cascaded applications of 'fetch'.
-}
instance C.ViewL f => C.ViewL (T f) where
   viewL :: forall a. T f a -> Maybe (a, T f a)
viewL (Cons a
x f a
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) a
x) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
fetch f a
xs

instance C.Cons f => C.Cons (T f) where
   cons :: forall a. a -> T f a -> T f a
cons a
x0 (Cons a
x1 f a
xs) = a
x0 forall a (f :: * -> *). a -> f a -> T f a
!: forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons a
x1 f a
xs

instance C.Snoc f => C.Snoc (T f) where
   snoc :: forall a. T f a -> a -> T f a
snoc (Cons a
x0 f a
xs) a
x1 = a
x0 forall a (f :: * -> *). a -> f a -> T f a
!: forall (f :: * -> *) a. Snoc f => f a -> a -> f a
C.snoc f a
xs a
x1


{- |
Synonym for 'Cons'.
For symmetry to 'snoc'.
-}
cons :: a -> f a -> T f a
cons :: forall a (f :: * -> *). a -> f a -> T f a
cons = forall (f :: * -> *) a. a -> f a -> T f a
Cons

snoc :: Traversable f => f a -> a -> T f a
snoc :: forall (f :: * -> *) a. Traversable f => f a -> a -> T f a
snoc f a
xs a
x =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumR (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) a
x f a
xs

-- name of the class could also be ShiftL
class Snoc f where snocFast :: f a -> a -> T f a
instance Snoc [] where snocFast :: forall a. [a] -> a -> T [] a
snocFast = forall (f :: * -> *) a.
(ViewL f, Empty f, Snoc f) =>
f a -> a -> T f a
snocGeneric
instance Snoc Seq where snocFast :: forall a. Seq a -> a -> T Seq a
snocFast = forall (f :: * -> *) a.
(ViewL f, Empty f, Snoc f) =>
f a -> a -> T f a
snocGeneric
instance Snoc Empty.T where snocFast :: forall a. T a -> a -> T T a
snocFast ~T a
Empty.Cons a
x = forall (f :: * -> *) a. a -> f a -> T f a
Cons a
x forall a. T a
Empty.Cons
instance Snoc Maybe where
   snocFast :: forall a. Maybe a -> a -> T Maybe a
snocFast Maybe a
mx a
y = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a
y, forall a. Maybe a
Nothing) (\a
x -> (a
x, forall a. a -> Maybe a
Just a
y)) Maybe a
mx

-- | For 'Seq' faster than 'snoc'.
snocGeneric :: (C.ViewL f, C.Empty f, C.Snoc f) => f a -> a -> T f a
snocGeneric :: forall (f :: * -> *) a.
(ViewL f, Empty f, Snoc f) =>
f a -> a -> T f a
snocGeneric f a
xs a
x =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
   case forall (f :: * -> *) a. ViewL f => f a -> Maybe (a, f a)
C.viewL f a
xs of
      Maybe (a, f a)
Nothing -> (a
x, forall (f :: * -> *) a. Empty f => f a
C.empty)
      Just (a
y,f a
ys) -> (a
y, forall (f :: * -> *) a. Snoc f => f a -> a -> f a
C.snoc f a
ys a
x)

snocAlt :: (C.Cons f, Traversable f) => f a -> a -> f a
snocAlt :: forall (f :: * -> *) a. (Cons f, Traversable f) => f a -> a -> f a
snocAlt f a
xs a
x = forall (f :: * -> *) a. Cons f => T f a -> f a
flatten forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Traversable f => f a -> a -> T f a
snoc f a
xs a
x


instance C.Empty f => C.Singleton (T f) where
   singleton :: forall a. a -> T f a
singleton = forall (f :: * -> *) a. Empty f => a -> T f a
singleton

singleton :: C.Empty f => a -> T f a
singleton :: forall (f :: * -> *) a. Empty f => a -> T f a
singleton a
x = a
x forall a (f :: * -> *). a -> f a -> T f a
!: forall (f :: * -> *) a. Empty f => f a
C.empty


viewL :: T f a -> (a, f a)
viewL :: forall (f :: * -> *) a. T f a -> (a, f a)
viewL (Cons a
x f a
xs) = (a
x, f a
xs)

viewR :: (Traversable f) => T f a -> (f a, a)
viewR :: forall (f :: * -> *) a. Traversable f => T f a -> (f a, a)
viewR (Cons a
x f a
xs) = forall a b. (a, b) -> (b, a)
swap forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (forall a b c. (a -> b -> c) -> b -> a -> c
flip (,)) a
x f a
xs


switchL :: (a -> f a -> b) -> T f a -> b
switchL :: forall a (f :: * -> *) b. (a -> f a -> b) -> T f a -> b
switchL a -> f a -> b
f (Cons a
x f a
xs) = a -> f a -> b
f a
x f a
xs

uncurrier :: (b -> f a -> c) -> (a -> b) -> T f a -> c
uncurrier :: forall b (f :: * -> *) a c.
(b -> f a -> c) -> (a -> b) -> T f a -> c
uncurrier b -> f a -> c
g = forall a (f :: * -> *) b. (a -> f a -> b) -> T f a -> b
switchL forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> f a -> c
g forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

currier :: ((f a -> b) -> c) -> (T f a -> b) -> a -> c
currier :: forall (f :: * -> *) a b c.
((f a -> b) -> c) -> (T f a -> b) -> a -> c
currier (f a -> b) -> c
g T f a -> b
f a
x = (f a -> b) -> c
g forall a b. (a -> b) -> a -> b
$ \f a
xs -> T f a -> b
f forall a b. (a -> b) -> a -> b
$ a
x forall a (f :: * -> *). a -> f a -> T f a
!: f a
xs


mapHead :: (a -> a) -> T f a -> T f a
mapHead :: forall a (f :: * -> *). (a -> a) -> T f a -> T f a
mapHead a -> a
f (Cons a
x f a
xs) = a -> a
f a
x forall a (f :: * -> *). a -> f a -> T f a
!: f a
xs

mapTail :: (f a -> g a) -> T f a -> T g a
mapTail :: forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> T f a -> T g a
mapTail f a -> g a
f (Cons a
x f a
xs) = a
x forall a (f :: * -> *). a -> f a -> T f a
!: f a -> g a
f f a
xs

init :: (Traversable f) => T f a -> f a
init :: forall (f :: * -> *) a. Traversable f => T f a -> f a
init = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Traversable f => T f a -> (f a, a)
viewR

last :: (Foldable f) => T f a -> a
last :: forall (f :: * -> *) a. Foldable f => T f a -> a
last = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. a -> b -> a
const)

foldl1 :: (Foldable f) => (a -> a -> a) -> T f a -> a
foldl1 :: forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 a -> a -> a
f (Cons a
x f a
xs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl a -> a -> a
f a
x f a
xs

{- |
It holds:

> foldl1Map f g = foldl1 f . fmap g

but 'foldl1Map' does not need a 'Functor' instance.
-}
foldl1Map :: (Foldable f) => (b -> b -> b) -> (a -> b) -> T f a -> b
foldl1Map :: forall (f :: * -> *) b a.
Foldable f =>
(b -> b -> b) -> (a -> b) -> T f a -> b
foldl1Map b -> b -> b
f a -> b
g (Cons a
x f a
xs) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl (\b
b a
a -> b -> b -> b
f b
b (a -> b
g a
a)) (a -> b
g a
x) f a
xs


-- cf. NumericPrelude: Algebra.Additive.sumNestedCommutative
{-
Estimate costs of @foldBalanced ListHT.merge@.
@a, b, c@ length of sub-lists and our measure for the cost.

xs = [a,b,c]
ys = [a,b,c,a+b,c+a+b]
costs: (a+b) + (c+a+b) = 2a+2b+c

xs = [a,b,c,d]
ys = [a,b,c,d,a+b,c+d,a+b+c+d]
costs: (a+b) + (c+d) + (a+b+c+d) = 2a+2b+2c+2d

xs = [a,b,c,d,e]
ys = [a,b,c,d,e,a+b,c+d,e+(a+b),c+d+e+(a+b)]
costs: (a+b) + (c+d) + (e+(a+b)) + (c+d+e+(a+b)) = 3a+3b+2c+2d+2e

Analysis is easiest if @length xs@ is a power of two, e.g. @2^n@.
Then the operator tree has height @n@.
That is, we get a run-time of @n * sum (map length xs)@.
This is usually better than @sort (concat xs)@
which has run-time @let m = sum (map length xs) in m * logBase 2 m@.
-}
{- |
Fold a non-empty list in a balanced way.
/Balanced/ means that each element
has approximately the same depth in the operator tree.
/Approximately the same depth/ means
that the difference between maximum and minimum depth is at most 1.
The accumulation operation must be associative and commutative
in order to get the same result as 'foldl1' or 'foldr1'.
-}
foldBalanced :: (a -> a -> a) -> T [] a -> a
foldBalanced :: forall a. (a -> a -> a) -> T [] a -> a
foldBalanced = forall a. (a -> [a] -> [a]) -> (a -> a -> a) -> T [] a -> a
foldBalancedGen (:)

foldBalancedStrict :: (a -> a -> a) -> T [] a -> a
foldBalancedStrict :: forall a. (a -> a -> a) -> T [] a -> a
foldBalancedStrict = forall a. (a -> [a] -> [a]) -> (a -> a -> a) -> T [] a -> a
foldBalancedGen (\a
x -> ((:) forall a b. (a -> b) -> a -> b
$! a
x))

foldBalancedGen :: (a -> [a] -> [a]) -> (a -> a -> a) -> T [] a -> a
foldBalancedGen :: forall a. (a -> [a] -> [a]) -> (a -> a -> a) -> T [] a -> a
foldBalancedGen a -> [a] -> [a]
listCons a -> a -> a
f xs :: T [] a
xs@(Cons a
_ [a]
rs) =
   let reduce :: [a] -> [a]
reduce (a
z0:a
z1:[a]
zs) = a -> [a] -> [a]
listCons (a -> a -> a
f a
z0 a
z1) ([a] -> [a]
reduce [a]
zs)
       reduce [a]
zs = [a]
zs
       ys :: T [] a
ys = forall (f :: * -> *) a. Append f => T f a -> f a -> T f a
appendRight T [] a
xs forall a b. (a -> b) -> a -> b
$ forall b a. [b] -> [a] -> [a]
Match.take [a]
rs forall a b. (a -> b) -> a -> b
$ [a] -> [a]
reduce forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Cons f => T f a -> f a
flatten T [] a
ys
   in  forall (f :: * -> *) a. Foldable f => T f a -> a
last T [] a
ys


-- | maximum is a total function
maximum :: (Ord a, Foldable f) => T f a -> a
maximum :: forall a (f :: * -> *). (Ord a, Foldable f) => T f a -> a
maximum = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 forall a. Ord a => a -> a -> a
P.max

-- | minimum is a total function
minimum :: (Ord a, Foldable f) => T f a -> a
minimum :: forall a (f :: * -> *). (Ord a, Foldable f) => T f a -> a
minimum = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 forall a. Ord a => a -> a -> a
P.min

-- | maximumBy is a total function
maximumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a
maximumBy :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Ordering) -> T f a -> a
maximumBy a -> a -> Ordering
f = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 (\a
x a
y -> case a -> a -> Ordering
f a
x a
y of Ordering
P.LT -> a
y; Ordering
_ -> a
x)

-- | minimumBy is a total function
minimumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a
minimumBy :: forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Ordering) -> T f a -> a
minimumBy a -> a -> Ordering
f = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 (\a
x a
y -> case a -> a -> Ordering
f a
x a
y of Ordering
P.GT -> a
y; Ordering
_ -> a
x)

-- | maximumKey is a total function
maximumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a
maximumKey :: forall b (f :: * -> *) a.
(Ord b, Foldable f) =>
(a -> b) -> T f a -> a
maximumKey a -> b
f =
   forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
Fold.maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. (a -> b) -> f a -> Mapped f a b
FoldU.Mapped (forall a b. (a -> b) -> a -> (b, a)
attachKey a -> b
f)

-- | minimumKey is a total function
minimumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a
minimumKey :: forall b (f :: * -> *) a.
(Ord b, Foldable f) =>
(a -> b) -> T f a -> a
minimumKey a -> b
f =
   forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
Fold.minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. (a -> b) -> f a -> Mapped f a b
FoldU.Mapped (forall a b. (a -> b) -> a -> (b, a)
attachKey a -> b
f)

-- | maximumKey is a total function
_maximumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a
_maximumKey :: forall b (f :: * -> *) a.
(Ord b, Foldable f, Functor f) =>
(a -> b) -> T f a -> a
_maximumKey a -> b
f =
   forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Ordering) -> T f a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> (b, a)
attachKey a -> b
f)

-- | minimumKey is a total function
_minimumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a
_minimumKey :: forall b (f :: * -> *) a.
(Ord b, Foldable f, Functor f) =>
(a -> b) -> T f a -> a
_minimumKey a -> b
f =
   forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Ordering) -> T f a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> (b, a)
attachKey a -> b
f)

attachKey :: (a -> b) -> a -> (b, a)
attachKey :: forall a b. (a -> b) -> a -> (b, a)
attachKey a -> b
f a
a = (a -> b
f a
a, a
a)

-- | sum does not need a zero for initialization
sum :: (Num a, Foldable f) => T f a -> a
sum :: forall a (f :: * -> *). (Num a, Foldable f) => T f a -> a
sum = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 forall a. Num a => a -> a -> a
(P.+)

-- | product does not need a one for initialization
product :: (Num a, Foldable f) => T f a -> a
product :: forall a (f :: * -> *). (Num a, Foldable f) => T f a -> a
product = forall (f :: * -> *) a. Foldable f => (a -> a -> a) -> T f a -> a
foldl1 forall a. Num a => a -> a -> a
(P.*)


chop :: (a -> Bool) -> [a] -> T [] [a]
chop :: forall a. (a -> Bool) -> [a] -> T [] [a]
chop a -> Bool
p =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a (f :: * -> *). a -> f a -> T f a
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (\ a
x ~([a]
y,[[a]]
ys) -> if a -> Bool
p a
x then ([],[a]
yforall a. a -> [a] -> [a]
:[[a]]
ys) else ((a
xforall a. a -> [a] -> [a]
:[a]
y),[[a]]
ys) ) ([],[])


instance (C.Cons f, C.Append f) => C.Append (T f) where
   append :: forall a. T f a -> T f a -> T f a
append T f a
xs T f a
ys = forall (f :: * -> *) a. Append f => T f a -> f a -> T f a
appendRight T f a
xs (forall (f :: * -> *) a. Cons f => T f a -> f a
flatten T f a
ys)

append :: (C.Append f, Traversable f) => T f a -> T f a -> T (T f) a
append :: forall (f :: * -> *) a.
(Append f, Traversable f) =>
T f a -> T f a -> T (T f) a
append T f a
xs T f a
ys =
   forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> T f a -> T g a
mapTail (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a.
(Append f, Traversable f) =>
f a -> T f a -> T f a
appendLeft T f a
ys) T f a
xs

appendRight :: (C.Append f) => T f a -> f a -> T f a
appendRight :: forall (f :: * -> *) a. Append f => T f a -> f a -> T f a
appendRight (Cons a
x f a
xs) f a
ys = forall (f :: * -> *) a. a -> f a -> T f a
Cons a
x (forall (f :: * -> *) a. Append f => f a -> f a -> f a
C.append f a
xs f a
ys)

appendLeft ::
   (C.Append f, Traversable f) =>
   f a -> T f a -> T f a
appendLeft :: forall (f :: * -> *) a.
(Append f, Traversable f) =>
f a -> T f a -> T f a
appendLeft f a
xt (Cons a
y f a
ys) =
   forall (f :: * -> *) a (g :: * -> *).
(f a -> g a) -> T f a -> T g a
mapTail (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Append f => f a -> f a -> f a
C.append f a
ys) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Traversable f => f a -> a -> T f a
snoc f a
xt a
y


{- |
generic variants:
'Data.Monoid.HT.cycle' or better @Semigroup.cycle@
-}
cycle :: (C.Cons f, C.Append f) => T f a -> T f a
cycle :: forall (f :: * -> *) a. (Cons f, Append f) => T f a -> T f a
cycle T f a
x =
   let y :: T f a
y = forall (f :: * -> *) a. Append f => f a -> f a -> f a
C.append T f a
x T f a
y
   in  T f a
y


instance (C.Zip f) => C.Zip (T f) where
   zipWith :: forall a b c. (a -> b -> c) -> T f a -> T f b -> T f c
zipWith = forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> T f a -> T f b -> T f c
zipWith

zipWith :: (C.Zip f) => (a -> b -> c) -> T f a -> T f b -> T f c
zipWith :: forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> T f a -> T f b -> T f c
zipWith a -> b -> c
f (Cons a
a f a
as) (Cons b
b f b
bs) = forall (f :: * -> *) a. a -> f a -> T f a
Cons (a -> b -> c
f a
a b
b) (forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> f a -> f b -> f c
C.zipWith a -> b -> c
f f a
as f b
bs)


instance (C.Repeat f) => C.Repeat (T f) where
   repeat :: forall a. a -> T f a
repeat a
a = forall (f :: * -> *) a. a -> f a -> T f a
Cons a
a forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Repeat f => a -> f a
C.repeat a
a

instance (C.Iterate f) => C.Iterate (T f) where
   iterate :: forall a. (a -> a) -> a -> T f a
iterate a -> a
f a
a = forall (f :: * -> *) a. a -> f a -> T f a
Cons a
a forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Iterate f => (a -> a) -> a -> f a
C.iterate a -> a
f (a -> a
f a
a)


{-
This implementation needs quadratic time
with respect to the number of 'Cons'.
Maybe a linear time solution can be achieved using a type function
that maps a container type to the type of the reversed container.
-}
reverse :: (Traversable f, C.Reverse f) => T f a -> T f a
reverse :: forall (f :: * -> *) a.
(Traversable f, Reverse f) =>
T f a -> T f a
reverse (Cons a
x f a
xs) = forall (f :: * -> *) a. Traversable f => f a -> a -> T f a
snoc (forall (f :: * -> *) a. Reverse f => f a -> f a
C.reverse f a
xs) a
x

instance (Traversable f, C.Reverse f) => C.Reverse (T f) where
   reverse :: forall a. T f a -> T f a
reverse = forall (f :: * -> *) a.
(Traversable f, Reverse f) =>
T f a -> T f a
reverse


{- |
If you nest too many non-empty lists
then the efficient merge-sort (linear-logarithmic runtime)
will degenerate to an inefficient insert-sort (quadratic runtime).
-}
instance (C.Sort f, InsertBy f) => C.Sort (T f) where
   sort :: forall a. Ord a => T f a -> T f a
sort (Cons a
x f a
xs) = forall (f :: * -> *) a. (Insert f, Ord a) => a -> f a -> T f a
insert a
x forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Sort f, Ord a) => f a -> f a
C.sort f a
xs

instance (C.SortBy f, InsertBy f) => C.SortBy (T f) where
   sortBy :: forall a. (a -> a -> Ordering) -> T f a -> T f a
sortBy a -> a -> Ordering
f (Cons a
x f a
xs) = forall (f :: * -> *) a.
InsertBy f =>
(a -> a -> Ordering) -> a -> f a -> T f a
insertBy a -> a -> Ordering
f a
x forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a.
SortBy f =>
(a -> a -> Ordering) -> f a -> f a
C.sortBy a -> a -> Ordering
f f a
xs


class Insert f where
   {- |
   Insert an element into an ordered list while preserving the order.
   -}
   insert :: (Ord a) => a -> f a -> T f a

instance (Insert f) => Insert (T f) where
   insert :: forall a. Ord a => a -> T f a -> T (T f) a
insert a
y xt :: T f a
xt@(Cons a
x f a
xs) =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
      case forall a. Ord a => a -> a -> Ordering
compare a
y a
x of
         Ordering
GT -> (a
x, forall (f :: * -> *) a. (Insert f, Ord a) => a -> f a -> T f a
insert a
y f a
xs)
         Ordering
_ -> (a
y, T f a
xt)

instance Insert Empty.T where
   insert :: forall a. Ord a => a -> T a -> T T a
insert = forall a (f :: * -> *).
(Ord a, InsertBy f, SortBy f) =>
a -> f a -> T f a
insertDefault

instance Insert [] where
   insert :: forall a. Ord a => a -> [a] -> T [] a
insert = forall a (f :: * -> *).
(Ord a, InsertBy f, SortBy f) =>
a -> f a -> T f a
insertDefault

instance Insert Maybe where
   insert :: forall a. Ord a => a -> Maybe a -> T Maybe a
insert = forall a (f :: * -> *).
(Ord a, InsertBy f, SortBy f) =>
a -> f a -> T f a
insertDefault

instance Insert Seq where
   insert :: forall a. Ord a => a -> Seq a -> T Seq a
insert = forall a (f :: * -> *).
(Ord a, InsertBy f, SortBy f) =>
a -> f a -> T f a
insertDefault

{-
This does not work consistently!
A Set is not a sorted list, since it collapses duplicate elements.

*Data.NonEmptyPrivate> mapTail (mapTail Set.toList) $ insert '3' $ insert '7' $ Set.fromList "346"
'3'!:'3'!:'4':'6':'7':[]

instance Insert Set where
   insert y xt =
      uncurry Cons $
      fromMaybe (y, xt) $ do
         (x,xs) <- Set.minView xt
         case compare y x of
            GT -> return (x, Set.insert y xs)
            EQ -> return (x, xs)
            LT -> mzero

We have preserved that function in NonEmpty.Mixed.
-}

{- |
Default implementation for 'insert' based on 'insertBy'.
-}
insertDefault :: (Ord a, InsertBy f, C.SortBy f) => a -> f a -> T f a
insertDefault :: forall a (f :: * -> *).
(Ord a, InsertBy f, SortBy f) =>
a -> f a -> T f a
insertDefault = forall (f :: * -> *) a.
InsertBy f =>
(a -> a -> Ordering) -> a -> f a -> T f a
insertBy forall a. Ord a => a -> a -> Ordering
compare


class Insert f => InsertBy f where
   insertBy :: (a -> a -> Ordering) -> a -> f a -> T f a

instance (InsertBy f) => InsertBy (T f) where
   insertBy :: forall a. (a -> a -> Ordering) -> a -> T f a -> T (T f) a
insertBy a -> a -> Ordering
f a
y xt :: T f a
xt@(Cons a
x f a
xs) =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
      case a -> a -> Ordering
f a
y a
x of
         Ordering
GT -> (a
x, forall (f :: * -> *) a.
InsertBy f =>
(a -> a -> Ordering) -> a -> f a -> T f a
insertBy a -> a -> Ordering
f a
y f a
xs)
         Ordering
_ -> (a
y, T f a
xt)

instance InsertBy Empty.T where
   insertBy :: forall a. (a -> a -> Ordering) -> a -> T a -> T T a
insertBy a -> a -> Ordering
_ a
x T a
Empty.Cons = forall (f :: * -> *) a. a -> f a -> T f a
Cons a
x forall a. T a
Empty.Cons

instance InsertBy [] where
   insertBy :: forall a. (a -> a -> Ordering) -> a -> [a] -> T [] a
insertBy a -> a -> Ordering
f a
y [a]
xt =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
      case [a]
xt of
         [] -> (a
y, [a]
xt)
         a
x:[a]
xs ->
            case a -> a -> Ordering
f a
y a
x of
               Ordering
GT -> (a
x, forall a. (a -> a -> Ordering) -> a -> [a] -> [a]
List.insertBy a -> a -> Ordering
f a
y [a]
xs)
               Ordering
_ -> (a
y, [a]
xt)

instance InsertBy Maybe where
   insertBy :: forall a. (a -> a -> Ordering) -> a -> Maybe a -> T Maybe a
insertBy a -> a -> Ordering
f a
y Maybe a
mx =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
      case Maybe a
mx of
         Maybe a
Nothing -> (a
y, forall a. Maybe a
Nothing)
         Just a
x ->
            forall b c a. (b -> c) -> (a, b) -> (a, c)
mapSnd forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
            case a -> a -> Ordering
f a
y a
x of
               Ordering
GT -> (a
x, a
y)
               Ordering
_ -> (a
y, a
x)

instance InsertBy Seq where
   {-
   If we assume a sorted list
   we could do binary search for the splitting point.
   -}
   insertBy :: forall a. (a -> a -> Ordering) -> a -> Seq a -> T Seq a
insertBy a -> a -> Ordering
f a
y Seq a
xt =
      forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall a b. (a -> b) -> a -> b
$
      case forall a. (a -> Bool) -> Seq a -> (Seq a, Seq a)
Seq.spanl ((Ordering
GT forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Ordering
f a
y) Seq a
xt of
         (Seq a
ys,Seq a
zs) ->
            case forall a. Seq a -> ViewL a
Seq.viewl Seq a
ys of
               ViewL a
Seq.EmptyL -> (a
y, Seq a
xt)
               a
w Seq.:< Seq a
ws -> (a
w, Seq a
ws forall a. Seq a -> Seq a -> Seq a
Seq.>< a
y forall a. a -> Seq a -> Seq a
Seq.<| Seq a
zs)

{-
Certainly not as efficient as insertBy as class method
since all elements of the list are touched.
-}
insertByTraversable ::
   (Traversable f) =>
   (a -> a -> Ordering) -> a -> f a -> T f a
insertByTraversable :: forall (f :: * -> *) a.
Traversable f =>
(a -> a -> Ordering) -> a -> f a -> T f a
insertByTraversable a -> a -> Ordering
cmp a
y0 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Traversable f => f a -> a -> T f a
snoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL
      (\(Bool
searching,a
y) a
x ->
         let stillSearching :: Bool
stillSearching = Bool
searching Bool -> Bool -> Bool
&& a -> a -> Ordering
cmp a
y a
x forall a. Eq a => a -> a -> Bool
== Ordering
GT
         in  forall a c b. (a -> c) -> (a, b) -> (c, b)
mapFst ((,) Bool
stillSearching) forall a b. (a -> b) -> a -> b
$ forall a. Bool -> a -> a -> a
if' Bool
stillSearching (a
y,a
x) (a
x,a
y))
      (Bool
True, a
y0)



mapWithIndex :: (Traversable f) => (Int -> a -> b) -> Int -> f a -> f b
mapWithIndex :: forall (f :: * -> *) a b.
Traversable f =>
(Int -> a -> b) -> Int -> f a -> f b
mapWithIndex Int -> a -> b
f Int
n = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\Int
k a
x -> (forall a. Enum a => a -> a
P.succ Int
k, Int -> a -> b
f Int
k a
x)) Int
n

removeAt :: (Traversable f) => Int -> T f a -> (a, f a)
removeAt :: forall (f :: * -> *) a. Traversable f => Int -> T f a -> (a, f a)
removeAt Int
n (Cons a
x0 f a
xs) =
   forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\a
x (Int
k,a
y) -> if Int
kforall a. Ord a => a -> a -> Bool
<=Int
n then (a
y,a
x) else (a
x,a
y)) a
x0 forall a b. (a -> b) -> a -> b
$
   forall (f :: * -> *) a b.
Traversable f =>
(Int -> a -> b) -> Int -> f a -> f b
mapWithIndex (,) Int
1 f a
xs

removeEach :: (Traversable f) => T f a -> T f (a, f a)
removeEach :: forall (f :: * -> *) a. Traversable f => T f a -> T f (a, f a)
removeEach T f a
xs  =  forall (f :: * -> *) a b.
Traversable f =>
(Int -> a -> b) -> Int -> f a -> f b
mapWithIndex (\Int
n a
_ -> forall (f :: * -> *) a. Traversable f => Int -> T f a -> (a, f a)
removeAt Int
n T f a
xs) Int
0 T f a
xs

{- |
prop> let takeUntil p xs = NonEmpty.zipWith const xs $ () !: void (takeWhile (not . p) $ NonEmpty.flatten xs) in \k xs -> takeUntil (>=k) xs == NonEmpty.takeUntil (>=(k::Int)) xs
-}
takeUntil :: (a -> Bool) -> T [] a -> T [] a
takeUntil :: forall a. (a -> Bool) -> T [] a -> T [] a
takeUntil a -> Bool
p (Cons a
x [a]
xs) =
   a
x forall a (f :: * -> *). a -> f a -> T f a
!: if a -> Bool
p a
x then [] else forall a. (a -> Bool) -> [a] -> [a]
ListHT.takeUntil a -> Bool
p [a]
xs

takeUntilAlt :: (a -> Bool) -> T [] a -> T [] a
takeUntilAlt :: forall a. (a -> Bool) -> T [] a -> T [] a
takeUntilAlt a -> Bool
p T [] a
xs =
   forall (f :: * -> *) a b c.
Zip f =>
(a -> b -> c) -> T f a -> T f b -> T f c
zipWith forall a b. a -> b -> a
const T [] a
xs forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. a -> f a -> T f a
Cons () forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> m ()
void forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
List.takeWhile (Bool -> Bool
P.not forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Cons f => T f a -> f a
flatten T [] a
xs



{-
It is somehow better than the variant in NonEmpty.Mixed,
since it can be applied to nested NonEmptys.

Type @g@ could be fixed to List,
since context (C.Cons g, C.Empty g) means
that @g@ is a supertype of something isomorphic to list.
However, repeatedly prepending an element might be more efficient
than repeated conversion from list to a structure like Sequence.
-}
tails :: (Traversable f, C.Cons g, C.Empty g) => f a -> T f (g a)
tails :: forall (f :: * -> *) (g :: * -> *) a.
(Traversable f, Cons g, Empty g) =>
f a -> T f (g a)
tails = forall (f :: * -> *) a b.
Traversable f =>
(a -> b -> b) -> b -> f a -> T f b
scanr forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons forall (f :: * -> *) a. Empty f => f a
C.empty


{- |
Only advised for structures with efficient appending of single elements
like 'Sequence'.
Alternatively you may consider 'initsRev'.
-}
inits :: (Traversable f, C.Snoc g, C.Empty g) => f a -> T f (g a)
inits :: forall (f :: * -> *) (g :: * -> *) a.
(Traversable f, Snoc g, Empty g) =>
f a -> T f (g a)
inits = forall (f :: * -> *) b a.
Traversable f =>
(b -> a -> b) -> b -> f a -> T f b
scanl forall (f :: * -> *) a. Snoc f => f a -> a -> f a
C.snoc forall (f :: * -> *) a. Empty f => f a
C.empty

{-
suggested in
<http://www.haskell.org/pipermail/libraries/2014-July/023291.html>
-}
initsRev ::
   (Traversable f, C.Cons g, C.Empty g, C.Reverse g) =>
   f a -> T f (g a)
initsRev :: forall (f :: * -> *) (g :: * -> *) a.
(Traversable f, Cons g, Empty g, Reverse g) =>
f a -> T f (g a)
initsRev = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Reverse f => f a -> f a
C.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) b a.
Traversable f =>
(b -> a -> b) -> b -> f a -> T f b
scanl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons) forall (f :: * -> *) a. Empty f => f a
C.empty

{-
Not exported by NonEmpty.
I think the transposeClip function is better.
-}
class TransposeOuter f where
   transpose :: TransposeInner g => f (g a) -> g (f a)

instance TransposeOuter [] where
   transpose :: forall (g :: * -> *) a. TransposeInner g => [g a] -> g [a]
transpose =
      let go :: [g a] -> g (f a)
go [] = forall (g :: * -> *) a. TransposeInner g => g a
transposeStart
          go (g a
xs : [g a]
xss) = forall (g :: * -> *) (f :: * -> *) a.
(TransposeInner g, Singleton f, Cons f) =>
g a -> g (f a) -> g (f a)
zipHeadTail g a
xs forall a b. (a -> b) -> a -> b
$ [g a] -> g (f a)
go [g a]
xss
      in  forall {g :: * -> *} {f :: * -> *} {a}.
(TransposeInner g, Singleton f, Cons f) =>
[g a] -> g (f a)
go

{-
We cannot define this instance,
because @transpose ([] !: [2] !: []) = [2 !: []]@

instance TransposeOuter f => TransposeOuter (T f) where
   transpose =
      let go (Cons xs xss) = zipHeadTail xs $ go xss
      in  go
-}

class TransposeInner g where
   transposeStart :: g a
   zipHeadTail :: (C.Singleton f, C.Cons f) => g a -> g (f a) -> g (f a)

instance TransposeInner [] where
   transposeStart :: forall a. [a]
transposeStart = []
   zipHeadTail :: forall (f :: * -> *) a.
(Singleton f, Cons f) =>
[a] -> [f a] -> [f a]
zipHeadTail =
      let go :: [a] -> [f a] -> [f a]
go (a
x:[a]
xs) (f a
ys:[f a]
yss) = forall (f :: * -> *) a. Cons f => a -> f a -> f a
C.cons a
x f a
ys forall a. a -> [a] -> [a]
: [a] -> [f a] -> [f a]
go [a]
xs [f a]
yss
          go [] [f a]
yss = [f a]
yss
          go [a]
xs [] = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Singleton f => a -> f a
C.singleton [a]
xs
      in  forall {f :: * -> *} {a}.
(Cons f, Singleton f) =>
[a] -> [f a] -> [f a]
go

{-
We cannot define this instance,
because @transpose ([] :: [NonEmpty.T [] Int]) = []@,
but in order to satisfy the types it must be ([] !: []).

instance TransposeInner f => TransposeInner (T f) where
   transposeStart = Cons ??? transposeStart
   zipHeadTail (Cons x xs) (Cons ys yss) =
      Cons (C.cons x ys) (zipHeadTail xs yss)
-}

{-
transpose :: [[a]] -> [[a]]
transpose =
   let go [] = []
       go (xs : xss) = zipHeadTail xs $ go xss
   in  go

zipHeadTail :: [a] -> [[a]] -> [[a]]
zipHeadTail (x:xs) (ys:yss) = (x:ys) : zipHeadTail xs yss
zipHeadTail [] yss = yss
zipHeadTail xs [] = fmap (:[]) xs
-}

transposePrelude :: [[a]] -> [[a]]
transposePrelude :: forall a. [[a]] -> [[a]]
transposePrelude =
   let go :: [[a]] -> [[a]]
go [] = []
       go ([] : [[a]]
xss) = [[a]] -> [[a]]
go [[a]]
xss
       go ((a
x:[a]
xs) : [[a]]
xss) =
          case forall a b. [(a, b)] -> ([a], [b])
ListHT.unzip forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. [a] -> Maybe (a, [a])
ListHT.viewL [[a]]
xss of
             ([a]
ys, [[a]]
yss) -> (a
x forall a. a -> [a] -> [a]
: [a]
ys) forall a. a -> [a] -> [a]
: [[a]] -> [[a]]
go ([a]
xs forall a. a -> [a] -> [a]
: [[a]]
yss)
   in  forall a. [[a]] -> [[a]]
go

propTranspose :: [[P.Int]] -> P.Bool
propTranspose :: [[Int]] -> Bool
propTranspose [[Int]]
xs =
   forall a. [[a]] -> [[a]]
List.transpose [[Int]]
xs forall a. Eq a => a -> a -> Bool
P.== forall (f :: * -> *) (g :: * -> *) a.
(TransposeOuter f, TransposeInner g) =>
f (g a) -> g (f a)
transpose [[Int]]
xs

propTransposePrelude :: [[P.Int]] -> P.Bool
propTransposePrelude :: [[Int]] -> Bool
propTransposePrelude [[Int]]
xs =
   forall a. [[a]] -> [[a]]
List.transpose [[Int]]
xs forall a. Eq a => a -> a -> Bool
P.== forall a. [[a]] -> [[a]]
transposePrelude [[Int]]
xs



scanl :: Traversable f => (b -> a -> b) -> b -> f a -> T f b
scanl :: forall (f :: * -> *) b a.
Traversable f =>
(b -> a -> b) -> b -> f a -> T f b
scanl b -> a -> b
f b
b =
   forall (f :: * -> *) a. a -> f a -> T f a
Cons b
b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\b
b0 -> (\b
b1 -> (b
b1,b
b1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> b
f b
b0) b
b

scanr :: Traversable f => (a -> b -> b) -> b -> f a -> T f b
scanr :: forall (f :: * -> *) a b.
Traversable f =>
(a -> b -> b) -> b -> f a -> T f b
scanr a -> b -> b
f b
b =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (f :: * -> *) a. a -> f a -> T f a
Cons forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumR (\b
b0 -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) b
b0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> b
f b
b0) b
b

mapAdjacent ::
   (Traversable f) => (a -> a -> b) -> T f a -> f b
mapAdjacent :: forall (f :: * -> *) a b.
Traversable f =>
(a -> a -> b) -> T f a -> f b
mapAdjacent a -> a -> b
f (Cons a
x f a
xs) =
   forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\a
a0 a
a1 -> (a
a1, a -> a -> b
f a
a0 a
a1)) a
x f a
xs

{-
A nice function but not particularly related to NonEmpty.
Maybe move it to Class module?
-}
mapAdjacent1 :: (Traversable f) => (a -> a -> b -> c) -> a -> f (a,b) -> f c
mapAdjacent1 :: forall (f :: * -> *) a b c.
Traversable f =>
(a -> a -> b -> c) -> a -> f (a, b) -> f c
mapAdjacent1 a -> a -> b -> c
f = (forall a b. (a, b) -> b
sndforall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL (\a
a0 (a
a1,b
b) -> (a
a1, a -> a -> b -> c
f a
a0 a
a1 b
b))

{- |
prop> \xs -> mapMaybe EitherHT.maybeLeft (NonEmpty.flatten xs) == either NonEmpty.flatten fst (NonEmpty.partitionEithersLeft (xs::NonEmpty.T[](Either Char Int)))
prop> \xs -> mapMaybe EitherHT.maybeRight (NonEmpty.flatten xs) == either (const []) (NonEmpty.flatten . snd) (NonEmpty.partitionEithersLeft (xs::NonEmpty.T[](Either Char Int)))
prop> \xs -> NonEmpty.partitionEithersRight (fmap EitherHT.swap xs) == EitherHT.mapLeft swap (EitherHT.swap (NonEmpty.partitionEithersLeft (xs::NonEmpty.T[](Either Char Int))))
-}
partitionEithersLeft :: T [] (Either a b) -> Either (T [] a) ([a], T [] b)
partitionEithersLeft :: forall a b. T [] (Either a b) -> Either (T [] a) ([a], T [] b)
partitionEithersLeft (Cons Either a b
x [Either a b]
xs) =
   case (Either a b
x, forall a b. [Either a b] -> ([a], [b])
ListHT.unzipEithers [Either a b]
xs) of
      (Right b
r, ([a]
ls,[b]
rs)) -> forall a b. b -> Either a b
Right ([a]
ls, forall (f :: * -> *) a. a -> f a -> T f a
Cons b
r [b]
rs)
      (Left a
l, ([a]
ls,[b]
rs)) ->
         forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. a -> f a -> T f a
Cons a
l [a]
ls) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,) (a
lforall a. a -> [a] -> [a]
:[a]
ls)) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
fetch [b]
rs

{- |
prop> \xs -> NonEmpty.partitionEithersLeft (fmap EitherHT.swap xs) == EitherHT.mapRight swap (EitherHT.swap (NonEmpty.partitionEithersRight (xs::NonEmpty.T[](Either Char Int))))
-}
partitionEithersRight :: T [] (Either a b) -> Either (T [] a, [b]) (T [] b)
partitionEithersRight :: forall a b. T [] (Either a b) -> Either (T [] a, [b]) (T [] b)
partitionEithersRight (Cons Either a b
x [Either a b]
xs) =
   case (Either a b
x, forall a b. [Either a b] -> ([a], [b])
ListHT.unzipEithers [Either a b]
xs) of
      (Left a
l, ([a]
ls,[b]
rs)) -> forall a b. a -> Either a b
Left (forall (f :: * -> *) a. a -> f a -> T f a
Cons a
l [a]
ls, [b]
rs)
      (Right b
r, ([a]
ls,[b]
rs)) ->
         forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. a -> f a -> T f a
Cons b
r [b]
rs) (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) (b
rforall a. a -> [a] -> [a]
:[b]
rs)) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. ViewL f => f a -> Maybe (T f a)
fetch [a]
ls


{- |
prop> forRange $ \b0 -> forRange $ \b1 -> forRange $ \b2 -> let b = FuncHT.unzip $ b0!:b1!:b2!:Empty.Cons in map (Ix.index b) (Ix.range b) == take (Ix.rangeSize b) [0..]
-}
instance C.Ix f => C.Ix (T f) where
   range :: forall i. Ix i => (T f i, T f i) -> [T f i]
range (Cons i
l f i
ls, Cons i
u f i
us) =
      forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. a -> f a -> T f a
Cons (forall a. Ix a => (a, a) -> [a]
Ix.range (i
l,i
u)) (forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> [f i]
C.range (f i
ls,f i
us))
   inRange :: forall i. Ix i => (T f i, T f i) -> T f i -> Bool
inRange (Cons i
l f i
ls, Cons i
u f i
us) (Cons i
i f i
is) =
      forall a. Ix a => (a, a) -> a -> Bool
Ix.inRange (i
l,i
u) i
i Bool -> Bool -> Bool
&& forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> f i -> Bool
C.inRange (f i
ls,f i
us) f i
is
   rangeSize :: forall i. Ix i => (T f i, T f i) -> Int
rangeSize (Cons i
l f i
ls, Cons i
u f i
us) =
      forall a. Ix a => (a, a) -> Int
Ix.rangeSize (i
l,i
u) forall a. Num a => a -> a -> a
* forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> Int
C.rangeSize (f i
ls,f i
us)
   rangeSizeIndex :: forall i. Ix i => (T f i, T f i) -> (Int, T f i -> Int)
rangeSizeIndex (Cons i
l f i
ls, Cons i
u f i
us) =
      let size :: Int
size = forall a. Ix a => (a, a) -> Int
Ix.rangeSize (i
l,i
u)
          (Int
subSize, f i -> Int
subIndex) = forall (f :: * -> *) i.
(Ix f, Ix i) =>
(f i, f i) -> (Int, f i -> Int)
C.rangeSizeIndex (f i
ls,f i
us)
      in (Int
sizeforall a. Num a => a -> a -> a
*Int
subSize,
            \(Cons i
i f i
is) -> forall a. Ix a => (a, a) -> a -> Int
Ix.index (i
l,i
u) i
i forall a. Num a => a -> a -> a
* Int
subSize forall a. Num a => a -> a -> a
+ f i -> Int
subIndex f i
is)
   indexHorner :: forall i. Ix i => (T f i, T f i) -> Int -> T f i -> Int
indexHorner (Cons i
l f i
ls, Cons i
u f i
us) =
      let size :: Int
size = forall a. Ix a => (a, a) -> Int
Ix.rangeSize (i
l,i
u)
      in \Int
superOffset (Cons i
i f i
is) ->
            forall (f :: * -> *) i.
(Ix f, Ix i) =>
(f i, f i) -> Int -> f i -> Int
C.indexHorner (f i
ls,f i
us) (Int
superOffsetforall a. Num a => a -> a -> a
*Int
size forall a. Num a => a -> a -> a
+ forall a. Ix a => (a, a) -> a -> Int
Ix.index (i
l,i
u) i
i) f i
is

{-
GHC-7.10 requires FlexibleContexts extension for this instance.
-}
instance (C.Ix f, Ix.Ix i, Ord (f i)) => Ix.Ix (T f i) where
   range :: (T f i, T f i) -> [T f i]
range = forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> [f i]
C.range
   index :: (T f i, T f i) -> T f i -> Int
index = forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> f i -> Int
C.index
   inRange :: (T f i, T f i) -> T f i -> Bool
inRange = forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> f i -> Bool
C.inRange
   rangeSize :: (T f i, T f i) -> Int
rangeSize = forall (f :: * -> *) i. (Ix f, Ix i) => (f i, f i) -> Int
C.rangeSize