product-profunctors 0.7.1.0 → 0.8.0.2

raw patch · 9 files changed

+277/−89 lines, 9 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/Profunctor/Product.hs +69/−52
• Data/Profunctor/Product/Class.hs +78/−7
• Data/Profunctor/Product/Default.hs +1/−0
• Data/Profunctor/Product/Internal/TH.hs +101/−17
• Data/Profunctor/Product/TH.hs +1/−1
• Data/Profunctor/Product/Tuples.hs +5/−1
• Data/Profunctor/Product/Tuples/TH.hs +12/−5
• LICENSE +1/−1
• product-profunctors.cabal +9/−5

@@ -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')++-- }

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

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

@@ -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@@ -220,6 +284,26 @@         body = NormalB (theDimap `o` pN `o` toTupleE)         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]

@@ -77,7 +77,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'

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

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

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

@@ -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.2 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,