summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authortomjaguarpaw <>2020-08-01 13:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-01 13:21:00 (GMT)
commit1859bae7b8f44937e402079a1b2fa039095d56f7 (patch)
treeafa275494d2ade157bfa52d258b19d5988c73f5f
parentb53fcbc82235b24fb0f2eca2d9998eb165e723af (diff)
version 0.11.0.0HEAD0.11.0.0master
-rw-r--r--CHANGELOG.md8
-rw-r--r--Data/Profunctor/Product/Default.hs2
-rw-r--r--Data/Profunctor/Product/Examples.hs60
-rw-r--r--Data/Profunctor/Product/Internal/Adaptor.hs9
-rw-r--r--Data/Profunctor/Product/Internal/TH.hs124
-rw-r--r--Data/Profunctor/Product/TH.hs64
-rw-r--r--Data/Profunctor/Product/Tuples/TH.hs23
-rw-r--r--Test/CheckTypes.hs27
-rw-r--r--Test/Definitions.hs48
-rw-r--r--product-profunctors.cabal2
10 files changed, 265 insertions, 102 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 93501d8..9c44672 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/Data/Profunctor/Product/Default.hs b/Data/Profunctor/Product/Default.hs
index 6022e2e..571d537 100644
--- a/Data/Profunctor/Product/Default.hs
+++ b/Data/Profunctor/Product/Default.hs
@@ -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'@.
diff --git a/Data/Profunctor/Product/Examples.hs b/Data/Profunctor/Product/Examples.hs
index be10986..3de2803 100644
--- a/Data/Profunctor/Product/Examples.hs
+++ b/Data/Profunctor/Product/Examples.hs
@@ -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 @@ instance PP.ProductProfunctor (Take a) where
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 Functor f => P.Profunctor (Traverse f) where
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)
diff --git a/Data/Profunctor/Product/Internal/Adaptor.hs b/Data/Profunctor/Product/Internal/Adaptor.hs
index ad9f9b1..bbc2cd2 100644
--- a/Data/Profunctor/Product/Internal/Adaptor.hs
+++ b/Data/Profunctor/Product/Internal/Adaptor.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
@@ -68,13 +67,6 @@ data Select = Fst | Snd
-- 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)
@@ -83,7 +75,6 @@ type family Unzip (z :: Select) (a :: k) :: k where
-- | 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
diff --git a/Data/Profunctor/Product/Internal/TH.hs b/Data/Profunctor/Product/Internal/TH.hs
index ff0d892..c38d323 100644
--- a/Data/Profunctor/Product/Internal/TH.hs
+++ b/Data/Profunctor/Product/Internal/TH.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Profunctor.Product.Internal.TH where
@@ -12,26 +13,32 @@ import Language.Haskell.TH (Dec(DataD, SigD, FunD, InstanceD, NewtypeD),
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 @@ makeAdaptorAndInstanceE adaptorNameM info = do
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 @@ makeAdaptorAndInstanceE adaptorNameM info = do
return []
return $ do
- as <- sequence [ adaptorSig'
- , adaptorDefinition' adaptorNameN
- , instanceDefinition']
+ as <- sequence ( [ adaptorSig'
+ , adaptorDefinition' adaptorNameN ]
+ ++ instanceDefinition' )
ns <- newtypeInstance'
return (as ++ ns)
@@ -90,11 +98,7 @@ data DataDecStuff = DataDecStuff {
}
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 @@ dataDecStuffOfInfo (TyConI (DataD _cxt tyName tyVars constructors _deriving)) =
, 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,53 +124,62 @@ varNameOfBinder (PlainTV n) = n
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)
@@ -311,6 +320,9 @@ xTuple patCon retCon (funN, numTyVars) = FunD funN [clause]
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
tupP ps = TupP ps
diff --git a/Data/Profunctor/Product/TH.hs b/Data/Profunctor/Product/TH.hs
index 36849a1..f870978 100644
--- a/Data/Profunctor/Product/TH.hs
+++ b/Data/Profunctor/Product/TH.hs
@@ -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 @@ import qualified Language.Haskell.TH as TH
-- | 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
diff --git a/Data/Profunctor/Product/Tuples/TH.hs b/Data/Profunctor/Product/Tuples/TH.hs
index 148baad..3830b09 100644
--- a/Data/Profunctor/Product/Tuples/TH.hs
+++ b/Data/Profunctor/Product/Tuples/TH.hs
@@ -151,12 +151,21 @@ convert :: Profunctor p => (a2 -> a1) -> (tp -> tTp) -> (b1 -> b2)
convert u u' f c = dimap u f . c . u'
mkDefaultNs :: [Int] -> Q [Dec]
-mkDefaultNs = 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]
+mkDefaultNs = fmap concat . mapM mkDefaultN
+
+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 @@ mkDefaultN n = instanceD (sequence (productProfunctor p : mkDefs))
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 ..] ]
diff --git a/Test/CheckTypes.hs b/Test/CheckTypes.hs
index 14eabb9..4956209 100644
--- a/Test/CheckTypes.hs
+++ b/Test/CheckTypes.hs
@@ -9,8 +9,11 @@ import Data.Profunctor.Product.Adaptor
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
@@ -75,6 +78,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
diff --git a/Test/Definitions.hs b/Test/Definitions.hs
index 092a173..c5fdc0d 100644
--- a/Test/Definitions.hs
+++ b/Test/Definitions.hs
@@ -3,6 +3,8 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
module Definitions where
@@ -12,10 +14,12 @@ import GHC.Generics (Generic)
-- 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 (SumProfunctor p, Default p a a', Default p b 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')
+
+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
diff --git a/product-profunctors.cabal b/product-profunctors.cabal
index 4a8c8a6..3a9ef57 100644
--- a/product-profunctors.cabal
+++ b/product-profunctors.cabal
@@ -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