module Data.NonEmptyPrivate where
import qualified Data.NonEmpty.Class as C
import qualified Data.Empty as Empty
import qualified Data.Traversable as Trav
import qualified Data.Foldable as Fold
import qualified Data.List.HT as ListHT
import qualified Data.List as List
import Data.Traversable (Traversable, mapAccumL, mapAccumR)
import Data.Foldable (Foldable, )
import Control.Monad (Monad, return, (=<<), )
import Control.Applicative (Applicative, liftA2, pure, (<*>), )
import Data.Functor (Functor, fmap, )
import Data.Function (flip, const, ($), (.), )
import Data.Maybe (Maybe(Just, Nothing), maybe, mapMaybe, )
import Data.Ord (Ord, Ordering(GT), (<), (>), compare, comparing, )
import Data.Tuple.HT (mapSnd, )
import Data.Tuple (fst, snd, )
import qualified Prelude as P
import Prelude (Eq, Show, Num, uncurry, )
import qualified Test.QuickCheck as QC
data T f a = Cons { head :: a, tail :: f a }
deriving (Eq, Ord)
instance (C.Show f, Show a) => Show (T f a) where
showsPrec = C.showsPrec
instance (C.Show f) => C.Show (T f) where
showsPrec p (Cons x xs) =
P.showParen (p>5) $
P.showsPrec 6 x . P.showString "!:" . C.showsPrec 5 xs
infixr 5 !:, `append`, `appendRight`, `appendLeft`
(!:) :: a -> f a -> T f a
(!:) = Cons
force :: T f a -> T f a
force x = Cons (head x) (tail x)
instance Functor f => Functor (T f) where
fmap f (Cons x xs) = f x !: fmap f xs
instance Foldable f => Foldable (T f) where
foldr f y (Cons x xs) = f x $ Fold.foldr f y xs
foldl1 = foldl1
foldr1 f (Cons x xs) =
maybe x (f x) $
Fold.foldr (\y -> Just . maybe y (f y)) Nothing xs
instance Traversable f => Traversable (T f) where
sequenceA (Cons x xs) = liftA2 Cons x $ Trav.sequenceA xs
instance
(Applicative f, C.Empty f, C.Cons f, C.Append f) =>
Applicative (T f) where
pure = singleton
(<*>) = apply
instance (Monad f, C.Empty f, C.Cons f, C.Append f) =>
Monad (T f) where
return = singleton
(>>=) = bind
instance (QC.Arbitrary a, C.Arbitrary f) => QC.Arbitrary (T f a) where
arbitrary = liftA2 Cons QC.arbitrary C.arbitrary
shrink (Cons x xs) = fmap (\(y, Aux ys) -> Cons y ys) $ QC.shrink (x, Aux xs)
newtype Aux f a = Aux (f a)
instance (C.Arbitrary f, QC.Arbitrary a) => QC.Arbitrary (Aux f a) where
arbitrary = fmap Aux C.arbitrary
shrink (Aux x) = fmap Aux $ C.shrink x
apply ::
(Applicative f, C.Cons f, C.Append f) =>
T f (a -> b) -> T f a -> T f b
apply (Cons f fs) (Cons x xs) =
Cons (f x) (fmap f xs `C.append` (fs <*> C.cons x xs))
bind ::
(Monad f, C.Cons f, C.Append f) =>
T f a -> (a -> T f b) -> T f b
bind (Cons x xs) k =
appendRight (k x) (flatten . k =<< xs)
toList :: Foldable f => T f a -> [a]
toList (Cons x xs) = x : Fold.toList xs
flatten :: C.Cons f => T f a -> f a
flatten (Cons x xs) = C.cons x xs
fetch :: C.View f => f a -> Maybe (T f a)
fetch = fmap (uncurry Cons) . C.viewL
instance C.Cons f => C.Cons (T f) where
cons = cons
cons :: C.Cons f => a -> T f a -> T f a
cons x0 (Cons x1 xs) = x0 !: C.cons x1 xs
snocExtend :: Traversable f => f a -> a -> T f a
snocExtend xs y0 =
uncurry Cons $ mapAccumR (\y x -> (x,y)) y0 xs
instance C.Empty f => C.Singleton (T f) where
singleton = singleton
singleton :: C.Empty f => a -> T f a
singleton x = x !: C.empty
reverse :: (Traversable f, C.Reverse f) => T f a -> T f a
reverse (Cons x xs) = snocExtend (C.reverse xs) x
instance (Traversable f, C.Reverse f) => C.Reverse (T f) where
reverse = reverse
mapHead :: (a -> a) -> T f a -> T f a
mapHead f (Cons x xs) = f x !: xs
mapTail :: (f a -> g a) -> T f a -> T g a
mapTail f (Cons x xs) = x !: f xs
init :: (C.Zip f, C.Cons f) => T f a -> f a
init (Cons x xs) = C.zipWith const (C.cons x xs) xs
last :: (Foldable f) => T f a -> a
last = foldl1 (flip const)
foldl1 :: (Foldable f) => (a -> a -> a) -> T f a -> a
foldl1 f (Cons x xs) = Fold.foldl f x xs
foldl1Map :: (Foldable f) => (a -> b) -> (b -> b -> b) -> T f a -> b
foldl1Map g f (Cons x xs) = Fold.foldl (\b a -> f b (g a)) (g x) xs
maximum :: (Ord a, Foldable f) => T f a -> a
maximum = foldl1 P.max
minimum :: (Ord a, Foldable f) => T f a -> a
minimum = foldl1 P.min
maximumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a
maximumBy f = foldl1 (\x y -> case f x y of P.LT -> y; _ -> x)
minimumBy :: (Foldable f) => (a -> a -> Ordering) -> T f a -> a
minimumBy f = foldl1 (\x y -> case f x y of P.GT -> y; _ -> x)
maximumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a
maximumKey f =
snd .
foldl1Map (attachKey f)
(\ky0 ky1 -> if fst ky0 < fst ky1 then ky1 else ky0)
minimumKey :: (Ord b, Foldable f) => (a -> b) -> T f a -> a
minimumKey f =
snd .
foldl1Map (attachKey f)
(\ky0 ky1 -> if fst ky0 > fst ky1 then ky1 else ky0)
_maximumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a
_maximumKey f =
snd . maximumBy (comparing fst) . fmap (attachKey f)
_minimumKey :: (Ord b, Foldable f, Functor f) => (a -> b) -> T f a -> a
_minimumKey f =
snd . minimumBy (comparing fst) . fmap (attachKey f)
attachKey :: (a -> b) -> a -> (b, a)
attachKey f a = (f a, a)
sum :: (Num a, Foldable f) => T f a -> a
sum = foldl1 (P.+)
product :: (Num a, Foldable f) => T f a -> a
product = foldl1 (P.*)
instance (C.Cons f, C.Append f) => C.Append (T f) where
append = append
append :: (C.Cons f, C.Append f) => T f a -> T f a -> T f a
append xs ys = appendRight xs (flatten ys)
appendRight :: (C.Append f) => T f a -> f a -> T f a
appendRight (Cons x xs) ys = Cons x (C.append xs ys)
appendLeft ::
(C.Append f, C.View f, C.Cons f) =>
f a -> T f a -> T f a
appendLeft xt yt =
force $
case C.viewL xt of
Nothing -> yt
Just (x,xs) -> Cons x $ C.append xs $ flatten yt
cycle :: (C.Cons f, C.Append f) => T f a -> T f a
cycle x =
let y = append x y
in y
instance (C.Zip f) => C.Zip (T f) where
zipWith = zipWith
zipWith :: (C.Zip f) => (a -> b -> c) -> T f a -> T f b -> T f c
zipWith f (Cons a as) (Cons b bs) = Cons (f a b) (C.zipWith f as bs)
instance (C.Repeat f) => C.Repeat (T f) where
repeat a = Cons a $ C.repeat a
instance (C.Sort f, Insert f) => C.Sort (T f) where
sortBy = sortBy
sortBy :: (C.Sort f, Insert f) => (a -> a -> Ordering) -> T f a -> T f a
sortBy f (Cons x xs) =
insertBy f x $ C.sortBy f xs
sort :: (Ord a, C.Sort f, Insert f) => T f a -> T f a
sort = sortBy compare
class Insert f where
insertBy :: (a -> a -> Ordering) -> a -> f a -> T f a
instance (Insert f) => Insert (T f) where
insertBy f y xt@(Cons x xs) =
uncurry Cons $
case f y x of
GT -> (x, insertBy f y xs)
_ -> (y, xt)
instance Insert Empty.T where
insertBy _ x Empty.Cons = Cons x Empty.Cons
instance Insert [] where
insertBy f y xt =
uncurry Cons $
case xt of
[] -> (y, xt)
x:xs ->
case f y x of
GT -> (x, List.insertBy f y xs)
_ -> (y, xt)
instance Insert Maybe where
insertBy f y mx =
uncurry Cons $
case mx of
Nothing -> (y, Nothing)
Just x ->
mapSnd Just $
case f y x of
GT -> (x, y)
_ -> (y, x)
insert :: (Ord a, Insert f, C.Sort f) => a -> f a -> T f a
insert = insertBy compare
class Functor f => RemoveEach f where
removeEach :: T f a -> T f (a, f a)
instance RemoveEach [] where
removeEach (Cons x xs) =
Cons (x, xs) (fmap (mapSnd (x:)) $ ListHT.removeEach xs)
instance RemoveEach Empty.T where
removeEach (Cons x Empty.Cons) = Cons (x, Empty.Cons) Empty.Cons
instance RemoveEach f => RemoveEach (T f) where
removeEach (Cons x xs) =
Cons (x, xs) (fmap (mapSnd (x !:)) $ removeEach xs)
instance RemoveEach Maybe where
removeEach (Cons x0 xs) =
(\ ~(a,b) -> Cons (x0, a) b) $
case xs of
Nothing -> (Nothing, Nothing)
Just x1 -> (Just x1, Just (x1, Just x0))
class Tails f where
tails :: (C.Cons g, C.Empty g) => f a -> T f (g a)
instance Tails [] where
tails xt =
force $
case C.viewL xt of
Nothing -> Cons C.empty C.empty
Just (x, xs) ->
case tails xs of
xss -> cons (C.cons x $ head xss) xss
instance Tails Empty.T where
tails Empty.Cons = Cons C.empty Empty.Cons
instance Tails f => Tails (T f) where
tails (Cons x xs) =
case tails xs of
xss -> Cons (C.cons x $ head xss) xss
instance Tails Maybe where
tails xs =
force $
case xs of
Nothing -> Cons C.empty Nothing
Just x -> Cons (C.cons x C.empty) (Just C.empty)
newtype Zip f a = Zip {unZip :: f a}
instance Functor f => Functor (Zip f) where
fmap f (Zip xs) = Zip $ fmap f xs
instance (C.Zip f, C.Repeat f) => Applicative (Zip f) where
pure a = Zip $ C.repeat a
Zip f <*> Zip x = Zip $ C.zipWith ($) f x
transposeClip ::
(Traversable f, C.Zip g, C.Repeat g) =>
f (g a) -> g (f a)
transposeClip =
unZip . Trav.sequenceA . fmap Zip
class TransposeOuter f where
transpose :: TransposeInner g => f (g a) -> g (f a)
instance TransposeOuter [] where
transpose =
let go [] = transposeStart
go (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 = []
zipHeadTail =
let go (x:xs) (ys:yss) = C.cons x ys : go xs yss
go [] yss = yss
go xs [] = fmap C.singleton xs
in go
transposePrelude :: [[a]] -> [[a]]
transposePrelude =
let go [] = []
go ([] : xss) = go xss
go ((x:xs) : xss) =
case ListHT.unzip $ mapMaybe ListHT.viewL xss of
(ys, yss) -> (x : ys) : go (xs : yss)
in go
propTranspose :: [[P.Int]] -> P.Bool
propTranspose xs =
List.transpose xs P.== transpose xs
propTransposePrelude :: [[P.Int]] -> P.Bool
propTransposePrelude xs =
List.transpose xs P.== transposePrelude xs
scanl :: Traversable f => (b -> a -> b) -> b -> f a -> T f b
scanl f b =
Cons b . snd .
mapAccumL (\b0 -> (\b1 -> (b1,b1)) . f b0) b
scanr :: Traversable f => (a -> b -> b) -> b -> f a -> T f b
scanr f b =
uncurry Cons .
mapAccumR (\b0 -> flip (,) b0 . flip f b0) b
mapAdjacent ::
(Traversable f) => (a -> a -> b) -> T f a -> f b
mapAdjacent f (Cons x xs) =
snd $ mapAccumL (\a0 a1 -> (a1, f a0 a1)) x xs