MonoPointed version of MonoUnfold and MonoUnfold1

Author: BebeSparkelSparkel

mono-traversable/src/Data/MonoTraversable.hs

@@ -95,7 +95,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 (..)
@@ -172,6 +173,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
@@ -996,90 +998,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.
 --
@@ -1344,6 +1385,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

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)