diff --git a/Bench/Main.hs b/Bench/Main.hs new file mode 100644 --- /dev/null +++ b/Bench/Main.hs @@ -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) + ] diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/Data/Profunctor/Product.hs b/Data/Profunctor/Product.hs --- a/Data/Profunctor/Product.hs +++ b/Data/Profunctor/Product.hs @@ -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 +-- } diff --git a/Data/Profunctor/Product/Adaptor.hs b/Data/Profunctor/Product/Adaptor.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Adaptor.hs @@ -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 diff --git a/Data/Profunctor/Product/Class.hs b/Data/Profunctor/Product/Class.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Class.hs @@ -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') diff --git a/Data/Profunctor/Product/Default.hs b/Data/Profunctor/Product/Default.hs --- a/Data/Profunctor/Product/Default.hs +++ b/Data/Profunctor/Product/Default.hs @@ -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]) diff --git a/Data/Profunctor/Product/Default/Class.hs b/Data/Profunctor/Product/Default/Class.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Default/Class.hs @@ -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 diff --git a/Data/Profunctor/Product/Examples.hs b/Data/Profunctor/Product/Examples.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Examples.hs @@ -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 +-- () +-- +-- @ +-- > 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) diff --git a/Data/Profunctor/Product/Flatten.hs b/Data/Profunctor/Product/Flatten.hs --- a/Data/Profunctor/Product/Flatten.hs +++ b/Data/Profunctor/Product/Flatten.hs @@ -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] diff --git a/Data/Profunctor/Product/Internal/Adaptor.hs b/Data/Profunctor/Product/Internal/Adaptor.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Internal/Adaptor.hs @@ -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 diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Internal/TH.hs @@ -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 [] diff --git a/Data/Profunctor/Product/Newtype.hs b/Data/Profunctor/Product/Newtype.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Newtype.hs @@ -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 diff --git a/Data/Profunctor/Product/TH.hs b/Data/Profunctor/Product/TH.hs --- a/Data/Profunctor/Product/TH.hs +++ b/Data/Profunctor/Product/TH.hs @@ -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 diff --git a/Data/Profunctor/Product/Tuples.hs b/Data/Profunctor/Product/Tuples.hs --- a/Data/Profunctor/Product/Tuples.hs +++ b/Data/Profunctor/Product/Tuples.hs @@ -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] diff --git a/Data/Profunctor/Product/Tuples/TH.hs b/Data/Profunctor/Product/Tuples/TH.hs new file mode 100644 --- /dev/null +++ b/Data/Profunctor/Product/Tuples/TH.hs @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# product-profunctors [![Hackage version](https://img.shields.io/hackage/v/product-profunctors.svg?label=Hackage)](https://hackage.haskell.org/package/product-profunctors) [![Build status](https://img.shields.io/github/workflow/status/tomjaguarpaw/product-profunctors/ci/master.svg)](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 diff --git a/Test/CheckTypes.hs b/Test/CheckTypes.hs --- a/Test/CheckTypes.hs +++ b/Test/CheckTypes.hs @@ -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 diff --git a/Test/Definitions.hs b/Test/Definitions.hs --- a/Test/Definitions.hs +++ b/Test/Definitions.hs @@ -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 diff --git a/Test/DefinitionsUndecidable.hs b/Test/DefinitionsUndecidable.hs new file mode 100644 --- /dev/null +++ b/Test/DefinitionsUndecidable.hs @@ -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) diff --git a/Test/Main.hs b/Test/Main.hs --- a/Test/Main.hs +++ b/Test/Main.hs @@ -1,4 +1,4 @@ -import CheckTypes +import CheckTypes () main :: IO () main = return () diff --git a/product-profunctors.cabal b/product-profunctors.cabal --- a/product-profunctors.cabal +++ b/product-profunctors.cabal @@ -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