module Data.NonEmpty.Class where import qualified Data.Sequence as Seq import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.List.HT as ListHT import qualified Data.List as List import qualified Control.DeepSeq as DeepSeq import Data.Sequence (Seq, ) import Data.Map (Map, ) import Data.Set (Set, ) import Data.Traversable (Traversable, mapAccumL, mapAccumR) import Control.Monad (liftM2, ) import Data.Tuple.HT (swap, ) import qualified Test.QuickCheck as QC import qualified Prelude as P import Prelude hiding (Show, showsPrec, zipWith, zipWith3, reverse, ) class Empty f where empty :: f a instance Empty [] where empty = [] instance Empty Maybe where empty = Nothing instance Empty Set where empty = Set.empty instance Empty (Map k) where empty = Map.empty instance Empty Seq where empty = Seq.empty class Cons f where cons :: a -> f a -> f a instance Cons [] where cons = (:) instance Cons Seq where cons = (Seq.<|) class Snoc f where snoc :: f a -> a -> f a instance Snoc [] where snoc = snocDefault instance Snoc Seq where snoc = (Seq.|>) snocDefault :: (Cons f, Traversable f) => f a -> a -> f a snocDefault xs x = uncurry cons $ mapAccumR (flip (,)) x xs class ViewL f where viewL :: f a -> Maybe (a, f a) instance ViewL [] where viewL = ListHT.viewL instance ViewL Maybe where viewL = fmap (\a -> (a, Nothing)) instance ViewL Set where viewL = Set.minView instance ViewL Seq where viewL x = case Seq.viewl x of Seq.EmptyL -> Nothing y Seq.:< ys -> Just (y,ys) -- viewL x = do y Seq.:< ys <- Just $ Seq.viewl x; Just (y,ys) class ViewR f where viewR :: f a -> Maybe (f a, a) instance ViewR [] where viewR = ListHT.viewR instance ViewR Maybe where viewR = fmap (\a -> (Nothing, a)) instance ViewR Set where viewR = fmap swap . Set.maxView instance ViewR Seq where viewR x = case Seq.viewr x of Seq.EmptyR -> Nothing ys Seq.:> y -> Just (ys,y) class (ViewL f, ViewR f) => View f where instance View [] where instance View Maybe where instance View Set where instance View Seq where {- Default implementation of 'viewR' based on 'viewL' and 'Traversable'. -} viewRDefault :: (ViewL f, Traversable f) => f a -> Maybe (f a, a) viewRDefault = fmap (swap . uncurry (mapAccumL (flip (,)))) . viewL class Singleton f where singleton :: a -> f a instance Singleton [] where singleton x = [x] instance Singleton Maybe where singleton x = Just x instance Singleton Set where singleton = Set.singleton instance Singleton Seq where singleton = Seq.singleton class Append f where append :: f a -> f a -> f a instance Append [] where append = (++) instance Append Seq where append = (Seq.><) infixr 5 `cons`, `append` {- | It must hold: > fmap f xs > = zipWith (\x _ -> f x) xs xs > = zipWith (\_ x -> f x) xs xs -} class Functor f => Zip f where zipWith :: (a -> b -> c) -> f a -> f b -> f c instance Zip [] where zipWith = List.zipWith instance Zip Maybe where zipWith = liftM2 instance Zip Seq where zipWith = Seq.zipWith zipWith3 :: (Zip f) => (a -> b -> c -> d) -> f a -> f b -> f c -> f d zipWith3 f a b c = zipWith ($) (zipWith f a b) c zipWith4 :: (Zip f) => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e zipWith4 f a b c d = zipWith ($) (zipWith3 f a b c) d zip :: (Zip f) => f a -> f b -> f (a,b) zip = zipWith (,) zip3 :: (Zip f) => f a -> f b -> f c -> f (a,b,c) zip3 = zipWith3 (,,) zip4 :: (Zip f) => f a -> f b -> f c -> f d -> f (a,b,c,d) zip4 = zipWith4 (,,,) class Repeat f where {- | Create a container with as many copies as possible of a given value. That is, for a container with fixed size @n@, the call @repeat x@ will generate a container with @n@ copies of @x@. -} repeat :: a -> f a instance Repeat [] where repeat = List.repeat instance Repeat Maybe where repeat = Just -- might be replaced by Mixed.iterate based on Traversable class Repeat f => Iterate f where iterate :: (a -> a) -> a -> f a instance Iterate [] where iterate = List.iterate instance Iterate Maybe where iterate _ = Just {- | We need to distinguish between 'Sort' and 'SortBy', since there is an @instance Sort Set@ but there cannot be an @instance SortBy Set@. -} class Sort f where sort :: (Ord a) => f a -> f a instance Sort [] where sort = List.sort instance Sort Maybe where sort = id instance Sort Seq where sort = Seq.sort instance Sort Set where sort = id {- | Default implementation for 'sort' based on 'sortBy'. -} sortDefault :: (Ord a, SortBy f) => f a -> f a sortDefault = sortBy compare class Sort f => SortBy f where sortBy :: (a -> a -> Ordering) -> f a -> f a instance SortBy [] where sortBy = List.sortBy instance SortBy Maybe where sortBy _f = id instance SortBy Seq where sortBy = Seq.sortBy class Reverse f where reverse :: f a -> f a instance Reverse [] where reverse = List.reverse instance Reverse Maybe where reverse = id instance Reverse Seq where reverse = Seq.reverse class Show f where showsPrec :: P.Show a => Int -> f a -> ShowS instance Show [] where showsPrec p xs = if null xs then showString "[]" else showParen (p>5) $ foldr (.) (showString "[]") $ map (\x -> P.showsPrec 6 x . showString ":") xs instance Show Set where showsPrec = P.showsPrec class Arbitrary f where arbitrary :: QC.Arbitrary a => QC.Gen (f a) shrink :: QC.Arbitrary a => f a -> [f a] instance Arbitrary [] where arbitrary = QC.arbitrary shrink = QC.shrink instance Arbitrary Maybe where arbitrary = QC.arbitrary shrink = QC.shrink class (Arbitrary f) => Gen f where genOf :: QC.Gen a -> QC.Gen (f a) instance Gen [] where genOf = QC.listOf instance Gen Maybe where genOf gen = do b <- QC.arbitrary if b then fmap Just gen else return Nothing class NFData f where rnf :: DeepSeq.NFData a => f a -> () instance NFData Maybe where rnf = DeepSeq.rnf instance NFData [] where rnf = DeepSeq.rnf instance NFData Set where rnf = DeepSeq.rnf instance (DeepSeq.NFData k) => NFData (Map k) where rnf = DeepSeq.rnf