product-profunctors 0.10.0.1 → 0.11.0.0

raw patch · 10 files changed

+264/−101 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• Data/Profunctor/Product/Default.hs +2/−0
• Data/Profunctor/Product/Examples.hs +59/−1
• Data/Profunctor/Product/Internal/Adaptor.hs +0/−9
• Data/Profunctor/Product/Internal/TH.hs +68/−56
• Data/Profunctor/Product/TH.hs +39/−25
• Data/Profunctor/Product/Tuples/TH.hs +16/−5
• Test/CheckTypes.hs +26/−1
• Test/Definitions.hs +45/−3
• product-profunctors.cabal +1/−1

@@ -1,3 +1,11 @@+# 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.++# 0.10.0.1+ * Added `Data.Profunctor.Product.Examples`  # 0.10.0.0

@@ -1,6 +1,8 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,              FlexibleContexts, PolyKinds, TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  -- | For some 'Data.Profunctor.Product.ProductProfunctor's @p@ and -- types @a@, @a'@ there is a unique most sensible value of @p a a'@.

@@ -2,13 +2,15 @@ {-# 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, (<*>))+import           Control.Applicative             (Applicative, liftA2, pure, (<*>),+                                                  ZipList(ZipList), getZipList)  newtype Replicator r f a b = Replicator (r -> f b)   deriving Functor@@ -97,9 +99,27 @@  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 @@ -115,3 +135,41 @@ instance Applicative f => PP.ProductProfunctor (Traverse f) where   purePP = pure   (****) = (<*>)++newtype Zipper a b = Zipper { unZipper :: Traverse ZipList a b }+  deriving Functor++instance a ~ b => D.Default Zipper [a] b where+  def = Zipper (P.dimap ZipList id D.def)++-- { Boilerplate++instance P.Profunctor Zipper where+  dimap f g = Zipper . P.dimap f g . unZipper++instance Applicative (Zipper a) where+  pure = Zipper . pure+  f <*> x = Zipper ((<*>) (unZipper f) (unZipper x))++instance PP.ProductProfunctor Zipper where+  purePP = pure+  (****) = (<*>)++-- }++-- | A challenge from a Clojurist on Hacker News+-- (https://news.ycombinator.com/item?id=23939350)+--+-- @+-- > cl_map (uncurry (+)) ([1,2,3], [4,5,6])+-- [5,7,9]+--+-- > cl_map (+3) [1,2,3]+-- [4,5,6]+--+-- > let max3 (x, y, z) = x `max` y `max` z+-- > cl_map max3 ([1,20], [3,4], [5,6])+-- [5,20]+-- @+cl_map :: D.Default Zipper a b => (b -> r) -> a -> [r]+cl_map f = getZipList . fmap f . runTraverse (unZipper D.def)

@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -68,14 +67,7 @@ -- 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@@ -83,7 +75,6 @@ -- | 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

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-}  module Data.Profunctor.Product.Internal.TH where@@ -12,26 +13,32 @@                             Con(RecC, NormalC),                             Clause(Clause),                             Type(VarT, ForallT, AppT, ConT),-                            Body(NormalB), Q, classP,+                            Body(NormalB), Q,                             Exp(ConE, VarE, AppE, TupE, LamE),                             Pat(TupP, VarP, ConP), Name,-                            Info(TyConI), reify, conE, conT, varE, varP,-                            instanceD)+                            Info(TyConI), reify, conE, appT, conT, varE, varP,+                            instanceD, Overlap(Incoherent), Pred) import Control.Monad ((<=<)) import Control.Applicative (pure, liftA2, (<$>), (<*>))-import Control.Arrow (second) -makeAdaptorAndInstanceI :: Maybe String -> Name -> Q [Dec]-makeAdaptorAndInstanceI adaptorNameM = returnOrFail <=< r makeAandIE <=< reify+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 adaptorNameM+        makeAandIE = makeAdaptorAndInstanceE sides adaptorNameM+        sides = case inferrable of+          True  -> [Just (Left ()), Just (Right ())]+          False -> [Nothing]  type Error = String -makeAdaptorAndInstanceE :: Maybe String -> Info -> Either Error (Q [Dec])-makeAdaptorAndInstanceE adaptorNameM info = do+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@@ -47,8 +54,9 @@         ConTys   _        -> adaptorDefinition numTyVars conName         FieldTys fieldTys -> adaptorDefinitionFields conName fieldTys -      instanceDefinition' = instanceDefinition tyName numTyVars numConTys-                                               adaptorNameN conName+      instanceDefinition' = map (\side ->+        instanceDefinition side tyName numTyVars numConTys adaptorNameN conName)+        sides        newtypeInstance' = if numConTys == 1 then                            newtypeInstance conName tyName@@ -56,9 +64,9 @@                            return []    return $ do-    as <- sequence [ adaptorSig'-                   , adaptorDefinition' adaptorNameN-                   , instanceDefinition']+    as <- sequence ( [ adaptorSig'+                     , adaptorDefinition' adaptorNameN ]+                   ++ instanceDefinition' )     ns <- newtypeInstance'     return (as ++ ns) @@ -90,11 +98,7 @@   }  dataDecStuffOfInfo :: Info -> Either Error DataDecStuff-#if __GLASGOW_HASKELL__ >= 800 dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars _kind constructors _deriving)) =-#else-dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) =-#endif   do     (conName, conTys) <- extractConstructorStuff constructors     let tyVars' = map varNameOfBinder tyVars@@ -104,11 +108,7 @@                         , dConTys  = conTys                         } -#if __GLASGOW_HASKELL__ >= 800 dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars _kind constructor _deriving)) =-#else-dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars constructor _deriving)) =-#endif   do     (conName, conTys) <- extractConstructorStuff [constructor]     let tyVars' = map varNameOfBinder tyVars@@ -124,54 +124,63 @@ varNameOfBinder (KindedTV n _) = n  conStuffOfConstructor :: Con -> Either Error (Name, ConTysFields)-conStuffOfConstructor (NormalC conName st) = do-  return (conName, ConTys (map snd st))-conStuffOfConstructor (RecC conName vst) = do-  return (conName, FieldTys (map (\(n, _, t) -> (n, t)) vst))--conStuffOfConstructor _ = Left "I can't deal with your constructor type"+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 [single] = return single-constructorOfConstructors [] = Left "I need at least one constructor"-constructorOfConstructors _many =-  Left "I can't deal with more than one constructor"+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 :: Name -> Int -> Int -> Name -> Name -> Q Dec-instanceDefinition tyName' numTyVars numConVars adaptorName' conName=instanceDec+instanceDefinition :: Maybe (Either () ())+                   -> Name+                   -> Int+                   -> Int+                   -> Name+                   -> Name+                   -> Q Dec+instanceDefinition side tyName' numTyVars numConVars adaptorName' conName =+  instanceDec   where instanceDec = liftA2-#if __GLASGOW_HASKELL__ >= 800-            (\i j -> InstanceD Nothing i j [defDefinition])-#else-            (\i j -> InstanceD i j [defDefinition])-#endif+            (\i j -> InstanceD (Incoherent <$ side) i j [defDefinition])             instanceCxt instanceType-        p = varTS "p"+        p :: Applicative m => m Type+        p = pure $ varTS "p"+        x = pure $ varTS "x" -        instanceCxt = mapM (uncurry classP) (pClass:defClasses)-        pClass :: Monad m => (Name, [m Type])-        pClass = (''ProductProfunctor, [return p])+        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) -        defaultPredOfVar :: String -> (Name, [Type])-        defaultPredOfVar fn = (''Default, [p,-                                           mkTySuffix "0" fn,-                                           mkTySuffix "1" fn])+        productProfunctor_p :: Q Pred+        productProfunctor_p = classP ''ProductProfunctor [p] -        defClasses = map (second (map return) . defaultPredOfVar)-                         (allTyVars numTyVars)+        (typeMatch, pArg0, pArg1) = case side of+            Nothing ->         ([],                       tyName0, tyName1)+            Just (Left ())  -> ([ [t| $x ~ $tyName0 |] ], x,       tyName1)+            Just (Right ()) -> ([ [t| $x ~ $tyName1 |] ], tyName0, x) -        pArg :: String -> Type-        pArg s = pArg' tyName' s numTyVars+        tyName0 = tyName "0"+        tyName1 = tyName "1" -        instanceType = [t| $(conT ''Default)-                           $(pure $ p)-                           $(pure $ pArg "0")-                           $(pure $ pArg "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)@@ -310,6 +319,9 @@         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

