Hello community, here is the log from the commit of package ghc-product-profunctors for openSUSE:Factory checked in at 2017-08-31 20:48:44 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-product-profunctors (Old) and /work/SRC/openSUSE:Factory/.ghc-product-profunctors.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-product-profunctors" Thu Aug 31 20:48:44 2017 rev:2 rq:513454 version:0.8.0.3 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-product-profunctors/ghc-product-profunctors.changes 2016-11-15 17:56:56.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-product-profunctors.new/ghc-product-profunctors.changes 2017-08-31 20:48:45.620325606 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:06:27 UTC 2017 - psimons@suse.com + +- Update to version 0.8.0.3. + +------------------------------------------------------------------- Old: ---- 1.cabal product-profunctors-0.7.1.0.tar.gz New: ---- product-profunctors-0.8.0.3.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-product-profunctors.spec ++++++ --- /var/tmp/diff_new_pack.xm01jw/_old 2017-08-31 20:48:46.580190873 +0200 +++ /var/tmp/diff_new_pack.xm01jw/_new 2017-08-31 20:48:46.588189750 +0200 @@ -1,7 +1,7 @@ # # spec file for package ghc-product-profunctors # -# Copyright (c) 2016 SUSE LINUX GmbH, Nuernberg, Germany. +# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,23 +19,20 @@ %global pkg_name product-profunctors %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.7.1.0 +Version: 0.8.0.3 Release: 0 Summary: Product-profunctors License: BSD-3-Clause -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-contravariant-devel BuildRequires: ghc-profunctors-devel BuildRequires: ghc-rpm-macros BuildRequires: ghc-tagged-devel BuildRequires: ghc-template-haskell-devel BuildRoot: %{_tmppath}/%{name}-%{version}-build -# End cabal-rpm deps %description Product profunctors. @@ -54,22 +51,15 @@ %prep %setup -q -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal - %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache ++++++ product-profunctors-0.7.1.0.tar.gz -> product-profunctors-0.8.0.3.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Class.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Class.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Class.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Class.hs 2017-02-25 23:59:20.000000000 +0100 @@ -1,12 +1,83 @@ module Data.Profunctor.Product.Class where -import Data.Profunctor (Profunctor) +import Data.Profunctor (Profunctor) +import qualified Data.Profunctor as Profunctor --- | A 'ProductProfunctor' is a generalization of an 'Applicative'. --- It has an "input", contravariant type parameter on the left as well --- as the usual 'Applicative' "output", covariant parameter on teh --- right. +-- | 'ProductProfunctor' is a generalization of 'Applicative'. +-- +-- It has the usual 'Applicative' "output" (covariant) parameter on +-- the right. Additionally it has an "input" (contravariant) type +-- parameter on the left. +-- +-- You will find it easier to see the correspondence between +-- 'ProductProfunctor' and 'Applicative' if you look at @purePP@, +-- @(***$)@, and @(****)@, which correspond to @pure@, @(\<$\>)@, and +-- @(\<*\>)@ respectively. +-- +-- @ +-- | Correspondence between Applicative and ProductProfunctor +-- | +-- | Applicative f ProductProfunctor p +-- | +-- | pure purePP +-- | :: b -> f b :: b -> p a b +-- | +-- | (\<$\>) (***$) +-- | :: (b -> b') :: (b -> b') +-- | -> f b -> p a b +-- | -> f b' -> p a b' +-- | +-- | (\<*\>) (****) +-- | :: f (b -> b') :: p a (b -> b') +-- | -> f b -> p a b +-- | -> f b' -> p a b' +-- @ +-- +-- It's easy to make instances of 'ProductProfunctor'. Just make +-- instances +-- +-- @ +-- instance Profunctor MyProductProfunctor where +-- ... +-- +-- instance Applicative (MyProductProfunctor a) where +-- ... +-- @ +-- +-- and then write +-- +-- @ +-- instance ProductProfunctor MyProductProfunctor where +-- purePP = pure +-- (****) = (\<*\>) +-- @ class Profunctor p => ProductProfunctor p where - empty :: p () () - (***!) :: p a b -> p a' b' -> p (a, a') (b, b') + -- | 'purePP' is the generalisation of @Applicative@'s @pure@. + -- + -- Aside from defining 'ProductProfunctor' instances you will + -- probably never need to use this; @pure@ should be sufficient (if + -- your 'ProductProfunctor' instance also has an @Applicative@ + -- instance). + purePP :: b -> p a b + purePP b = Profunctor.dimap (const ()) (const b) empty + + -- | '****' is the generalisation of @Applicative@'s @\<*\>@. + -- + -- Aside from defining 'ProductProfunctor' instances you will you + -- will probably never need to use this; @\<*\>@ should be + -- sufficient (if your 'ProductProfunctor' instance has also been + -- given an @Applicative@ instance). + (****) :: p a (b -> c) -> p a b -> p a c + (****) f x = Profunctor.dimap dup (uncurry ($)) (f ***! x) + where dup y = (y, y) + -- | You probably never want to use 'empty' and it may be deprecated + -- in a future version. + empty :: p () () + empty = purePP () + + -- | You probably never want to use '***!' and it 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Default.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Default.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Default.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Default.hs 2017-02-25 23:59:20.000000000 +0100 @@ -17,6 +17,7 @@ import Data.Profunctor.Product.Default.Class import Data.Profunctor.Product.Tuples.TH (mkDefaultNs, maxTupleSize) +-- | This will be deprecated in a future version cdef :: Default (PPOfContravariant u) a a => u a cdef = unPPOfContravariant def diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Internal/TH.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Internal/TH.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Internal/TH.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Internal/TH.hs 2017-02-25 23:59:20.000000000 +0100 @@ -3,8 +3,8 @@ module Data.Profunctor.Product.Internal.TH where -import Data.Profunctor (dimap) -import Data.Profunctor.Product +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), @@ -31,17 +31,27 @@ makeAdaptorAndInstanceE :: Maybe String -> Info -> Either Error (Q [Dec]) makeAdaptorAndInstanceE adaptorNameM info = do - (tyName, tyVars, conName, conTys) <- dataDecStuffOfInfo info - let numTyVars = length tyVars - numConTys = length conTys + 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' = adaptorDefinition numTyVars conName adaptorNameN + adaptorDefinition' = + case conTys of ConTys _ -> + adaptorDefinition numTyVars conName adaptorNameN + FieldTys fieldTys -> + adaptorDefinitionFields conName fieldTys adaptorNameN + instanceDefinition' = instanceDefinition tyName numTyVars numConTys adaptorNameN conName - newtypeInstance' = if length conTys == 1 then + newtypeInstance' = if numConTys == 1 then newtypeInstance conName tyName else return [] @@ -63,7 +73,23 @@ return [InstanceD [] (ConT ''N.Newtype `AppT` ConT tyName) body] #endif -dataDecStuffOfInfo :: Info -> Either Error (Name, [Name], Name, [Name]) +data ConTysFields = ConTys [Name] + -- ^^ The type of each constructor field + | FieldTys [(Name, Name)] + -- ^^ 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 #if __GLASGOW_HASKELL__ >= 800 dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars _kind constructors _deriving)) = #else @@ -72,7 +98,12 @@ do (conName, conTys) <- extractConstructorStuff constructors let tyVars' = map varNameOfBinder tyVars - return (tyName, tyVars', conName, conTys) + return DataDecStuff { dTyName = tyName + , dTyVars = tyVars' + , dConName = conName + , dConTys = conTys + } + #if __GLASGOW_HASKELL__ >= 800 dataDecStuffOfInfo (TyConI (NewtypeD _cxt tyName tyVars _kind constructor _deriving)) = #else @@ -81,25 +112,31 @@ do (conName, conTys) <- extractConstructorStuff [constructor] let tyVars' = map varNameOfBinder tyVars - return (tyName, tyVars', conName, conTys) + return DataDecStuff { dTyName = tyName + , dTyVars = tyVars' + , dConName = conName + , dConTys = conTys + } dataDecStuffOfInfo _ = Left "That doesn't look like a data or newtype declaration to me" varNameOfType :: Type -> Either Error Name varNameOfType (VarT n) = Right n -varNameOfType x = Left $ "Found a non-variable type" ++ show x +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 :: Con -> Either Error (Name, ConTysFields) conStuffOfConstructor (NormalC conName st) = do conTys <- mapM (varNameOfType . snd) st - return (conName, conTys) + return (conName, ConTys conTys) conStuffOfConstructor (RecC conName vst) = do - conTys <- mapM (varNameOfType . thrd) vst - return (conName, conTys) - where thrd = \(_,_,x) -> x + conTys <- mapM nameType vst + return (conName, FieldTys conTys) + where nameType (n, _, VarT t) = Right (n, t) + nameType (_, _, x) = Left ("Found a non-variable type " ++ show x) + conStuffOfConstructor _ = Left "I can't deal with your constructor type" constructorOfConstructors :: [Con] -> Either Error Con @@ -108,7 +145,7 @@ constructorOfConstructors _many = Left "I can't deal with more than one constructor" -extractConstructorStuff :: [Con] -> Either Error (Name, [Name]) +extractConstructorStuff :: [Con] -> Either Error (Name, ConTysFields) extractConstructorStuff = conStuffOfConstructor <=< constructorOfConstructors instanceDefinition :: Name -> Int -> Int -> Name -> Name -> Q Dec @@ -203,6 +240,33 @@ 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 @@ -221,6 +285,26 @@ wheres = [toTuple conName (toTupleN, numConVars), fromTuple conName (fromTupleN, numConVars)] +adaptorDefinitionFields :: Name -> [(Name, name)] -> Name -> Dec +adaptorDefinitionFields conName fieldsTys adaptorName = + FunD adaptorName [clause] + where fields = map fst fieldsTys + -- TODO: vv f should be generated in Q + fP = VarP (mkName "f") + fE = VarE (mkName "f") + clause = Clause [fP] (NormalB body) [] + body = case fields of + [] -> error "Can't handle no fields in constructor" + field1:fields' -> let first = (VarE '(***$)) `AppE` (ConE conName) + `AppE` (theLmap field1) + app x y = (VarE '(****)) `AppE` x + `AppE` (theLmap y) + in foldl app first fields' + + theLmap field = appEAll (VarE 'lmap) + [ VarE field + , VarE field `AppE` fE ] + xTuple :: ([Pat] -> Pat) -> ([Exp] -> Exp) -> (Name, Int) -> Dec xTuple patCon retCon (funN, numTyVars) = FunD funN [clause] where clause = Clause [pat] body [] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/TH.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/TH.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/TH.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/TH.hs 2017-02-25 23:59:20.000000000 +0100 @@ -18,7 +18,7 @@ -- \"adaptor\" with the following splice: -- -- @ --- $(makeAdaptorAndInstance \"pFoo\" ''Foo) +-- \$(makeAdaptorAndInstance \"pFoo\" ''Foo) -- @ -- -- The adaptor for a type @Foo@ is by convention called @pFoo@, but in @@ -26,7 +26,7 @@ -- the name @pFoo@ yourself you can use -- -- @ --- $(makeAdaptorAndInstance' ''Foo) +-- \$(makeAdaptorAndInstance' ''Foo) -- @ -- -- and it will be named @pFoo@ automatically. @@ -34,8 +34,9 @@ -- @pFoo@ will have the type -- -- @ --- pFoo :: ProductProfunctor p => --- Foo (p a a') (p b b') (p c c') -> p (Foo a b c) (Foo a' b' c') +-- pFoo :: 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 @@ -50,8 +51,9 @@ -- (its implementation is given below). -- -- @ --- pFooApplicative :: Applicative f => --- Foo (f a) (f b) (f c) -> f (Foo a b c) +-- pFooApplicative :: Applicative f +-- => Foo (f a) (f b) (f c) +-- -> f (Foo a b c) -- @ -- -- The product-profunctor \"adaptor\" (in this case @pFoo@) is a @@ -77,7 +79,7 @@ -- @ -- instance 'N.Newtype' Foo where -- 'N.constructor' = Foo --- 'N.field' = \(Foo x) -> x +-- 'N.field' = \\(Foo x) -> x -- @ -- -- which allows you to use the polymorphic function 'N.pNewtype' @@ -85,7 +87,7 @@ -- -- 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 you would do in the more familiar +-- very closely to what we would do in the more familiar -- @Applicative@ case. For an @Applicative@ we would write -- -- @ @@ -126,7 +128,7 @@ -- | For example -- -- @ --- $(makeAdaptorAndInstance \"pFoo\" ''Foo) +-- \$(makeAdaptorAndInstance \"pFoo\" ''Foo) -- @ -- -- generates the 'Default' instance and the adaptor @pFoo@. @@ -136,7 +138,7 @@ -- | For example -- -- @ --- $(makeAdaptorAndInstance ''Foo) +-- \$(makeAdaptorAndInstance ''Foo) -- @ -- -- generates the 'Default' instance and the adaptor @pFoo@. The name diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Tuples/TH.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Tuples/TH.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Tuples/TH.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Tuples/TH.hs 2017-02-25 23:59:20.000000000 +0100 @@ -14,6 +14,7 @@ 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 @@ -37,12 +38,18 @@ pTns :: [Int] -> Q [Dec] pTns = fmap concat . mapM pTn +productProfunctor :: Name -> Q Pred +productProfunctor p = classP ''ProductProfunctor [pure (VarT p)] + +default_ :: Name -> Name -> Name -> Q Pred +default_ p a b = classP ''Default (map (pure . VarT) [p, a, b]) + pTn :: Int -> Q [Dec] pTn n = sequence [sig, fun] where p = mkName "p" sig = sigD (pT n) (forallT (map PlainTV $ p : take n as ++ take n bs) - (pure [ConT ''ProductProfunctor `AppT` VarT p]) + (sequence [productProfunctor p]) (arrowT `appT` mkLeftTy `appT` mkRightTy) ) mkLeftTy = foldl appT (conT tN) @@ -115,7 +122,7 @@ pN n = sequence [sig, fun] where sig = sigD nm (forallT (map PlainTV $ p : as ++ bs) - (pure [ConT ''ProductProfunctor `AppT` VarT p]) + (sequence [productProfunctor p]) (arrowT `appT` mkLeftTy `appT` mkRightTy) ) mkLeftTy = case n of @@ -146,11 +153,11 @@ mkDefaultNs = mapM mkDefaultN mkDefaultN :: Int -> Q Dec -mkDefaultN n = instanceD (pure (ConT ''ProductProfunctor `AppT` VarT p : mkDefs)) +mkDefaultN n = instanceD (sequence (productProfunctor p : mkDefs)) (conT ''Default `appT` varT p `appT` mkTupT as `appT` mkTupT bs) [mkFun] where - mkDefs = zipWith (\a b -> ConT ''Default `AppT` VarT p `AppT` VarT a `AppT` VarT b) as bs + mkDefs = zipWith (\a b -> default_ p a b) as bs mkTupT = foldl appT (tupleT n) . map varT mkFun = funD 'def [clause [] bdy []] bdy = normalB $ case n of @@ -161,4 +168,4 @@ bs = take n [ mkName $ 'b':show i | i <- [0::Int ..] ] maxTupleSize :: Int -maxTupleSize = 35 +maxTupleSize = 62 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Tuples.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Tuples.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product/Tuples.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product/Tuples.hs 2017-02-25 23:59:20.000000000 +0100 @@ -1,6 +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 import Data.Profunctor.Product.Tuples.TH -mkTs [0..35] +mkTs [0..maxTupleSize] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/Data/Profunctor/Product.hs new/product-profunctors-0.8.0.3/Data/Profunctor/Product.hs --- old/product-profunctors-0.7.1.0/Data/Profunctor/Product.hs 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/Data/Profunctor/Product.hs 2017-02-25 23:59:20.000000000 +0100 @@ -9,7 +9,7 @@ import Data.Functor.Contravariant (Contravariant, contramap) import Control.Category (id) import Control.Arrow (Arrow, (***), (<<<), arr, (&&&)) -import Control.Applicative (Applicative, liftA2, pure) +import Control.Applicative (Applicative, liftA2, pure, (<*>)) import Data.Monoid (Monoid, mempty, (<>)) import Data.Profunctor.Product.Newtype @@ -63,65 +63,24 @@ -- Still, at least we now have default implementations of the class -- methods, which makes things simpler. --- This appears to be just 'Data.Functor.Contravariant.Divisible' -class Contravariant f => ProductContravariant f where - point :: f () - (***<) :: f a -> f b -> f (a, b) - --- | This is exactly the same as @Applicative@'s @\<*\>@, but for a --- 'ProductProfunctor'. -(****) :: ProductProfunctor p => p a (b -> c) -> p a b -> p a c -(****) f x = Profunctor.dimap dup (uncurry ($)) (f ***! x) - where dup y = (y, y) - --- | This is exactly 'Profunctor.rmap', given a name which highlights --- the similarity to @Applicative@'s @\<$\>@. +-- | '***$' is the generalisation of @Applicative@'s @\<$\>@. +-- +-- '***$' = 'Profunctor.rmap', just like '<$>' = 'fmap'. +-- +-- You will probably never need to use this; @\<$\>@ should be +-- sufficient (if your 'ProductProfunctor' instance has also been given +-- a @Functor@ instance). (***$) :: ProductProfunctor p => (b -> c) -> p a b -> p a c (***$) = Profunctor.rmap -defaultEmpty :: Applicative (p ()) => p () () -defaultEmpty = pure () - -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') - -defaultPoint :: Monoid (p ()) => p () -defaultPoint = mempty - -defaultContravariantProduct :: (Contravariant f, Monoid (f (a, b))) - => f a -> f b -> f (a, b) -defaultContravariantProduct p p' = contramap fst p <> contramap snd p' - -newtype PPOfContravariant f a b = PPOfContravariant (f a) - -unPPOfContravariant :: PPOfContravariant c a a -> c a -unPPOfContravariant (PPOfContravariant pp) = pp - -instance Contravariant f => Profunctor (PPOfContravariant f) where - dimap f _ (PPOfContravariant p) = PPOfContravariant (contramap f p) - -instance ProductContravariant f => ProductProfunctor (PPOfContravariant f) where - empty = PPOfContravariant point - PPOfContravariant f ***! PPOfContravariant f' = PPOfContravariant (f ***< f') - instance ProductProfunctor (->) where - empty = id - (***!) = (***) + purePP = pure + (****) = (<*>) instance Arrow arr => ProductProfunctor (WrappedArrow arr) where - empty = id + empty = id (***!) = (***) -data AndArrow arr z a b = AndArrow { runAndArrow :: arr z b } - -instance Arrow arr => Profunctor (AndArrow arr z) where - dimap _ f (AndArrow g) = AndArrow (arr f <<< g) - -instance Arrow arr => ProductProfunctor (AndArrow arr z) where - empty = AndArrow (arr (const ())) - (AndArrow f) ***! (AndArrow f') = AndArrow (f &&& f') - -- { Sum class Profunctor p => SumProfunctor p where @@ -132,6 +91,10 @@ instance SumProfunctor (->) where f +++! g = either (Left . f) (Right . g) +-- | 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] @@ -148,3 +111,57 @@ pTns [0..maxTupleSize] pNs [0..maxTupleSize] + +-- { Deprecated stuff + +-- | You probably never want to use 'defaultEmpty' and it may be +-- deprecated in a later version. +defaultEmpty :: Applicative (p ()) => p () () +defaultEmpty = pure () + +-- | You probably never want to use 'defaultProfunctorProduct' and it +-- may be deprecated in a later version. +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') + +-- | You probably never want to use 'defaultPoint' and it may be +-- deprecated in a later version. +defaultPoint :: Monoid (p ()) => p () +defaultPoint = mempty + +{-# DEPRECATED ProductContravariant "Use Data.Functor.Contravariant.Divisible instead" #-} +class Contravariant f => ProductContravariant f where + point :: f () + (***<) :: f a -> f b -> f (a, b) + +{-# DEPRECATED AndArrow "If you really need this, file an issue. It will go soon." #-} +data AndArrow arr z a b = AndArrow { runAndArrow :: arr z b } + +instance Arrow arr => Profunctor (AndArrow arr z) where + dimap _ f (AndArrow g) = AndArrow (arr f <<< g) + +instance Arrow arr => ProductProfunctor (AndArrow arr z) where + empty = AndArrow (arr (const ())) + (AndArrow f) ***! (AndArrow f') = AndArrow (f &&& f') + +{-# DEPRECATED defaultContravariantProduct "defaultContravariantProduct will be removed" #-} +defaultContravariantProduct :: (Contravariant f, Monoid (f (a, b))) + => f a -> f b -> f (a, b) +defaultContravariantProduct p p' = contramap fst p <> contramap snd p' + +{-# DEPRECATED PPOfContravariant "PPOfContravariant will be removed" #-} +newtype PPOfContravariant f a b = PPOfContravariant (f a) + +{-# DEPRECATED unPPOfContravariant "unPPOfContravariant will be removed" #-} +unPPOfContravariant :: PPOfContravariant c a a -> c a +unPPOfContravariant (PPOfContravariant pp) = pp + +instance Contravariant f => Profunctor (PPOfContravariant f) where + dimap f _ (PPOfContravariant p) = PPOfContravariant (contramap f p) + +instance ProductContravariant f => ProductProfunctor (PPOfContravariant f) where + empty = PPOfContravariant point + PPOfContravariant f ***! PPOfContravariant f' = PPOfContravariant (f ***< f') + +-- } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/LICENSE new/product-profunctors-0.8.0.3/LICENSE --- old/product-profunctors-0.7.1.0/LICENSE 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/LICENSE 2017-02-25 23:59:20.000000000 +0100 @@ -1,4 +1,4 @@ -Copyright (c) 2013, Karamaan Group LLC +Copyright (c) 2013, Karamaan Group LLC; 2014-2017 Purely Agile Limited All rights reserved. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/product-profunctors-0.7.1.0/product-profunctors.cabal new/product-profunctors-0.8.0.3/product-profunctors.cabal --- old/product-profunctors-0.7.1.0/product-profunctors.cabal 2016-05-28 09:39:24.000000000 +0200 +++ new/product-profunctors-0.8.0.3/product-profunctors.cabal 2017-02-25 23:59:20.000000000 +0100 @@ -1,21 +1,24 @@ name: product-profunctors -version: 0.7.1.0 +copyright: Copyright (c) 2013, Karamaan Group LLC; 2014-2017 Purely Agile Limited +version: 0.8.0.3 synopsis: product-profunctors description: Product profunctors homepage: https://github.com/tomjaguarpaw/product-profunctors 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==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 source-repository head - Type: git - Location: https://github.com/tomjaguarpaw/product-profunctors + type: git + location: https://github.com/tomjaguarpaw/product-profunctors library + default-language: Haskell2010 build-depends: base >= 4.5 && < 5 , profunctors >= 4.0 && < 5.3 , contravariant >= 0.4 && < 1.5 @@ -37,6 +40,7 @@ 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,