From 237cf16249b795573ba2a9d4703477e7fe6d5e8f Mon Sep 17 00:00:00 2001 From: William Rusnack Date: Sat, 6 Jul 2024 11:07:56 -0400 Subject: [PATCH] MonoPointed version of MonoUnfold and MonoUnfold1 --- mono-traversable/src/Data/MonoTraversable.hs | 151 ++++++++++++------- mono-traversable/test/Main.hs | 47 +++--- 2 files changed, 123 insertions(+), 75 deletions(-) diff --git a/mono-traversable/src/Data/MonoTraversable.hs b/mono-traversable/src/Data/MonoTraversable.hs index e2991b10..2925a3e0 100644 --- a/mono-traversable/src/Data/MonoTraversable.hs +++ b/mono-traversable/src/Data/MonoTraversable.hs @@ -94,7 +94,8 @@ import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Storable as VS import qualified Data.IntSet as IntSet import Data.Semigroup - ( Semigroup + ( Semigroup ((<>)) + , Endo (Endo) -- Option has been removed in base-4.16 (GHC 9.2) #if !MIN_VERSION_base(4,16,0) , Option (..) @@ -169,6 +170,7 @@ type instance Element (Par1 a) = a type instance Element (U1 a) = a type instance Element (V1 a) = a type instance Element (Proxy a) = a +type instance Element (Endo mono) = Element mono -- | Monomorphic containers that can be mapped over. class MonoFunctor mono where @@ -993,90 +995,129 @@ minimumByMay f mono class MonoUnfold mono where unfoldrM :: Monad m => (a -> m (Maybe (Element mono, a))) -> a -> m mono unfoldrNM :: Monad m => Int -> (a -> m (Maybe (Element mono, a))) -> a -> m mono - unfoldrNM' :: Monad m => Int -> (a -> m ( (Element mono, a))) -> a -> m mono + unfoldrExactNM :: Monad m => Int -> (a -> m ( (Element mono, a))) -> a -> m mono unfoldlM :: Monad m => (a -> m (Maybe (a, Element mono))) -> a -> m mono unfoldlNM :: Monad m => Int -> (a -> m (Maybe (a, Element mono))) -> a -> m mono - unfoldlNM' :: Monad m => Int -> (a -> m ( (a, Element mono))) -> a -> m mono + unfoldlExactNM :: Monad m => Int -> (a -> m ( (a, Element mono))) -> a -> m mono unfoldr :: MonoUnfold mono => (a -> Maybe (Element mono, a)) -> a -> mono unfoldr = wrapIdentity unfoldrM unfoldrN :: MonoUnfold mono => Int -> (a -> Maybe (Element mono, a)) -> a -> mono unfoldrN = wrapIdentity . unfoldrNM -unfoldrN' :: MonoUnfold mono => Int -> (a -> (Element mono, a)) -> a -> mono -unfoldrN' = wrapIdentity . unfoldrNM' +unfoldrExactN :: MonoUnfold mono => Int -> (a -> (Element mono, a)) -> a -> mono +unfoldrExactN = wrapIdentity . unfoldrExactNM unfoldl :: MonoUnfold mono => (a -> Maybe (a, Element mono)) -> a -> mono unfoldl = wrapIdentity unfoldlM unfoldlN :: MonoUnfold mono => Int -> (a -> Maybe (a, Element mono)) -> a -> mono unfoldlN = wrapIdentity . unfoldlNM -unfoldlN' :: MonoUnfold mono => Int -> (a -> (a, Element mono)) -> a -> mono -unfoldlN' = wrapIdentity . unfoldlNM' +unfoldlExactN :: MonoUnfold mono => Int -> (a -> (a, Element mono)) -> a -> mono +unfoldlExactN = wrapIdentity . unfoldlExactNM wrapIdentity :: ((a -> Identity b) -> c -> Identity d) -> (a -> b) -> c -> d wrapIdentity f g = runIdentity . f (Identity . g) -instance MonoUnfold [a] where - unfoldrM f x = f x >>= maybe (pure []) (\(y,x) -> (y :) <$> unfoldrM f x) - unfoldrNM n f x | n > 0 = f x >>= maybe (pure []) (\(y,x) -> (y :) <$> unfoldrNM (n - 1) f x) - | otherwise = pure [] - unfoldrNM' n f x | n > 0 = f x >>= \(y,x) -> (y :) <$> unfoldrNM' (n - 1) f x - | otherwise = pure [] - unfoldlM f = fmap ($ []) . g - where g x = f x >>= maybe (pure id) (\(y,z) -> g y <&> (. (z :))) - unfoldlNM n f = fmap ($ []) . g n - where g n x | n > 0 = f x >>= maybe (pure id) (\(y,z) -> g (n - 1) y <&> (. (z :))) +instance {-# OVERLAPPABLE #-} (Monoid a, MonoPointed a) => MonoUnfold a where + unfoldrM f x = f x >>= maybe (pure mempty) (\(y,x) -> (opoint y <>) <$> unfoldrM f x) + unfoldrNM n f x | n > 0 = f x >>= maybe (pure mempty) (\(y,x) -> (opoint y <>) <$> unfoldrNM (n - 1) f x) + | otherwise = pure mempty + unfoldrExactNM n f x | n > 0 = f x >>= \(y,x) -> (opoint y <>) <$> unfoldrExactNM (n - 1) f x + | otherwise = pure mempty + unfoldlM f = fmap ($ mempty) . g + where g x = f x >>= maybe (pure id) (\(y,z) -> g y <&> (. (opoint z <>))) + unfoldlNM n f = fmap ($ mempty) . g n + where g n x | n > 0 = f x >>= maybe (pure id) (\(y,z) -> g (n - 1) y <&> (. (opoint z <>))) | otherwise = pure id - unfoldlNM' n f = fmap ($ []) . g n - where g n x | n > 0 = f x >>= \(x,y) -> g (n - 1) x <&> (. (y :)) + unfoldlExactNM n f = fmap ($ mempty) . g n + where g n x | n > 0 = f x >>= \(x,y) -> g (n - 1) x <&> (. (opoint y <>)) | otherwise = pure id +--instance {-# OVERLAPPING #-} MonoUnfold (V.Vector a) where +-- unfoldrM = V.unfoldrM +-- unfoldrNM = V.unfoldrNM +-- unfoldrExactNM = V.unfoldrExactNM + +--instance MonoUnfold (Endo [a]) where +-- unfoldrM f x = f x >>= maybe (pure mempty) (\(y,x) -> (Endo (y :) <>) <$> unfoldrM f x) +-- unfoldrNM n f x | n > 0 = f x >>= maybe (pure mempty) (\(y,x) -> (Endo (y :) <>) <$> unfoldrNM (n - 1) f x) +-- | otherwise = pure mempty +-- unfoldrExactNM n f x | n > 0 = f x >>= \(y,x) -> (Endo (y :) <>) <$> unfoldrExactNM (n - 1) f x +-- | otherwise = pure mempty +-- unfoldlM f = fmap ($ mempty) . g +-- where g x = f x >>= maybe (pure id) (\(y,z) -> g y <&> (. (Endo (z :) <>))) +-- unfoldlNM n f = fmap ($ mempty) . g n +-- where g n x | n > 0 = f x >>= maybe (pure id) (\(y,z) -> g (n - 1) y <&> (. (Endo (z :) <>))) +-- | otherwise = pure id +-- unfoldlExactNM n f = fmap ($ mempty) . g n +-- where g n x | n > 0 = f x >>= \(x,y) -> g (n - 1) x <&> (. (Endo (y :) <>)) +-- | otherwise = pure id +--instance MonoUnfold [a] where +-- unfoldrM f x = f x >>= maybe (pure []) (\(y,x) -> (y :) <$> unfoldrM f x) +-- unfoldrNM n f x | n > 0 = f x >>= maybe (pure []) (\(y,x) -> (y :) <$> unfoldrNM (n - 1) f x) +-- | otherwise = pure [] +-- unfoldrExactNM n f x | n > 0 = f x >>= \(y,x) -> (y :) <$> unfoldrExactNM (n - 1) f x +-- | otherwise = pure [] +-- unfoldlM f = fmap ($ []) . g +-- where g x = f x >>= maybe (pure id) (\(y,z) -> g y <&> (. (z :))) +-- unfoldlNM n f = fmap ($ []) . g n +-- where g n x | n > 0 = f x >>= maybe (pure id) (\(y,z) -> g (n - 1) y <&> (. (z :))) +-- | otherwise = pure id +-- unfoldlExactNM n f = fmap ($ []) . g n +-- where g n x | n > 0 = f x >>= \(x,y) -> g (n - 1) x <&> (. (y :)) +-- | otherwise = pure id class MonoUnfold1 mono where unfoldr1M :: Monad m => (a -> m (Element mono, Maybe a)) -> a -> m mono unfoldr1NM :: Monad m => Int -> (a -> m (Element mono, Maybe a)) -> a -> m mono - unfoldr1NM' :: Monad m => Int -> (a -> m (Element mono, a)) -> a -> m mono + unfoldr1ExactNM :: Monad m => Int -> (a -> m (Element mono, a)) -> a -> m mono unfoldl1M :: Monad m => (a -> m (Maybe a, Element mono)) -> a -> m mono unfoldl1NM :: Monad m => Int -> (a -> m (Maybe a, Element mono)) -> a -> m mono - unfoldl1NM' :: Monad m => Int -> (a -> m ( a, Element mono)) -> a -> m mono + unfoldl1ExactNM :: Monad m => Int -> (a -> m ( a, Element mono)) -> a -> m mono unfoldr1 :: MonoUnfold1 mono => (a -> (Element mono, Maybe a)) -> a -> mono unfoldr1 = wrapIdentity unfoldr1M unfoldr1N :: MonoUnfold1 mono => Int -> (a -> (Element mono, Maybe a)) -> a -> mono unfoldr1N = wrapIdentity . unfoldr1NM -unfoldr1N' :: MonoUnfold1 mono => Int -> (a -> (Element mono, a)) -> a -> mono -unfoldr1N' = wrapIdentity . unfoldr1NM' +unfoldr1ExactN :: MonoUnfold1 mono => Int -> (a -> (Element mono, a)) -> a -> mono +unfoldr1ExactN = wrapIdentity . unfoldr1ExactNM unfoldl1 :: MonoUnfold1 mono => (a -> (Maybe a, Element mono)) -> a -> mono unfoldl1 = wrapIdentity unfoldl1M unfoldl1N :: MonoUnfold1 mono => Int -> (a -> (Maybe a, Element mono)) -> a -> mono unfoldl1N = wrapIdentity . unfoldl1NM -unfoldl1N' :: MonoUnfold1 mono => Int -> (a -> ( a, Element mono)) -> a -> mono -unfoldl1N' = wrapIdentity . unfoldl1NM' - -instance MonoUnfold1 (NonEmpty a) where - unfoldr1M f x = g f (NE.:|) (:) x - where - g :: Monad m => (b -> m (a, Maybe b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> b -> m (f a) - g f cons cons' x = f x >>= \(y,mx) -> cons y <$> maybe (pure []) (g f cons' cons') mx - unfoldr1NM n f x = g f (NE.:|) (:) n x - where - g :: Monad m => (b -> m (a, Maybe b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> Int -> b -> m (f a) - g f cons cons' n x = f x >>= \(y,mx) -> cons y <$> maybe (pure []) (g f cons' cons' (n - 1)) (bool Nothing mx (n > 1)) - unfoldr1NM' n f x = g f (NE.:|) (:) n x - where - g :: Monad m => (b -> m (a, b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> Int -> b -> m (f a) - g f cons cons' n x = f x >>= \(y,x) -> cons y <$> bool (pure []) (g f cons' cons' (n - 1) x) (n > 1) - unfoldl1M f x = g x <&> \(y,h) -> y NE.:| h [] - where g x = f x >>= \(mx,y) -> maybe (pure (y,id)) (\x -> g x <&> fmap (. (y :))) mx - unfoldl1NM n f x = g n x <&> \(y,h) -> y NE.:| h [] - where g n x = f x >>= \(mx,y) -> maybe (pure (y,id)) (\x -> g (n - 1) x <&> fmap (. (y :))) (bool Nothing mx (n > 1)) - unfoldl1NM' n f x = g n x <&> \(y,h) -> y NE.:| h [] - where g n x = f x >>= \(x,y) -> bool (pure (y,id)) (g (n - 1) x <&> fmap (. (y :))) (n > 1) - -instance MonoUnfold1 [a] where - unfoldr1M f = fmap NE.toList . unfoldr1M f - unfoldr1NM n f = fmap NE.toList . unfoldr1NM n f - unfoldr1NM' n f = fmap NE.toList . unfoldr1NM' n f - unfoldl1M f = fmap NE.toList . unfoldl1M f - unfoldl1NM n f = fmap NE.toList . unfoldl1NM n f - unfoldl1NM' n f = fmap NE.toList . unfoldl1NM' n f +unfoldl1ExactN :: MonoUnfold1 mono => Int -> (a -> ( a, Element mono)) -> a -> mono +unfoldl1ExactN = wrapIdentity . unfoldl1ExactNM + +instance {-# OVERLAPPABLE #-} (MonoPointed a, Semigroup a) => MonoUnfold1 a where + unfoldr1M f x = f x >>= \(y,mx) -> maybe (pure $ opoint y) (fmap (opoint y <>) . unfoldr1M f) mx + unfoldr1NM n f x = f x >>= \(y,mx) -> maybe (pure $ opoint y) (fmap (opoint y <>) . unfoldr1NM (n - 1) f) (bool Nothing mx (n > 1)) + unfoldr1ExactNM n f x = f x >>= \(y,x) -> bool (pure $ opoint y) ((opoint y <>) <$> unfoldr1ExactNM (n - 1) f x) (n > 1) + unfoldl1M f x = f x >>= \(mx,y) -> maybe (pure $ opoint y) (fmap (<> opoint y) . unfoldl1M f) mx + unfoldl1NM n f x = f x >>= \(mx,y) -> maybe (pure $ opoint y) (fmap (<> opoint y) . unfoldl1NM (n - 1) f) $ bool Nothing mx (n > 1) + unfoldl1ExactNM n f x = f x >>= \(x,y) -> bool (pure $ opoint y) (fmap (<> opoint y) $ unfoldl1ExactNM (n - 1) f x) (n > 1) +--instance MonoUnfold1 (NonEmpty a) where +-- unfoldr1M f x = g f (NE.:|) (:) x +-- where +-- g :: Monad m => (b -> m (a, Maybe b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> b -> m (f a) +-- g f cons cons' x = f x >>= \(y,mx) -> cons y <$> maybe (pure []) (g f cons' cons') mx +-- unfoldr1NM n f x = g f (NE.:|) (:) n x +-- where +-- g :: Monad m => (b -> m (a, Maybe b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> Int -> b -> m (f a) +-- g f cons cons' n x = f x >>= \(y,mx) -> cons y <$> maybe (pure []) (g f cons' cons' (n - 1)) (bool Nothing mx (n > 1)) +-- unfoldr1ExactNM n f x = g f (NE.:|) (:) n x +-- where +-- g :: Monad m => (b -> m (a, b)) -> (a -> [a] -> f a) -> (a -> [a] -> [a]) -> Int -> b -> m (f a) +-- g f cons cons' n x = f x >>= \(y,x) -> cons y <$> bool (pure []) (g f cons' cons' (n - 1) x) (n > 1) +-- unfoldl1M f x = g x <&> \(y,h) -> y NE.:| h [] +-- where g x = f x >>= \(mx,y) -> maybe (pure (y,id)) (\x -> g x <&> fmap (. (y :))) mx +-- unfoldl1NM n f x = g n x <&> \(y,h) -> y NE.:| h [] +-- where g n x = f x >>= \(mx,y) -> maybe (pure (y,id)) (\x -> g (n - 1) x <&> fmap (. (y :))) (bool Nothing mx (n > 1)) +-- unfoldl1ExactNM n f x = g n x <&> \(y,h) -> y NE.:| h [] +-- where g n x = f x >>= \(x,y) -> bool (pure (y,id)) (g (n - 1) x <&> fmap (. (y :))) (n > 1) +--instance MonoUnfold1 [a] where +-- unfoldr1M f = fmap NE.toList . unfoldr1M f +-- unfoldr1NM n f = fmap NE.toList . unfoldr1NM n f +-- unfoldr1ExactNM n f = fmap NE.toList . unfoldr1ExactNM n f +-- unfoldl1M f = fmap NE.toList . unfoldl1M f +-- unfoldl1NM n f = fmap NE.toList . unfoldl1NM n f +-- unfoldl1ExactNM n f = fmap NE.toList . unfoldl1ExactNM n f -- | Monomorphic containers that can be traversed from left to right. -- @@ -1337,6 +1378,10 @@ instance MonoPointed (Tree a) where instance (Applicative f, Applicative g) => MonoPointed ((f :+: g) a) where opoint = R1 . pure {-# INLINE opoint #-} +-- | @since ???????????? +instance (MonoPointed mono, Semigroup mono) => MonoPointed (Endo mono) where + opoint = Endo . (<>) . opoint + {-# INLINE opoint #-} -- | Typeclass for monomorphic containers where it is always okay to diff --git a/mono-traversable/test/Main.hs b/mono-traversable/test/Main.hs index f583b7ef..02bb4635 100644 --- a/mono-traversable/test/Main.hs +++ b/mono-traversable/test/Main.hs @@ -14,7 +14,7 @@ import Data.Containers import Data.Sequences import qualified Data.Sequence as Seq import qualified Data.NonNull as NN -import Data.Monoid (mempty, mconcat, (<>)) +import Data.Monoid (mempty, mconcat, (<>), Endo(Endo)) import Data.Maybe (fromMaybe) import qualified Data.List as List @@ -557,8 +557,8 @@ main = hspec $ do headMay (Seq.fromList [] :: Seq.Seq Int) @?= Nothing describe "MonoUnfold" $ do - let test typ dummy = describe typ $ do - let fromList' = (`fromListAs` dummy) + let test :: (Arbitrary (Element mono), MonoUnfold mono, Eq mono, Show mono, Show (Element mono)) => String -> ([Element mono] -> mono) -> Spec + test typ fromList' = describe typ $ do let headTailMay xs = case xs of x:xs -> Just (x,xs) [] -> Nothing @@ -567,17 +567,18 @@ main = hspec $ do let headTailSwap = swap . headTail prop "unfoldr" $ \xs -> unfoldr headTailMay xs @?= fromList' xs prop "unfoldrN" $ \(n,xs) -> unfoldrN n headTailMay xs @?= fromList' (take n xs) - prop "unfoldrN'" $ \(n, InfiniteList xs _) -> unfoldrN' n headTail xs @?= fromList' (take n xs) + prop "unfoldrExactN" $ \(n, InfiniteList xs _) -> unfoldrExactN n headTail xs @?= fromList' (take n xs) prop "unfoldl" $ \xs -> unfoldl headTailMaySwap xs @?= fromList' (reverse xs) prop "unfoldlN" $ \(n,xs) -> unfoldlN n headTailMaySwap xs @?= fromList' (reverse (take n xs)) - prop "unfoldlN'" $ \(n,InfiniteList xs _) -> unfoldlN' n headTailSwap xs @?= fromList' (reverse (take n xs)) - test "List" ([] :: [Int]) - --test "Vector" (V.empty :: V.Vector Int) - --test "Storable Vector" (VS.empty :: VS.Vector Int) - --test "Unboxed Vector" (U.empty :: U.Vector Int) - --test "Strict ByteString" S.empty - --test "Lazy ByteString" L.empty - --test "Strict Text" T.empty + prop "unfoldlExactN" $ \(n,InfiniteList xs _) -> unfoldlExactN n headTailSwap xs @?= fromList' (reverse (take n xs)) + test "Endo" (Prelude.foldr (\x f -> Endo (x :) <> f) mempty :: [Int] -> Endo [Int]) + test "List" (id :: [Int] -> [Int]) + test "Vector" (V.fromList :: [Int] -> V.Vector Int) + test "Storable Vector" (VS.fromList :: [Int] -> VS.Vector Int) + test "Unboxed Vector" (U.fromList :: [Int] -> U.Vector Int) + test "Strict ByteString" S.pack + test "Lazy ByteString" L.pack + test "Strict Text" T.pack describe "MonoUnfold1" $ do let test :: (Arbitrary (Element mono), MonoUnfold1 mono, Eq mono, Show mono, Show (Element mono)) => String -> ([Element mono] -> mono) -> Spec @@ -591,17 +592,19 @@ main = hspec $ do let take1 n = take (bool 1 n (n >= 1)) prop "unfoldr1" $ \(QCM.NonEmpty xs) -> unfoldr1 headTailMay xs @?= fromList' xs prop "unfoldr1N" $ \(n, QCM.NonEmpty xs) -> unfoldr1N n headTailMay xs @?= fromList' (take1 n xs) - prop "unfoldr1N'" $ \(n, InfiniteList xs _) -> unfoldr1N' n headTail xs @?= fromList' (take1 n xs) + prop "unfoldr1ExactN" $ \(n, InfiniteList xs _) -> unfoldr1ExactN n headTail xs @?= fromList' (take1 n xs) prop "unfoldl1" $ \(QCM.NonEmpty xs) -> unfoldl1 headTailMaySwap xs @?= fromList' (reverse xs) prop "unfoldl1N" $ \(n, QCM.NonEmpty xs) -> unfoldl1N n headTailMaySwap xs @?= fromList' (reverse (take1 n xs)) - prop "unfoldl1N'" $ \(n,InfiniteList xs _) -> unfoldl1N' n headTailSwap xs @?= fromList' (reverse (take1 n xs)) + prop "unfoldl1ExactN" $ \(n,InfiniteList xs _) -> unfoldl1ExactN n headTailSwap xs @?= fromList' (reverse (take1 n xs)) test "List" (id :: [Int] -> [Int]) test "NonEmpty" (NE.fromList :: [Int] -> NE.NonEmpty Int) - --test "Vector" (V.empty :: V.Vector Int) - --test "Storable Vector" (VS.empty :: VS.Vector Int) - --test "Unboxed Vector" (U.empty :: U.Vector Int) - --test "Strict ByteString" S.empty - --test "Lazy ByteString" L.empty - --test "Strict Text" T.empty - --test "Lazy Text" TL.empty-test "Lazy Text" TL.empty - -- + test "Vector" (V.fromList :: [Int] -> V.Vector Int) + test "Storable Vector" (VS.fromList :: [Int] -> VS.Vector Int) + test "Unboxed Vector" (U.fromList :: [Int] -> U.Vector Int) + test "Strict ByteString" S.pack + test "Lazy ByteString" L.pack + test "Strict Text" T.pack + test "Lazy Text" TL.pack + +instance Eq (Endo [Int]) where Endo f == Endo g = f mempty == g mempty +instance Show (Endo [Int]) where show (Endo f) = "Endo " <> show (f mempty)