From b33825efd051dc0084bea378dabcf921e5ceee23 Mon Sep 17 00:00:00 2001 From: Koji Miyazato Date: Sat, 31 Dec 2022 18:08:48 +0900 Subject: [PATCH] Add instances for (covariant) Day - Eq1 and Ord1, using the same approach to the free applicative - Directly copied Data/Functor/Classes/Compat.hs from free - Foldable/Traversable and Foldable1/Traversable1 --- kan-extensions.cabal | 4 +- src/Data/Functor/Classes/Compat.hs | 107 +++++++++ src/Data/Functor/Day.hs | 373 ++++++++++++++++++++--------- 3 files changed, 376 insertions(+), 108 deletions(-) create mode 100644 src/Data/Functor/Classes/Compat.hs diff --git a/kan-extensions.cabal b/kan-extensions.cabal index f08b425..6de9ef6 100644 --- a/kan-extensions.cabal +++ b/kan-extensions.cabal @@ -86,7 +86,9 @@ library Data.Functor.Kan.Ran Data.Functor.Yoneda Data.Functor.Coyoneda - + other-modules: + Data.Functor.Classes.Compat + ghc-options: -Wall default-language: Haskell2010 diff --git a/src/Data/Functor/Classes/Compat.hs b/src/Data/Functor/Classes/Compat.hs new file mode 100644 index 0000000..5c20bf4 --- /dev/null +++ b/src/Data/Functor/Classes/Compat.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +#include "kan-extensions-common.h" +#ifdef LIFTED_FUNCTOR_CLASSES +{-# LANGUAGE Safe #-} +module Data.Functor.Classes.Compat ( + mappend, + boringEq, + emptyEq, + boringCompare, + module Data.Functor.Classes, + ) where + +import Data.Functor.Classes + +#if !(MIN_VERSION_base(4,8,0)) +import Data.Monoid (mappend) +#endif + +boringEq :: Eq1 f => f a -> f b -> Bool +boringEq = liftEq (\_ _ -> True) + +emptyEq :: Eq1 f => f a -> f b -> Bool +emptyEq = liftEq (\_ _ -> False) + +boringCompare :: Ord1 f => f a -> f b -> Ordering +boringCompare = liftCompare (\_ _ -> EQ) +#else +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Trustworthy #-} +module Data.Functor.Classes.Compat ( + Lift1 (..), + on, + boringEq, + emptyEq, + liftEq, + boringCompare, + liftCompare, + module Data.Functor.Classes, + ) where + +------------------------------------------------------------------------------- +-- transformers-0.4 helpers, copied from prelude-extras +------------------------------------------------------------------------------- + +# if !(MIN_VERSION_base(4,8,0)) +import Data.Foldable +import Data.Traversable +# endif +import Data.Functor.Classes +import Data.Function (on) + +-- If Show1 and Read1 are ever derived by the same mechanism as +-- Show and Read, rather than GND, that will change their behavior +-- here. +newtype Lift1 f a = Lift1 { lower1 :: f a } + deriving (Functor, Foldable, Traversable, Eq1, Ord1, Show1, Read1) + +instance (Eq1 f, Eq a) => Eq (Lift1 f a) where (==) = eq1 +instance (Ord1 f, Ord a) => Ord (Lift1 f a) where compare = compare1 +instance (Show1 f, Show a) => Show (Lift1 f a) where showsPrec = showsPrec1 +instance (Read1 f, Read a) => Read (Lift1 f a) where readsPrec = readsPrec1 + +boringEq :: (Eq1 f, Functor f) => f a -> f b -> Bool +boringEq fa fb = eq1 (fmap (const ()) fa) (fmap (const ()) fb) + +-- | Internal only, do not export +data AlwaysFalse = AlwaysFalse + +instance Eq AlwaysFalse where + _ == _ = False + +emptyEq :: (Eq1 f, Functor f) => f a -> f b -> Bool +emptyEq fa fb = eq1 (fmap (const AlwaysFalse) fa) (fmap (const AlwaysFalse) fb) + +-- | Internal only, do not export +data EqualityTmp b = EqualityLeft (b -> Bool) | EqualityRight b + +instance Eq (EqualityTmp b) where + EqualityLeft f == EqualityRight x = f x + EqualityRight x == EqualityLeft f = f x + _ == _ = error "Undefined combination for equality" + +-- | Emulated @liftEq@ using old @eq1@ +liftEq :: (Eq1 f, Functor f) => (a -> b -> Bool) -> f a -> f b -> Bool +liftEq eq fa fb = eq1 (fmap (EqualityLeft . eq) fa) (fmap EqualityRight fb) + +boringCompare :: (Ord1 f, Functor f) => f a -> f b -> Ordering +boringCompare fa fb = compare1 (fmap (const ()) fa) (fmap (const ()) fb) + +-- | Internal only, do not export +data ComparisonTmp b = ComparisonLeft (b -> Ordering) | ComparisonRight b + +instance Eq (ComparisonTmp b) where + x == y = compare x y == EQ +instance Ord (ComparisonTmp b) where + compare (ComparisonLeft f) (ComparisonRight b) = f b + compare (ComparisonRight b) (ComparisonLeft f) = case f b of + LT -> GT + EQ -> EQ + GT -> LT + compare _ _ = error "Unexpected combination for comparison" + +-- | Emulated @liftCompare@ using old @compare1@ +liftCompare :: (Ord1 f, Functor f) => (a -> b -> Ordering) -> f a -> f b -> Ordering +liftCompare cmp fa fb = compare1 (fmap (ComparisonLeft . cmp) fa) (fmap ComparisonRight fb) +#endif \ No newline at end of file diff --git a/src/Data/Functor/Day.hs b/src/Data/Functor/Day.hs index 710e0fd..3fc1f03 100644 --- a/src/Data/Functor/Day.hs +++ b/src/Data/Functor/Day.hs @@ -1,59 +1,78 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} +#include "kan-extensions-common.h" {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + ----------------------------------------------------------------------------- --- | --- Copyright : (C) 2014-2016 Edward Kmett --- License : BSD-style (see the file LICENSE) --- --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- Eitan Chatav first introduced me to this construction --- --- The Day convolution of two covariant functors is a covariant functor. --- --- Day convolution is usually defined in terms of contravariant functors, --- however, it just needs a monoidal category, and Hask^op is also monoidal. --- --- Day convolution can be used to nicely describe monoidal functors as monoid --- objects w.r.t this product. --- --- + ---------------------------------------------------------------------------- -module Data.Functor.Day - ( Day(..) - , day - , dap - , assoc, disassoc - , swapped - , intro1, intro2 - , elim1, elim2 - , trans1, trans2 - , cayley, dayley - ) where +{- | +Copyright : (C) 2014-2016 Edward Kmett +License : BSD-style (see the file LICENSE) + +Maintainer : Edward Kmett +Stability : provisional +Portability : portable + +Eitan Chatav first introduced me to this construction + +The Day convolution of two covariant functors is a covariant functor. + +Day convolution is usually defined in terms of contravariant functors, +however, it just needs a monoidal category, and Hask^op is also monoidal. + +Day convolution can be used to nicely describe monoidal functors as monoid +objects w.r.t this product. + + +-} +module Data.Functor.Day ( + Day (..), + day, + dap, + assoc, + disassoc, + swapped, + intro1, + intro2, + elim1, + elim2, + trans1, + trans2, + cayley, + dayley, +) where import Control.Applicative import Control.Category import Control.Comonad import Control.Comonad.Trans.Class import Data.Distributive -import Data.Profunctor.Cayley (Cayley(..)) -import Data.Profunctor.Composition (Procompose(..)) -import Data.Functor.Adjunction +import Data.Functor.Classes.Compat import Data.Functor.Identity import Data.Functor.Rep +import Data.Profunctor.Cayley (Cayley (..)) +import Data.Profunctor.Composition (Procompose (..)) +import Data.Functor.Adjunction +import Data.Foldable +import Data.Semigroup.Foldable ( Foldable1(foldMap1) ) +import Data.Traversable +import Data.Semigroup.Traversable ( Traversable1(traverse1) ) + +import qualified Data.Array as Arr #ifdef __GLASGOW_HASKELL__ import Data.Typeable #endif -import Prelude hiding (id,(.)) +import Prelude hiding (id, (.), foldr) +import Data.Monoid (Sum(..)) +import Data.Functor.Apply (Apply, liftF2) + -- | The Day convolution of two covariant functors. data Day f g a = forall b c. Day (f b) (g c) (b -> c -> a) @@ -88,8 +107,10 @@ instance Functor (Day f g) where instance (Applicative f, Applicative g) => Applicative (Day f g) where pure x = Day (pure ()) (pure ()) (\_ _ -> x) (Day fa fb u) <*> (Day gc gd v) = - Day ((,) <$> fa <*> gc) ((,) <$> fb <*> gd) - (\(a,c) (b,d) -> u a b (v c d)) + Day + ((,) <$> fa <*> gc) + ((,) <$> fb <*> gd) + (\(a, c) (b, d) -> u a b (v c d)) instance (Representable f, Representable g) => Distributive (Day f g) where distribute f = Day (tabulate id) (tabulate id) $ \x y -> @@ -101,7 +122,7 @@ instance (Representable f, Representable g) => Distributive (Day f g) where instance (Representable f, Representable g) => Representable (Day f g) where type Rep (Day f g) = (Rep f, Rep g) tabulate f = Day (tabulate id) (tabulate id) (curry f) - index (Day m n o) (x,y) = o (index m x) (index n y) + index (Day m n o) (x, y) = o (index m x) (index n y) instance (Adjunction f u, Adjunction f' u') => Adjunction (Day f f') (Day u u') where unit a = Day (unit ()) (unit ()) (\f f' -> Day f f' (\() () -> a)) @@ -116,105 +137,243 @@ instance (Comonad f, Comonad g) => Comonad (Day f g) where instance (ComonadApply f, ComonadApply g) => ComonadApply (Day f g) where Day fa fb u <@> Day gc gd v = - Day ((,) <$> fa <@> gc) ((,) <$> fb <@> gd) - (\(a,c) (b,d) -> u a b (v c d)) + Day + ((,) <$> fa <@> gc) + ((,) <$> fb <@> gd) + (\(a, c) (b, d) -> u a b (v c d)) instance Comonad f => ComonadTrans (Day f) where lower (Day fb gc bca) = bca (extract fb) <$> gc --- | Day convolution provides a monoidal product. The associativity --- of this monoid is witnessed by 'assoc' and 'disassoc'. --- --- @ --- 'assoc' . 'disassoc' = 'id' --- 'disassoc' . 'assoc' = 'id' --- 'fmap' f '.' 'assoc' = 'assoc' '.' 'fmap' f --- @ +liftEqDay :: +#ifdef LIFTED_FUNCTOR_CLASSES + (Eq1 f, Eq1 g) +#else + (Eq1 f, Functor f, Eq1 g, Functor g) +#endif + => (a -> b -> Bool) -> Day f g a -> Day f g b -> Bool +liftEqDay eq (Day f1 g1 op1) (Day f2 g2 op2) + | emptyEq f1 f2 = boringEq g1 g2 + | otherwise = liftEq (\a1 a2 -> liftEq (\b1 b2 -> eq (op1 a1 b1) (op2 a2 b2)) g1 g2) f1 f2 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Eq1 f, Eq1 g) => Eq1 (Day f g) where + liftEq = liftEqDay + +instance (Eq1 f, Eq1 g, Eq a) => Eq (Day f g a) where + (==) = eq1 +#else +instance (Eq1 f, Functor f, Eq1 g, Functor g) => Eq1 (Day f g) where + eq1 = liftEqDay (==) + +instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq a) => Eq (Day f g a) where + (==) = eq1 +#endif + +liftCompareDay :: +#ifdef LIFTED_FUNCTOR_CLASSES + (Ord1 f, Ord1 g) +#else + (Ord1 f, Functor f, Ord1 g, Functor g) +#endif + => (a -> b -> Ordering) -> Day f g a -> Day f g b -> Ordering +liftCompareDay cmp (Day f1 g1 op1) (Day f2 g2 op2) + | emptyEq f1 f2 = boringCompare g1 g2 + | otherwise = liftCompare (\a1 a2 -> liftCompare (\b1 b2 -> cmp (op1 a1 b1) (op2 a2 b2)) g1 g2) f1 f2 + +#ifdef LIFTED_FUNCTOR_CLASSES +instance (Ord1 f, Ord1 g) => Ord1 (Day f g) where + liftCompare = liftCompareDay + +instance (Ord1 f, Ord1 g, Ord a) => Ord (Day f g a) where + compare = compare1 +#else +instance (Ord1 f, Functor f, Ord1 g, Functor g) => Ord1 (Day f g) where + compare1 = liftCompareDay compare + +instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord a) => Ord (Day f g a) where + compare = compare1 +#endif + +-- | @'toList' == 'dap' . 'trans1' toList . 'trans2' toList@ +instance (Foldable f, Foldable g) => Foldable (Day f g) where + foldMap h (Day f g op) = foldMap (\a -> foldMap (\b -> h (op a b)) g) f + foldr step zero (Day f g op) = foldr (\a r -> foldr (\b -> step (op a b)) r g) zero f + +#if MIN_VERSION_base(4,8,0) + null (Day f g _) = null f || null g + + length (Day f g _) = length f * length g +#endif + +instance (Foldable1 f, Foldable1 g) => Foldable1 (Day f g) where + foldMap1 h (Day f g op) = foldMap1 (\a -> foldMap1 (\b -> h (op a b)) g) f + +testEmpty :: Traversable f => f a -> Maybe (f b) +testEmpty = traverse (const Nothing) + +indices :: Traversable f => f a -> f Int +indices = snd . mapAccumL (\n _ -> n `seq` (n+1, n)) 0 + +length' :: Foldable f => f a -> Int +#if MIN_VERSION_base(9,8,0) +length' = length +#else +length' = getSum . foldMap (const (Sum 1)) +#endif + +instance (Traversable f, Traversable g) => Traversable (Day f g) where + -- Note on the implementation of traverse (Day f g) + -- + -- This implementation first checks if either f or g is null, + -- and takes a fast path if it is. + -- + -- The benefit of this check is skipping the traversal of the + -- other (not found to be null) functor to save time and memory, + -- used to keep unnecessary indices. + -- + -- Most of the time, the @testEmpty@ check is cheap. + -- For example, @testEmpty@ is @O(1)@ on @[]@ or @Array i@. + + traverse h (Day f g op) = case (testEmpty f, testEmpty g) of + (Just fAny, _) -> pure (Day fAny g const) + (_, Just gAny) -> pure (Day f gAny (\_ v -> v)) + _ -> + let fi = indices f + gj = indices g + lenF = length' f + lenG = length' g + idx a i j = a Arr.! (lenG * i + j) + makeArray = Arr.listArray (0, lenF * lenG - 1) + fromTable cs = Day fi gj (idx (makeArray cs)) + in fromTable <$> traverse h (op <$> toList f <*> toList g) + +instance (Traversable1 f, Traversable1 g) => Traversable1 (Day f g) where + traverse1 h (Day f g op) = case mfcs of + Nothing -> error "impossible!" + Just fcs -> fromTable <$> fcs + where + fi = indices f + gj = indices g + lenF = length' f + lenG = length' g + idx a i j = a Arr.! (lenG * i + j) + makeArray = Arr.listArray (0, lenF * lenG - 1) . toList + fromTable cs = Day fi gj (idx (makeArray cs)) + mfcs = traverseNonEmpty h (op <$> toList f <*> toList g) + +traverseNonEmpty :: Apply f => (a -> f b) -> [a] -> Maybe (f [b]) +traverseNonEmpty f = go + where + go [] = Nothing + go (a:as) = Just $ go' a as + + go' a [] = (: []) <$> f a + go' a (a':as) = liftF2 (:) (f a) (go' a' as) + +{- | Day convolution provides a monoidal product. The associativity +of this monoid is witnessed by 'assoc' and 'disassoc'. + +@ +'assoc' . 'disassoc' = 'id' +'disassoc' . 'assoc' = 'id' +'fmap' f '.' 'assoc' = 'assoc' '.' 'fmap' f +@ +-} assoc :: Day f (Day g h) a -> Day (Day f g) h a assoc (Day fb (Day gd he dec) bca) = Day (Day fb gd (,)) he $ - \ (b,d) e -> bca b (dec d e) - --- | Day convolution provides a monoidal product. The associativity --- of this monoid is witnessed by 'assoc' and 'disassoc'. --- --- @ --- 'assoc' . 'disassoc' = 'id' --- 'disassoc' . 'assoc' = 'id' --- 'fmap' f '.' 'disassoc' = 'disassoc' '.' 'fmap' f --- @ + \(b, d) e -> bca b (dec d e) + +{- | Day convolution provides a monoidal product. The associativity +of this monoid is witnessed by 'assoc' and 'disassoc'. + +@ +'assoc' . 'disassoc' = 'id' +'disassoc' . 'assoc' = 'id' +'fmap' f '.' 'disassoc' = 'disassoc' '.' 'fmap' f +@ +-} disassoc :: Day (Day f g) h a -> Day f (Day g h) a -disassoc (Day (Day fb gc bce) hd eda) = Day fb (Day gc hd (,)) $ \ b (c,d) -> +disassoc (Day (Day fb gc bce) hd eda) = Day fb (Day gc hd (,)) $ \b (c, d) -> eda (bce b c) d --- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric. --- --- @ --- 'fmap' f '.' 'swapped' = 'swapped' '.' 'fmap' f --- @ +{- | The monoid for 'Day' convolution on the cartesian monoidal structure is symmetric. + +@ +'fmap' f '.' 'swapped' = 'swapped' '.' 'fmap' f +@ +-} swapped :: Day f g a -> Day g f a swapped (Day fb gc abc) = Day gc fb (flip abc) --- | 'Identity' is the unit of 'Day' convolution --- --- @ --- 'intro1' '.' 'elim1' = 'id' --- 'elim1' '.' 'intro1' = 'id' --- @ +{- | 'Identity' is the unit of 'Day' convolution + +@ +'intro1' '.' 'elim1' = 'id' +'elim1' '.' 'intro1' = 'id' +@ +-} intro1 :: f a -> Day Identity f a intro1 fa = Day (Identity ()) fa $ \_ a -> a --- | 'Identity' is the unit of 'Day' convolution --- --- @ --- 'intro2' '.' 'elim2' = 'id' --- 'elim2' '.' 'intro2' = 'id' --- @ +{- | 'Identity' is the unit of 'Day' convolution + +@ +'intro2' '.' 'elim2' = 'id' +'elim2' '.' 'intro2' = 'id' +@ +-} intro2 :: f a -> Day f Identity a intro2 fa = Day fa (Identity ()) const --- | 'Identity' is the unit of 'Day' convolution --- --- @ --- 'intro1' '.' 'elim1' = 'id' --- 'elim1' '.' 'intro1' = 'id' --- @ +{- | 'Identity' is the unit of 'Day' convolution + +@ +'intro1' '.' 'elim1' = 'id' +'elim1' '.' 'intro1' = 'id' +@ +-} elim1 :: Functor f => Day Identity f a -> f a elim1 (Day (Identity b) fc bca) = bca b <$> fc --- | 'Identity' is the unit of 'Day' convolution --- --- @ --- 'intro2' '.' 'elim2' = 'id' --- 'elim2' '.' 'intro2' = 'id' --- @ +{- | 'Identity' is the unit of 'Day' convolution + +@ +'intro2' '.' 'elim2' = 'id' +'elim2' '.' 'intro2' = 'id' +@ +-} elim2 :: Functor f => Day f Identity a -> f a elim2 (Day fb (Identity c) bca) = flip bca c <$> fb --- | Collapse via a monoidal functor. --- --- @ --- 'dap' ('day' f g) = f '<*>' g --- @ +{- | Collapse via a monoidal functor. + +@ +'dap' ('day' f g) = f '<*>' g +@ +-} dap :: Applicative f => Day f f a -> f a dap (Day fb fc abc) = liftA2 abc fb fc --- | Apply a natural transformation to the left-hand side of a Day convolution. --- --- This respects the naturality of the natural transformation you supplied: --- --- @ --- 'fmap' f '.' 'trans1' fg = 'trans1' fg '.' 'fmap' f --- @ +{- | Apply a natural transformation to the left-hand side of a Day convolution. + +This respects the naturality of the natural transformation you supplied: + +@ +'fmap' f '.' 'trans1' fg = 'trans1' fg '.' 'fmap' f +@ +-} trans1 :: (forall x. f x -> g x) -> Day f h a -> Day g h a trans1 fg (Day fb hc bca) = Day (fg fb) hc bca --- | Apply a natural transformation to the right-hand side of a Day convolution. --- --- This respects the naturality of the natural transformation you supplied: --- --- @ --- 'fmap' f '.' 'trans2' fg = 'trans2' fg '.' 'fmap' f --- @ +{- | Apply a natural transformation to the right-hand side of a Day convolution. + +This respects the naturality of the natural transformation you supplied: + +@ +'fmap' f '.' 'trans2' fg = 'trans2' fg '.' 'fmap' f +@ +-} trans2 :: (forall x. g x -> h x) -> Day f g a -> Day f h a trans2 gh (Day fb gc bca) = Day fb (gh gc) bca