Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

MonoUnfold and MonoUnfold1 #224

Draft
wants to merge 2 commits into
base: master
Choose a base branch
from
Draft

MonoUnfold and MonoUnfold1 #224

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
eee60a0
Initial concempt for MonoUnfold
BebeSparkelSparkel Jul 5, 2024
d89ce9a
MonoPointed version of MonoUnfold and MonoUnfold1
BebeSparkelSparkel Jul 6, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
145 changes: 141 additions & 4 deletions mono-traversable/src/Data/MonoTraversable.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,6 +9,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
-- | Type classes mirroring standard typeclasses, but working with monomorphic containers.
--
-- The motivation is that some commonly used data types (i.e., 'ByteString' and
Expand Down Expand Up @@ -36,7 +37,7 @@ import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as B
import qualified Data.Foldable as F
import Data.Functor
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, maybe)
import Data.Monoid (Monoid (..), Any (..), All (..))
import Data.Proxy
import qualified Data.Text as T
Expand All @@ -48,7 +49,7 @@ import Data.Int (Int, Int64)
import GHC.Exts (build)
import GHC.Generics ((:.:), (:*:), (:+:)(..), K1(..), M1(..), Par1(..), Rec1(..), U1(..), V1)
import Prelude (Bool (..), const, Char, flip, IO, Maybe (..), Either (..),
(+), Integral, Ordering (..), compare, fromIntegral, Num, (>=),
(+), Integral, Ordering (..), compare, fromIntegral, Num, (>=), (>),
(==), seq, otherwise, Eq, Ord, (-), (*))
import qualified Prelude
import qualified Data.ByteString.Internal as Unsafe
Expand All @@ -64,7 +65,8 @@ import Data.IntMap (IntMap)
import Data.IntSet (IntSet)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Functor.Identity (Identity)
import qualified Data.List.NonEmpty as NE
import Data.Functor.Identity (Identity(Identity,runIdentity))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.HashMap.Strict (HashMap)
Expand Down Expand Up @@ -93,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 (..)
Expand All @@ -102,6 +105,8 @@ import Data.Semigroup
)
import qualified Data.ByteString.Unsafe as SU
import Control.Monad.Trans.Identity (IdentityT)
import Data.Function (($))
import Data.Bool (bool)

-- | Type family for getting the type of the elements
-- of a monomorphic container.
Expand Down Expand Up @@ -168,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
Expand Down Expand Up @@ -989,6 +995,133 @@ minimumByMay f mono
| otherwise = Just (minimumByEx f mono)
{-# INLINE minimumByMay #-}

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
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
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
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
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 {-# 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
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
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
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
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
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.
--
-- NOTE: Due to limitations with the role system, GHC is yet unable to provide newtype-derivation of
Expand Down Expand Up @@ -1252,6 +1385,10 @@ instance MonoPointed (Tree a) where
instance (Applicative f, Applicative g) => MonoPointed ((f :+: g) a) where
opoint = R1 . pure
{-# INLINE opoint #-}
-- | @since ????????????
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

there's a lot of commented code here; is this meant to be a draft PR?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Thanks for the draft suggestion. Could you give you opinion on #229 that is related to this?

instance (MonoPointed mono, Semigroup mono) => MonoPointed (Endo mono) where
opoint = Endo . (<>) . opoint
{-# INLINE opoint #-}


-- | Typeclass for monomorphic containers where it is always okay to
Expand Down
61 changes: 59 additions & 2 deletions mono-traversable/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -47,8 +47,12 @@ import Control.Applicative
import Control.Monad.Trans.Writer

import Prelude (Bool (..), ($), IO, Eq (..), fromIntegral, Ord (..), String, mod, Int, Integer, show,
return, asTypeOf, (.), Show, (+), succ, Maybe (..), (*), mod, map, flip, otherwise, (-), div, maybe, Char)
return, asTypeOf, (.), Show, (+), succ, Maybe (..), (*), mod, map, flip, otherwise, (-), div, maybe, Char,
fmap, id
)
import qualified Prelude
import Data.Tuple (swap)
import Data.Bool (bool)

newtype NonEmpty' a = NonEmpty' (NE.NonEmpty a)
deriving (Show, Eq)
Expand Down Expand Up @@ -551,3 +555,56 @@ main = hspec $ do
it "#83 head on Seq works correctly" $ do
headEx (Seq.fromList [1 :: Int,2,3]) @?= (1 :: Int)
headMay (Seq.fromList [] :: Seq.Seq Int) @?= Nothing

describe "MonoUnfold" $ do
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
let headTailMaySwap = fmap swap . headTailMay
let headTail (x:xs) = (x,xs)
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 "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 "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
test typ fromList' = describe typ $ do
let headTailMay xs = case xs of
x:[] -> (x, Nothing)
x:xs -> (x, Just xs)
let headTailMaySwap = swap . headTailMay
let headTail (x:xs) = (x,xs)
let headTailSwap = swap . headTail
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 "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 "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.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)
Loading