@@ -1,5 +1,3 @@-{-# LANGUAGE TemplateHaskell #-}- -- | If you have a data declaration which is a polymorphic product, -- for example --@@ -18,7 +16,7 @@ -- \"adaptor\" with the following splice: -- -- @--- \$(makeAdaptorAndInstance \"pFoo\" ''Foo)+-- \$('makeAdaptorAndInstanceInferrable' \"pFoo\" ''Foo) -- @ -- -- The adaptor for a type @Foo@ is by convention called @pFoo@, but in@@ -26,7 +24,7 @@ -- the name @pFoo@ yourself you can use -- -- @--- \$(makeAdaptorAndInstance' ''Foo)+-- \$('makeAdaptorAndInstanceInferrable'' ''Foo) -- @ -- -- and it will be named @pFoo@ automatically.@@ -34,7 +32,7 @@ -- @pFoo@ will have the type -- -- @--- pFoo :: ProductProfunctor p+-- 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') -- @@@ -42,7 +40,7 @@ -- and the instance generated will be -- -- @--- instance (ProductProfunctor p, Default p a a', Default p b b', Default p c c')+-- 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') -- @ --@@ -51,7 +49,7 @@ -- (its implementation is given below). -- -- @--- pFooApplicative :: Applicative f+-- pFooApplicative :: 'Control.Applicative.Applicative' f --                 => Foo (f a) (f b) (f c) --                 -> f (Foo a b c) -- @@@ -91,32 +89,32 @@ -- @Applicative@ case.  For an @Applicative@ we would write -- -- @--- pFooApplicative :: Applicative f+-- pFooApplicative :: 'Control.Applicative.Applicative' f --                 => Foo (f a) (f b) (f c) -> f (Foo a b c)--- pFooApplicative f = Foo \<$\> foo f---                         \<*\> bar f---                         \<*\> baz f+-- pFooApplicative f = Foo 'Control.Applicative.<$>' foo f+--                         'Control.Applicative.<*>' bar f+--                         'Control.Applicative.<*>' baz f -- @ -- -- whereas for a @ProductProfunctor@ we write -- -- @--- import Data.Profunctor (lmap)--- import Data.Profunctor.Product ((***$), (****))+-- import "Data.Profunctor" ('Data.Profunctor.lmap')+-- import "Data.Profunctor.Product" (('Data.Profunctor.Product.***$'), ('Data.Profunctor.Product.****')) ----- pFoo :: ProductProfunctor p+-- 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 ***$ lmap foo (foo f)---              **** lmap bar (bar f)---              **** lmap baz (baz f)+-- 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 (ProductProfunctor p, Default p a a', Default p b b', Default p c c')---       => Default p (Foo a b c) (Foo a' b' c') where---     def = pFoo (Foo def def def)+-- 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') -- @  @@ -128,21 +126,37 @@ -- | For example -- -- @--- \$(makeAdaptorAndInstance \"pFoo\" ''Foo)+-- \$(makeAdaptorAndInstanceInferrable \"pFoo\" ''Foo) -- @ -- -- generates the 'Default' instance and the adaptor @pFoo@.-makeAdaptorAndInstance :: String -> TH.Name -> TH.Q [TH.Dec]-makeAdaptorAndInstance adaptorNameS = makeAdaptorAndInstanceI (Just adaptorNameS)+makeAdaptorAndInstanceInferrable :: String -> TH.Name -> TH.Q [TH.Dec]+makeAdaptorAndInstanceInferrable adaptorNameS =+  makeAdaptorAndInstanceI True (Just adaptorNameS)  -- | For example -- -- @--- \$(makeAdaptorAndInstance' ''Foo)+-- \$(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++-- | 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)++-- | 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 Nothing+makeAdaptorAndInstance' =+  makeAdaptorAndInstanceI False Nothing

@@ -151,12 +151,21 @@ convert u u' f c = dimap u f . c . u'  mkDefaultNs :: [Int] -> Q [Dec]-mkDefaultNs = mapM mkDefaultN+mkDefaultNs = fmap concat . mapM mkDefaultN -mkDefaultN :: Int -> Q Dec-mkDefaultN n = instanceD (sequence (productProfunctor p : mkDefs))-                         (conT ''Default `appT` varT p `appT` mkTupT as `appT` mkTupT bs)-                         [mkFun]+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 (\a b -> default_ p a b) as bs     mkTupT = foldl appT (tupleT n) . map varT@@ -165,6 +174,8 @@       0 -> varE 'empty       _ -> varE (mkName $ 'p':show n) `appE` tupE (replicate n (varE '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 ..] ] 

