mirror of
https://github.com/jcpetruzza/barbies.git
synced 2024-10-03 21:28:35 +03:00
Replace ProductB with ApplicativeB
In terms of operations, they are isomorphic, but the applicative laws are more lax, so we can define more lawful instances. We also remove `ProductBC`, since `bdicts` can just be expressed in terms of `baddDict` and `bpure`.
This commit is contained in:
Daniel Gorin
parent
9393a5afef
commit
83f4d4195e
@ -1,6 +1,6 @@
|
||||
# Changelog for barbies
|
||||
|
||||
## ...
|
||||
## 2.0.0.0
|
||||
- Builds with ghc 8.8.
|
||||
- Remove functions deprecated on release 1.0
|
||||
- Deprecate `Data.Functor.Prod`, `(/*)` and `(/*/)`.
|
||||
@ -10,6 +10,9 @@
|
||||
- Create a `Barbies` module, to contain wrappers, basic docs, etc.
|
||||
`Data.Functor.Barbie` contains only functor-related stuff.
|
||||
- Add a `ErrorContainer` wrapper, similar to `Container` but for `Either e`.
|
||||
- Replace `ProductB` by `ApplicativeB`, with more lax laws
|
||||
- Remove `ProductBC`, since `bdicts` can now be defined in terms of `ApplicativeB`
|
||||
and `ConstraintsB`.
|
||||
|
||||
## 1.1.3.0
|
||||
- `Wear` will raise a `TypeError` instead of getting
|
||||
|
||||
@ -38,13 +38,12 @@ library
|
||||
Data.Functor.Prod
|
||||
|
||||
other-modules:
|
||||
Barbies.Internal.Applicative
|
||||
Barbies.Internal.Bare
|
||||
Barbies.Internal.Constraints
|
||||
Barbies.Internal.Containers
|
||||
Barbies.Internal.Dicts
|
||||
Barbies.Internal.Functor
|
||||
Barbies.Internal.Product
|
||||
Barbies.Internal.ProductC
|
||||
Barbies.Internal.Traversable
|
||||
Barbies.Internal.Trivial
|
||||
Barbies.Internal.Wear
|
||||
@ -52,6 +51,10 @@ library
|
||||
|
||||
Data.Generics.GenericN
|
||||
|
||||
-- To be removed
|
||||
Data.Barbie.Internal.Product
|
||||
Data.Barbie.Internal.ProductC
|
||||
|
||||
hs-source-dirs:
|
||||
src
|
||||
|
||||
@ -90,11 +93,11 @@ test-suite barbies-test
|
||||
TestBarbies
|
||||
TestBarbiesW
|
||||
Clothes
|
||||
Spec.Applicative
|
||||
Spec.Bare
|
||||
Spec.Constraints
|
||||
Spec.Functor
|
||||
Spec.Traversable
|
||||
Spec.Product
|
||||
Spec.Wrapper
|
||||
|
||||
hs-source-dirs:
|
||||
|
||||
107
src/Barbies.hs
107
src/Barbies.hs
@ -7,63 +7,106 @@
|
||||
-- that turn her into a different doll. E.g.
|
||||
--
|
||||
-- @
|
||||
-- data Barbie f
|
||||
-- = Barbie
|
||||
-- data Person f
|
||||
-- = Person
|
||||
-- { name :: f 'String'
|
||||
-- , age :: f 'Int'
|
||||
-- }
|
||||
--
|
||||
-- b1 :: Barbie 'Data.Monoid.Last' -- Barbie with a monoid structure
|
||||
-- b2 :: Barbie ('Data.Functor.Const.Const' a) -- 'Barbies.Container' Barbie
|
||||
-- b3 :: Barbie 'Data.Functor.Identity.Identity' -- Barbie's new clothes
|
||||
-- b1 :: Person 'Data.Monoid.Last' -- Barbie with a monoid structure
|
||||
-- b2 :: Person ('Data.Functor.Const.Const' a) -- 'Barbies.Container' Barbie
|
||||
-- b3 :: Person 'Data.Functor.Identity.Identity' -- Barbie's new clothes
|
||||
-- @
|
||||
--
|
||||
-- This module define the classes to work with these types and easily
|
||||
-- This package define the classes to work with these types and easily
|
||||
-- transform them. They all come with default instances based on
|
||||
-- `GHC.Generics.Generic`, so using them is as easy as:
|
||||
--
|
||||
-- @
|
||||
-- data Barbie f
|
||||
-- = Barbie
|
||||
-- data Person f
|
||||
-- = Person
|
||||
-- { name :: f 'String'
|
||||
-- , age :: f 'Int'
|
||||
-- }
|
||||
-- deriving
|
||||
-- ( 'GHC.Generics.Generic'
|
||||
-- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC'
|
||||
-- , 'FunctorB', 'TraversableB', 'ApplicativeB', 'ConstraintsB'
|
||||
-- )
|
||||
--
|
||||
-- deriving instance 'AllBF' 'Show' f Barbie => 'Show' (Barbie f)
|
||||
-- deriving instance 'AllBF' 'Eq' f Barbie => 'Eq' (Barbie f)
|
||||
-- deriving instance 'AllBF' 'Show' f Person => 'Show' (Person f)
|
||||
-- deriving instance 'AllBF' 'Eq' f Person => 'Eq' (Person f)
|
||||
-- @
|
||||
--
|
||||
-- Sometimes one wants to use @Barbie 'Data.Functor.Identity.Identity'@
|
||||
-- and it may feel like a second-class record type, where one needs to
|
||||
-- unpack values in each field. "Barbies.Bare" offers a way to have
|
||||
-- bare versions of a barbie-type.
|
||||
--
|
||||
-- Notice that all classes in this package are poly-kinded. Intuitively,
|
||||
-- a barbie is a type parameterised by a functor, and because a barbies is
|
||||
-- a type of functor, a type parameterised by a barbie is a (higher-kinded)
|
||||
-- barbie too:
|
||||
--
|
||||
-- @
|
||||
-- data Catalog b
|
||||
-- = Catalog (b 'Identity') (b 'Maybe')
|
||||
-- deriving
|
||||
-- ('GHC.Generics.Generic'
|
||||
-- , 'FunctorB', 'TraversableB', 'ProductB', 'ConstraintsB', 'ProductBC'
|
||||
-- )
|
||||
-- @
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
module Barbies
|
||||
( -- * Functor interfaces
|
||||
( -- * Functor interface
|
||||
|
||||
-- | Barbie-types are functors. That means that if one is familiar
|
||||
-- with standard classes like 'Functor', 'Applicative' or 'Traversable',
|
||||
-- one already knows how to work with barbie-types too. For instance, just
|
||||
-- like one would use:
|
||||
--
|
||||
-- @
|
||||
-- 'fmap' f (xs :: [a])@
|
||||
-- @
|
||||
--
|
||||
-- to apply @f@ uniformly on every @a@ occurring
|
||||
-- in @xs@, one could use the following to turn a 'Either'-outfit
|
||||
-- into 'Maybe'-outfit:
|
||||
--
|
||||
-- @
|
||||
-- 'bmap' ('either' (\\_ -> 'Nothing') 'Just') (p :: Person ('Either' e))@
|
||||
-- @
|
||||
--
|
||||
-- In this case, the argument of 'bmap' will have to be applied on all
|
||||
-- fields of @p@:
|
||||
--
|
||||
-- @
|
||||
-- name p :: 'Either' e 'String'
|
||||
-- age p :: 'Either' e 'Int'
|
||||
-- @
|
||||
--
|
||||
-- So 'bmap' here demands a polymorphic function of type:
|
||||
--
|
||||
-- @
|
||||
-- forall a . 'Either' e a -> 'Maybe' a@
|
||||
-- @
|
||||
--
|
||||
-- Polymorphic functions with 'Applicative' effects can be applied
|
||||
-- using 'btraverse' and the effects will be accumulated. Finally,
|
||||
-- 'bzipWith' gives us an analogous of 'Control.Applicative.liftA2':
|
||||
--
|
||||
-- @
|
||||
-- addDefaults :: Person 'Maybe' -> Person 'Data.Functor.Identity' -> Person 'Data.Functor.Identity'
|
||||
-- addDefaults = 'bzipWith' (\\m d -> 'maybe' d 'pure' m)
|
||||
-- @
|
||||
--
|
||||
-- Notice that here 'bzipWith' has lifted a function of type:
|
||||
--
|
||||
-- @
|
||||
-- forall a. 'Maybe' a -> 'Data.Functor.Identity' a -> 'Data.Functor.Identity' a
|
||||
-- @
|
||||
--
|
||||
-- The 'Functor' class captures endo-functors on 'Data.Kind.Type'. 'FunctorB' is
|
||||
-- for functors from indexed-types to 'Data.Kind.Type'. In particular, barbie-types
|
||||
-- are indexed-types too, so a type parameterized by a barbie is a
|
||||
-- (higher-kinded) barbie as well.
|
||||
--
|
||||
-- @
|
||||
-- data Catalog b
|
||||
-- = Catalog (b 'Data.Functor.Identity') (b 'Maybe')
|
||||
-- deriving
|
||||
-- ('GHC.Generics.Generic'
|
||||
-- , 'FunctorB', 'TraversableB', 'ApplicativeB', 'ConstraintsB'
|
||||
-- )
|
||||
-- @
|
||||
module Data.Functor.Barbie
|
||||
|
||||
-- * Container-barbies
|
||||
|
||||
-- | Wrappers for Barbies that look like containers, providing the
|
||||
-- expected instances for container types.
|
||||
-- | Some clothes make barbies look like containers, and we can make those
|
||||
-- behave like normal 'Functor's.
|
||||
|
||||
, Containers.Container(..)
|
||||
, Containers.ErrorContainer(..)
|
||||
|
||||
@ -9,11 +9,11 @@ module Barbies.Internal
|
||||
, Internal.GTraversableB(..)
|
||||
, Internal.CanDeriveTraversableB
|
||||
|
||||
-- * Product
|
||||
, Internal.gbuniqDefault
|
||||
-- * Applicative
|
||||
, Internal.gbpureDefault
|
||||
, Internal.gbprodDefault
|
||||
, Internal.GProductB(..)
|
||||
, Internal.CanDeriveProductB
|
||||
, Internal.GApplicativeB(..)
|
||||
, Internal.CanDeriveApplicativeB
|
||||
|
||||
-- * Constraints
|
||||
, Internal.gbaddDictsDefault
|
||||
@ -24,11 +24,6 @@ module Barbies.Internal
|
||||
, Internal.X
|
||||
, Internal.TagSelf, Internal.Self, Internal.Other
|
||||
|
||||
-- * Proof
|
||||
, Internal.gbdictsDefault
|
||||
, Internal.GProductBC(..)
|
||||
, Internal.CanDeriveProductBC
|
||||
|
||||
-- * Bare values
|
||||
, Internal.gbcoverDefault
|
||||
, Internal.gbstripDefault
|
||||
@ -41,11 +36,10 @@ module Barbies.Internal
|
||||
|
||||
where
|
||||
|
||||
import qualified Barbies.Internal.Applicative as Internal
|
||||
import qualified Barbies.Internal.Bare as Internal
|
||||
import qualified Barbies.Internal.Constraints as Internal
|
||||
import qualified Barbies.Internal.Functor as Internal
|
||||
import qualified Barbies.Internal.Product as Internal
|
||||
import qualified Barbies.Internal.ProductC as Internal
|
||||
import qualified Barbies.Internal.Traversable as Internal
|
||||
|
||||
import Data.Generics.GenericN (GenericN, Rec(..), RepN)
|
||||
|
||||
227
src/Barbies/Internal/Applicative.hs
Normal file
227
src/Barbies/Internal/Applicative.hs
Normal file
@ -0,0 +1,227 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Barbies.Internal.Applicative
|
||||
( ApplicativeB(bpure, bprod)
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
|
||||
, CanDeriveApplicativeB
|
||||
, GApplicativeB(..)
|
||||
, gbprodDefault, gbpureDefault
|
||||
)
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Functor (FunctorB (..))
|
||||
|
||||
import Data.Functor.Product (Product (..))
|
||||
import Data.Kind (Type)
|
||||
import Data.Proxy (Proxy (..))
|
||||
|
||||
import Data.Generics.GenericN
|
||||
|
||||
|
||||
-- | A 'FunctorB' with application, providing operations to:
|
||||
-- * embed an "empty" value ('bpure')
|
||||
-- * align and combine values ('bprod')
|
||||
--
|
||||
-- It should satisfy the following laws:
|
||||
--
|
||||
-- [Naturality of 'bprod']
|
||||
--
|
||||
-- @
|
||||
-- 'bmap' (\('Pair' a b) -> 'Pair' (f a) (g b)) (u `'bprod'` v) = 'bmap' f u `'bprod'` 'bmap' g v
|
||||
-- @
|
||||
--
|
||||
-- [Left and right identity]
|
||||
--
|
||||
-- @
|
||||
-- 'bmap' (\('Pair' _ b) -> b) ('bpure' e ``bprod'` v) = v
|
||||
-- 'bmap' (\('Pair' a _) -> a) (u ``bprod' `'bpure' e) = u
|
||||
-- @
|
||||
--
|
||||
-- [Associativity]
|
||||
--
|
||||
-- @
|
||||
-- 'bmap' (\('Pair' a ('Pair' b c)) -> 'Pair' ('Pair' a b) c) (u `'bprod'` (v `'bprod'` w)) = (u `'bprod'` v) `'bprod'` w
|
||||
-- @
|
||||
--
|
||||
-- It is to 'FunctorB' in is that 'Applicative'
|
||||
-- relates to 'Functor'. For a presentation of 'Applicative' as
|
||||
-- a monoidal functor, see Section 7 of
|
||||
-- <http://www.soi.city.ac.uk/~ross/papers/Applicative.html Applicative Programming with Effects>.
|
||||
--
|
||||
-- There is a default implementation of 'bprod' and 'bpure' based on 'Generic'.
|
||||
-- Intuitively, it works on types where the value of `bpure` is uniquely defined.
|
||||
-- This corresponds rougly to record types (in the presence of sums, there would
|
||||
-- be several candidates for `bpure`), where the argument @f@ covers every field.
|
||||
class FunctorB b => ApplicativeB (b :: (k -> Type) -> Type) where
|
||||
bpure :: (forall a . f a) -> b f
|
||||
bprod :: b f -> b g -> b (f `Product` g)
|
||||
|
||||
default bpure :: CanDeriveApplicativeB b f f => (forall a . f a) -> b f
|
||||
bpure = gbpureDefault
|
||||
|
||||
default bprod :: CanDeriveApplicativeB b f g => b f -> b g -> b (f `Product` g)
|
||||
bprod = gbprodDefault
|
||||
|
||||
|
||||
-- | An alias of 'bprod', since this is like a 'zip' for Barbie-types.
|
||||
bzip :: ApplicativeB b => b f -> b g -> b (f `Product` g)
|
||||
bzip = bprod
|
||||
|
||||
-- | An equivalent of 'unzip' for Barbie-types.
|
||||
bunzip :: ApplicativeB b => b (f `Product` g) -> (b f, b g)
|
||||
bunzip bfg = (bmap (\(Pair a _) -> a) bfg, bmap (\(Pair _ b) -> b) bfg)
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith' for Barbie-types.
|
||||
bzipWith :: ApplicativeB b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h
|
||||
bzipWith f bf bg
|
||||
= bmap (\(Pair fa ga) -> f fa ga) (bf `bprod` bg)
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith3' for Barbie-types.
|
||||
bzipWith3
|
||||
:: ApplicativeB b
|
||||
=> (forall a. f a -> g a -> h a -> i a)
|
||||
-> b f -> b g -> b h -> b i
|
||||
bzipWith3 f bf bg bh
|
||||
= bmap (\(Pair (Pair fa ga) ha) -> f fa ga ha)
|
||||
(bf `bprod` bg `bprod` bh)
|
||||
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith4' for Barbie-types.
|
||||
bzipWith4
|
||||
:: ApplicativeB b
|
||||
=> (forall a. f a -> g a -> h a -> i a -> j a)
|
||||
-> b f -> b g -> b h -> b i -> b j
|
||||
bzipWith4 f bf bg bh bi
|
||||
= bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia)
|
||||
(bf `bprod` bg `bprod` bh `bprod` bi)
|
||||
|
||||
|
||||
-- | @'CanDeriveApplicativeB' B f g@ is in practice a predicate about @B@ only.
|
||||
-- Intuitively, it says that the following holds, for any arbitrary @f@:
|
||||
--
|
||||
-- * There is an instance of @'Generic' (B f)@.
|
||||
--
|
||||
-- * @B@ has only one constructor (that is, it is not a sum-type).
|
||||
--
|
||||
-- * Every field of @B f@ is of the form @f a@, for some type @a@.
|
||||
-- In other words, @B@ has no "hidden" structure.
|
||||
type CanDeriveApplicativeB b f g
|
||||
= ( GenericN (b f)
|
||||
, GenericN (b g)
|
||||
, GenericN (b (f `Product` g))
|
||||
, GApplicativeB f g (RepN (b f)) (RepN (b g)) (RepN (b (f `Product` g)))
|
||||
)
|
||||
|
||||
|
||||
-- ======================================
|
||||
-- Generic derivation of instances
|
||||
-- ======================================
|
||||
|
||||
-- | Default implementation of 'bprod' based on 'Generic'.
|
||||
gbprodDefault
|
||||
:: forall b f g
|
||||
. CanDeriveApplicativeB b f g
|
||||
=> b f -> b g -> b (f `Product` g)
|
||||
gbprodDefault l r
|
||||
= toN $ gbprod (Proxy @f) (Proxy @g) (fromN l) (fromN r)
|
||||
{-# INLINE gbprodDefault #-}
|
||||
|
||||
gbpureDefault:: forall b f . CanDeriveApplicativeB b f f => (forall a . f a) -> b f
|
||||
gbpureDefault x
|
||||
= toN $ gbpure (Proxy @f) (Proxy @(RepN (b f))) (Proxy @(RepN (b (f `Product` f)))) x
|
||||
{-# INLINE gbpureDefault #-}
|
||||
|
||||
class GApplicativeB (f :: k -> *) (g :: k -> *) repbf repbg repbfg where
|
||||
gbprod :: Proxy f -> Proxy g -> repbf x -> repbg x -> repbfg x
|
||||
|
||||
gbpure :: (f ~ g, repbf ~ repbg) => Proxy f -> Proxy repbf -> Proxy repbfg -> (forall a . f a) -> repbf x
|
||||
|
||||
-- ----------------------------------
|
||||
-- Trivial cases
|
||||
-- ----------------------------------
|
||||
|
||||
instance GApplicativeB f g repf repg repfg => GApplicativeB f g (M1 i c repf)
|
||||
(M1 i c repg)
|
||||
(M1 i c repfg) where
|
||||
gbprod pf pg (M1 l) (M1 r) = M1 (gbprod pf pg l r)
|
||||
{-# INLINE gbprod #-}
|
||||
|
||||
gbpure pf _ _ x = M1 (gbpure pf (Proxy @repf) (Proxy @repfg) x)
|
||||
{-# INLINE gbpure #-}
|
||||
|
||||
|
||||
instance GApplicativeB f g U1 U1 U1 where
|
||||
gbprod _ _ U1 U1 = U1
|
||||
{-# INLINE gbprod #-}
|
||||
|
||||
gbpure _ _ _ _ = U1
|
||||
{-# INLINE gbpure #-}
|
||||
|
||||
instance
|
||||
( GApplicativeB f g lf lg lfg
|
||||
, GApplicativeB f g rf rg rfg
|
||||
) => GApplicativeB f g (lf :*: rf)
|
||||
(lg :*: rg)
|
||||
(lfg :*: rfg) where
|
||||
gbprod pf pg (l1 :*: l2) (r1 :*: r2)
|
||||
= (l1 `lprod` r1) :*: (l2 `rprod` r2)
|
||||
where
|
||||
lprod = gbprod pf pg
|
||||
rprod = gbprod pf pg
|
||||
{-# INLINE gbprod #-}
|
||||
|
||||
gbpure pf _ _ x = (gbpure pf (Proxy @lf) (Proxy @lfg) x :*: gbpure pf (Proxy @rf) (Proxy @rfg) x)
|
||||
{-# INLINE gbpure #-}
|
||||
|
||||
-- --------------------------------
|
||||
-- The interesting cases
|
||||
-- --------------------------------
|
||||
|
||||
type P0 = Param 0
|
||||
|
||||
instance GApplicativeB f g (Rec (P0 f a) (f a))
|
||||
(Rec (P0 g a) (g a))
|
||||
(Rec (P0 (f `Product` g) a) ((f `Product` g) a)) where
|
||||
gbprod _ _ (Rec (K1 fa)) (Rec (K1 ga))
|
||||
= Rec (K1 (Pair fa ga))
|
||||
{-# INLINE gbprod #-}
|
||||
|
||||
gbpure _ _ _ x = Rec (K1 x)
|
||||
{-# INLINE gbpure #-}
|
||||
|
||||
|
||||
instance
|
||||
( SameOrParam b b'
|
||||
, ApplicativeB b'
|
||||
) => GApplicativeB f g (Rec (b (P0 f)) (b' f))
|
||||
(Rec (b (P0 g)) (b' g))
|
||||
(Rec (b (P0 (f `Product` g))) (b' (f `Product` g))) where
|
||||
gbprod _ _ (Rec (K1 bf)) (Rec (K1 bg))
|
||||
= Rec (K1 (bf `bprod` bg))
|
||||
{-# INLINE gbprod #-}
|
||||
|
||||
gbpure _ _ _ x = Rec (K1 (bpure x))
|
||||
{-# INLINE gbpure #-}
|
||||
|
||||
|
||||
-- --------------------------------
|
||||
-- Instances for base types
|
||||
-- --------------------------------
|
||||
|
||||
instance ApplicativeB Proxy where
|
||||
bprod _ _ = Proxy
|
||||
{-# INLINE bprod #-}
|
||||
|
||||
bpure _ = Proxy
|
||||
{-# INLINE bpure #-}
|
||||
|
||||
instance (ApplicativeB a, ApplicativeB b) => ApplicativeB (Product a b) where
|
||||
bprod (Pair ll lr) (Pair rl rr) = Pair (bprod ll rl) (bprod lr rr)
|
||||
{-# INLINE bprod #-}
|
||||
|
||||
bpure x = Pair (bpure x) (bpure x)
|
||||
{-# INLINE bpure #-}
|
||||
@ -7,6 +7,10 @@ module Barbies.Internal.Constraints
|
||||
, bmapC
|
||||
, btraverseC
|
||||
, AllBF
|
||||
, bdicts
|
||||
, bpureC
|
||||
, bmempty
|
||||
|
||||
|
||||
, CanDeriveConstraintsB
|
||||
, GAllBC(..)
|
||||
@ -18,6 +22,7 @@ module Barbies.Internal.Constraints
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Applicative(ApplicativeB(..))
|
||||
import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict)
|
||||
import Barbies.Internal.Functor(FunctorB (..))
|
||||
import Barbies.Internal.Traversable(TraversableB (..))
|
||||
@ -126,6 +131,31 @@ btraverseC f b = btraverse (\(Pair (Dict :: Dict c a) x) -> f x) (baddDicts b)
|
||||
type AllBF c f b = AllB (ClassF c f) b
|
||||
|
||||
|
||||
-- | Similar to 'baddDicts' but can produce the instance dictionaries
|
||||
-- "out of the blue".
|
||||
bdicts :: forall c b . (ConstraintsB b, ApplicativeB b, AllB c b) => b (Dict c)
|
||||
bdicts = bmap (\(Pair c _) -> c) $ baddDicts $ bpure Proxy
|
||||
|
||||
|
||||
-- | Like 'bpure' but a constraint is allowed to be required on
|
||||
-- each element of @b@.
|
||||
bpureC
|
||||
:: forall c f b .
|
||||
( AllB c b
|
||||
, ConstraintsB b
|
||||
, ApplicativeB b
|
||||
)
|
||||
=> (forall a . c a => f a)
|
||||
-> b f
|
||||
bpureC x
|
||||
= bmap (requiringDict @c x) bdicts
|
||||
|
||||
-- | Builds a @b f@, by applying 'mempty' on every field of @b@.
|
||||
bmempty :: forall f b . (AllBF Monoid f b, ConstraintsB b, ApplicativeB b) => b f
|
||||
bmempty
|
||||
= bpureC @(ClassF Monoid f) mempty
|
||||
|
||||
|
||||
-- | The representation used for the generic computation of the @'AllB' c b@
|
||||
-- constraints. Here 'X' is an arbitrary constant since the actual
|
||||
-- argument to @b@ is irrelevant.
|
||||
|
||||
@ -16,7 +16,7 @@ import GHC.Generics (Generic)
|
||||
|
||||
-- {{ Container ---------------------------------------------------------------
|
||||
|
||||
-- | Wrapper for Barbies that act as containers of @a@
|
||||
-- | Wrapper for barbies that act as containers of @a@
|
||||
-- by wearing @('Const' a)@.
|
||||
newtype Container b a
|
||||
= Container { getContainer :: b (Const a) }
|
||||
@ -40,9 +40,9 @@ instance TraversableB b => Traversable (Container b) where
|
||||
traverse f
|
||||
= fmap Container . btraverse (bitraverse f pure) . getContainer
|
||||
|
||||
instance ProductB b => Applicative (Container b) where
|
||||
instance ApplicativeB b => Applicative (Container b) where
|
||||
pure a
|
||||
= Container $ buniq (Const a)
|
||||
= Container $ bpure (Const a)
|
||||
|
||||
l <*> r
|
||||
= Container $ bzipWith appConst (getContainer l) (getContainer r)
|
||||
@ -56,7 +56,7 @@ instance ProductB b => Applicative (Container b) where
|
||||
|
||||
-- {{ ErrorContainer ----------------------------------------------------------
|
||||
|
||||
-- | Wrapper for Barbies that act as containers of @e@
|
||||
-- | Wrapper for barbies that act as containers of @e@
|
||||
-- by wearing @'Either' e@.
|
||||
newtype ErrorContainer b e
|
||||
= ErrorContainer { getErrorContainer :: b (Either e) }
|
||||
|
||||
@ -6,10 +6,9 @@ module Barbies.Internal.Trivial
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Applicative(ApplicativeB(..))
|
||||
import Barbies.Internal.Constraints(ConstraintsB(..))
|
||||
import Barbies.Internal.Functor(FunctorB(..))
|
||||
import Barbies.Internal.Product(ProductB(..))
|
||||
import Barbies.Internal.ProductC(ProductBC(..))
|
||||
import Barbies.Internal.Traversable(TraversableB(..))
|
||||
|
||||
import Data.Data (Data(..))
|
||||
@ -63,6 +62,5 @@ instance Monoid (Unit f) where
|
||||
|
||||
instance FunctorB Unit
|
||||
instance TraversableB Unit
|
||||
instance ProductB Unit
|
||||
instance ApplicativeB Unit
|
||||
instance ConstraintsB Unit
|
||||
instance ProductBC Unit
|
||||
|
||||
@ -6,12 +6,11 @@ module Barbies.Internal.Wrappers
|
||||
( Barbie(..)
|
||||
) where
|
||||
|
||||
import Barbies.Internal.Applicative
|
||||
import Barbies.Internal.Constraints
|
||||
import Barbies.Internal.Dicts
|
||||
import Barbies.Internal.Functor
|
||||
import Barbies.Internal.Traversable
|
||||
import Barbies.Internal.Product
|
||||
import Barbies.Internal.ProductC
|
||||
|
||||
import Data.Kind (Type)
|
||||
import Data.Semigroup (Semigroup, (<>))
|
||||
@ -21,7 +20,7 @@ import Prelude hiding (Semigroup, (<>)) -- ghc < 8.2
|
||||
-- | A wrapper for Barbie-types, providing useful instances.
|
||||
newtype Barbie (b :: (k -> Type) -> Type) f
|
||||
= Barbie { getBarbie :: b f }
|
||||
deriving (FunctorB, ProductB, ProductBC)
|
||||
deriving (FunctorB, ApplicativeB)
|
||||
|
||||
-- Need to derive it manually to make GHC 8.0.2 happy
|
||||
instance ConstraintsB b => ConstraintsB (Barbie b) where
|
||||
@ -32,12 +31,12 @@ instance TraversableB b => TraversableB (Barbie b) where
|
||||
btraverse f = fmap Barbie . btraverse f . getBarbie
|
||||
|
||||
|
||||
instance (ProductBC b, AllBF Semigroup f b) => Semigroup (Barbie b f) where
|
||||
instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b) => Semigroup (Barbie b f) where
|
||||
(<>) = bzipWith3 mk bdicts
|
||||
where
|
||||
mk :: Dict (ClassF Semigroup f) a -> f a -> f a -> f a
|
||||
mk = requiringDict (<>)
|
||||
|
||||
instance (ProductBC b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where
|
||||
instance (ConstraintsB b, ApplicativeB b, AllBF Semigroup f b, AllBF Monoid f b) => Monoid (Barbie b f) where
|
||||
mempty = bmempty
|
||||
mappend = (<>)
|
||||
|
||||
@ -14,8 +14,13 @@ module Data.Barbie
|
||||
|
||||
-- * Product
|
||||
, ProductB(buniq, bprod)
|
||||
|
||||
-- ** Utility functions
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
, App.bzip
|
||||
, App.bunzip
|
||||
, App.bzipWith
|
||||
, App.bzipWith3
|
||||
, App.bzipWith4
|
||||
|
||||
-- * Constraints and instance dictionaries
|
||||
, ConstraintsB(AllB, baddDicts)
|
||||
@ -46,15 +51,15 @@ module Data.Barbie
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Constraints (AllBF, ConstraintsB (..), bmapC, btraverseC)
|
||||
import Barbies.Internal.Constraints (AllBF, ConstraintsB (..), bmapC, btraverseC, bmempty)
|
||||
|
||||
import Barbies.Internal.Functor(FunctorB(..))
|
||||
import Barbies.Internal.Wrappers(Barbie(..))
|
||||
import Barbies.Internal.Product
|
||||
( ProductB(..)
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
)
|
||||
import Barbies.Internal.ProductC(ProductBC(..), buniqC, bmempty)
|
||||
import qualified Barbies.Internal.Applicative as App
|
||||
|
||||
import Data.Barbie.Internal.Product(ProductB(..))
|
||||
import Data.Barbie.Internal.ProductC(ProductBC(..), buniqC)
|
||||
|
||||
import Barbies.Internal.Traversable
|
||||
( TraversableB(..)
|
||||
, bsequence, bsequence'
|
||||
|
||||
@ -19,4 +19,4 @@ where
|
||||
|
||||
import Barbies.Internal.Constraints
|
||||
import Barbies.Internal.Dicts
|
||||
import Barbies.Internal.ProductC
|
||||
import Data.Barbie.Internal.ProductC
|
||||
|
||||
@ -2,18 +2,19 @@
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Barbies.Internal.Product
|
||||
{-# OPTIONS_GHC -Wno-orphans -Wno-deprecations #-}
|
||||
module Data.Barbie.Internal.Product
|
||||
( ProductB(buniq, bprod)
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
|
||||
, CanDeriveProductB
|
||||
, GProductB(..)
|
||||
, gbprodDefault, gbuniqDefault
|
||||
)
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Functor (FunctorB (..))
|
||||
import Barbies.Internal.Functor (FunctorB)
|
||||
import Barbies.Internal.Trivial (Unit)
|
||||
import Barbies.Internal.Wrappers (Barbie(..))
|
||||
import qualified Barbies.Internal.Applicative as App
|
||||
|
||||
import Data.Functor.Product (Product (..))
|
||||
import Data.Kind (Type)
|
||||
@ -22,45 +23,9 @@ import Data.Proxy (Proxy (..))
|
||||
import Data.Generics.GenericN
|
||||
|
||||
|
||||
-- | Barbie-types that can form products, subject to the laws:
|
||||
--
|
||||
-- @
|
||||
-- 'bmap' (\\('Pair' a _) -> a) . 'uncurry' 'bprod' = 'fst'
|
||||
-- 'bmap' (\\('Pair' _ b) -> b) . 'uncurry' 'bprod' = 'snd'
|
||||
-- @
|
||||
--
|
||||
-- Notice that because of the laws, having an internal product structure is not
|
||||
-- enough to have a lawful instance. E.g.
|
||||
--
|
||||
-- @
|
||||
-- data Ok f = Ok {o1 :: f 'String', o2 :: f 'Int'}
|
||||
-- data Bad f = Bad{b1 :: f 'String', hiddenFromArg: 'Int'} -- no lawful instance
|
||||
-- @
|
||||
--
|
||||
-- Intuitively, the laws for this class require that `b` hides no structure
|
||||
-- from its argument @f@. Because of this, if we are given any:
|
||||
--
|
||||
-- @
|
||||
-- x :: forall a . f a
|
||||
-- @
|
||||
--
|
||||
-- then this determines a unique value of type @b f@, witnessed by the 'buniq'
|
||||
-- method.
|
||||
-- For example:
|
||||
--
|
||||
-- @
|
||||
-- 'buniq' x = Ok {o1 = x, o2 = x}
|
||||
-- @
|
||||
--
|
||||
-- Formally, 'buniq' should satisfy:
|
||||
--
|
||||
-- @
|
||||
-- 'const' ('buniq' x) = 'bmap' ('const' x)
|
||||
-- @
|
||||
--
|
||||
-- There is a default implementation of 'bprod' and 'buniq' for 'Generic' types,
|
||||
-- so instances can derived automatically.
|
||||
class FunctorB b => ProductB (b :: (k -> Type) -> Type) where
|
||||
{-# DEPRECATED ProductB "Use ApplicativeB" #-}
|
||||
{-# DEPRECATED buniq "Use bpure" #-}
|
||||
class App.ApplicativeB b => ProductB (b :: (k -> Type) -> Type) where
|
||||
bprod :: b f -> b g -> b (f `Product` g)
|
||||
|
||||
buniq :: (forall a . f a) -> b f
|
||||
@ -72,48 +37,7 @@ class FunctorB b => ProductB (b :: (k -> Type) -> Type) where
|
||||
buniq = gbuniqDefault
|
||||
|
||||
|
||||
-- | An alias of 'bprod', since this is like a 'zip' for Barbie-types.
|
||||
bzip :: ProductB b => b f -> b g -> b (f `Product` g)
|
||||
bzip = bprod
|
||||
|
||||
-- | An equivalent of 'unzip' for Barbie-types.
|
||||
bunzip :: ProductB b => b (f `Product` g) -> (b f, b g)
|
||||
bunzip bfg = (bmap (\(Pair a _) -> a) bfg, bmap (\(Pair _ b) -> b) bfg)
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith' for Barbie-types.
|
||||
bzipWith :: ProductB b => (forall a. f a -> g a -> h a) -> b f -> b g -> b h
|
||||
bzipWith f bf bg
|
||||
= bmap (\(Pair fa ga) -> f fa ga) (bf `bprod` bg)
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith3' for Barbie-types.
|
||||
bzipWith3
|
||||
:: ProductB b
|
||||
=> (forall a. f a -> g a -> h a -> i a)
|
||||
-> b f -> b g -> b h -> b i
|
||||
bzipWith3 f bf bg bh
|
||||
= bmap (\(Pair (Pair fa ga) ha) -> f fa ga ha)
|
||||
(bf `bprod` bg `bprod` bh)
|
||||
|
||||
|
||||
-- | An equivalent of 'Data.List.zipWith4' for Barbie-types.
|
||||
bzipWith4
|
||||
:: ProductB b
|
||||
=> (forall a. f a -> g a -> h a -> i a -> j a)
|
||||
-> b f -> b g -> b h -> b i -> b j
|
||||
bzipWith4 f bf bg bh bi
|
||||
= bmap (\(Pair (Pair (Pair fa ga) ha) ia) -> f fa ga ha ia)
|
||||
(bf `bprod` bg `bprod` bh `bprod` bi)
|
||||
|
||||
|
||||
-- | @'CanDeriveProductB' B f g@ is in practice a predicate about @B@ only.
|
||||
-- Intuitively, it says that the following holds, for any arbitrary @f@:
|
||||
--
|
||||
-- * There is an instance of @'Generic' (B f)@.
|
||||
--
|
||||
-- * @B@ has only one constructor (that is, it is not a sum-type).
|
||||
--
|
||||
-- * Every field of @B f@ is of the form @f a@, for some type @a@.
|
||||
-- In other words, @B@ has no "hidden" structure.
|
||||
type CanDeriveProductB b f g
|
||||
= ( GenericN (b f)
|
||||
, GenericN (b g)
|
||||
@ -121,6 +45,15 @@ type CanDeriveProductB b f g
|
||||
, GProductB f g (RepN (b f)) (RepN (b g)) (RepN (b (f `Product` g)))
|
||||
)
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (ProductB b, FunctorB b) => App.ApplicativeB b where
|
||||
bpure = Data.Barbie.Internal.Product.buniq
|
||||
bprod = Data.Barbie.Internal.Product.bprod
|
||||
|
||||
instance ProductB Unit where
|
||||
|
||||
instance ProductB b => ProductB (Barbie b) where
|
||||
buniq x = Barbie (buniq x)
|
||||
bprod (Barbie l) (Barbie r) = Barbie (bprod l r)
|
||||
|
||||
-- ======================================
|
||||
-- Generic derivation of instances
|
||||
@ -2,10 +2,10 @@
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Barbies.Internal.ProductC
|
||||
{-# OPTIONS_GHC -Wno-deprecations #-}
|
||||
module Data.Barbie.Internal.ProductC
|
||||
( ProductBC(..)
|
||||
, buniqC
|
||||
, bmempty
|
||||
|
||||
, CanDeriveProductBC
|
||||
, GAllB
|
||||
@ -15,67 +15,43 @@ module Barbies.Internal.ProductC
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Constraints
|
||||
import Barbies.Internal.Dicts(ClassF, Dict (..), requiringDict)
|
||||
import Barbies.Internal.Functor(bmap)
|
||||
import Barbies.Internal.Product(ProductB (..))
|
||||
import Data.Kind(Type)
|
||||
import Barbies.Internal.Constraints(ConstraintsB(..), GAllB, GAllBRep, Self, Other, X)
|
||||
import Barbies.Internal.Dicts(Dict (..), requiringDict)
|
||||
import Barbies.Internal.Functor(FunctorB(bmap))
|
||||
import Barbies.Internal.Trivial(Unit(..))
|
||||
import Barbies.Internal.Wrappers(Barbie(..))
|
||||
|
||||
import Data.Barbie.Internal.Product(ProductB(..))
|
||||
import Data.Generics.GenericN
|
||||
|
||||
import Data.Functor.Product (Product (..))
|
||||
import Data.Kind(Type)
|
||||
import Data.Proxy(Proxy (..))
|
||||
|
||||
-- | Every type @b@ that is an instance of both 'ProductB' and
|
||||
-- 'ConstraintsB' can be made an instance of 'ProductBC'
|
||||
-- as well.
|
||||
--
|
||||
-- Intuitively, in addition to 'buniq' from 'ProductB', one
|
||||
-- can define 'buniqC' that takes into account constraints:
|
||||
--
|
||||
-- @
|
||||
-- 'buniq' :: (forall a . f a) -> b f
|
||||
-- 'buniqC' :: 'AllB' c b => (forall a . c a => f a) -> b f
|
||||
-- @
|
||||
--
|
||||
-- For technical reasons, 'buniqC' is not currently provided
|
||||
-- as a method of this class and is instead defined in terms
|
||||
-- 'bdicts', which is similar to 'baddDicts' but can produce the
|
||||
-- instance dictionaries out-of-the-blue. 'bdicts' could also be
|
||||
-- defined in terms of 'buniqC', so they are essentially equivalent.
|
||||
--
|
||||
-- @
|
||||
-- 'bdicts' :: forall c b . 'AllB' c b => b ('Dict' c)
|
||||
-- 'bdicts' = 'buniqC' ('Dict' @c)
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- There is a default implementation for 'Generic' types, so
|
||||
-- instances can derived automatically.
|
||||
class (ConstraintsB b, ProductB b) => ProductBC (b :: (k -> Type) -> Type) where
|
||||
bdicts :: AllB c b => b (Dict c)
|
||||
|
||||
default bdicts :: (CanDeriveProductBC c b, AllB c b) => b (Dict c)
|
||||
bdicts = gbdictsDefault
|
||||
|
||||
-- | Every type that admits a generic instance of 'ProductB' and
|
||||
-- 'ConstraintsB', has a generic instance of 'ProductBC' as well.
|
||||
|
||||
type CanDeriveProductBC c b
|
||||
= ( GenericN (b (Dict c))
|
||||
, AllB c b ~ GAllB c (GAllBRep b)
|
||||
, GProductBC c (GAllBRep b) (RepN (b (Dict c)))
|
||||
)
|
||||
|
||||
-- | Like 'buniq' but a constraint is allowed to be required on
|
||||
-- each element of @b@.
|
||||
{-# DEPRECATED buniqC "Use bpureC instead" #-}
|
||||
buniqC :: forall c f b . (AllB c b, ProductBC b) => (forall a . c a => f a) -> b f
|
||||
buniqC x
|
||||
= bmap (requiringDict @c x) bdicts
|
||||
|
||||
-- | Builds a @b f@, by applying 'mempty' on every field of @b@.
|
||||
bmempty :: forall f b . (AllBF Monoid f b, ProductBC b) => b f
|
||||
bmempty
|
||||
= buniqC @(ClassF Monoid f) mempty
|
||||
instance ProductBC b => ProductBC (Barbie b) where
|
||||
bdicts = Barbie bdicts
|
||||
|
||||
instance ProductBC Unit where
|
||||
bdicts = Unit
|
||||
|
||||
|
||||
-- ===============================================================
|
||||
-- Generic derivations
|
||||
@ -1,8 +1,8 @@
|
||||
-----------------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.Functor.Barbie
|
||||
-- Module: Data.Functor.Barbie
|
||||
--
|
||||
-- TBP
|
||||
-- Functors from indexed-types to types.
|
||||
----------------------------------------------------------------------------
|
||||
module Data.Functor.Barbie
|
||||
(
|
||||
@ -16,10 +16,14 @@ module Data.Functor.Barbie
|
||||
, bfoldMap
|
||||
, bsequence, bsequence'
|
||||
|
||||
-- * Product
|
||||
, ProductB(buniq, bprod)
|
||||
-- * Applicative
|
||||
, Appl.ApplicativeB(bpure, bprod)
|
||||
-- ** Utility functions
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
, Appl.bzip
|
||||
, Appl.bunzip
|
||||
, Appl.bzipWith
|
||||
, Appl.bzipWith3
|
||||
, Appl.bzipWith4
|
||||
|
||||
-- * Constraints and instance dictionaries
|
||||
-- | Consider the following function:
|
||||
@ -32,25 +36,23 @@ module Data.Functor.Barbie
|
||||
-- We would then like to be able to do:
|
||||
--
|
||||
-- @
|
||||
-- 'Data.Barbie.bmap' 'showIt' :: 'Data.Functor.Barbie.FunctorB' b => b 'Maybe' -> b ('Data.Functor.Const' 'String')
|
||||
-- 'Data.Functor.Barbie.bmap' 'showIt' :: 'Data.Functor.Barbie.FunctorB' b => b 'Maybe' -> b ('Data.Functor.Const' 'String')
|
||||
-- @
|
||||
--
|
||||
-- This however doesn't work because of the @('Show' a)@ constraint in the
|
||||
-- the type of @showIt@.
|
||||
--
|
||||
-- The 'ConstraintsB' class let us overcome this problem.
|
||||
-- The 'Cons.ConstraintsB' class let us overcome this problem.
|
||||
|
||||
, ConstraintsB(..)
|
||||
, AllBF
|
||||
|
||||
-- ** Products and constaints
|
||||
, ProductBC(bdicts)
|
||||
, Cons.ConstraintsB(..)
|
||||
, Cons.AllBF
|
||||
|
||||
-- ** Utility functions
|
||||
, bmapC
|
||||
, btraverseC
|
||||
, buniqC
|
||||
, bmempty
|
||||
, Cons.bdicts
|
||||
, Cons.bmapC
|
||||
, Cons.btraverseC
|
||||
, Cons.bpureC
|
||||
, Cons.bmempty
|
||||
|
||||
-- * Support for generic derivations
|
||||
, Rec(..)
|
||||
@ -58,14 +60,11 @@ module Data.Functor.Barbie
|
||||
|
||||
where
|
||||
|
||||
import Barbies.Internal.Constraints(AllBF, ConstraintsB (..), bmapC, btraverseC)
|
||||
import qualified Barbies.Internal.Constraints as Cons
|
||||
|
||||
import Barbies.Internal.Functor(FunctorB(..))
|
||||
import Barbies.Internal.Product
|
||||
( ProductB(..)
|
||||
, bzip, bunzip, bzipWith, bzipWith3, bzipWith4
|
||||
)
|
||||
import Barbies.Internal.ProductC(ProductBC(..), buniqC, bmempty)
|
||||
import qualified Barbies.Internal.Applicative as Appl
|
||||
|
||||
import Barbies.Internal.Traversable
|
||||
( TraversableB(..)
|
||||
, bsequence, bsequence'
|
||||
|
||||
54
test/Spec.hs
54
test/Spec.hs
@ -4,7 +4,7 @@ import Test.Tasty.HUnit (testCase, (@?=))
|
||||
import qualified Spec.Bare as Bare
|
||||
import qualified Spec.Constraints as Constraints
|
||||
import qualified Spec.Functor as Functor
|
||||
import qualified Spec.Product as Product
|
||||
import qualified Spec.Applicative as Applicative
|
||||
import qualified Spec.Traversable as Traversable
|
||||
import qualified Spec.Wrapper as Wrapper
|
||||
|
||||
@ -12,7 +12,7 @@ import TestBarbies
|
||||
import TestBarbiesW
|
||||
|
||||
import Barbies.Bare(Covered)
|
||||
import Data.Functor.Barbie(bfoldMap, bmapC, btraverseC, buniqC)
|
||||
import Data.Functor.Barbie(bfoldMap, bmapC, btraverseC, bpureC)
|
||||
import Data.Functor.Const (Const (..))
|
||||
import Data.Functor.Identity (Identity (..))
|
||||
import Data.Monoid (Sum (..))
|
||||
@ -77,38 +77,38 @@ main
|
||||
, Traversable.laws @(CompositeRecordW Covered)
|
||||
]
|
||||
|
||||
, testGroup "Product Laws"
|
||||
[ Product.laws @Record0
|
||||
, Product.laws @Record1
|
||||
, Product.laws @Record3
|
||||
, Product.laws @CompositeRecord
|
||||
, testGroup "Product Laws of derived applicatives"
|
||||
[ Applicative.productLaws @Record0
|
||||
, Applicative.productLaws @Record1
|
||||
, Applicative.productLaws @Record3
|
||||
, Applicative.productLaws @CompositeRecord
|
||||
|
||||
, Product.laws @Record1S
|
||||
, Product.laws @Record3S
|
||||
, Applicative.productLaws @Record1S
|
||||
, Applicative.productLaws @Record3S
|
||||
|
||||
, Product.laws @(Record1W Covered)
|
||||
, Product.laws @(Record3W Covered)
|
||||
, Product.laws @(CompositeRecordW Covered)
|
||||
, Applicative.productLaws @(Record1W Covered)
|
||||
, Applicative.productLaws @(Record3W Covered)
|
||||
, Applicative.productLaws @(CompositeRecordW Covered)
|
||||
|
||||
, Product.laws @(Record1WS Covered)
|
||||
, Product.laws @(Record3WS Covered)
|
||||
, Applicative.productLaws @(Record1WS Covered)
|
||||
, Applicative.productLaws @(Record3WS Covered)
|
||||
]
|
||||
|
||||
, testGroup "Uniq Laws"
|
||||
[ Product.uniqLaws @Record0
|
||||
, Product.uniqLaws @Record1
|
||||
, Product.uniqLaws @Record3
|
||||
, Product.uniqLaws @CompositeRecord
|
||||
[ Applicative.uniqLaws @Record0
|
||||
, Applicative.uniqLaws @Record1
|
||||
, Applicative.uniqLaws @Record3
|
||||
, Applicative.uniqLaws @CompositeRecord
|
||||
|
||||
, Product.uniqLaws @Record1S
|
||||
, Product.uniqLaws @Record3S
|
||||
, Applicative.uniqLaws @Record1S
|
||||
, Applicative.uniqLaws @Record3S
|
||||
|
||||
, Product.uniqLaws @(Record1W Covered)
|
||||
, Product.uniqLaws @(Record3W Covered)
|
||||
, Product.uniqLaws @(CompositeRecordW Covered)
|
||||
, Applicative.uniqLaws @(Record1W Covered)
|
||||
, Applicative.uniqLaws @(Record3W Covered)
|
||||
, Applicative.uniqLaws @(CompositeRecordW Covered)
|
||||
|
||||
, Product.uniqLaws @(Record1WS Covered)
|
||||
, Product.uniqLaws @(Record3WS Covered)
|
||||
, Applicative.uniqLaws @(Record1WS Covered)
|
||||
, Applicative.uniqLaws @(Record3WS Covered)
|
||||
]
|
||||
|
||||
, testGroup "adDict projection"
|
||||
@ -196,9 +196,9 @@ main
|
||||
@?= (Sum 1, Record1 (Identity 1))
|
||||
]
|
||||
, testGroup
|
||||
"buniqC"
|
||||
"bpureC"
|
||||
[ testCase "Record1" $
|
||||
buniqC @Num (Identity (fromIntegral (42 :: Int)))
|
||||
bpureC @Num (Identity (fromIntegral (42 :: Int)))
|
||||
@?= Record1 (Identity 42)
|
||||
]
|
||||
]
|
||||
|
||||
@ -1,11 +1,12 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
module Spec.Product ( laws, uniqLaws )
|
||||
module Spec.Applicative
|
||||
( productLaws, uniqLaws )
|
||||
|
||||
where
|
||||
|
||||
import Clothes(F, G)
|
||||
|
||||
import Data.Functor.Barbie(FunctorB(..), ProductB(..))
|
||||
import Data.Functor.Barbie(FunctorB(..), ApplicativeB(..))
|
||||
|
||||
import Data.Functor.Product(Product(Pair))
|
||||
import Data.Typeable(Typeable, Proxy(..), typeRep)
|
||||
@ -14,16 +15,18 @@ import Test.Tasty(TestTree)
|
||||
import Test.Tasty.QuickCheck(Arbitrary(..), testProperty, (===))
|
||||
|
||||
|
||||
laws
|
||||
-- We only derive ApplicativeB for products, so we test the product
|
||||
-- laws, which are stronger than the applicative ones.
|
||||
productLaws
|
||||
:: forall b
|
||||
. ( ProductB b
|
||||
. ( ApplicativeB b
|
||||
, Eq (b F), Eq (b G)
|
||||
, Show (b F), Show (b G)
|
||||
, Arbitrary (b F), Arbitrary (b G)
|
||||
, Typeable b
|
||||
)
|
||||
=> TestTree
|
||||
laws
|
||||
productLaws
|
||||
= testProperty (show (typeRep (Proxy :: Proxy b))) $ \l r ->
|
||||
bmap first (bprod l r) == (l :: b F) &&
|
||||
bmap second (bprod l r) == (r :: b G)
|
||||
@ -31,9 +34,10 @@ laws
|
||||
first (Pair a _) = a
|
||||
second (Pair _ b) = b
|
||||
|
||||
-- `bpure` is uniquely determined in products
|
||||
uniqLaws
|
||||
:: forall b
|
||||
. ( ProductB b
|
||||
. ( ApplicativeB b
|
||||
, Eq (b Maybe)
|
||||
, Show (b F), Show (b Maybe)
|
||||
, Arbitrary (b F)
|
||||
@ -42,4 +46,4 @@ uniqLaws
|
||||
=> TestTree
|
||||
uniqLaws
|
||||
= testProperty (show (typeRep (Proxy :: Proxy b))) $ \b ->
|
||||
bmap (const Nothing) (b :: b F) === buniq Nothing
|
||||
bmap (const Nothing) (b :: b F) === bpure Nothing
|
||||
@ -8,7 +8,7 @@ where
|
||||
|
||||
import Clothes(F)
|
||||
import Barbies.Constraints(ClassF, Dict)
|
||||
import Data.Functor.Barbie(bmap, ConstraintsB(..), AllBF, ProductBC(..))
|
||||
import Data.Functor.Barbie(bmap, bdicts, ApplicativeB, ConstraintsB(..), AllBF)
|
||||
|
||||
import Data.Functor.Product (Product(Pair))
|
||||
import Data.Typeable(Typeable, Proxy(..), typeRep)
|
||||
@ -35,7 +35,7 @@ lawAddDictPrj
|
||||
|
||||
lawDictsEquivPrj
|
||||
:: forall b
|
||||
. ( ProductBC b, AllBF Show F b
|
||||
. ( ApplicativeB b, ConstraintsB b, AllBF Show F b
|
||||
, Eq (b (Dict (ClassF Show F)))
|
||||
, Show (b F), Show (b (Dict (ClassF Show F)))
|
||||
, Arbitrary (b F)
|
||||
|
||||
@ -8,8 +8,7 @@ where
|
||||
|
||||
import Prelude hiding (Semigroup, (<>))
|
||||
|
||||
import Barbies (Barbie(..))
|
||||
import Data.Functor.Barbie (AllBF, ProductBC)
|
||||
import Barbies (AllBF, ApplicativeB, Barbie(..), ConstraintsB)
|
||||
|
||||
import Data.Semigroup (Semigroup, (<>))
|
||||
|
||||
@ -19,7 +18,8 @@ import Test.Tasty.QuickCheck(Arbitrary(..), testProperty)
|
||||
lawsMonoid
|
||||
:: forall b
|
||||
. ( Arbitrary (b []), Eq (b []), Show (b [])
|
||||
, ProductBC b
|
||||
, ApplicativeB b
|
||||
, ConstraintsB b
|
||||
, AllBF Semigroup [] b
|
||||
, AllBF Monoid [] b
|
||||
)
|
||||
|
||||
@ -46,9 +46,8 @@ data Record0 (f :: * -> *)
|
||||
|
||||
instance FunctorB Record0
|
||||
instance TraversableB Record0
|
||||
instance ProductB Record0
|
||||
instance ApplicativeB Record0
|
||||
instance ConstraintsB Record0
|
||||
instance ProductBC Record0
|
||||
|
||||
instance Arbitrary (Record0 f) where arbitrary = pure Record0
|
||||
|
||||
@ -60,9 +59,8 @@ data Record1 f
|
||||
|
||||
instance FunctorB Record1
|
||||
instance TraversableB Record1
|
||||
instance ProductB Record1
|
||||
instance ApplicativeB Record1
|
||||
instance ConstraintsB Record1
|
||||
instance ProductBC Record1
|
||||
|
||||
deriving instance AllBF Show f Record1 => Show (Record1 f)
|
||||
deriving instance AllBF Eq f Record1 => Eq (Record1 f)
|
||||
@ -78,9 +76,8 @@ data Record1S f
|
||||
|
||||
instance FunctorB Record1S
|
||||
instance TraversableB Record1S
|
||||
instance ProductB Record1S
|
||||
instance ApplicativeB Record1S
|
||||
instance ConstraintsB Record1S
|
||||
instance ProductBC Record1S
|
||||
|
||||
deriving instance AllBF Show f Record1S => Show (Record1S f)
|
||||
deriving instance AllBF Eq f Record1S => Eq (Record1S f)
|
||||
@ -100,9 +97,8 @@ data Record3 f
|
||||
|
||||
instance FunctorB Record3
|
||||
instance TraversableB Record3
|
||||
instance ProductB Record3
|
||||
instance ApplicativeB Record3
|
||||
instance ConstraintsB Record3
|
||||
instance ProductBC Record3
|
||||
|
||||
deriving instance AllBF Show f Record3 => Show (Record3 f)
|
||||
deriving instance AllBF Eq f Record3 => Eq (Record3 f)
|
||||
@ -121,9 +117,8 @@ data Record3S f
|
||||
|
||||
instance FunctorB Record3S
|
||||
instance TraversableB Record3S
|
||||
instance ProductB Record3S
|
||||
instance ApplicativeB Record3S
|
||||
instance ConstraintsB Record3S
|
||||
instance ProductBC Record3S
|
||||
|
||||
deriving instance AllBF Show f Record3S => Show (Record3S f)
|
||||
deriving instance AllBF Eq f Record3S => Eq (Record3S f)
|
||||
@ -186,9 +181,8 @@ data CompositeRecord f
|
||||
|
||||
instance FunctorB CompositeRecord
|
||||
instance TraversableB CompositeRecord
|
||||
instance ProductB CompositeRecord
|
||||
instance ApplicativeB CompositeRecord
|
||||
instance ConstraintsB CompositeRecord
|
||||
instance ProductBC CompositeRecord
|
||||
|
||||
deriving instance AllBF Show f CompositeRecord => Show (CompositeRecord f)
|
||||
deriving instance AllBF Eq f CompositeRecord => Eq (CompositeRecord f)
|
||||
@ -224,9 +218,8 @@ data InfRec f
|
||||
|
||||
instance FunctorB InfRec
|
||||
instance TraversableB InfRec
|
||||
instance ProductB InfRec
|
||||
instance ApplicativeB InfRec
|
||||
instance ConstraintsB InfRec
|
||||
instance ProductBC InfRec
|
||||
|
||||
deriving instance AllBF Show f InfRec => Show (InfRec f)
|
||||
deriving instance AllBF Eq f InfRec => Eq (InfRec f)
|
||||
@ -265,9 +258,8 @@ data ParB b (f :: * -> *)
|
||||
|
||||
instance FunctorB b => FunctorB (ParB b)
|
||||
instance TraversableB b => TraversableB (ParB b)
|
||||
instance ProductB b => ProductB (ParB b)
|
||||
instance ApplicativeB b => ApplicativeB (ParB b)
|
||||
instance ConstraintsB b => ConstraintsB (ParB b)
|
||||
instance ProductBC b => ProductBC (ParB b)
|
||||
|
||||
data ParBH h b (f :: * -> *)
|
||||
= ParBH (h (b f))
|
||||
@ -282,9 +274,8 @@ data ParX a f
|
||||
|
||||
instance FunctorB (ParX a)
|
||||
instance TraversableB (ParX a)
|
||||
instance ProductB (ParX a)
|
||||
instance ApplicativeB (ParX a)
|
||||
instance ConstraintsB (ParX a)
|
||||
instance ProductBC (ParX a)
|
||||
|
||||
|
||||
-----------------------------------------------------
|
||||
@ -300,6 +291,5 @@ data HKB b
|
||||
|
||||
instance FunctorB HKB
|
||||
instance TraversableB HKB
|
||||
instance ProductB HKB
|
||||
instance ApplicativeB HKB
|
||||
instance ConstraintsB HKB
|
||||
instance ProductBC HKB
|
||||
|
||||
@ -40,10 +40,9 @@ data Record1W t f
|
||||
instance FunctorB (Record1W Bare)
|
||||
instance FunctorB (Record1W Covered)
|
||||
instance TraversableB (Record1W Covered)
|
||||
instance ProductB (Record1W Covered)
|
||||
instance ApplicativeB (Record1W Covered)
|
||||
instance ConstraintsB (Record1W Bare)
|
||||
instance ConstraintsB (Record1W Covered)
|
||||
instance ProductBC (Record1W Covered)
|
||||
instance BareB Record1W
|
||||
|
||||
|
||||
@ -64,10 +63,9 @@ data Record1WS t f
|
||||
instance FunctorB (Record1WS Bare)
|
||||
instance FunctorB (Record1WS Covered)
|
||||
instance TraversableB (Record1WS Covered)
|
||||
instance ProductB (Record1WS Covered)
|
||||
instance ApplicativeB (Record1WS Covered)
|
||||
instance ConstraintsB (Record1WS Bare)
|
||||
instance ConstraintsB (Record1WS Covered)
|
||||
instance ProductBC (Record1WS Covered)
|
||||
instance BareB Record1WS
|
||||
|
||||
|
||||
@ -91,10 +89,9 @@ data Record3W t f
|
||||
instance FunctorB (Record3W Bare)
|
||||
instance FunctorB (Record3W Covered)
|
||||
instance TraversableB (Record3W Covered)
|
||||
instance ProductB (Record3W Covered)
|
||||
instance ApplicativeB (Record3W Covered)
|
||||
instance ConstraintsB (Record3W Bare)
|
||||
instance ConstraintsB (Record3W Covered)
|
||||
instance ProductBC (Record3W Covered)
|
||||
|
||||
instance BareB Record3W
|
||||
|
||||
@ -119,10 +116,9 @@ data Record3WS t f
|
||||
instance FunctorB (Record3WS Bare)
|
||||
instance FunctorB (Record3WS Covered)
|
||||
instance TraversableB (Record3WS Covered)
|
||||
instance ProductB (Record3WS Covered)
|
||||
instance ApplicativeB (Record3WS Covered)
|
||||
instance ConstraintsB (Record3WS Bare)
|
||||
instance ConstraintsB (Record3WS Covered)
|
||||
instance ProductBC (Record3WS Covered)
|
||||
instance BareB Record3WS
|
||||
|
||||
deriving instance AllB Show (Record3WS Bare) => Show (Record3WS Bare f)
|
||||
@ -182,10 +178,9 @@ data CompositeRecordW t f
|
||||
instance FunctorB (CompositeRecordW Bare)
|
||||
instance FunctorB (CompositeRecordW Covered)
|
||||
instance TraversableB (CompositeRecordW Covered)
|
||||
instance ProductB (CompositeRecordW Covered)
|
||||
instance ApplicativeB (CompositeRecordW Covered)
|
||||
instance ConstraintsB (CompositeRecordW Bare)
|
||||
instance ConstraintsB (CompositeRecordW Covered)
|
||||
instance ProductBC (CompositeRecordW Covered)
|
||||
instance BareB CompositeRecordW
|
||||
|
||||
deriving instance AllB Show (CompositeRecordW Bare) => Show (CompositeRecordW Bare f)
|
||||
@ -232,10 +227,9 @@ data InfRecW t f
|
||||
instance FunctorB (InfRecW Bare)
|
||||
instance FunctorB (InfRecW Covered)
|
||||
instance TraversableB (InfRecW Covered)
|
||||
instance ProductB (InfRecW Covered)
|
||||
instance ApplicativeB (InfRecW Covered)
|
||||
instance ConstraintsB (InfRecW Bare)
|
||||
instance ConstraintsB (InfRecW Covered)
|
||||
instance ProductBC (InfRecW Covered)
|
||||
instance BareB InfRecW
|
||||
|
||||
deriving instance AllB Show (InfRecW Bare) => Show (InfRecW Bare f)
|
||||
@ -284,7 +278,7 @@ data ParBW b t (f :: * -> *)
|
||||
|
||||
instance FunctorB (b t) => FunctorB (ParBW b t)
|
||||
instance TraversableB (b t) => TraversableB (ParBW b t)
|
||||
instance ProductB (b t) => ProductB (ParBW b t)
|
||||
instance ApplicativeB (b t) => ApplicativeB (ParBW b t)
|
||||
instance BareB b => BareB (ParBW b)
|
||||
|
||||
-- XXX GHC currently rejects deriving this one since it
|
||||
@ -298,9 +292,6 @@ instance ConstraintsB (b t) => ConstraintsB (ParBW b t) where
|
||||
type AllB c (ParBW b t) = AllB c (b t)
|
||||
baddDicts (ParBW btf) = ParBW (baddDicts btf)
|
||||
|
||||
-- XXX SEE NOTE ON ConstraintsB
|
||||
instance ProductBC (b t) => ProductBC (ParBW b t) where
|
||||
bdicts = ParBW bdicts
|
||||
|
||||
data ParBHW h b t (f :: * -> *)
|
||||
= ParBHW (h (b t f))
|
||||
@ -317,6 +308,5 @@ data ParXW a t f
|
||||
instance FunctorB (ParXW a Bare)
|
||||
instance FunctorB (ParXW a Covered)
|
||||
instance TraversableB (ParXW a Covered)
|
||||
instance ProductB (ParXW a Covered)
|
||||
instance ApplicativeB (ParXW a Covered)
|
||||
instance ConstraintsB (ParXW a Covered)
|
||||
instance ProductBC (ParXW a Covered)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user