diff --git a/Data/Profunctor/Product.hs b/Data/Profunctor/Product.hs --- a/Data/Profunctor/Product.hs +++ b/Data/Profunctor/Product.hs @@ -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 --git a/Data/Profunctor/Product/Class.hs b/Data/Profunctor/Product/Class.hs --- a/Data/Profunctor/Product/Class.hs +++ b/Data/Profunctor/Product/Class.hs @@ -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 --git a/Data/Profunctor/Product/Default.hs b/Data/Profunctor/Product/Default.hs --- a/Data/Profunctor/Product/Default.hs +++ b/Data/Profunctor/Product/Default.hs @@ -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 --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs --- a/Data/Profunctor/Product/Internal/TH.hs +++ b/Data/Profunctor/Product/Internal/TH.hs @@ -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] diff --git a/Data/Profunctor/Product/TH.hs b/Data/Profunctor/Product/TH.hs --- a/Data/Profunctor/Product/TH.hs +++ b/Data/Profunctor/Product/TH.hs @@ -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' diff --git a/Data/Profunctor/Product/Tuples.hs b/Data/Profunctor/Product/Tuples.hs --- a/Data/Profunctor/Product/Tuples.hs +++ b/Data/Profunctor/Product/Tuples.hs @@ -1,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 --git a/Data/Profunctor/Product/Tuples/TH.hs b/Data/Profunctor/Product/Tuples/TH.hs --- a/Data/Profunctor/Product/Tuples/TH.hs +++ b/Data/Profunctor/Product/Tuples/TH.hs @@ -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 --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Karamaan Group LLC +Copyright (c) 2013, Karamaan Group LLC; 2014-2017 Purely Agile Limited All rights reserved. diff --git a/product-profunctors.cabal b/product-profunctors.cabal --- a/product-profunctors.cabal +++ b/product-profunctors.cabal @@ -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,