product-profunctors 0.6.3.1 → 0.11.1.1
raw patch · 22 files changed
Files
- Bench/Main.hs +59/−0
- CHANGELOG.md +55/−0
- Data/Profunctor/Product.hs +132/−411
- Data/Profunctor/Product/Adaptor.hs +53/−0
- Data/Profunctor/Product/Class.hs +115/−0
- Data/Profunctor/Product/Default.hs +61/−258
- Data/Profunctor/Product/Default/Class.hs +112/−0
- Data/Profunctor/Product/Examples.hs +175/−0
- Data/Profunctor/Product/Flatten.hs +4/−120
- Data/Profunctor/Product/Internal/Adaptor.hs +126/−0
- Data/Profunctor/Product/Internal/TH.hs +401/−0
- Data/Profunctor/Product/Newtype.hs +10/−0
- Data/Profunctor/Product/TH.hs +127/−293
- Data/Profunctor/Product/Tuples.hs +8/−37
- Data/Profunctor/Product/Tuples/TH.hs +186/−0
- LICENSE +1/−1
- README.md +11/−0
- Test/CheckTypes.hs +68/−1
- Test/Definitions.hs +78/−1
- Test/DefinitionsUndecidable.hs +74/−0
- Test/Main.hs +1/−1
- product-profunctors.cabal +45/−11
+ Bench/Main.hs view
@@ -0,0 +1,59 @@+-- Compare genericAdaptor with hand-written, specialized adaptors.+-- They should optimize to identical Core.++{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++import Criterion.Main+import Control.DeepSeq+import GHC.Generics++import Data.Profunctor.Product+import Data.Profunctor.Product.Adaptor++deriving instance Generic (a, b, c, d, e, f, g, h, i, j)+instance NFData (Int, Bool, Int, Bool, Int, Int, Bool, Int, Bool, Int)++p3_G :: ProductProfunctor p => Adaptor p (p a a', p b b', p c c')+p3_G = genericAdaptor++p3_0 (fa, fb, fc) (a, b, c) = (fa a, fb b, fc c)++t3 :: (Int -> Int, Bool -> Bool, Double -> Double)+t3 = (id, id, id)++u3 :: (Int, Bool, Double)+u3 = (0, False, 0)++p10_G+ :: ProductProfunctor p+ => Adaptor p+ ( p a a', p b b', p c c', p d d', p e e'+ , p f f', p g g', p h h', p i i', p j j')+p10_G = genericAdaptor++p10_0 (fa, fb, fc, fd, fe, ff, fg, fh, fi, fj) (a, b, c, d, e, f, g, h, i, j) =+ (fa a, fb b, fc c, fd d, fe e, ff f, fg g, fh h, fi i, fj j)++t10+ :: (Int -> Int, Bool -> Bool, Int -> Int, Bool -> Bool, Int -> Int+ , Int -> Int, Bool -> Bool, Int -> Int, Bool -> Bool, Int -> Int)+t10 = (id, id, id, id, id, id, id, id, id, id)++u10 :: (Int, Bool, Int, Bool, Int, Int, Bool, Int, Bool, Int)+u10 = (0, False, 1, True, 2, 3, False, 4, True, 5)++main = defaultMain+ [ bench "p3_0" $ nf (p3_0 t3) u3+ , bench "p3_G" $ nf (\u -> u `seq` p3_G t3 u) u3++ , bench "p3_0-bis" $ nf (uncurry p3_0) (t3, u3)+ , bench "p3_G-ter" $ nf (\(t, u) -> u `seq` p3_G t u) (t3, u3)++ , bench "p10_0" $ nf (p10_0 t10) u10+ , bench "p10_G" $ nf (\u -> u `seq` p10_G t10 u) u10++ , bench "p10_0-bis" $ nf (uncurry p10_0) (t10, u10)+ , bench "p10_G-ter" $ nf (\(t, u) -> u `seq` p10_G t u) (t10, u10)+ ]
+ CHANGELOG.md view
@@ -0,0 +1,55 @@+# 0.11.1.1++* No user-visible changes++# 0.11.1.0++* Generalise `(***$)` to work on `Profunctor` instead of `ProductProfunctor`.+* `instance Monoid r => ProductProfunctor (Forget r)`+* `instance SumProfunctor (Forget r)`++# 0.11.0.3++* Support GHC 9.2++# 0.11.0.2++* Support GHC 9.0++# 0.11.0.0++* Added `makeAdaptorAndInstanceInferrable` which has better inference+ properties, at the cost having to turn on `UndecidableInstances`.+ The tuple instances are now made by this method too.++ Please note that if you have written your own `Default` instances+ containing tuples they will no longer work, or may break in+ unexpected ways. For example, the following are no longer supported++ ```haskell+ instance Default MyProfunctor (Foo, Bar) Baz+ instance Default MyProfunctor Foo, (Bar, Baz)+ ```++# 0.10.0.1++* Added `Data.Profunctor.Product.Examples`++# 0.10.0.0++* Removed `ProductContravariant`, `AndArrow`, `defaultContravariantProduct`,+ `PPOfContravariant`, `unPPOfContravariant`, `cdef`++* Deprecated `defaultEmpty`, `defaultProfunctorProduct`, `defaultPoint`++# 0.9.0.0++* Added more `ProductProfunctor/SumProfunctor` instances including for+ types in `Data.Bifunctor`++* Added `Data.Profunctor.Product.Adaptor` which derives+ `genericAdaptor` with `Generic`++* Added ability to derive `Default` instance with `Generic`++Sorry, we didn't track changes before version 0.9.0.0
Data/Profunctor/Product.hs view
@@ -1,17 +1,49 @@-module Data.Profunctor.Product where+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE TemplateHaskell #-} +module Data.Profunctor.Product (-- * @ProductProfunctor@+ ProductProfunctor(..),+ (***$),+ -- * @SumProfunctor@+ SumProfunctor(..),+ list,+ -- * @Newtype@+ Newtype(..),+ pNewtype,+ -- * Deprecated versions+ -- | Do not use. Will be removed in a+ -- future version.+ defaultEmpty,+ defaultProfunctorProduct,+ defaultPoint,+ -- * Re-exports+ module Data.Profunctor.Product.Class,+ module Data.Profunctor.Product) where+ import Prelude hiding (id)-import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow)+import Data.Profunctor (Profunctor, lmap, WrappedArrow, Star(Star), Costar, Forget(Forget)) import qualified Data.Profunctor as Profunctor-import Data.Functor.Contravariant (Contravariant, contramap)--- vv TODO: don't want to have to import all those explicitly. What to do?+import Data.Profunctor.Composition (Procompose(..))+import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen)+import Control.Category (id)+import Control.Arrow (Arrow, (***), ArrowChoice, (+++))+import Control.Applicative (Applicative, liftA2, pure, (<*>), Alternative, (<|>), (<$>))++import Data.Monoid (Monoid, mempty)+import Data.Tagged++import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Joker+import Data.Bifunctor.Product+import Data.Bifunctor.Tannen++import Data.Profunctor.Product.Newtype++import Data.Profunctor.Product.Class import Data.Profunctor.Product.Flatten--- vv and these import Data.Profunctor.Product.Tuples-import Control.Category (id)-import Control.Arrow (Arrow, (***), (<<<), arr, (&&&))-import Control.Applicative (Applicative, liftA2, pure)-import Data.Monoid (Monoid, mempty, (<>))+import Data.Profunctor.Product.Tuples.TH (pTns, maxTupleSize, pNs) -- ProductProfunctor and ProductContravariant are potentially -- redundant type classes. It seems to me that these are equivalent@@ -58,68 +90,101 @@ -- Still, at least we now have default implementations of the class -- methods, which makes things simpler. -class Profunctor p => ProductProfunctor p where- empty :: p () ()- (***!) :: p a b -> p a' b' -> p (a, a') (b, b')---- This appears to be just 'Data.Functor.Contravariant.Divisible'-class Contravariant f => ProductContravariant f where- point :: f ()- (***<) :: f a -> f b -> f (a, b)--defaultEmpty :: Applicative (p ()) => p () ()-defaultEmpty = pure ()+-- | '***$' is the generalisation of 'Functor''s @\<$\>@.+--+-- '***$' = 'Profunctor.rmap', just like '<$>' = 'fmap'.+--+-- (You probably won't need to use this. @\<$\>@ should be+-- sufficient.)+--+-- /Since 0.11.1.0:/ Generalised to work on arbitrary 'Profunctor's.+(***$) :: Profunctor p => (b -> c) -> p a b -> p a c+(***$) = Profunctor.rmap -defaultProfunctorProduct :: (Applicative (p (a, a')), Profunctor p)- => p a b -> p a' b' -> p (a, a') (b, b')-defaultProfunctorProduct p p' = liftA2 (,) (lmap fst p) (lmap snd p')+instance ProductProfunctor (->) where+ purePP = pure+ (****) = (<*>) -defaultPoint :: Monoid (p ()) => p ()-defaultPoint = mempty+instance Arrow arr => ProductProfunctor (WrappedArrow arr) where+ empty = id+ (***!) = (***) -defaultContravariantProduct :: (Contravariant f, Monoid (f (a, b)))- => f a -> f b -> f (a, b)-defaultContravariantProduct p p' = contramap fst p <> contramap snd p'+instance ProductProfunctor Tagged where+ purePP = pure+ (****) = (<*>) -newtype PPOfContravariant f a b = PPOfContravariant (f a)+instance Applicative f => ProductProfunctor (Star f) where+ purePP = pure+ (****) = (<*>) -unPPOfContravariant :: PPOfContravariant c a a -> c a-unPPOfContravariant (PPOfContravariant pp) = pp+instance Functor f => ProductProfunctor (Costar f) where+ purePP = pure+ (****) = (<*>) -instance Contravariant f => Profunctor (PPOfContravariant f) where- dimap f _ (PPOfContravariant p) = PPOfContravariant (contramap f p)+-- | @since 0.11.1.0+instance Monoid r => ProductProfunctor (Forget r) where+ purePP _ = Forget (const mempty)+ Forget f ***! Forget g = Forget $ \(a, a') -> f a <> g a' -instance ProductContravariant f => ProductProfunctor (PPOfContravariant f) where- empty = PPOfContravariant point- PPOfContravariant f ***! PPOfContravariant f' = PPOfContravariant (f ***< f')+instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Procompose p q) where+ purePP a = Procompose (purePP a) (purePP ())+ Procompose pf qf **** Procompose pa qa =+ Procompose (lmap fst pf **** lmap snd pa) ((,) ***$ qf **** qa) -instance ProductProfunctor (->) where- empty = id- (***!) = (***)+instance (Functor f, Applicative g, ProductProfunctor p) => ProductProfunctor (Biff p f g) where+ purePP = Biff . purePP . pure+ Biff abc **** Biff ab = Biff $ (<*>) ***$ abc **** ab -instance Arrow arr => ProductProfunctor (WrappedArrow arr) where- empty = id- (***!) = (***)+instance Applicative f => ProductProfunctor (Joker f) where+ purePP = Joker . pure+ Joker bc **** Joker b = Joker $ bc <*> b -data AndArrow arr z a b = AndArrow { runAndArrow :: arr z b }+instance Divisible f => ProductProfunctor (Clown f) where+ purePP _ = Clown conquer+ Clown l **** Clown r = Clown $ divide (\a -> (a, a)) l r -instance Arrow arr => Profunctor (AndArrow arr z) where- dimap _ f (AndArrow g) = AndArrow (arr f <<< g)+instance (ProductProfunctor p, ProductProfunctor q) => ProductProfunctor (Product p q) where+ purePP a = Pair (purePP a) (purePP a)+ Pair l1 l2 **** Pair r1 r2 = Pair (l1 **** r1) (l2 **** r2) -instance Arrow arr => ProductProfunctor (AndArrow arr z) where- empty = AndArrow (arr (const ()))- (AndArrow f) ***! (AndArrow f') = AndArrow (f &&& f')+instance (Applicative f, ProductProfunctor p) => ProductProfunctor (Tannen f p) where+ purePP = Tannen . pure . purePP+ Tannen f **** Tannen a = Tannen $ liftA2 (****) f a -- { Sum -class Profunctor p => SumProfunctor p where- -- Morally we should have 'zero :: p Void Void' but I don't think- -- that would actually be useful- (+++!) :: p a b -> p a' b' -> p (Either a a') (Either b b')- instance SumProfunctor (->) where f +++! g = either (Left . f) (Right . g) +instance ArrowChoice arr => SumProfunctor (WrappedArrow arr) where+ (+++!) = (+++)++instance Applicative f => SumProfunctor (Star f) where+ Star f +++! Star g = Star $ either (fmap Left . f) (fmap Right . g)++-- | @since 0.11.1.0+instance SumProfunctor (Forget r) where+ Forget f +++! Forget g = Forget $ either f g++instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Procompose p q) where+ Procompose pa qa +++! Procompose pb qb = Procompose (pa +++! pb) (qa +++! qb)++instance Alternative f => SumProfunctor (Joker f) where+ Joker f +++! Joker g = Joker $ Left <$> f <|> Right <$> g++instance Decidable f => SumProfunctor (Clown f) where+ Clown f +++! Clown g = Clown $ chosen f g++instance (SumProfunctor p, SumProfunctor q) => SumProfunctor (Product p q) where+ Pair l1 l2 +++! Pair r1 r2 = Pair (l1 +++! r1) (l2 +++! r2)++instance (Applicative f, SumProfunctor p) => SumProfunctor (Tannen f p) where+ Tannen l +++! Tannen r = Tannen $ liftA2 (+++!) l r++-- | A generalisation of @map :: (a -> b) -> [a] -> [b]@. It is also,+-- in spirit, a generalisation of @traverse :: (a -> f b) -> [a] -> f+-- [b]@, but the types need to be shuffled around a bit to make that+-- work. list :: (ProductProfunctor p, SumProfunctor p) => p a b -> p [a] [b] list p = Profunctor.dimap fromList toList (empty +++! (p ***! list p)) where toList :: Either () (a, [a]) -> [a]@@ -133,367 +198,23 @@ -- } -pT0 :: ProductProfunctor p => T0 -> p T0 T0-pT0 = const empty--pT1 :: ProductProfunctor p => T1 (p a1 b1) -> p (T1 a1) (T1 b1)-pT1 = id--pT2 :: ProductProfunctor p => T2 (p a1 b1) (p a2 b2) -> p (T2 a1 a2) (T2 b1 b2)-pT2 = uncurry (***!)--chain :: ProductProfunctor p => (t -> p a2 b2) -> (p a1 b1, t)- -> p (a1, a2) (b1, b2)-chain rest (a, as) = pT2 (a, rest as)--pT3 :: ProductProfunctor p => T3 (p a1 b1) (p a2 b2) (p a3 b3)- -> p (T3 a1 a2 a3) (T3 b1 b2 b3)-pT3 = chain pT2--pT4 :: ProductProfunctor p => T4 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- -> p (T4 a1 a2 a3 a4) (T4 b1 b2 b3 b4)-pT4 = chain pT3--pT5 :: ProductProfunctor p => T5 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5)- -> p (T5 a1 a2 a3 a4 a5) (T5 b1 b2 b3 b4 b5)-pT5 = chain pT4--pT6 :: ProductProfunctor p => T6 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6)- -> p (T6 a1 a2 a3 a4 a5 a6) (T6 b1 b2 b3 b4 b5 b6)-pT6 = chain pT5--pT7 :: ProductProfunctor p => T7 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7)- -> p (T7 a1 a2 a3 a4 a5 a6 a7) (T7 b1 b2 b3 b4 b5 b6 b7)-pT7 = chain pT6--pT8 :: ProductProfunctor p => T8 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- -> p (T8 a1 a2 a3 a4 a5 a6 a7 a8) (T8 b1 b2 b3 b4 b5 b6 b7 b8)-pT8 = chain pT7--pT9 :: ProductProfunctor p => T9 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9)- -> p (T9 a1 a2 a3 a4 a5 a6 a7 a8 a9)- (T9 b1 b2 b3 b4 b5 b6 b7 b8 b9)-pT9 = chain pT8--pT10 :: ProductProfunctor p => T10 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10)- -> p (T10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)- (T10 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10)-pT10 = chain pT9--pT11 :: ProductProfunctor p => T11 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- -> p (T11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11)- (T11 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11)-pT11 = chain pT10--pT12 :: ProductProfunctor p => T12 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12)- -> p (T12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12)- (T12 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12)-pT12 = chain pT11--pT13 :: ProductProfunctor p => T13 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13)- -> p (T13 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13)- (T13 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13)-pT13 = chain pT12--pT14 :: ProductProfunctor p => T14 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- -> p (T14 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14)- (T14 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14)-pT14 = chain pT13--pT15 :: ProductProfunctor p => T15 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15)- -> p (T15 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15)- (T15 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15)-pT15 = chain pT14--pT16 :: ProductProfunctor p => T16 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16)- -> p (T16 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16)- (T16 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16)-pT16 = chain pT15--pT17 :: ProductProfunctor p => T17 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- -> p (T17 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17)- (T17 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17)-pT17 = chain pT16--pT18 :: ProductProfunctor p => T18 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18)- -> p (T18 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18)- (T18 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18)-pT18 = chain pT17--pT19 :: ProductProfunctor p => T19 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19)- -> p (T19 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19)- (T19 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19)-pT19 = chain pT18--pT20 :: ProductProfunctor p => T20 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19) (p a20 b20)- -> p (T20 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20)- (T20 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20)-pT20 = chain pT19--pT21 :: ProductProfunctor p => T21 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19) (p a20 b20)- (p a21 b21)- -> p (T21 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21)- (T21 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21)-pT21 = chain pT20--pT22 :: ProductProfunctor p => T22 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19) (p a20 b20)- (p a21 b21) (p a22 b22)- -> p (T22 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22)- (T22 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22)-pT22 = chain pT21--pT23 :: ProductProfunctor p => T23 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19) (p a20 b20)- (p a21 b21) (p a22 b22) (p a23 b23)- -> p (T23 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23)- (T23 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23)-pT23 = chain pT22--pT24 :: ProductProfunctor p => T24 (p a1 b1) (p a2 b2) (p a3 b3) (p a4 b4)- (p a5 b5) (p a6 b6) (p a7 b7) (p a8 b8)- (p a9 b9) (p a10 b10) (p a11 b11)- (p a12 b12) (p a13 b13) (p a14 b14)- (p a15 b15) (p a16 b16) (p a17 b17)- (p a18 b18) (p a19 b19) (p a20 b20)- (p a21 b21) (p a22 b22) (p a23 b23)- (p a24 b24)- -> p (T24 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24)- (T24 b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 b11 b12 b13 b14 b15 b16 b17 b18 b19 b20 b21 b22 b23 b24)-pT24 = chain pT23--convert :: Profunctor p => (a2 -> a1) -> (tp -> tTp) -> (b1 -> b2)- -> (tTp -> p a1 b1)- -> tp -> p a2 b2-convert u u' f c = dimap u f . c . u'--p0 :: ProductProfunctor p => () -> p () ()-p0 = convert unflatten0 unflatten0 flatten0 pT0--p1 :: ProductProfunctor p => p a1 b1 -> p a1 b1-p1 = convert unflatten1 unflatten1 flatten1 pT1--p2 :: ProductProfunctor p => (p a1 b1, p a2 b2) -> p (a1, a2) (b1, b2)-p2 = convert unflatten2 unflatten2 flatten2 pT2--p3 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3)- -> p (a1, a2, a3) (b1, b2, b3)-p3 = convert unflatten3 unflatten3 flatten3 pT3--p4 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4)- -> p (a1, a2, a3, a4) (b1, b2, b3, b4)-p4 = convert unflatten4 unflatten4 flatten4 pT4--p5 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5)- -> p (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)-p5 = convert unflatten5 unflatten5 flatten5 pT5--p6 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6)- -> p (a1, a2, a3, a4, a5, a6) (b1, b2, b3, b4, b5, b6)-p6 = convert unflatten6 unflatten6 flatten6 pT6--p7 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7)- -> p (a1, a2, a3, a4, a5, a6, a7) (b1, b2, b3, b4, b5, b6, b7)-p7 = convert unflatten7 unflatten7 flatten7 pT7--p8 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8)- -> p (a1, a2, a3, a4, a5, a6, a7, a8) (b1, b2, b3, b4, b5, b6, b7, b8)-p8 = convert unflatten8 unflatten8 flatten8 pT8--p9 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9)- (b1, b2, b3, b4, b5, b6, b7, b8, b9)-p9 = convert unflatten9 unflatten9 flatten9 pT9--p10 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10)-p10 = convert unflatten10 unflatten10 flatten10 pT10--p11 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11)-p11 = convert unflatten11 unflatten11 flatten11 pT11--p12 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12)-p12 = convert unflatten12 unflatten12 flatten12 pT12--p13 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13)-p13 = convert unflatten13 unflatten13 flatten13 pT13--p14 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14)-p14 = convert unflatten14 unflatten14 flatten14 pT14--p15 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15)-p15 = convert unflatten15 unflatten15 flatten15 pT15--p16 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16)-p16 = convert unflatten16 unflatten16 flatten16 pT16--p17 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16, p a17 b17)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17)-p17 = convert unflatten17 unflatten17 flatten17 pT17--p18 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18)-p18 = convert unflatten18 unflatten18 flatten18 pT18+pTns [0..maxTupleSize] -p19 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19)-p19 = convert unflatten19 unflatten19 flatten19 pT19+pNs [0..maxTupleSize] -p20 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19, p a20 b20)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20)-p20 = convert unflatten20 unflatten20 flatten20 pT20+-- { Deprecated stuff -p21 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19, p a20 b20,- p a21 b21)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21)-p21 = convert unflatten21 unflatten21 flatten21 pT21+{-# DEPRECATED defaultEmpty "Use pure () instead" #-}+defaultEmpty :: Applicative (p ()) => p () ()+defaultEmpty = pure () -p22 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19, p a20 b20,- p a21 b21, p a22 b22)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22)-p22 = convert unflatten22 unflatten22 flatten22 pT22+{-# DEPRECATED defaultProfunctorProduct "Use \\p p' -> liftA2 (,) (lmap fst p) (lmap snd p') instead" #-}+defaultProfunctorProduct :: (Applicative (p (a, a')), Profunctor p)+ => p a b -> p a' b' -> p (a, a') (b, b')+defaultProfunctorProduct p p' = liftA2 (,) (lmap fst p) (lmap snd p') -p23 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19, p a20 b20,- p a21 b21, p a22 b22, p a23 b23)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22, b23)-p23 = convert unflatten23 unflatten23 flatten23 pT23+{-# DEPRECATED defaultPoint "Use mempty instead" #-}+defaultPoint :: Monoid (p ()) => p ()+defaultPoint = mempty -p24 :: ProductProfunctor p => (p a1 b1, p a2 b2, p a3 b3, p a4 b4,- p a5 b5, p a6 b6, p a7 b7, p a8 b8,- p a9 b9, p a10 b10, p a11 b11, p a12 b12,- p a13 b13, p a14 b14, p a15 b15, p a16 b16,- p a17 b17, p a18 b18, p a19 b19, p a20 b20,- p a21 b21, p a22 b22, p a23 b23, p a24 b24)- -> p (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24)- (b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22, b23, b24)-p24 = convert unflatten24 unflatten24 flatten24 pT24+-- }
+ Data/Profunctor/Product/Adaptor.hs view
@@ -0,0 +1,53 @@+-- |+--+-- Adaptors generalize traversals in two ways:+--+-- - they may focus on values of different types;+--+-- - the type of transformation is an abstract product profunctor @p a b@,+-- rather than a function type @a -> f b@.+--+-- > (a -> f b) -> (a, a) -> f (b, b) -- Traversal+-- > (p a1 b1, p a2 b2) -> p (a1, a2) (b1, b2) -- Adaptor+--+-- This module provides a generic implementation of adaptors+-- and a type synonym for convenience.+--+-- === Example+--+-- @+-- {-\# LANGUAGE DeriveGeneric \#-}+-- import "GHC.Generics"+--+-- data Foo a b c = Foo { fooA :: a, fooB :: b, fooC :: c } deriving 'GHC.Generics.Generic'+--+-- pFoo :: 'Data.Profunctor.Product.ProductProfunctor' p => 'Adaptor' p (Foo (p a a') (p b b') (p c c'))+-- pFoo = 'genericAdaptor'+-- @+--+-- is equivalent to+--+-- @+-- pFoo :: 'Data.Profunctor.Product.ProductProfunctor' p =>+-- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')+-- pFoo (Foo a b c) = Foo+-- 'Data.Profunctor.Product.***$' 'Data.Profunctor.lmap' fooA a+-- 'Data.Profunctor.Product.****' 'Data.Profunctor.lmap' fooB b+-- 'Data.Profunctor.Product.****' 'Data.Profunctor.lmap' fooC c+-- @+--+-- To use the type synonym 'Adaptor' in versions of GHC older than 8.0.1,+-- @Foo@ must be an instance of 'Unzippable'. You may simply declare a+-- default instance:+--+-- @+-- instance 'Unzippable' Foo+-- @++module Data.Profunctor.Product.Adaptor+ ( genericAdaptor+ , Adaptor+ , Unzippable+ ) where++import Data.Profunctor.Product.Internal.Adaptor
+ Data/Profunctor/Product/Class.hs view
@@ -0,0 +1,115 @@+module Data.Profunctor.Product.Class where++import Data.Profunctor (Profunctor)+import qualified Data.Profunctor as Profunctor++-- | 'ProductProfunctor' is a generalization of+-- 'Control.Applicative.Applicative'.+-- It has the usual 'Control.Applicative.Applicative' "output"+-- (covariant) parameter on the right. Additionally it has an "input"+-- (contravariant) type parameter on the left.+--+-- The methods for 'ProductProfunctor' correspond closely to those for+-- 'Control.Applicative.Applicative' as laid out in the following+-- table.+-- The only difference between them is that the 'ProductProfunctor'+-- has a contravariant type parameter on the left. We can use the+-- contravariant to compose them in nice ways as described at+-- "Data.Profunctor.Product".+--+-- @+-- | Correspondence between Applicative and ProductProfunctor+-- |+-- | 'Control.Applicative.Applicative' f 'ProductProfunctor' p+-- |+-- | 'Control.Applicative.pure' 'purePP'+-- | :: b -> f b :: b -> p a b+-- |+-- | ('Control.Applicative.<$>') ('Data.Profunctor.Product.***$')+-- | :: (b -> b') :: (b -> b')+-- | -> f b -> p a b+-- | -> f b' -> p a b'+-- |+-- | ('Control.Applicative.<*>') ('****')+-- | :: f (b -> b') :: p a (b -> b')+-- | -> f b -> p a b+-- | -> f b' -> p a b'+-- @+--+-- If @p@ is an instance of 'ProductProfunctor' then @p a a'@+-- represents a sort of process for turning @a@s into @a'@s that can+-- be "laid out side-by-side" with other values of @p@ to form "wider"+-- processes. For example, if I have+--+-- @+-- p :: p a x -- a process for turning as into xs+-- q :: p b y -- a process for turning bs into ys+-- r :: p c z -- a process for turning cs into zs+-- @+--+-- then I can combine them using 'p3' to get+--+-- @+-- p3 p q r :: p (a, b, c) (x, y, z)+-- -- a process for turning (a, b, c)s into (x, y, z)s+-- @+--+-- You would typically compose 'ProductProfunctor's using+-- 'Profunctors''s 'Profunctor.lmap' and 'Applicative''s 'pure',+-- '<$>' / 'fmap' and '<*>'.+--+-- It's easy to make instances of 'ProductProfunctor'. Just make+-- instances+--+-- @+-- instance 'Profunctor' MyProductProfunctor where+-- ...+--+-- instance 'Control.Applicative.Applicative' (MyProductProfunctor a) where+-- ...+-- @+--+-- and then write+--+-- @+-- instance 'ProductProfunctor' MyProductProfunctor where+-- 'purePP' = 'Control.Applicative.pure'+-- ('****') = ('Control.Applicative.<*>')+-- @+class Profunctor p => ProductProfunctor p where+ -- | 'purePP' is the generalisation of @Applicative@'s+ -- 'Control.Applicative.pure'.+ --+ -- (You probably won't need to use this except to define+ -- 'ProductProfunctor' instances. In your own code @pure@ should be+ -- sufficient.)+ purePP :: b -> p a b+ purePP b = Profunctor.dimap (const ()) (const b) empty++ -- | '****' is the generalisation of @Applicative@'s+ -- 'Control.Applicative.<*>'.+ --+ -- (You probably won't need to use this except to define+ -- 'ProductProfunctor' instances. In your own code @\<*\>@ should+ -- be sufficient.)+ (****) :: p a (b -> c) -> p a b -> p a c+ (****) f x = Profunctor.dimap dup (uncurry ($)) (f ***! x)+ where dup y = (y, y)++ -- | Use @pure ()@ instead. @empty@ may be deprecated in a future+ -- version.+ empty :: p () ()+ empty = purePP ()++ -- | Use @\\f g -> (,) 'Control.Applicative.<$>'+ -- 'Data.Profunctor.lmap' fst f 'Control.Applicative.<*>'+ -- 'Data.Profunctor.lmap' snd g@ instead.+ -- @(***!)@ may be deprecated in a future version.+ (***!) :: p a b -> p a' b' -> p (a, a') (b, b')+ f ***! g = (,) `Profunctor.rmap` Profunctor.lmap fst f+ **** Profunctor.lmap snd g++class Profunctor p => SumProfunctor p where+ -- Morally we should have 'zero :: p Void Void' but I don't think+ -- that would actually be useful+ (+++!) :: p a b -> p a' b' -> p (Either a a') (Either b b')
Data/Profunctor/Product/Default.hs view
@@ -1,268 +1,71 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,- FlexibleContexts #-}+ FlexibleContexts, PolyKinds, TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -module Data.Profunctor.Product.Default where+-- | For some 'Data.Profunctor.Product.ProductProfunctor's @p@ and+-- types @a@, @a'@ there is a unique most sensible value of @p a a'@.+-- 'Default' exists to automatically generate that unique most+-- sensible value for a product given unique most sensible values for+-- the base types. If the unique most sensible values of type @p a+-- a'@, @p b b'@ and @p c c'@ are+--+-- @+-- sensible_a :: p a a'+-- sensible_b :: p b b'+-- sensible_c :: p c c'+-- @+--+-- then the unique most sensible value of type @p (a, b, c) (a', b',+-- c')@ is+--+-- @+--'Data.Profunctor.Product.p3' (sensible_a, sebsible_b, sensible_c)+-- :: p (a, b, c) (a', b', c')+-- @+--+-- Therefore there is an instance+--+-- @+-- instance+-- ( 'Default' p a a'+-- , 'Default' p b b'+-- , 'Default' p c c'+-- )+-- => 'Default' p (a, b, c) (a', b', c')+-- where 'def' = 'Data.Profunctor.Product.p3' ('def', 'def', 'def')+-- @+--+-- which can be read as "if the unique most sensible values of types+-- ... are ... then the unique most sensible value of the 3-tuple is+-- given by composing them with 'p3'". Naturally each different+-- product type has a different composition function. +module Data.Profunctor.Product.Default+ ( module Data.Profunctor.Product.Default.Class+ ) where++import Control.Applicative (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Profunctor (Profunctor, dimap) -- TODO: vv this imports a lot of names. Should we list them all? import Data.Profunctor.Product--class Default p a b where- -- Would rather call it "default", but that's a keyword- def :: p a b--cdef :: Default (PPOfContravariant u) a a => u a-cdef = unPPOfContravariant def--instance ProductProfunctor p => Default p () () where- def = empty--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2)- => Default p (a1, a2) (b1, b2) where- def = p2 (def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3)- => Default p (a1, a2, a3)- (b1, b2, b3) where- def = p3 (def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4)- => Default p (a1, a2, a3, a4)- (b1, b2, b3, b4) where- def = p4 (def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5)- => Default p (a1, a2, a3, a4, a5)- (b1, b2, b3, b4, b5) where- def = p5 (def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6)- => Default p (a1, a2, a3, a4, a5, a6)- (b1, b2, b3, b4, b5, b6) where- def = p6 (def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7)- => Default p (a1, a2, a3, a4, a5, a6, a7)- (b1, b2, b3, b4, b5, b6, b7) where- def = p7 (def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8)- (b1, b2, b3, b4, b5, b6, b7, b8) where- def = p8 (def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8, a9)- (b1, b2, b3, b4, b5, b6, b7, b8, b9) where- def = p9 (def, def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10) where- def = p10 (def, def, def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11) where- def = p11 (def, def, def, def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12) where- def = p12 (def, def, def, def, def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13) where- def = p13 (def, def, def, def, def, def, def, def, def, def,- def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14) where- def = p14 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14, Default p a15 b15)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15) where- def = p15 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16) where- def = p16 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17) where- def = p17 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18) where- def = p18 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def)--instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19) where- def = p19 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def)+import Data.Tagged (Tagged (Tagged)) -instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19, Default p a20 b20)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20) where- def = p20 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def, def)+import Data.Profunctor.Product.Default.Class+import Data.Profunctor.Product.Tuples.TH (mkDefaultNs, maxTupleSize) -instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19, Default p a20 b20,- Default p a21 b21)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21) where- def = p21 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def, def,- def)+instance (Profunctor p, Default p a b) => Default p (Identity a) (Identity b)+ where+ def = dimap (\(Identity a) -> a) Identity def -instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19, Default p a20 b20,- Default p a21 b21, Default p a22 b22)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22) where- def = p22 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def, def,- def, def)+instance (Profunctor p, Default p a b) => Default p (Const a c) (Const b c')+ where+ def = dimap (\(Const a) -> a) Const def -instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19, Default p a20 b20,- Default p a21 b21, Default p a22 b22, Default p a23 b23)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22, b23) where- def = p23 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def, def,- def, def, def)+instance (Profunctor p, Default p a b) => Default p (Tagged s a) (Tagged s' b)+ where+ def = dimap (\(Tagged a) -> a) Tagged def -instance (ProductProfunctor p, Default p a1 b1, Default p a2 b2,- Default p a3 b3, Default p a4 b4, Default p a5 b5,- Default p a6 b6, Default p a7 b7, Default p a8 b8,- Default p a9 b9, Default p a10 b10, Default p a11 b11,- Default p a12 b12, Default p a13 b13, Default p a14 b14,- Default p a15 b15, Default p a16 b16, Default p a17 b17,- Default p a18 b18, Default p a19 b19, Default p a20 b20,- Default p a21 b21, Default p a22 b22, Default p a23 b23,- Default p a24 b24)- => Default p (a1, a2, a3, a4, a5, a6, a7, a8,- a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24)- (b1, b2, b3, b4, b5, b6, b7, b8,- b9, b10, b11, b12, b13, b14, b15, b16, b17, b18, b19, b20, b21, b22, b23, b24) where- def = p24 (def, def, def, def, def, def, def, def, def, def,- def, def, def, def, def, def, def, def, def, def,- def, def, def, def)+mkDefaultNs (0:[2..maxTupleSize])
+ Data/Profunctor/Product/Default/Class.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ConstraintKinds, DataKinds, DefaultSignatures, FlexibleContexts,+ FlexibleInstances, LambdaCase,+ MultiParamTypeClasses, TypeFamilies, TypeOperators #-}+module Data.Profunctor.Product.Default.Class where++import GHC.Exts (Constraint)+import GHC.Generics++import Data.Profunctor (Profunctor, dimap)+import Data.Profunctor.Product.Class++class Default p a b where+ -- Would rather call it "default", but that's a keyword+ def :: p a b+ default def :: (Profunctor p, Generic a, Generic b, GDefault p (Rep a) (Rep b)) => p a b+ def = gdef++-- | See 'DefaultFields''. But this more general form allows the input and+-- output types to vary a bit.+type DefaultFields p a b = GDefCnstr p (Rep a) (Rep b)++-- | 'Default' constraints on the fields of a 'Generic' datatype.+--+-- For a type like+--+-- > data Foo = Bar { a :: Int, b :: String }+-- > | Baz Bool+--+-- we get the following constraints+--+-- > DefaultFields' p Foo =+-- > ( Default p Int Int+-- > , Default p String String+-- > , Default p Bool Bool+-- > )+type DefaultFields' p a = DefaultFields p a a++-- | @'DefaultPConstraints' p a@ expands to the minimal combination of+-- @'Profunctor' p@, @'ProductProfunctor' p@, @'SumProfunctor' p@ needed to implement+-- the instance @'Default' p a a@ for a 'Generic' datatype @a@.+--+-- > DefaultPConstraints p Foo =+-- > ( ProductProfunctor p -- because Foo has a constructor Bar with many fields+-- > , SumProfunctor p -- because Foo has multiple constructors+-- > )+--+-- > DefaultConstraints p (a, b) =+-- > ( ProductProfunctor p -- (a, b) has a single constructor with two fields+-- > )+type DefaultPConstraints p a = GDefPCnstr p (Rep a)++-- | @'DefaultConstraints' p a b@ forms all of the context needed to implement+-- the instance @'Default' p a b@ for 'Generic' types @a@ and @b@.+--+-- This serves to abbreviate the context in instances of 'Default' for+-- parametric types.+type DefaultConstraints p a b = (DefaultPConstraints p a, DefaultFields p a b)++-- | This serves to abbreviate the context in instances of 'Default' for+-- non-parametric types.+type DefaultConstraints' p a = DefaultConstraints p a a++-- | A list of 'Default' constraints.+--+-- > Defaults '[p a a', p b b', p c c'] =+-- > (Default p a a', Default p b b', Default p c c')+type family Defaults (as :: [*]) :: Constraint+type instance Defaults '[] = ()+type instance Defaults (p a a' ': as) = (Default p a a', Defaults as)++-- * Generic instance for Default++class GDefault p f g where+ type GDefCnstr p f g :: Constraint+ gdef1 :: p (f a) (g a)++instance ProductProfunctor p => GDefault p U1 U1 where+ type GDefCnstr p U1 U1 = ()+ gdef1 = dimap (const ()) (const U1) empty++instance (Profunctor p, GDefault p f g) => GDefault p (M1 i c f) (M1 i c g) where+ type GDefCnstr p (M1 i c f) (M1 i c g) = GDefCnstr p f g+ gdef1 = dimap unM1 M1 gdef1++instance (Profunctor p, Default p c c') => GDefault p (K1 i c) (K1 i c') where+ type GDefCnstr p (K1 i c) (K1 i c') = Default p c c'+ gdef1 = dimap unK1 K1 def++instance (ProductProfunctor p, GDefault p f f', GDefault p g g') => GDefault p (f :*: g) (f' :*: g') where+ type GDefCnstr p (f :*: g) (f' :*: g') = (GDefCnstr p f f', GDefCnstr p g g')+ gdef1 = dimap (\(x :*: y) -> (x, y)) (uncurry (:*:)) $ gdef1 ***! gdef1++instance (SumProfunctor p, GDefault p f f', GDefault p g g') => GDefault p (f :+: g) (f' :+: g') where+ type GDefCnstr p (f :+: g) (f' :+: g') = (GDefCnstr p f f', GDefCnstr p g g')+ gdef1 = dimap sumToEither eitherToSum $ gdef1 +++! gdef1+ where+ eitherToSum = \case+ Left x -> L1 x+ Right x -> R1 x+ sumToEither = \case+ L1 x -> Left x+ R1 x -> Right x++type family GDefPCnstr (p :: * -> * -> *) (f :: * -> *) :: Constraint+type instance GDefPCnstr p U1 = ProductProfunctor p+type instance GDefPCnstr p (M1 i c f) = GDefPCnstr p f+type instance GDefPCnstr p (K1 i c) = Profunctor p+type instance GDefPCnstr p (f :*: g) = ProductProfunctor p+type instance GDefPCnstr p (f :+: g) = (SumProfunctor p, GDefPCnstr p f, GDefPCnstr p g)++gdef :: (Profunctor p, Generic a, Generic b, GDefault p (Rep a) (Rep b)) => p a b+gdef = dimap from to gdef1
+ Data/Profunctor/Product/Examples.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Profunctor.Product.Examples where++import qualified Data.Profunctor as P+import qualified Data.Profunctor.Product as PP+import qualified Data.Profunctor.Product.Default as D+import Control.Applicative (Applicative, liftA2, pure, (<*>),+ ZipList(ZipList), getZipList)++newtype Replicator r f a b = Replicator (r -> f b)+ deriving Functor++instance Applicative f => D.Default (Replicator (f b) f) b b where+ def = Replicator id++-- | A higher-order generalisation of 'Prelude.replicate'. For+-- example+--+-- @+-- foo :: IO (String, String, String)+-- foo = replicateT getLine+-- @+--+-- @+-- > foo+-- Hello+-- world+-- !+-- (\"Hello\",\"world\",\"!\")+-- @+replicateT :: D.Default (Replicator r f) b b => r -> f b+replicateT = f+ where Replicator f = def'+ def' :: D.Default p a a => p a a+ def' = D.def++-- Boilerplate that is derivable using generics but I never got round+-- to implementing it.+instance Applicative f => Applicative (Replicator r f a) where+ pure = Replicator . pure . pure+ Replicator f <*> Replicator x = Replicator (liftA2 (<*>) f x)++instance Functor f => P.Profunctor (Replicator r f) where+ dimap _ h (Replicator f) = Replicator ((fmap . fmap) h f)++instance Applicative f=> PP.ProductProfunctor (Replicator r f) where+ purePP = pure+ (****) = (<*>)++-- In the real world this would be 'StateT [a] Maybe b' but I don't want to+-- pick up the transformers dependency here+newtype Take a z b = Take ([a] -> Maybe ([a], b))+ deriving Functor++instance D.Default (Take a) z a where+ def = Take (\as ->+ case as of+ [] -> Nothing+ (a:as') -> Just (as', a))++-- | A type safe generalisation of 'Prelude.take'. For example+--+-- @+-- > let count = [1..] :: [Int]+-- > takeT count :: Maybe (Int, Int)+-- Just (1,2)+-- > takeT count+-- :: Maybe (Int, Int, (Int, (Int, Int), Int, Int),+-- Const Int Bool, Identity (Int, Int), Tagged String Int)+-- Just (1,2,(3,(4,5),6,7),Const 8,Identity (9,10),Tagged 11)+-- @+takeT :: D.Default (Take a) b b+ => [a]+ -> Maybe b+takeT = takeExplicit D.def+ where takeExplicit :: Take a b b -> [a] -> Maybe b+ takeExplicit (Take f) as = fmap snd (f as)++-- More boilerplate+instance Applicative (Take a z) where+ pure x = Take (\as -> pure (as, x))+ Take f <*> Take x = Take (\as -> do+ (as', f') <- f as+ (as'', x') <- x as'++ return (as'', f' x'))++instance P.Profunctor (Take a) where+ dimap _ g (Take h) = Take ((fmap . fmap . fmap) g h)++instance PP.ProductProfunctor (Take a) where+ purePP = pure+ (****) = (<*>)++newtype Traverse f a b = Traverse { runTraverse :: a -> f b } deriving Functor++-- | Use 'sequenceT' instead. It has a better name.+traverseT :: D.Default (Traverse f) a b => a -> f b+traverseT = runTraverse D.def++-- | Actually, @Sequence@ is a better name for this+type Sequence = Traverse++-- | A higher-order generalisation of 'Data.Traversable.sequenceA'. For example+--+-- @+-- > sequenceT (print 3110, putStrLn "World") :: IO ((), ())+-- 3110+-- World+-- ((),())+-- @+sequenceT :: D.Default (Sequence f) a b => a -> f b+sequenceT = runTraverse D.def++-- If we used this then inference may get better:+--+-- instance a ~ b => D.Default (Traverse f) (f a) b where+instance D.Default (Traverse f) (f a) a where+ def = Traverse id++-- Boilerplate that is derivable using generics but I never got round+-- to implementing it.+instance Applicative f => Applicative (Traverse f a) where+ pure = Traverse . pure . pure+ Traverse f <*> Traverse x = Traverse (liftA2 (<*>) f x)++instance Functor f => P.Profunctor (Traverse f) where+ dimap g h (Traverse f) = Traverse (P.dimap g (fmap h) f)++instance Applicative f => PP.ProductProfunctor (Traverse f) where+ purePP = pure+ (****) = (<*>)++newtype Zipper a b = Zipper { unZipper :: Traverse ZipList a b }+ deriving Functor++instance a ~ b => D.Default Zipper [a] b where+ def = Zipper (P.dimap ZipList id D.def)++-- { Boilerplate++instance P.Profunctor Zipper where+ dimap f g = Zipper . P.dimap f g . unZipper++instance Applicative (Zipper a) where+ pure = Zipper . pure+ f <*> x = Zipper ((<*>) (unZipper f) (unZipper x))++instance PP.ProductProfunctor Zipper where+ purePP = pure+ (****) = (<*>)++-- }++-- | A challenge from a Clojurist on Hacker News+-- (<https://news.ycombinator.com/item?id=23939350>)+--+-- @+-- > cl_map (uncurry (+)) ([1,2,3], [4,5,6])+-- [5,7,9]+--+-- > cl_map (+3) [1,2,3]+-- [4,5,6]+--+-- > let max3 (x, y, z) = x \`max\` y \`max\` z+-- > cl_map max3 ([1,20], [3,4], [5,6])+-- [5,20]+-- @+cl_map :: D.Default Zipper a b => (b -> r) -> a -> [r]+cl_map f = getZipList . fmap f . runTraverse (unZipper D.def)
Data/Profunctor/Product/Flatten.hs view
@@ -1,124 +1,8 @@-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Profunctor.Product.Flatten where -flatten0 () = ()-unflatten0 () = ()--flatten1 a = a-unflatten1 a = a--flatten2 (a, b) = (a, b)-unflatten2 (a, b) = (a, b)--flatten3 (a, (b, c)) = (a, b, c)-unflatten3 (a, b, c) = (a, (b, c))--flatten4 (a, (b, (c, a4))) = (a, b, c, a4)-unflatten4 (a, b, c, a4) = (a, (b, (c, a4)))--flatten5 (a, (b, (c, (a4, a5)))) = (a, b, c, a4, a5)-unflatten5 (a, b, c, a4, a5) = (a, (b, (c, (a4, a5))))--flatten6 (a, (b, (c, (a4, (a5, a6))))) = (a, b, c, a4, a5, a6)-unflatten6 (a, b, c, a4, a5, a6) = (a, (b, (c, (a4, (a5, a6)))))--flatten7 (a, (b, (c, (a4, (a5, (a6, a7)))))) = (a, b, c, a4, a5, a6, a7)-unflatten7 (a, b, c, a4, a5, a6, a7) = (a, (b, (c, (a4, (a5, (a6, a7))))))--flatten8 (a, (b, (c, (a4, (a5, (a6, (a7, a8)))))))- = (a, b, c, a4, a5, a6, a7, a8)-unflatten8 (a, b, c, a4, a5, a6, a7, a8)- = (a, (b, (c, (a4, (a5, (a6, (a7, a8)))))))--flatten9 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, a9))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9)-unflatten9 (a, b, c, a4, a5, a6, a7, a8, a9)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, a9))))))))--flatten10 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, a10)))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10)-unflatten10 (a, b, c, a4, a5, a6, a7, a8, a9, a10)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, a10)))))))))--flatten11 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, a11))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11)-unflatten11 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, a11))))))))))--flatten12 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, a12)))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12)-unflatten12 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, a12)))))))))))--flatten13 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- a13))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13)-unflatten13 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, a13))))))))))))--flatten14 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, a14)))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14)-unflatten14 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, a14)))))))))))))--flatten15 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, a15))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15)-unflatten15 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, a15))))))))))))))--flatten16 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, a16)))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16)-unflatten16 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, a16)))))))))))))))--flatten17 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, a17))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17)-unflatten17 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, a17))))))))))))))))--flatten18 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, a18)))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18)-unflatten18 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, a18)))))))))))))))))--flatten19 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, a19))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19)-unflatten19 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, a19))))))))))))))))))--flatten20 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, (a19, a20)))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)-unflatten20 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, (a19, a20)))))))))))))))))))--flatten21 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, a21))))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21)-unflatten21 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, a21))))))))))))))))))))--flatten22 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, a22)))))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22)-unflatten22 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, a22)))))))))))))))))))))--flatten23 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, (a22, a23))))))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23)-unflatten23 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, (a22, a23))))))))))))))))))))))+import Data.Profunctor.Product.Tuples.TH (mkFlattenNs, mkUnflattenNs, maxTupleSize) -flatten24 (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12,- (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, (a22, (a23, a24)))))))))))))))))))))))- = (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24)-unflatten24 (a, b, c, a4, a5, a6, a7, a8, a9, a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, a20, a21, a22, a23, a24)- = (a, (b, (c, (a4, (a5, (a6, (a7, (a8, (a9, (a10, (a11, (a12, (a13, (a14, (a15, (a16, (a17, (a18, (a19, (a20, (a21, (a22, (a23, a24)))))))))))))))))))))))+mkFlattenNs [0..maxTupleSize]+mkUnflattenNs [0..maxTupleSize]
+ Data/Profunctor/Product/Internal/Adaptor.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Profunctor.Product.Internal.Adaptor where++import Data.Profunctor (Profunctor, dimap, lmap)+import Data.Profunctor.Product (ProductProfunctor, (****), (***$))+import GHC.Generics (from, to,+ M1(M1), K1(K1), (:*:)((:*:)),+ Generic, Rep)++-- * Exported++-- | Generic adaptor.+--+-- @+-- 'genericAdaptor' :: 'ProductProfunctor' p =>+-- 'Adaptor' p (Foo (p a a') (p b b') (p c c'))+-- 'genericAdaptor' :: 'ProductProfunctor' p =>+-- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')+-- @+genericAdaptor :: GAdaptable p a b c => a -> p b c+genericAdaptor a = dimap from to (gAdaptor (from a))++-- | A type synonym to shorten the signature of an adaptor.+--+-- @+-- 'Adaptor' p (Foo (p a a') (p b b') (p c c'))+-- ~+-- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')+-- @+type Adaptor p a = a -> p (Unzip 'Fst a) (Unzip 'Snd a)++-- * Implementation++-- | A constraint synonym on generic types for which an adaptor can be+-- defined generically.+type GAdaptable p a b c =+ ( Generic a, Generic b, Generic c+ , GUnzip 'Fst (Rep a) ~ Rep b+ , GUnzip 'Snd (Rep a) ~ Rep c+ , GAdaptor p (Rep a)+ )++-- | A flag denoting a type-level field accessor.+data Select = Fst | Snd++-- | A type like+--+-- > T = Foo (p a a') (p b b') (p c c')+--+-- can be unzipped to+--+-- > Unzip 'Fst T = Foo a b c+-- > Unzip 'Snd T = Foo a' b' c'+--+-- This defines the type family 'Unzip' with versions of GHC older than 8.0.1.+-- For 8.0.1 and newer versions, 'Unzip' is an independent type family+-- and 'Unzippable' is just an empty class for backwards compatibility.+class Unzippable (a :: k) where++type family Unzip (z :: Select) (a :: k) :: k where+ Unzip z (f a) = Unzip' z f (Project z a)+ Unzip z a = a++-- | A hack to enable kind-polymorphic recursion.+type family Unzip' (z :: Select) (a :: k) :: k where+ Unzip' z a = Unzip z a++-- There is a bug in GHC < 8 apparently preventing us from using pure+-- type families. https://ghc.haskell.org/trac/ghc/ticket/11699+-- Defining them as associated types seems to be a valid work around.++-- | A type @p a b@ can be seen as a type-level pair @'(a, b)@.+class TypePair a where+ -- | This type synonym extracts a component, @a@ or @b@,+ -- of that pair @p a b@.+ type Project (z :: Select) a++instance forall (p :: * -> * -> *) a b. TypePair (p a b) where+ type Project 'Fst (p a b) = a+ type Project 'Snd (p a b) = b++-- | Unzips the types of fields of a record.+--+-- > T = (M1 _ _ (K1 _ (p c1 c2))) :*: (M1 _ _ (K1 _ (p d1 d2)))+-- > GUnzip 'Fst T = (M1 _ _ (K1 _ c1 )) :*: (M1 _ _ (K1 _ d1 ))+-- > GUnzip 'Snd T = (M1 _ _ (K1 _ c2 )) :*: (M1 _ _ (K1 _ d2 ))+type family GUnzip (z :: Select) (f :: * -> *) :: * -> *+type instance GUnzip z (f :*: g) = GUnzip z f :*: GUnzip z g+type instance GUnzip z (K1 i c) = K1 i (Project z c)+type instance GUnzip z (M1 i c f) = M1 i c (GUnzip z f)++-- | Adaptors over generic representations of types.+class Profunctor p => GAdaptor p f | f -> p where+ gAdaptor :: f a -> p (GUnzip 'Fst f a) (GUnzip 'Snd f a)++instance+ (ProductProfunctor p, GAdaptor p f, GAdaptor p g)+ => GAdaptor p (f :*: g) where+ gAdaptor (f :*: g) = (:*:)+ ***$ lmap pfst (gAdaptor f)+ **** lmap psnd (gAdaptor g)+ where pfst (f' :*: _) = f'+ psnd (_ :*: g') = g'++instance GAdaptor p f => GAdaptor p (M1 i c f) where+ gAdaptor (M1 f) = dimap+ (\(M1 f') -> f')+ (\f' -> M1 f')+ (gAdaptor f)++instance Profunctor p => GAdaptor p (K1 i (p a b)) where+ gAdaptor (K1 c) = dimap+ (\(K1 c') -> c')+ (\c' -> K1 c')+ c
+ Data/Profunctor/Product/Internal/TH.hs view
@@ -0,0 +1,401 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Profunctor.Product.Internal.TH where++import Data.Profunctor (dimap, lmap)+import Data.Profunctor.Product hiding (constructor, field)+import Data.Profunctor.Product.Default (Default, def)+import qualified Data.Profunctor.Product.Newtype as N+import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),+ mkName, newName, nameBase,+ Con(RecC, NormalC),+ Clause(Clause),+ Type(VarT, ForallT, AppT, ConT),+ Body(NormalB), Q,+ Exp(ConE, VarE, AppE, TupE, LamE),+ Pat(TupP, VarP, ConP), Name,+ Info(TyConI), reify, conE, appT, conT, varE, varP,+ instanceD, Overlap(Incoherent), Pred)+import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndr_, TyVarBndrSpec,+ plainTVSpecified, tvName)+import Control.Monad ((<=<))+import Control.Applicative (pure, liftA2, (<$>), (<*>))++makeAdaptorAndInstanceI :: Bool -> Maybe String -> Name -> Q [Dec]+makeAdaptorAndInstanceI inferrable adaptorNameM =+ returnOrFail <=< r makeAandIE <=< reify+ where r = (return .)+ returnOrFail (Right decs) = decs+ returnOrFail (Left errMsg) = fail errMsg+ makeAandIE = makeAdaptorAndInstanceE sides adaptorNameM+ sides = case inferrable of+ True -> [Just (Left ()), Just (Right ())]+ False -> [Nothing]++type Error = String++makeAdaptorAndInstanceE :: [Maybe (Either () ())]+ -> Maybe String+ -> Info+ -> Either Error (Q [Dec])+makeAdaptorAndInstanceE sides adaptorNameM info = do+ dataDecStuff <- dataDecStuffOfInfo info+ let tyName = dTyName dataDecStuff+ tyVars = dTyVars dataDecStuff+ conName = dConName dataDecStuff+ conTys = dConTys dataDecStuff++ numTyVars = length tyVars+ numConTys = lengthCons conTys+ defaultAdaptorName = (mkName . ("p" ++) . nameBase) conName+ adaptorNameN = maybe defaultAdaptorName mkName adaptorNameM+ adaptorSig' = adaptorSig tyName numTyVars adaptorNameN+ adaptorDefinition' = case conTys of+ ConTys _ -> adaptorDefinition numTyVars conName+ FieldTys fieldTys -> adaptorDefinitionFields conName fieldTys++ instanceDefinition' = map (\side ->+ instanceDefinition side tyName numTyVars numConTys adaptorNameN conName)+ sides++ newtypeInstance' = if numConTys == 1 then+ newtypeInstance conName tyName+ else+ return []++ return $ do+ as <- sequence ( [ adaptorSig'+ , adaptorDefinition' adaptorNameN ]+ ++ instanceDefinition' )+ ns <- newtypeInstance'+ return (as ++ ns)++newtypeInstance :: Name -> Name -> Q [Dec]+newtypeInstance conName tyName = do+ x <- newName "x"++ let body = [ FunD 'N.constructor [simpleClause (NormalB (ConE conName))]+ , FunD 'N.field [simpleClause (NormalB (LamE [conP conName [VarP x]] (VarE x)))] ]+ i <- instanceD (pure [])+ [t| $(conT ''N.Newtype) $(conT tyName) |]+ (map pure body)+ pure [i]++data ConTysFields = ConTys [Type]+ -- ^^ The type of each constructor field+ | FieldTys [(Name, Type)]+ -- ^^ The fieldname and type of each constructor field++lengthCons :: ConTysFields -> Int+lengthCons (ConTys l) = length l+lengthCons (FieldTys l) = length l++data DataDecStuff = DataDecStuff {+ dTyName :: Name+ , dTyVars :: [Name]+ , dConName :: Name+ , dConTys :: ConTysFields+ }++dataDecStuffOfInfo :: Info -> Either Error DataDecStuff+dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars _kind constructors _deriving)) =+ do+ (conName, conTys) <- extractConstructorStuff constructors+ let tyVars' = map varNameOfBinder tyVars+ return DataDecStuff { dTyName = tyName+ , dTyVars = tyVars'+ , dConName = conName+ , dConTys = conTys+ }++dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars _kind constructor _deriving)) =+ do+ (conName, conTys) <- extractConstructorStuff [constructor]+ let tyVars' = map varNameOfBinder tyVars+ return DataDecStuff { dTyName = tyName+ , dTyVars = tyVars'+ , dConName = conName+ , dConTys = conTys+ }+dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtype declaration to me"++varNameOfBinder :: TyVarBndr_ flag -> Name+varNameOfBinder = tvName++conStuffOfConstructor :: Con -> Either Error (Name, ConTysFields)+conStuffOfConstructor = \case+ NormalC conName st -> return (conName, ConTys (map snd st))+ RecC conName vst -> return (conName, FieldTys (map (\(n, _, t) -> (n, t)) vst))+ _ -> Left "I can't deal with your constructor type"++constructorOfConstructors :: [Con] -> Either Error Con+constructorOfConstructors = \case+ [single] -> return single+ [] -> Left "I need at least one constructor"+ _many -> Left "I can't deal with more than one constructor"++extractConstructorStuff :: [Con] -> Either Error (Name, ConTysFields)+extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors++instanceDefinition :: Maybe (Either () ())+ -> Name+ -> Int+ -> Int+ -> Name+ -> Name+ -> Q Dec+instanceDefinition side tyName' numTyVars numConVars adaptorName' conName =+ instanceDec+ where instanceDec = liftA2+ (\i j -> InstanceD (Incoherent <$ side) i j [defDefinition])+ instanceCxt instanceType+ p :: Applicative m => m Type+ p = pure $ varTS "p"+ x = pure $ varTS "x"++ instanceCxt = do+ typeMatch' <- sequence typeMatch+ productProfunctor_p' <- productProfunctor_p+ default_p_as0_as1 <- traverse default_p_a0_a1 (allTyVars numTyVars)+ pure (productProfunctor_p' : typeMatch' ++ default_p_as0_as1)++ productProfunctor_p :: Q Pred+ productProfunctor_p = classP ''ProductProfunctor [p]++ (typeMatch, pArg0, pArg1) = case side of+ Nothing -> ([], tyName0, tyName1)+ Just (Left ()) -> ([ [t| $x ~ $tyName0 |] ], x, tyName1)+ Just (Right ()) -> ([ [t| $x ~ $tyName1 |] ], tyName0, x)++ tyName0 = tyName "0"+ tyName1 = tyName "1"++ default_p_a0_a1 :: String -> Q Pred+ default_p_a0_a1 a = classP ''Default [p, tvar a "0", tvar a "1"]++ tvar a i = pure (mkTySuffix i a)++ tyName :: String -> Q Type+ tyName suffix = pure $ pArg' tyName' suffix numTyVars++ instanceType = [t| $(conT ''Default) $p $pArg0 $pArg1 |]++ defDefinition = FunD 'def [simpleClause defBody]+ defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN)+ defsN = replicate numConVars (VarE 'def)++adaptorSig :: Name -> Int -> Name -> Q Dec+adaptorSig tyName' numTyVars n = fmap (SigD n) adaptorType+ where p = mkName "p"+ adaptorType = ForallT scope <$> adaptorCxt <*> adaptorAfterCxt+ adaptorAfterCxt = [t| $before -> $after |]+ adaptorCxt = fmap (:[]) (classP ''ProductProfunctor [pType])+ before = foldl (liftA2 AppT) (pure (ConT tyName')) pArgs+ pType = pure $ VarT p+ pArgs = map pApp tyVars+ pApp :: String -> Q Type+ pApp v = [t| $pType $(mkVarTsuffix "0" v) $(mkVarTsuffix "1" v) |]+++ tyVars = allTyVars numTyVars++ pArg :: String -> Q Type+ pArg s = pure $ pArg' tyName' s numTyVars++ after = [t| $pType $(pArg "0") $(pArg "1") |]++ scope = concat [ [plainTVSpecified p]+ , map (mkTyVarsuffix "0") tyVars+ , map (mkTyVarsuffix "1") tyVars ]++-- This should probably fail in a more graceful way than an error. I+-- guess via Either or Q.+tupleAdaptors :: Int -> Name+tupleAdaptors n = case n of 1 -> 'p1+ 2 -> 'p2+ 3 -> 'p3+ 4 -> 'p4+ 5 -> 'p5+ 6 -> 'p6+ 7 -> 'p7+ 8 -> 'p8+ 9 -> 'p9+ 10 -> 'p10+ 11 -> 'p11+ 12 -> 'p12+ 13 -> 'p13+ 14 -> 'p14+ 15 -> 'p15+ 16 -> 'p16+ 17 -> 'p17+ 18 -> 'p18+ 19 -> 'p19+ 20 -> 'p20+ 21 -> 'p21+ 22 -> 'p22+ 23 -> 'p23+ 24 -> 'p24+ 25 -> 'p25+ 26 -> 'p26+ 27 -> 'p27+ 28 -> 'p28+ 29 -> 'p29+ 30 -> 'p30+ 31 -> 'p31+ 32 -> 'p32+ 33 -> 'p33+ 34 -> 'p34+ 35 -> 'p35+ 36 -> 'p36+ 37 -> 'p37+ 38 -> 'p38+ 39 -> 'p39+ 40 -> 'p40+ 41 -> 'p41+ 42 -> 'p42+ 43 -> 'p43+ 44 -> 'p44+ 45 -> 'p45+ 46 -> 'p46+ 47 -> 'p47+ 48 -> 'p48+ 49 -> 'p49+ 50 -> 'p50+ 51 -> 'p51+ 52 -> 'p52+ 53 -> 'p53+ 54 -> 'p54+ 55 -> 'p55+ 56 -> 'p56+ 57 -> 'p57+ 58 -> 'p58+ 59 -> 'p59+ 60 -> 'p60+ 61 -> 'p61+ 62 -> 'p62+ _ -> error errorMsg+ where errorMsg = "Data.Profunctor.Product.TH: "+ ++ show n+ ++ " is too many type variables for me!"++adaptorDefinition :: Int -> Name -> Name -> Q Dec+adaptorDefinition numConVars conName x = fmap (FunD x . pure) clause+ where clause = fmap (\b -> Clause [] b wheres) body+ toTupleN = mkName "toTuple"+ fromTupleN = mkName "fromTuple"+ toTupleE = varE toTupleN+ fromTupleE = varE fromTupleN+ theDimap = [| $(varE 'dimap) $toTupleE $fromTupleE |]+ pN = varE (tupleAdaptors numConVars)+ body = fmap NormalB [| $theDimap . $pN . $toTupleE |]+ wheres = [toTuple conName (toTupleN, numConVars),+ fromTuple conName (fromTupleN, numConVars)]++adaptorDefinitionFields :: Name -> [(Name, name)] -> Name -> Q Dec+adaptorDefinitionFields conName fieldsTys adaptorName =+ fmap (FunD adaptorName . pure) clause+ where fields = map fst fieldsTys+ -- TODO: vv f should be generated in Q+ fP = varP (mkName "f")+ fE = varE (mkName "f")+ clause = liftA2 (\fP' b -> Clause [fP'] (NormalB b) []) fP body+ body = case fields of+ [] -> error "Can't handle no fields in constructor"+ field1:fields' ->+ let first =+ [| $(varE '(***$)) $(conE conName) $(theLmap field1) |]+ app x y =+ [| $(varE '(****)) $x $(theLmap y) |]+ in foldl app first fields'++ theLmap field =+ [| $(varE 'lmap) $(varE field) ($(varE field) $fE) |]++xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec+xTuple patCon retCon (funN, numTyVars) = FunD funN [clause]+ where clause = Clause [pat] body []+ pat = patCon varPats+ body = NormalB (retCon varExps)+ varPats = map varPS (allTyVars numTyVars)+ varExps = map varS (allTyVars numTyVars)++classP :: Name -> [Q Type] -> Q Type+classP class_ = foldl appT (conT class_)++tupP :: [Pat] -> Pat+tupP [p] = p+tupP ps = TupP ps++tupE :: [Exp] -> Exp+tupE [e] = e+tupE es = TupE+#if MIN_VERSION_template_haskell(2,16,0)+ $ map Just+#endif+ es++conP :: Name -> [Pat] -> Pat+conP conname = ConP conname+#if MIN_VERSION_template_haskell(2,18,0)+ []+#endif++fromTuple :: Name -> (Name, Int) -> Dec+fromTuple conName = xTuple patCon retCon+ where patCon = tupP+ retCon = appEAll (ConE conName)++toTuple :: Name -> (Name, Int) -> Dec+toTuple conName = xTuple patCon retCon+ where patCon = conP conName+ retCon = tupE++{-+Note that we can also do the instance definition like this, but it would+require pulling the to/fromTuples to the top level++instance (ProductProfunctor p, Default p a a', Default p b b',+ Default p c c', Default p d d', Default p e e',+ Default p f f', Default p g g', Default p h h')+ => Default p (LedgerRow' a b c d e f g h)+ (LedgerRow' a' b' c' d' e' f' g' h') where+ def = dimap tupleOfLedgerRow lRowOfTuple def+-}++pArg' :: Name -> String -> Int -> Type+pArg' tn s = appTAll (ConT tn) . map (varTS . (++s)) . allTyVars++allTyVars :: Int -> [String]+allTyVars numTyVars = map varA tyNums+ where varA i = "a" ++ show i ++ "_"+ tyNums :: [Int]+ tyNums = [1..numTyVars]++varS :: String -> Exp+varS = VarE . mkName++varPS :: String -> Pat+varPS = VarP . mkName++mkTyVarsuffix :: String -> String -> TyVarBndrSpec+mkTyVarsuffix s = plainTVSpecified . mkName . (++s)++mkTySuffix :: String -> String -> Type+mkTySuffix s = varTS . (++s)++mkVarTsuffix :: String -> String -> Q Type+mkVarTsuffix s = pure . VarT . mkName . (++s)++varTS :: String -> Type+varTS = VarT . mkName++appTAll :: Type -> [Type] -> Type+appTAll = foldl AppT++appEAll :: Exp -> [Exp] -> Exp+appEAll = foldl AppE++simpleClause :: Body -> Clause+simpleClause x = Clause [] x []
+ Data/Profunctor/Product/Newtype.hs view
@@ -0,0 +1,10 @@+module Data.Profunctor.Product.Newtype where++import qualified Data.Profunctor as P++class Newtype t where+ constructor :: a -> t a+ field :: t a -> a++pNewtype :: (P.Profunctor p, Newtype t) => p a b -> p (t a) (t b)+pNewtype = P.dimap field constructor
Data/Profunctor/Product/TH.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | If you have a data declaration which is a polymorphic product, -- for example --@@ -15,314 +13,150 @@ -- -- then you can use Template Haskell to automatically derive the -- product-profunctor 'Default' instances and product-profunctor--- \"adaptor\" with the following import and splice:+-- \"adaptor\" with the following splice: -- -- @--- $(makeAdaptorAndInstance \"pFoo\" ''Foo)+-- \$('makeAdaptorAndInstanceInferrable' \"pFoo\" ''Foo) -- @ ----- * The adaptor for a type Foo is by convention called pFoo, but in--- practice you can call it anything.+-- The adaptor for a type @Foo@ is by convention called @pFoo@, but in+-- practice you can call it anything. If you don't care to specify+-- the name @pFoo@ yourself you can use ----- The instance generated will be+-- @+-- \$('makeAdaptorAndInstanceInferrable'' ''Foo)+-- @ --+-- and it will be named @pFoo@ automatically.+--+-- @pFoo@ will have the type+-- -- @--- instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c')+-- pFoo :: 'Data.Profunctor.Product.ProductProfunctor' p+-- => Foo (p a a') (p b b') (p c c')+-- -> p (Foo a b c) (Foo a' b' c')+-- @+--+-- and the instance generated will be+--+-- @+-- instance ('Data.Profunctor.Product.ProductProfunctor' p, Default p a a', Default p b b', Default p c c') -- => Default p (Foo a b c) (Foo a' b' c') -- @ ----- and pFoo will have the type+-- If you are confused about the meaning of @pFoo@ it may help to+-- consider the corresponding function that works with @Applicative@s+-- (its implementation is given below). -- -- @--- pFoo :: ProductProfunctor p =>--- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')+-- pFooApplicative :: 'Control.Applicative.Applicative' f+-- => Foo (f a) (f b) (f c)+-- -> f (Foo a b c) -- @--module Data.Profunctor.Product.TH where--import Data.Profunctor (dimap)-import Data.Profunctor.Product (ProductProfunctor, p1, p2, p3, p4, p5, p6, p7,- p8, p9, p10, p11, p12, p13, p14, p15, p16, p17,- p18, p19, p20, p21, p22, p23, p24)-import Data.Profunctor.Product.Default (Default, def)-import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),- mkName, TyVarBndr(PlainTV, KindedTV),- Con(RecC, NormalC),- Strict(NotStrict), Clause(Clause),- Type(VarT, ForallT, AppT, ArrowT, ConT),- Body(NormalB), Q, classP,- Exp(ConE, VarE, InfixE, AppE, TupE),- Pat(TupP, VarP, ConP), Name,- Info(TyConI), reify)-import Control.Monad ((<=<))-import Control.Applicative ((<$>), (<*>))-import Control.Arrow (second)--makeAdaptorAndInstance :: String -> Name -> Q [Dec]-makeAdaptorAndInstance adaptorNameS = returnOrFail <=< r makeAandIE <=< reify- where r = (return .)- returnOrFail (Right decs) = decs- returnOrFail (Left errMsg) = fail errMsg- makeAandIE = makeAdaptorAndInstanceE adaptorNameS--type Error = String--makeAdaptorAndInstanceE :: String -> Info -> Either Error (Q [Dec])-makeAdaptorAndInstanceE adaptorNameS info = do- (tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info- let numTyVars = length tyVars- numConTys = length conTys- adaptorNameN = mkName adaptorNameS- adaptorSig' = adaptorSig tyName numTyVars adaptorNameN- adaptorDefinition' = adaptorDefinition numTyVars conName adaptorNameN- instanceDefinition' = instanceDefinition tyName numTyVars numConTys- adaptorNameN conName-- return ((\a b -> [a, adaptorDefinition', b]) <$> adaptorSig' <*> instanceDefinition')---- TODO: support newtypes?-dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name])-dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) =- do- (conName, conTys) <- extractConstructorStuff constructors- let tyVars' = map varNameOfBinder tyVars- return (tyName, tyVars', conName, conTys)-dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars constructor _deriving)) =- do- (conName, conTys) <- extractConstructorStuff [constructor]- let tyVars' = map varNameOfBinder tyVars- return (tyName, tyVars', conName, conTys)-dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtpe declaration to me"--varNameOfType :: Type -> Either Error Name-varNameOfType (VarT n) = Right n-varNameOfType x = Left $ "Found a non-variable type" ++ show x--varNameOfBinder :: TyVarBndr -> Name-varNameOfBinder (PlainTV n) = n-varNameOfBinder (KindedTV n _) = n--conStuffOfConstructor :: Con -> Either Error (Name, [Name])-conStuffOfConstructor (NormalC conName st) = do- conTys <- mapM (varNameOfType . snd) st- return (conName, conTys)-conStuffOfConstructor (RecC conName vst) = do- conTys <- mapM (varNameOfType . thrd) vst- return (conName, conTys)- where thrd = \(_,_,x) -> x-conStuffOfConstructor _ = Left "I can't deal with your constructor type"--constructorOfConstructors :: [Con] -> Either Error Con-constructorOfConstructors [single] = return single-constructorOfConstructors [] = Left "I need at least one constructor"-constructorOfConstructors _many = Left msg- where msg = "I can't deal with more than one constructor"--extractConstructorStuff :: [Con] -> Either Error (Name, [Name])-extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors---- MakeRecordT and makeRecordData were from an old interface. We could probably--- delete them now.-data MakeRecordT = MakeRecordT { typeName :: String- , constructorName :: String- , fieldNames :: [String]- , deriving_ :: [String]- , adaptorName :: String }--makeRecordData :: MakeRecordT -> Q [Dec]-makeRecordData r = return [datatype'] where- MakeRecordT tyName conName tyVars derivings _ = r- tyName' = mkName tyName- datatype' = datatype tyName' tyVars conName derivings--makeRecord :: MakeRecordT -> Q [Dec]-makeRecord r = decs- where MakeRecordT tyName conName tyVars derivings _ = r- decs = (\a i -> [datatype', a, adaptorDefinition', i])- <$> adaptorSig'- <*> instanceDefinition'- tyName' = mkName tyName- conName' = mkName conName-- adaptorName' = mkName (adaptorName r)-- numTyVars = length tyVars-- datatype' = datatype tyName' tyVars conName derivings- adaptorSig' = adaptorSig tyName' numTyVars adaptorName'- adaptorDefinition' = adaptorDefinition numTyVars conName' adaptorName'- instanceDefinition' = instanceDefinition tyName' numTyVars numTyVars- adaptorName' conName'---- The implementations of the datatype (only used in the old makeRecord),--- instance and adaptor follow.-datatype :: Name -> [String] -> String -> [String] -> Dec-datatype tyName tyVars conName derivings = datatype'- where datatype' = DataD [] tyName tyVars' [con] derivings'- fields = map toField tyVars- tyVars' = map (PlainTV . mkName) tyVars- con = RecC (mkName conName) fields- toField s = (mkName s, NotStrict, VarT (mkName s))- derivings' = map mkName derivings--instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec-instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec- where instanceDec = fmap (\i -> InstanceD i instanceType [defDefinition])- instanceCxt- instanceCxt = mapM (uncurry classP) (pClass:defClasses)- pClass = (''ProductProfunctor, [return (varTS "p")])-- defaultPredOfVar :: String -> (Name, [Type])- defaultPredOfVar fn = (''Default, [varTS "p",- mkTySuffix "0" fn,- mkTySuffix "1" fn])-- defClasses = map (second (map return) . defaultPredOfVar)- (allTyVars numTyVars)-- pArg :: String -> Type- pArg s = pArg' tyName' s numTyVars-- instanceType = appTAll (ConT ''Default)- [varTS "p", pArg "0", pArg "1"]-- defDefinition = FunD 'def [Clause [] defBody []]- defBody = NormalB(VarE adaptorName' `AppE` appEAll (ConE conName) defsN)- defsN = replicate numConVars (VarE 'def)--adaptorSig :: Name -> Int -> Name -> Q Dec-adaptorSig tyName' numTyVars n = fmap (SigD n) adaptorType- where adaptorType = fmap (\a -> ForallT scope a adaptorAfterCxt) adaptorCxt- adaptorAfterCxt = before `appArrow` after- adaptorCxt = fmap (:[]) (classP ''ProductProfunctor [return (VarT (mkName "p"))])- before = appTAll (ConT tyName') pArgs- pType = VarT (mkName "p")- pArgs = map pApp tyVars- pApp :: String -> Type- pApp v = appTAll pType [mkVarTsuffix "0" v, mkVarTsuffix "1" v]+--+-- The product-profunctor \"adaptor\" (in this case @pFoo@) is a+-- generalization of @Data.Traversable.sequence@ in two different+-- ways. Firstly it works on datatypes with multiple type parameters.+-- Secondly it works on 'ProductProfunctor's, which are themselves a+-- generalization of 'Applicative's.+--+-- If your type has only one field, for example+--+-- @+-- data Foo a = Foo a+-- @+--+-- or+--+-- @+-- newtype Foo a = Foo a+-- @+--+-- then you will also get the instance+--+-- @+-- instance 'Data.Profunctor.Product.Newtype.Newtype' Foo where+-- 'Data.Profunctor.Product.Newtype.constructor' = Foo+-- 'Data.Profunctor.Product.Newtype.field' = \\(Foo x) -> x+-- @+--+-- which allows you to use the polymorphic function 'Data.Profunctor.Product.Newtype.pNewtype'+-- instead of @pFoo@.+--+-- If you prefer not to use Template Haskell then the generated code+-- can be written by hand because it is quite simple. It corresponds+-- very closely to what we would do in the more familiar+-- @Applicative@ case. For an @Applicative@ we would write+--+-- @+-- pFooApplicative :: 'Control.Applicative.Applicative' f+-- => Foo (f a) (f b) (f c) -> f (Foo a b c)+-- pFooApplicative f = Foo 'Control.Applicative.<$>' foo f+-- 'Control.Applicative.<*>' bar f+-- 'Control.Applicative.<*>' baz f+-- @+--+-- whereas for a @ProductProfunctor@ we write+--+-- @+-- import "Data.Profunctor" ('Data.Profunctor.lmap')+-- import "Data.Profunctor.Product" (('Data.Profunctor.Product.***$'), ('Data.Profunctor.Product.****'))+--+-- pFoo :: 'Data.Profunctor.Product.ProductProfunctor' p+-- => Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c')+-- pFoo f = Foo 'Data.Profunctor.Product.***$' 'Data.Profunctor.lmap' foo (foo f)+-- 'Data.Profunctor.Product.****' 'Data.Profunctor.lmap' bar (bar f)+-- 'Data.Profunctor.Product.****' 'Data.Profunctor.lmap' baz (baz f)+-- @+--+-- The 'Default' instance is then very simple.+--+-- @+-- instance ('Data.Profunctor.Product.ProductProfunctor' p, 'Data.Profunctor.Product.Default.Default' p a a', 'Data.Profunctor.Product.Default.Default' p b b', 'Data.Profunctor.Product.Default.Default' p c c')+-- => 'Data.Profunctor.Product.Default.Default' p (Foo a b c) (Foo a' b' c') where+-- 'Data.Profunctor.Product.Default.def' = pFoo (Foo 'Data.Profunctor.Product.Default.def' 'Data.Profunctor.Product.Default.def' 'Data.Profunctor.Product.Default.def')+-- @ - tyVars = allTyVars numTyVars-- pArg :: String -> Type- pArg s = pArg' tyName' s numTyVars-- after = appTAll pType [pArg "0", pArg "1"]-- scope = concat [ [PlainTV (mkName "p")]- , map (mkTyVarsuffix "0") tyVars- , map (mkTyVarsuffix "1") tyVars ]---- This should probably fail in a more graceful way than an error. I--- guess via Either or Q.-tupleAdaptors :: Int -> Name-tupleAdaptors n = case n of 1 -> 'p1- 2 -> 'p2- 3 -> 'p3- 4 -> 'p4- 5 -> 'p5- 6 -> 'p6- 7 -> 'p7- 8 -> 'p8- 9 -> 'p9- 10 -> 'p10- 11 -> 'p11- 12 -> 'p12- 13 -> 'p13- 14 -> 'p14- 15 -> 'p15- 16 -> 'p16- 17 -> 'p17- 18 -> 'p18- 19 -> 'p19- 20 -> 'p20- 21 -> 'p21- 22 -> 'p22- 23 -> 'p23- 24 -> 'p24- _ -> error errorMsg- where errorMsg = "Data.Profunctor.Product.TH: "- ++ show n- ++ " is too many type variables for me!"--adaptorDefinition :: Int -> Name -> Name -> Dec-adaptorDefinition numConVars conName = flip FunD [clause]- where clause = Clause [] body wheres- toTupleN = mkName "toTuple"- fromTupleN = mkName "fromTuple"- toTupleE = VarE toTupleN- fromTupleE = VarE fromTupleN- theDimap = appEAll (VarE 'dimap) [toTupleE, fromTupleE]- pN = VarE (tupleAdaptors numConVars)- body = NormalB (theDimap `o` pN `o` toTupleE)- wheres = [toTuple conName (toTupleN, numConVars),- fromTuple conName (fromTupleN, numConVars)]--xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec-xTuple patCon retCon (funN, numTyVars) = FunD funN [clause]- where clause = Clause [pat] body []- pat = patCon varPats- body = NormalB (retCon varExps)- varPats = map varPS (allTyVars numTyVars)- varExps = map varS (allTyVars numTyVars)--fromTuple :: Name -> (Name, Int) -> Dec-fromTuple conName = xTuple patCon retCon- where patCon = TupP- retCon = appEAll (ConE conName)--toTuple :: Name -> (Name, Int) -> Dec-toTuple conName = xTuple patCon retCon- where patCon = ConP conName- retCon = TupE--{--Note that we can also do the instance definition like this, but it would-require pulling the to/fromTuples to the top level--instance (ProductProfunctor p, Default p a a', Default p b b',- Default p c c', Default p d d', Default p e e',- Default p f f', Default p g g', Default p h h')- => Default p (LedgerRow' a b c d e f g h)- (LedgerRow' a' b' c' d' e' f' g' h') where- def = dimap tupleOfLedgerRow lRowOfTuple def--}--pArg' :: Name -> String -> Int -> Type-pArg' tn s = appTAll (ConT tn) . map (varTS . (++s)) . allTyVars--allTyVars :: Int -> [String]-allTyVars numTyVars = map varA tyNums- where varA i = "a" ++ show i ++ "_"- tyNums :: [Int]- tyNums = [1..numTyVars]--o :: Exp -> Exp -> Exp-o x y = InfixE (Just x) (varS ".") (Just y)--varS :: String -> Exp-varS = VarE . mkName--varPS :: String -> Pat-varPS = VarP . mkName--mkTyVarsuffix :: String -> String -> TyVarBndr-mkTyVarsuffix s = PlainTV . mkName . (++s)--mkTySuffix :: String -> String -> Type-mkTySuffix s = varTS . (++s)+module Data.Profunctor.Product.TH where -mkVarTsuffix :: String -> String -> Type-mkVarTsuffix s = VarT . mkName . (++s)+import Data.Profunctor.Product.Internal.TH (makeAdaptorAndInstanceI)+import qualified Language.Haskell.TH as TH -varTS :: String -> Type-varTS = VarT . mkName+-- | For example+--+-- @+-- \$(makeAdaptorAndInstanceInferrable \"pFoo\" ''Foo)+-- @+--+-- generates the 'Default' instance and the adaptor @pFoo@.+makeAdaptorAndInstanceInferrable :: String -> TH.Name -> TH.Q [TH.Dec]+makeAdaptorAndInstanceInferrable adaptorNameS =+ makeAdaptorAndInstanceI True (Just adaptorNameS) -appTAll :: Type -> [Type] -> Type-appTAll = foldl AppT+-- | For example+--+-- @+-- \$(makeAdaptorAndInstanceInferrable' ''Foo)+-- @+--+-- generates the 'Default' instance and the adaptor @pFoo@. The name+-- of the adaptor is chosen by prefixing the type name \"Foo\" with+-- the string \"p\".+makeAdaptorAndInstanceInferrable' :: TH.Name -> TH.Q [TH.Dec]+makeAdaptorAndInstanceInferrable' =+ makeAdaptorAndInstanceI True Nothing -appEAll :: Exp -> [Exp] -> Exp-appEAll = foldl AppE+-- | Use 'makeAdaptorAndInstanceInferrable' instead, because it+-- generates instances with better inference properties. Will be+-- deprecated in version 0.12.+makeAdaptorAndInstance :: String -> TH.Name -> TH.Q [TH.Dec]+makeAdaptorAndInstance adaptorNameS =+ makeAdaptorAndInstanceI False (Just adaptorNameS) -appArrow :: Type -> Type -> Type-appArrow l r = appTAll ArrowT [l, r]+-- | Use 'makeAdaptorAndInstanceInferrable' instead, because it+-- generates instances with better inference properties. Will be+-- deprecated in version 0.12.+makeAdaptorAndInstance' :: TH.Name -> TH.Q [TH.Dec]+makeAdaptorAndInstance' =+ makeAdaptorAndInstanceI False Nothing
Data/Profunctor/Product/Tuples.hs view
@@ -1,39 +1,10 @@+{-# LANGUAGE TemplateHaskell #-}++-- | This is old cruft. You should never use this and it will likely+-- be deprecated in a future version.+ module Data.Profunctor.Product.Tuples where -type T0 = ()-type T1 a = a-type T2 a b = (a, T1 b)-type T3 a b c = (a, T2 b c)-type T4 a b c d = (a, T3 b c d)-type T5 a b c d e = (a, T4 b c d e)-type T6 a b c d e f = (a, T5 b c d e f)-type T7 a b c d e f g = (a, T6 b c d e f g)-type T8 a b c d e f g h = (a, T7 b c d e f g h)-type T9 a b c d e f g h a9 = (a, T8 b c d e f g h a9)-type T10 a b c d e f g h a9 a10 = (a, T9 b c d e f g h a9 a10)-type T11 a b c d e f g h a9 a10 a11 = (a, T10 b c d e f g h a9 a10 a11)-type T12 a b c d e f g h a9 a10 a11 a12 = (a, T11 b c d e f g h a9 a10 a11 a12)-type T13 a b c d e f g h a9 a10 a11 a12 a13 =- (a, T12 b c d e f g h a9 a10 a11 a12 a13)-type T14 a b c d e f g h a9 a10 a11 a12 a13 a14 =- (a, T13 b c d e f g h a9 a10 a11 a12 a13 a14)-type T15 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 =- (a, T14 b c d e f g h a9 a10 a11 a12 a13 a14 a15)-type T16 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 =- (a, T15 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16)-type T17 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 =- (a, T16 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17)-type T18 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 =- (a, T17 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18)-type T19 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 =- (a, T18 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19)-type T20 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 =- (a, T19 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20)-type T21 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 =- (a, T20 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21)-type T22 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 =- (a, T21 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22)-type T23 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 =- (a, T22 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23)-type T24 a b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24 =- (a, T23 b c d e f g h a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 a21 a22 a23 a24)+import Data.Profunctor.Product.Tuples.TH++mkTs [0..maxTupleSize]
+ Data/Profunctor/Product/Tuples/TH.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Profunctor.Product.Tuples.TH+ ( mkTs+ , pTns+ , mkFlattenNs+ , mkUnflattenNs+ , pNs+ , mkDefaultNs+ , maxTupleSize+ ) where++import Language.Haskell.TH+import Language.Haskell.TH.Datatype.TyVarBndr++import Data.Profunctor (Profunctor (dimap))+import Data.Profunctor.Product.Class (ProductProfunctor, (***!), empty)+import Data.Profunctor.Product.Default.Class (Default (def))+import Control.Applicative (pure)++mkTs :: [Int] -> Q [Dec]+mkTs = mapM mkT++mkT :: Int -> Q Dec+mkT n = tySynD (tyName n) tyVars tyDef+ where+ tyName n' = mkName ('T':show n')+ tyVars = map plainTV . take n $ allNames+ tyDef = case n of+ 0 -> tupleT 0+ 1 -> varT (head allNames)+ _ -> tupleT 2 `appT` varT (head allNames) `appT` applyT (n - 1)+ applyT n' = foldl (\t v -> t `appT` varT v) (conT (tyName n')) (take n' (tail allNames))+ allNames = [ mkName $ c:show i | i <- [0::Int ..], c <- ['a'..'z'] ]++chain :: ProductProfunctor p => (t -> p a2 b2) -> (p a1 b1, t)+ -> p (a1, a2) (b1, b2)+chain rest (a, as) = a ***! rest as++pTns :: [Int] -> Q [Dec]+pTns = fmap concat . mapM pTn++productProfunctor :: Name -> Q Pred+productProfunctor p = [t|ProductProfunctor $(v p)|]+ where v = pure . VarT++default_ :: Name -> Name -> Name -> Q Pred+default_ p a b = [t|Default $(v p) $(v a) $(v b)|]+ where v = pure . VarT++pTn :: Int -> Q [Dec]+pTn n = sequence [sig, fun]+ where+ p = mkName "p"+ sig = sigD (pT n) (forallT (map plainTVSpecified $ p : take n as ++ take n bs)+ (sequence [productProfunctor p])+ (arrowT `appT` mkLeftTy `appT` mkRightTy)+ )+ mkLeftTy = foldl appT (conT tN)+ $ zipWith (\a b -> varT p `appT` varT a `appT` varT b) (take n as) (take n bs)+ mkRightTy = varT p `appT` foldl appT (conT tN) (map varT . take n $ as)+ `appT` foldl appT (conT tN) (map varT . take n $ bs)+ fun = funD (pT n) [ clause [] (normalB bdy) [] ]+ bdy = case n of+ 0 -> [| const empty |]+ 1 -> [| id |]+ 2 -> [| uncurry (***!) |]+ _ -> [| chain $(varE (pT (n - 1))) |]+ pT n' = mkName ("pT" ++ show n')+ tN = mkName ('T':show n)+ as = [ mkName $ 'a':show i | i <- [0::Int ..] ]+ bs = [ mkName $ 'b':show i | i <- [0::Int ..] ]++mkFlattenNs :: [Int] -> Q [Dec]+mkFlattenNs = fmap concat . mapM mkFlattenN++mkFlattenN :: Int -> Q [Dec]+mkFlattenN n = sequence [sig, fun]+ where+ sig = sigD nm (forallT (map plainTVSpecified names) (pure []) $ arrowT `appT` unflatT names `appT` flatT names)+ fun = funD nm [ clause [mkTupPat names] (normalB bdy) [] ]+ bdy = mkFlatExp names+ unflatT [] = tupleT 0+ unflatT [v] = varT v+ unflatT (v:vs) = tupleT 2 `appT` varT v `appT` unflatT vs+ flatT [] = tupleT 0+ flatT [v] = varT v+ flatT vs = foldl appT (tupleT (length vs)) (map varT vs)+ mkTupPat [] = tupP []+ mkTupPat [v] = varP v+ mkTupPat (v:vs) = tupP [varP v, mkTupPat vs]+ mkFlatExp [] = tupE []+ mkFlatExp [v] = varE v+ mkFlatExp vs = tupE (map varE vs)+ nm = mkName ("flatten" ++ show n)+ names = take n [ mkName $ c:show i | i <- [0::Int ..], c <- ['a'..'z'] ]++mkUnflattenNs :: [Int] -> Q [Dec]+mkUnflattenNs = fmap concat . mapM mkUnflattenN++mkUnflattenN :: Int -> Q [Dec]+mkUnflattenN n = sequence [sig, fun]+ where+ sig = sigD nm (forallT (map plainTVSpecified names) (pure []) $ arrowT `appT` flatT names `appT` unflatT names)+ fun = funD nm [ clause [mkTupPat names] (normalB bdy) [] ]+ bdy = mkUnflatExp names+ unflatT [] = tupleT 0+ unflatT [v] = varT v+ unflatT (v:vs) = tupleT 2 `appT` varT v `appT` unflatT vs+ flatT [] = tupleT 0+ flatT [v] = varT v+ flatT vs = foldl appT (tupleT (length vs)) (map varT vs)+ mkTupPat [] = tupP []+ mkTupPat [v] = varP v+ mkTupPat vs = tupP (map varP vs)+ mkUnflatExp [] = tupE []+ mkUnflatExp [v] = varE v+ mkUnflatExp (v:vs) = tupE [varE v, mkUnflatExp vs]+ nm = mkName ("unflatten" ++ show n)+ names = take n [ mkName $ c:show i | i <- [0::Int ..], c <- ['a'..'z'] ]++pNs :: [Int] -> Q [Dec]+pNs = fmap concat . mapM pN++pN :: Int -> Q [Dec]+pN n = sequence [sig, fun]+ where+ sig = sigD nm (forallT (map plainTVSpecified $ p : as ++ bs)+ (sequence [productProfunctor p])+ (arrowT `appT` mkLeftTy `appT` mkRightTy)+ )+ mkLeftTy = case n of+ 1 -> mkPT (head as) (head bs)+ _ -> foldl appT (tupleT n) (zipWith mkPT as bs)+ mkRightTy = varT p `appT` mkTupT as `appT` mkTupT bs+ mkTupT [v] = varT v+ mkTupT vs = foldl appT (tupleT n) (map varT vs)+ mkPT a b = varT p `appT` varT a `appT` varT b+ fun = funD nm [ clause [] (normalB bdy) [] ]+ bdy = [| convert $(unflat) $(unflat) $(flat) $(pT) |]+ unflat = varE $ mkName unflatNm+ flat = varE $ mkName flatNm+ pT = varE $ mkName pTNm+ unflatNm = "unflatten" ++ show n+ flatNm = "flatten" ++ show n+ pTNm = "pT" ++ show n+ nm = mkName ('p':show n)+ p = mkName "p"+ as = take n [ mkName $ 'a':show i | i <- [0::Int ..] ]+ bs = take n [ mkName $ 'b':show i | i <- [0::Int ..] ]++convert :: Profunctor p => (a2 -> a1) -> (tp -> tTp) -> (b1 -> b2)+ -> (tTp -> p a1 b1)+ -> tp -> p a2 b2+convert u u' f c = dimap u f . c . u'++mkDefaultNs :: [Int] -> Q [Dec]+mkDefaultNs = fmap concat . mapM mkDefaultN++mkDefaultN :: Int -> Q [Dec]+mkDefaultN n =+ sequence [ instanceWithOverlapD+ (Just Incoherent)+ (sequence (productProfunctor p : x ~~ mkTupT as : mkDefs))+ (conT ''Default `appT` varT p `appT` x `appT` mkTupT bs)+ [mkFun]+ , instanceWithOverlapD+ (Just Incoherent)+ (sequence (productProfunctor p : x ~~ mkTupT bs : mkDefs))+ (conT ''Default `appT` varT p `appT` mkTupT as `appT` x)+ [mkFun]+ ]+ where+ mkDefs = zipWith (default_ p) as bs+ mkTupT = foldl appT (tupleT n) . map varT+ mkFun = funD 'def [clause [] bdy []]+ bdy = normalB $ case n of+ 0 -> varE 'empty+ _ -> varE (mkName $ 'p':show n) `appE` tupE (replicate n [| def |])+ p = mkName "p"+ x = varT (mkName "x")+ t1 ~~ t2 = [t| $t1 ~ $t2 |]+ as = take n [ mkName $ 'a':show i | i <- [0::Int ..] ]+ bs = take n [ mkName $ 'b':show i | i <- [0::Int ..] ]++maxTupleSize :: Int+maxTupleSize = 62
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013, Karamaan Group LLC+Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited; 2019-2023 Tom Ellis All rights reserved.
+ README.md view
@@ -0,0 +1,11 @@+# product-profunctors [](https://hackage.haskell.org/package/product-profunctors) [](https://github.com/tomjaguarpaw/product-profunctors/actions)++## Backup maintainers++In the event of the main developer becoming unreachable, please+contact the following who are authorised to make bugfixes and+dependency version bumps:++* Adam Bergmark+* Erik Hesselink+* Oliver Charles
Test/CheckTypes.hs view
@@ -1,10 +1,20 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-}+ module CheckTypes where import Data.Profunctor.Product (ProductProfunctor) import Data.Profunctor.Product.Default (Default, def)+import Data.Profunctor.Product.Adaptor import Definitions (Data2, Data3, Record2, Record3,- pData2, pData3, pRecord2, pRecord3)+ RecordDefaultName,+ Data2Inferrable(Data2Inferrable),+ Record2Inferrable(Record2Inferrable),+ pData2, pData3, pRecord2, pRecord3,+ pRecordDefaultName,+ unArrow, Unit(Unit), point)+import DefinitionsUndecidable () -- The test suite checks that the TH derived adaptor is of the correct -- type and that the typeclass instance has been generated. We don't@@ -45,3 +55,60 @@ Default p a a', Default p b b', Default p c c') => p (Record3 a b c) (Record3 a' b' c') instanceRecord3 = def++defaultNameGenerated :: ProductProfunctor p => RecordDefaultName (p x x') (p y y')+ -> p (RecordDefaultName x y) (RecordDefaultName x' y')+defaultNameGenerated = pRecordDefaultName++-- We similarly test the type of the generic adaptor.++pData2G :: ProductProfunctor p =>+ Data2 (p a a') (p b b') -> p (Data2 a b) (Data2 a' b')+pData2G = genericAdaptor++pData3G :: ProductProfunctor p =>+ Data3 (p a a') (p b b') (p c c') -> p (Data3 a b c) (Data3 a' b' c')+pData3G = genericAdaptor++pRecord2G :: ProductProfunctor p+ => Record2 (p a a') (p b b') -> p (Record2 a b) (Record2 a' b')+pRecord2G = pRecord2++pRecord3G :: ProductProfunctor p+ => Record3 (p a a') (p b b') (p c c') -> p (Record3 a b c) (Record3 a' b' c')+pRecord3G = pRecord3++-- Can type inference information flow from the left type argument of+-- a Profunctor to the right?+inferDataLR :: ()+inferDataLR = const () (unArrow def (Data2Inferrable Unit Unit))++inferRecordLR :: ()+inferRecordLR = const () (unArrow def (Record2Inferrable Unit Unit))++inferTupleLR :: ()+inferTupleLR = const () (unArrow def (Unit, Unit))++-- Can type inference information flow from the right type argument of+-- a Profunctor to the left?+inferDataRL :: ()+inferDataRL = case unArrow def point of Data2Inferrable Unit Unit -> ()++inferRecordRL :: ()+inferRecordRL = case unArrow def point of Record2Inferrable Unit Unit -> ()++inferTupleRL :: ()+inferTupleRL = case unArrow def point of (Unit, Unit) -> ()++data a :~: b where+ Refl :: a :~: a++pData2TypeEq+ :: (Data2 (p a a') (p b b') -> p (Data2 a b) (Data2 a' b'))+ :~: Adaptor p (Data2 (p a a') (p b b'))+pData2TypeEq = Refl++pData3TypeEq+ :: (Data3 (p a a') (p b b') (p c c') -> p (Data3 a b c) (Data3 a' b' c'))+ :~: Adaptor p (Data3 (p a a') (p b b') (p c c'))+pData3TypeEq = Refl
Test/Definitions.hs view
@@ -1,22 +1,99 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Definitions where +import GHC.Generics (Generic)+ -- We define the data types and generate the TH in a separate module -- because we want to ensure that no external names are required to be -- imported. -import Data.Profunctor.Product.TH (makeAdaptorAndInstance)+import Data.Profunctor+import Data.Profunctor.Product+import Data.Profunctor.Product.Adaptor (Unzippable)+import Data.Profunctor.Product.Default (Default, def)+import Data.Profunctor.Product.TH (makeAdaptorAndInstance, makeAdaptorAndInstance',+ makeAdaptorAndInstanceInferrable) data Data2 a b = Data2 a b+ deriving Generic data Data3 a b c = Data3 a b c+ deriving Generic data Record2 a b = Record2 { a2 :: a, b2 :: b }+ deriving Generic data Record3 a b c = Record3 { a3 :: a, b3 :: b, c3 :: c }+ deriving Generic +data RecordDefaultName x y = RecordDefaultName { x :: x, y :: y }+ deriving Generic++data DataGeneric a b c = DataGeneric a b c deriving Generic+data RecordGeneric a b c = RecordGeneric { a4 :: a, b4 :: b, c4 :: c } deriving Generic+data SumGeneric a b = SumL a | SumR b deriving Generic+data ProductAndSumGeneric a b c = PSumL a | PSumR b c deriving Generic+ $(makeAdaptorAndInstance "pData2" ''Data2) $(makeAdaptorAndInstance "pData3" ''Data3) $(makeAdaptorAndInstance "pRecord2" ''Record2) $(makeAdaptorAndInstance "pRecord3" ''Record3)+$(makeAdaptorAndInstance' ''RecordDefaultName)++instance Unzippable Data2+instance Unzippable Data3++instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c')+ => Default p (DataGeneric a b c) (DataGeneric a' b' c')++instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c')+ => Default p (RecordGeneric a b c) (RecordGeneric a' b' c')++instance (SumProfunctor p, Default p a a', Default p b b')+ => Default p (SumGeneric a b) (SumGeneric a' b')++instance (ProductProfunctor p, SumProfunctor p, Default p a a', Default p b b', Default p c c')+ => Default p (ProductAndSumGeneric a b c) (ProductAndSumGeneric a' b' c')++data Data2Inferrable a b = Data2Inferrable a b+data Record2Inferrable a b = Record2Inferrable { a2I :: a, b2I :: b } deriving Show++$(makeAdaptorAndInstanceInferrable "pData2Inferrable" ''Data2Inferrable)+$(makeAdaptorAndInstanceInferrable "pRecord2Inferrable" ''Record2Inferrable)++newtype Arrow a b = Arrow { unArrow :: a -> b }++instance Profunctor Arrow where+ dimap f g = Arrow . dimap f g . unArrow++instance ProductProfunctor Arrow where+ purePP = Arrow . purePP+ f **** g = Arrow (unArrow f **** unArrow g)++data Unit = Unit++class Pointed a where+ point :: a++instance Pointed Unit where+ point = Unit++instance (Pointed a, Pointed b) => Pointed (Data2Inferrable a b) where+ point = Data2Inferrable point point++instance (Pointed a, Pointed b) => Pointed (Record2Inferrable a b) where+ point = Record2Inferrable point point++instance (Pointed a, Pointed b) => Pointed (a, b) where+ point = (point, point)++instance {-# INCOHERENT #-} a ~ Unit => Default Arrow Unit a where+ def = Arrow id++instance {-# INCOHERENT #-} a ~ Unit => Default Arrow a Unit where+ def = Arrow id
+ Test/DefinitionsUndecidable.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module DefinitionsUndecidable where++-- | We define the data types and generate the TH in a separate module+-- because we want to ensure that no external names are required to be+-- imported.+--+-- It's a bit sad that these need UndecidableInstances++import GHC.Generics (Generic)+import Data.Profunctor.Product (ProductProfunctor, SumProfunctor)+import Data.Profunctor.Product.Default+ (Default, DefaultFields', DefaultConstraints, DefaultConstraints')++data MonomorphicProduct = Product Int Bool deriving Generic+data MonomorphicSum = A Int | B Bool deriving Generic+data MonomorphicBoth = Both1 Char | Both2 Int Bool deriving Generic+data PolyProduct a b c = PolyProduct a b c deriving Generic++instance (ProductProfunctor p, DefaultFields' p MonomorphicProduct)+ => Default p MonomorphicProduct MonomorphicProduct++instance (SumProfunctor p, DefaultFields' p MonomorphicSum)+ => Default p MonomorphicSum MonomorphicSum++instance (DefaultConstraints' p MonomorphicBoth)+ => Default p MonomorphicBoth MonomorphicBoth++instance+ ( DefaultConstraints p+ (PolyProduct a b c)+ (PolyProduct a' b' c')+ ) => Default p (PolyProduct a b c) (PolyProduct a' b' c')++-- A constraint @c@.+data Dict c where+ Dict :: c => Dict c++-- Entailment @c => d@.+data c :- d where+ Sub :: (c => Dict d) -> c :- d++-- Equivalence of constraints.+type c :<=>: d = (c :- d, d :- c)++checkDFMonomorphicProduct+ :: DefaultFields' p MonomorphicProduct :<=>:+ (Default p Int Int, Default p Bool Bool)+checkDFMonomorphicProduct = (Sub Dict, Sub Dict)++checkDFMonomorphicSum+ :: DefaultFields' p MonomorphicSum :<=>:+ (Default p Int Int, Default p Bool Bool)+checkDFMonomorphicSum = (Sub Dict, Sub Dict)++checkDCMonomorphicBoth+ :: DefaultConstraints' p MonomorphicBoth :<=>:+ (ProductProfunctor p, SumProfunctor p, Default p Int Int, Default p Bool Bool, Default p Char Char)+checkDCMonomorphicBoth = (Sub Dict, Sub Dict)++checkDCPolyProduct+ :: DefaultConstraints p (PolyProduct a b c) (PolyProduct a' b' c') :<=>:+ (ProductProfunctor p, Default p a a', Default p b b', Default p c c')+checkDCPolyProduct = (Sub Dict, Sub Dict)
Test/Main.hs view
@@ -1,4 +1,4 @@-import CheckTypes+import CheckTypes () main :: IO () main = return ()
product-profunctors.cabal view
@@ -1,40 +1,74 @@ name: product-profunctors-version: 0.6.3.1+copyright: Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited; 2019-2023 Tom Ellis+version: 0.11.1.1 synopsis: product-profunctors-description: Product profunctors+description: Product profunctors and tools for working with them homepage: https://github.com/tomjaguarpaw/product-profunctors+bug-reports: https://github.com/tomjaguarpaw/product-profunctors/issues license: BSD3-license-File: LICENSE+license-file: LICENSE author: Purely Agile maintainer: Purely Agile category: Control, Category build-type: Simple-cabal-version: >= 1.8+cabal-version: 1.18+tested-with: GHC==9.6, GHC==9.4, GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8+extra-doc-files:+ README.md+ CHANGELOG.md source-repository head- Type: git- Location: https://github.com/tomjaguarpaw/product-profunctors+ type: git+ location: https://github.com/tomjaguarpaw/product-profunctors.git library- build-depends: base >= 4.5 && < 5- , profunctors >= 4.0 && < 5.2- , contravariant >= 0.4 && < 1.4- , template-haskell+ default-language: Haskell2010+ build-depends: base >= 4.5 && < 4.19+ , profunctors >= 5 && < 5.7+ , bifunctors >= 5.4 && < 6.0+ , contravariant >= 0.4 && < 1.6+ , tagged >= 0.0 && < 1+ , template-haskell < 2.21+ , th-abstraction >= 0.4 && < 0.5 exposed-modules: Data.Profunctor.Product,+ Data.Profunctor.Product.Adaptor Data.Profunctor.Product.Default,+ Data.Profunctor.Product.Examples, Data.Profunctor.Product.Flatten,+ Data.Profunctor.Product.Internal.Adaptor+ Data.Profunctor.Product.Internal.TH,+ Data.Profunctor.Product.Newtype, Data.Profunctor.Product.TH, Data.Profunctor.Product.Tuples+ Data.Profunctor.Product.Tuples.TH+ other-modules: Data.Profunctor.Product.Class,+ Data.Profunctor.Product.Default.Class ghc-options: -Wall + if impl(ghc < 7.10)+ build-depends: transformers >= 0.2 && < 0.6+ test-suite test+ default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: Main.hs other-modules: CheckTypes,- Definitions+ Definitions,+ DefinitionsUndecidable hs-source-dirs: Test build-depends: base >= 4 && < 5, profunctors, product-profunctors ghc-options: -Wall++benchmark bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: Bench+ build-depends:+ base >= 4 && < 5,+ criterion,+ deepseq,+ product-profunctors