@@ -9,8 +9,11 @@  import Definitions (Data2, Data3, Record2, Record3,                     RecordDefaultName,+                    Data2Inferrable(Data2Inferrable),+                    Record2Inferrable(Record2Inferrable),                     pData2, pData3, pRecord2, pRecord3,-                    pRecordDefaultName)+                    pRecordDefaultName,+                    unArrow, Unit(Unit), point) import DefinitionsUndecidable ()  -- The test suite checks that the TH derived adaptor is of the correct@@ -74,6 +77,28 @@ 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

@@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}  module Definitions where @@ -12,10 +14,12 @@ -- because we want to ensure that no external names are required to be -- imported. -import Data.Profunctor.Product (ProductProfunctor, SumProfunctor)+import Data.Profunctor+import Data.Profunctor.Product import Data.Profunctor.Product.Adaptor (Unzippable)-import Data.Profunctor.Product.Default (Default)-import Data.Profunctor.Product.TH (makeAdaptorAndInstance, makeAdaptorAndInstance')+import Data.Profunctor.Product.Default (Default, def)+import Data.Profunctor.Product.TH (makeAdaptorAndInstance, makeAdaptorAndInstance',+                                  makeAdaptorAndInstanceInferrable)  data Data2 a b = Data2 a b   deriving Generic@@ -55,3 +59,41 @@  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

@@ -1,6 +1,6 @@ name:          product-profunctors copyright:     Copyright (c) 2013, Karamaan Group LLC; 2014-2018 Purely Agile Limited; 2019-2020 Tom Ellis-version:       0.10.0.1+version:       0.11.0.0 synopsis:      product-profunctors description:   Product profunctors and tools for working with them homepage:      https://github.com/tomjaguarpaw/product-profunctors