From 59da94372b7c9fdbffdc2cc41bd9e6c14aa91913 Mon Sep 17 00:00:00 2001 From: Steve Mao Date: Sat, 28 Oct 2023 21:30:48 +1100 Subject: [PATCH 1/2] add newtype utils --- Data/Profunctor/Product/Newtype.hs | 37 ++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/Data/Profunctor/Product/Newtype.hs b/Data/Profunctor/Product/Newtype.hs index 096d1b5..5ad7902 100644 --- a/Data/Profunctor/Product/Newtype.hs +++ b/Data/Profunctor/Product/Newtype.hs @@ -8,3 +8,40 @@ class Newtype t where pNewtype :: (P.Profunctor p, Newtype t) => p a b -> p (t a) (t b) pNewtype = P.dimap field constructor + +-- when you have a newtype that wraps a newtype +-- templateTemplate = pNewtype2 $ requiredTableField "id" +pNewtype2 :: (Profunctor p, Newtype t1, Newtype t2) => p a b -> p (t1 (t2 a))(t1 (t2 b)) +pNewtype2 = dimap (field . field) (constructor . constructor) + +-- tableId :: (Newtype t) => (TableFields (Maybe (t (Field SqlUuid))) (t (Field SqlUuid))) +-- tableId = fpNewtype $ optionalTableField "id" +fpNewtype :: (Functor f, Profunctor p, Newtype t) => p (f a) b -> p (f (t a)) (t b) +fpNewtype = dimap (field <$>) constructor + +mapNewtype :: (Newtype t) => (a -> b) -> t a -> t b +mapNewtype f = constructor . f . field + +-- when you have a newtype that wraps a newtype +mapNewtype2 :: (Newtype t1, Newtype t2) => (a -> b) -> t1 (t2 a) -> t1 (t2 b) +mapNewtype2 = mapNewtype . mapNewtype + +-- removeNothing :: (Newtype t) => t [Maybe a] -> [t a] +-- removeNothing = traverseT catMaybes +traverseT :: (Functor f, Newtype t1, Newtype t2) => (a -> f b) -> t1 a -> f (t2 b) +traverseT f ns = constructor <$> f (field ns) + +traverseT_ :: (Functor f, Newtype t1, Newtype t2) => (a -> f b) -> t1 a -> f (t2 ()) +traverseT_ f ns = constructor () <$ f (field ns) + +sequenceT :: (Functor f, Newtype t) => t (f a) -> f (t a) +sequenceT = traverseT id + +sequenceT_ :: (Functor f, Newtype t) => t (f a) -> f (t ()) +sequenceT_ = traverseT_ id + +forT :: (Functor f, Newtype t1, Newtype t2) => t1 a -> (a -> f b) -> f (t2 b) +forT = flip traverseT + +forT_ :: (Functor f, Newtype t1, Newtype t2) => t1 a -> (a -> f b) -> f (t2 ()) +forT_ = flip traverseT_ From a3a710f01af2dfd39ff3740f893d116f6eb9be46 Mon Sep 17 00:00:00 2001 From: Steve Mao Date: Mon, 30 Oct 2023 22:25:58 +1100 Subject: [PATCH 2/2] fix build --- Data/Profunctor/Product/Newtype.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Data/Profunctor/Product/Newtype.hs b/Data/Profunctor/Product/Newtype.hs index 5ad7902..7c9406e 100644 --- a/Data/Profunctor/Product/Newtype.hs +++ b/Data/Profunctor/Product/Newtype.hs @@ -11,13 +11,13 @@ pNewtype = P.dimap field constructor -- when you have a newtype that wraps a newtype -- templateTemplate = pNewtype2 $ requiredTableField "id" -pNewtype2 :: (Profunctor p, Newtype t1, Newtype t2) => p a b -> p (t1 (t2 a))(t1 (t2 b)) -pNewtype2 = dimap (field . field) (constructor . constructor) +pNewtype2 :: (P.Profunctor p, Newtype t1, Newtype t2) => p a b -> p (t1 (t2 a))(t1 (t2 b)) +pNewtype2 = P.dimap (field . field) (constructor . constructor) -- tableId :: (Newtype t) => (TableFields (Maybe (t (Field SqlUuid))) (t (Field SqlUuid))) -- tableId = fpNewtype $ optionalTableField "id" -fpNewtype :: (Functor f, Profunctor p, Newtype t) => p (f a) b -> p (f (t a)) (t b) -fpNewtype = dimap (field <$>) constructor +fpNewtype :: (Functor f, P.Profunctor p, Newtype t) => p (f a) b -> p (f (t a)) (t b) +fpNewtype = P.dimap (field <$>) constructor mapNewtype :: (Newtype t) => (a -> b) -> t a -> t b mapNewtype f = constructor . f . field