product-profunctors 0.8.0.3 → 0.9.0.0

raw patch · 15 files changed

+628/−21 lines, 15 filesdep +bifunctorsdep +criteriondep +deepseqdep ~basedep ~profunctorsPVP ok

version bump matches the API change (PVP)

Dependencies added: bifunctors, criterion, deepseq

Dependency ranges changed: base, profunctors

API changes (from Hackage documentation)

Files

• Bench/Main.hs +59/−0
• CHANGELOG.md +11/−0
• Data/Profunctor/Product.hs +74/−9
• Data/Profunctor/Product/Adaptor.hs +53/−0
• Data/Profunctor/Product/Class.hs +5/−0
• Data/Profunctor/Product/Default/Class.hs +107/−1
• Data/Profunctor/Product/Internal/Adaptor.hs +135/−0
• Data/Profunctor/Product/TH.hs +1/−1
• LICENSE +1/−1
• README.md +11/−0
• Test/CheckTypes.hs +38/−1
• Test/Definitions.hs +33/−1
• Test/DefinitionsUndecidable.hs +74/−0
• Test/Main.hs +1/−1
• product-profunctors.cabal +25/−6

@@ -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)+  ]

@@ -0,0 +1,11 @@+# 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

@@ -1,16 +1,28 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell   #-}+ module Data.Profunctor.Product (module Data.Profunctor.Product.Class,                                 module Data.Profunctor.Product.Newtype,                                 module Data.Profunctor.Product) where  import Prelude hiding (id)-import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow)+import Data.Profunctor (Profunctor, dimap, lmap, WrappedArrow, Star(..), Costar) import qualified Data.Profunctor as Profunctor+import Data.Profunctor.Composition (Procompose(..)) import Data.Functor.Contravariant (Contravariant, contramap)+import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable, chosen) import Control.Category (id)-import Control.Arrow (Arrow, (***), (<<<), arr, (&&&))-import Control.Applicative (Applicative, liftA2, pure, (<*>))+import Control.Arrow (Arrow, (***), (<<<), arr, (&&&), 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@@ -81,15 +93,68 @@   empty  = id   (***!) = (***) --- { Sum+instance ProductProfunctor Tagged where+  purePP = pure+  (****) = (<*>) -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 Applicative f => ProductProfunctor (Star f) where+  purePP = pure+  (****) = (<*>) +instance Functor f => ProductProfunctor (Costar f) where+  purePP = pure+  (****) = (<*>)++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 (Functor f, Applicative g, ProductProfunctor p) => ProductProfunctor (Biff p f g) where+  purePP = Biff . purePP . pure+  Biff abc **** Biff ab = Biff $ (<*>) ***$ abc **** ab++instance Applicative f => ProductProfunctor (Joker f) where+  purePP = Joker . pure+  Joker bc **** Joker b = Joker $ bc <*> b++instance Divisible f => ProductProfunctor (Clown f) where+  purePP _ = Clown conquer+  Clown l **** Clown r = Clown $ divide (\a -> (a, a)) l r++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 (Applicative f, ProductProfunctor p) => ProductProfunctor (Tannen f p) where+  purePP = Tannen . pure . purePP+  Tannen f **** Tannen a = Tannen $ liftA2 (****) f a++-- { Sum+ 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)++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

@@ -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

@@ -81,3 +81,8 @@   (***!) :: 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')

@@ -1,6 +1,112 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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

@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}+{-# 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+#if __GLASGOW_HASKELL__ < 800+  type Unzip (z :: Select) a :: k+  type Unzip z a = a++instance Unzippable (f :: * -> k') => Unzippable (f a) where+  type Unzip z (f a) = Unzip z f (Project z a)+#else++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+#endif++-- 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

@@ -138,7 +138,7 @@ -- | For example -- -- @--- \$(makeAdaptorAndInstance ''Foo)+-- \$(makeAdaptorAndInstance' ''Foo) -- @ -- -- generates the 'Default' instance and the adaptor @pFoo@.  The name

@@ -1,4 +1,4 @@-Copyright (c) 2013, Karamaan Group LLC; 2014-2017 Purely Agile Limited+Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited  All rights reserved. 

@@ -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) [![Linux Build Status](https://img.shields.io/travis/tomjaguarpaw/product-profunctors.svg?label=Linux%20build)](https://travis-ci.org/tomjaguarpaw/product-profunctors)++## 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

@@ -1,12 +1,17 @@+{-# 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,                     RecordDefaultName,                     pData2, pData3, pRecord2, pRecord3,                     pRecordDefaultName)+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@@ -48,5 +53,37 @@                  => 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 :: 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++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

@@ -1,25 +1,57 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-}  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 (ProductProfunctor, SumProfunctor)+import Data.Profunctor.Product.Adaptor (Unzippable)+import Data.Profunctor.Product.Default (Default) import Data.Profunctor.Product.TH (makeAdaptorAndInstance, makeAdaptorAndInstance')  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+$(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')

@@ -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)

@@ -1,4 +1,4 @@-import CheckTypes+import CheckTypes ()  main :: IO () main = return ()

@@ -1,9 +1,10 @@ name:          product-profunctors-copyright:     Copyright (c) 2013, Karamaan Group LLC; 2014-2017 Purely Agile Limited-version:       0.8.0.3+copyright:     Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited+version:       0.9.0.0 synopsis:      product-profunctors description:   Product profunctors homepage:      https://github.com/tomjaguarpaw/product-profunctors+bug-reports:   https://github.com/tomjaguarpaw/product-profunctors/issues license:       BSD3 license-file:  LICENSE author:        Purely Agile@@ -11,22 +12,28 @@ category:      Control, Category build-type:    Simple cabal-version: >= 1.18-tested-with:   GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+tested-with:   GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3+extra-doc-files:+    README.md+    CHANGELOG.md  source-repository head   type:     git-  location: https://github.com/tomjaguarpaw/product-profunctors+  location: https://github.com/tomjaguarpaw/product-profunctors.git  library   default-language: Haskell2010   build-depends:   base >= 4.5 && < 5-                 , profunctors >= 4.0 && < 5.3+                 , profunctors   >= 5   && < 5.3+                 , bifunctors    >= 5.4 && < 6.0                  , contravariant >= 0.4 && < 1.5                  , tagged >= 0.0 && < 1                  , template-haskell   exposed-modules: Data.Profunctor.Product,+                   Data.Profunctor.Product.Adaptor                    Data.Profunctor.Product.Default,                    Data.Profunctor.Product.Flatten,+                   Data.Profunctor.Product.Internal.Adaptor                    Data.Profunctor.Product.Internal.TH,                    Data.Profunctor.Product.Newtype,                    Data.Profunctor.Product.TH,@@ -44,10 +51,22 @@   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