diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md diff --git a/Conkin.hs b/Conkin.hs new file mode 100644 --- /dev/null +++ b/Conkin.hs @@ -0,0 +1,820 @@ +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- The 'Conkin' module defines tools for types of kind @(k -> *) -> *@ +-- (__con__tinuation __kin__d types), treating them as functors from the category of +-- types of kind @k -> *@ (/Hask^k/) to the category of types of kind @*@ (/Hask/). +-- +-- It defines its own 'Functor', 'Applicative', 'Foldable', and 'Traversable' +-- classes, as continuation kind types are kind-incompatible with the +-- homonymous classes in "Prelude". +-- +-- The 'Dispose' type lifts a traditional functor to a continuation kind +-- functor: +-- +-- >>> :k Dispose Maybe 0 +-- Dispose Maybe 0 :: (Nat -> *) -> * +-- +-- While the 'Coyoneda' type does the opposite. +-- +-- >>> data OfSymbol a = OfSymbol (a "hello") +-- >>> :k OfSymbol +-- OfSymbol :: (Symbol -> *) -> * +-- >>> :k Coyoneda OfSymbol +-- Coyoneda OfSymbol :: * -> * +-- +-- Two of the most useful functions provided by the module are 'align' and +-- 'apportion', as they allow you to transpose the composition of a traditional +-- endofunctor and a continuation kind functor. +-- +-- >>> rows = zipWith (\ch ix -> Pair (Identity ch, Identity ix)) "abc" [0..2] +-- >>> rows +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- >>> cols = align rows +-- >>> cols +-- Pair { getPair = ( "abc" , [ 0 , 1 , 2 ] ) } +-- >>> apportion cols +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'a' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'a' , Identity 2 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 2 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- >>> apportion $ fmap ZipList cols +-- ZipList +-- { getZipList = +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- } +-- +-- There's also convenience types for 'Product's and 'Coproduct's of +-- continuation kind functors, as well as for 'Tuple's and 'Tagged' unions +-- of arbitrary types. +module Conkin + {- classes -} + ( Functor(..), (<$>) + , Applicative(..), type (~>)(..), liftA2, liftA3, liftA4 + , Foldable(..) + , Traversable(..), traverse', sequenceA', liftT1, liftT2, liftT3, liftT4, align, apportion + {- wrappers -} + , Dispose(..) + , Coyoneda(..), getCoyoneda, toCoyoneda + {- functors -} + , Product(..), toProduct, fromProduct + , Coproduct(..) + , Pair(..) + , Tuple(..) + , Tagged(..) + {- utility types -} + , Flip(..) + , Curry(..) + , Uncurry(..), pattern UncurryStrict, getUncurryStrict, uncurried + , Pure(..) + --, Exists(..) + --, Both(..) + --, Curry2(..) + --, Compose2(..) + ) where +import Prelude hiding (Functor(..), (<$>), Applicative(..), Traversable(..), Foldable(..) ) +import qualified Prelude +import qualified Control.Applicative as Prelude +import Data.Functor.Compose (Compose(..)) +import Data.Functor.Const (Const(..)) +import Data.Monoid (Endo(..), (<>)) +import Unsafe.Coerce (unsafeCoerce) +import Data.Functor.Identity (Identity(..)) + +-- $setup +-- >>> :set -XDataKinds -XGADTs +-- >>> :m +GHC.TypeLits +-- >>> import Text.Show.Pretty (pPrint) +-- >>> :set -interactive-print pPrint +-- >>> import Control.Applicative (ZipList(..)) + +{- Classes ----------------------------------------------------------------------} + +-- | A functor from /Hask^k/ to /Hask/, an analogue of 'Prelude.Functor' for kind @(k -> *) -> *@ +class Functor (f :: (k -> *) -> *) where + fmap :: (forall (x :: k). a x -> b x) -> f a -> f b + +-- | An analogue of 'Prelude.<$>' for use with "Conkin"'s 'Functor' +(<$>) :: Functor f => (forall x. a x -> b x) -> f a -> f b +(<$>) = fmap +infixl 4 <$> + +-- | An analogue of 'Prelude.Applicative' for kind @(k -> *) -> *@ +class Functor f => Applicative (f :: (k -> *) -> *) where + pure :: (forall (x :: k). a x) -> f a + (<*>) :: f (a ~> b) -> f a -> f b +infixl 4 <*> + +-- | arrows in /Hask^k/ have type @a ~> b :: k -> *@ +newtype (~>) (a :: k -> *) (b :: k -> *) (x :: k) = + Arrow { (~$~) :: a x -> b x } +infixr 0 ~> +infixr 0 ~$~ +-- XXX: (Prelude.Contravariant a, Prelude.Functor b) => Prelude.Functor (a ~> b) + +-- | An analogue of 'Prelude.liftA2' for use with "Conkin"'s 'Applicative' +liftA2 :: Applicative f => (forall x. a x -> b x -> c x) -> f a -> f b -> f c +liftA2 f a b = (Arrow . f) <$> a <*> b + +-- | An analogue of 'Prelude.liftA3' for use with "Conkin"'s 'Applicative' +liftA3 :: Applicative f => (forall x. a x -> b x -> c x -> d x) -> f a -> f b -> f c -> f d +liftA3 f a b c = Arrow . (Arrow .) . f <$> a <*> b <*> c + +-- | An extension of 'liftA3' to functions of four arguments +liftA4 :: Applicative f => (forall x. a x -> b x -> c x -> d x -> e x) -> f a -> f b -> f c -> f d -> f e +liftA4 f a b c d = Arrow . (Arrow .) . ((Arrow.).) . f <$> a <*> b <*> c <*> d + +-- | An analogue of 'Prelude.Foldable' for kind @(k -> *) -> *@ +class Foldable (t :: (k -> *) -> *) where + foldr :: (forall (x :: k). a x -> b -> b ) -> b -> t a -> b + foldr f b ta = foldMap (Endo . f) ta `appEndo` b + + foldMap :: Monoid m => (forall (x :: k). a x -> m) -> t a -> m + foldMap f = foldr (\ax b -> f ax <> b) mempty + + {-# MINIMAL foldr | foldMap #-} + +-- | An analogue of 'Prelude.Traversable' for kind @(k -> *) -> *@ +class (Foldable t, Functor t) => Traversable (t :: (i -> *) -> *) where + traverse :: forall (f :: (j -> *) -> *) (a :: i -> *) (b :: i -> j -> *). + Applicative f => (forall x. a x -> f (b x)) -> t a -> f (Compose t (Flip b)) + traverse f = sequenceA . fmap (Compose . f) + + sequenceA :: forall (f :: (j -> *) -> *) (a :: i -> j -> *). + Applicative f => t (Compose f a) -> f (Compose t (Flip a)) + sequenceA = traverse getCompose + + {-# MINIMAL traverse | sequenceA #-} + +-- | version of 'traverse' that unflips the inner type +traverse' :: (Traversable t, Applicative f) => (forall x. a x -> f (Flip b x)) -> t a -> f (Compose t b) +traverse' f = fmap (Compose . fmap (getFlip . getFlip) . getCompose) . traverse f + +-- | version of 'sequenceA' that unflips the inner type +sequenceA' :: (Traversable t, Applicative f) => t (Compose f (Flip a)) -> f (Compose t a) +sequenceA' = fmap (Compose . fmap (getFlip . getFlip) . getCompose) . sequenceA + +-- | 'sequenceA' helper for single-parameter constructors +-- +-- >>> :{ +-- data OfOne a = OfOne (a Int) +-- instance Functor OfOne where +-- fmap h (OfOne a) = OfOne (h a) +-- instance Applicative OfOne where +-- pure = OfOne +-- OfOne f <*> OfOne a = OfOne (f ~$~ a) +-- instance Foldable OfOne where +-- foldMap h (OfOne a) = h a +-- instance Traversable OfOne where +-- sequenceA (OfOne fa) = liftT1 OfOne fa +-- :} +liftT1 :: Applicative g => + (forall h. h w -> f h) -> Compose g a w -> g (Compose f (Flip a)) +liftT1 c = fmap (Compose . c . Flip) . getCompose + +-- | 'sequenceA' helper for two-parameter constructors +-- +-- >>> :{ +-- data OfTwo a = OfTwo (a Int) (a Char) +-- instance Functor OfTwo where +-- fmap h (OfTwo ai ac) = OfTwo (h ai) (h ac) +-- instance Applicative OfTwo where +-- pure a = OfTwo a a +-- OfTwo fi fc <*> OfTwo ai ac = OfTwo (fi ~$~ ai) (fc ~$~ ac) +-- instance Foldable OfTwo where +-- foldMap h (OfTwo ai ac) = h ai <> h ac +-- instance Traversable OfTwo where +-- sequenceA (OfTwo fai fac) = liftT2 OfTwo fai fac +-- :} +liftT2 :: Applicative g => + (forall h. h w -> h x -> f h) -> Compose g a w -> Compose g a x -> g (Compose f (Flip a)) +liftT2 c (Compose gaw) (Compose gax) = + liftA2 (\awt axt -> Compose $ c (Flip awt) (Flip axt)) gaw gax + +-- | 'sequenceA' helper for three-parameter constructors +-- +-- >>> :{ +-- data OfThree a = OfThree (a Int) (a Char) (a Bool) +-- instance Functor OfThree where +-- fmap h (OfThree ai ac ab) = OfThree (h ai) (h ac) (h ab) +-- instance Applicative OfThree where +-- pure a = OfThree a a a +-- OfThree fi fc fb <*> OfThree ai ac ab = OfThree (fi ~$~ ai) (fc ~$~ ac) (fb ~$~ ab) +-- instance Foldable OfThree where +-- foldMap h (OfThree ai ac ab) = h ai <> h ac <> h ab +-- instance Traversable OfThree where +-- sequenceA (OfThree fai fac fab) = liftT3 OfThree fai fac fab +-- :} +liftT3 :: Applicative g => + (forall h. h w -> h x -> h y -> f h) -> Compose g a w -> Compose g a x -> Compose g a y -> g (Compose f (Flip a)) +liftT3 c (Compose gaw) (Compose gax) (Compose gay) = + liftA3 (\awt axt ayt -> Compose $ c (Flip awt) (Flip axt) (Flip ayt)) gaw gax gay + +-- | 'sequenceA' helper for four-parameter constructors +-- +-- >>> :{ +-- data OfFour a = OfFour (a Int) (a Char) (a Bool) (a Double) +-- instance Functor OfFour where +-- fmap h (OfFour ai ac ab ad) = OfFour (h ai) (h ac) (h ab) (h ad) +-- instance Applicative OfFour where +-- pure a = OfFour a a a a +-- OfFour fi fc fb fd <*> OfFour ai ac ab ad = OfFour (fi ~$~ ai) (fc ~$~ ac) (fb ~$~ ab) (fd ~$~ ad) +-- instance Foldable OfFour where +-- foldMap h (OfFour ai ac ab ad) = h ai <> h ac <> h ab <> h ad +-- instance Traversable OfFour where +-- sequenceA (OfFour fai fac fab fad) = liftT4 OfFour fai fac fab fad +-- :} +liftT4 :: Applicative g => + (forall h. h w -> h x -> h y -> h z -> f h) -> Compose g a w -> Compose g a x -> Compose g a y -> Compose g a z -> g (Compose f (Flip a)) +liftT4 c (Compose gaw) (Compose gax) (Compose gay) (Compose gaz) = + liftA4 (\awt axt ayt azt -> Compose $ c (Flip awt) (Flip axt) (Flip ayt) (Flip azt)) gaw gax gay gaz + +-- | Loosely, 'align' transforms an array of structures into a structure +-- of arrays, if by \"array\" one means an arbitrary collection type. +-- +-- >>> rows = zipWith (\ch ix -> Pair (Identity ch, Identity ix)) "abc" [0..2] +-- >>> rows +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- >>> align rows +-- Pair { getPair = ( "abc" , [ 0 , 1 , 2 ] ) } +align :: (Prelude.Traversable f, Applicative g) => f (g Identity) -> g f +align = fmap teardown . sequenceA . Dispose . Prelude.fmap setup where + setup :: Functor g => g Identity -> Compose g (Flip Const) void + setup = Compose . fmap (Flip . Const . runIdentity) + + teardown :: Prelude.Functor f => Compose (Dispose f void) (Flip (Flip Const)) x -> f x + teardown = Prelude.fmap (getConst . getFlip . getFlip) . getDispose . getCompose + +-- | Loosely, 'apportion' transforms a structure of arrays into an array +-- of structures, if by \"array\" one means an arbitrary collection type. +-- +-- Depending on the collection's 'Prelude.Applicative' instance, this +-- may or may not be the inverse of 'align'. +-- +-- >>> cols = Pair { getPair = ( "abc" , [ 0 , 1 , 2 ] ) } +-- >>> apportion cols +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'a' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'a' , Identity 2 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 2 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- >>> apportion $ fmap ZipList cols +-- ZipList +-- { getZipList = +-- [ Pair { getPair = ( Identity 'a' , Identity 0 ) } +-- , Pair { getPair = ( Identity 'b' , Identity 1 ) } +-- , Pair { getPair = ( Identity 'c' , Identity 2 ) } +-- ] +-- } +apportion :: (Prelude.Applicative f, Traversable g) => g f -> f (g Identity) +apportion = Prelude.fmap teardown . getDispose . traverse setup where + setup :: Prelude.Functor f => f x -> Dispose f void (Const x) + setup = Dispose . Prelude.fmap Const + + teardown :: Functor g => Compose g (Flip Const) void -> g Identity + teardown = fmap (Identity . getConst . getFlip) . getCompose + + +{- Dispose -----------------------------------------------------------------------} + +-- | If @f@ is a functor from /Hask/ to /Hask/, then, @forall (x :: k). Dispose f +-- x@ is a functor from /Hask^k/ to /Hask/ +-- +-- The name comes from the isomorphism @Dispose f ~ Flip (Compose f) :: k -> (k +-- -> *) -> *@, as a pun off the latin prefixes "com-", meaning together, and +-- "dis-", meaning apart. +newtype Dispose (f :: * -> *) (x :: k) (a :: k -> *) = + Dispose { getDispose :: f (a x) } + deriving (Show, Eq, Ord) + +instance Prelude.Functor f => Functor (Dispose f x) where + fmap f (Dispose fx) = Dispose $ Prelude.fmap f fx + +instance Prelude.Applicative f => Applicative (Dispose f x) where + pure a = Dispose $ Prelude.pure a + Dispose ff <*> Dispose fa = Dispose $ Prelude.liftA2 (~$~) ff fa + +instance Prelude.Foldable t => Foldable (Dispose t x) where + foldr f b = Prelude.foldr f b . getDispose + foldMap f = Prelude.foldMap f . getDispose + +instance Prelude.Traversable t => Traversable (Dispose t x) where + sequenceA = teardown . Prelude.traverse setup . getDispose where + setup :: Compose f a x -> Coyoneda f (Exists (a x)) + setup = Coyoneda Exists . getCompose + + teardown :: (Functor f, Prelude.Functor t) => Coyoneda f (t (Exists (a x))) -> f (Compose (Dispose t x) (Flip a)) + teardown (Coyoneda k fax) = Compose . Dispose . Prelude.fmap Flip . unwrap k <$> fax + + -- by parametricity, `t`'s implementation of `Prelude.sequenceA :: t (g e) -> + -- g (t e)` can't inspect the value of `e`, so all `Exists a` values + -- must be wrapped `a x` values, so this should be an okay use + -- of `unsafeGetExists`. + unwrap :: Prelude.Functor t => (b x -> t (Exists a)) -> b x -> t (a x) + unwrap k bx = Prelude.fmap (unsafeGetExists bx) $ k bx + + unsafeGetExists :: proxy x -> Exists a -> a x + unsafeGetExists _ (Exists az) = unsafeCoerce az + +data Exists (a :: k -> *) where + Exists :: a x -> Exists a + + +{- Coyoneda ---------------------------------------------------------------------} + +-- | If @t@ is a functor from /Hask^k/ to /Hask/, then @Coyoneda t@ is a functor +-- from /Hask/ to /Hask/. +-- +-- It's very similar to the 'Data.Functor.Coyoneda.Coyoneda' from the @kan-extensions@ package, +-- differing only in kind, and @Coyoneda t a@ is isomorphic to @t (Const a)@ for any 'Functor'. +data Coyoneda (t :: (k -> *) -> *) (u :: *) where + Coyoneda :: (forall x. a x -> u) -> t a -> Coyoneda t u + +-- | convert a functor from its 'Coyoneda' representation +getCoyoneda :: Functor t => Coyoneda t a -> t (Const a) +getCoyoneda (Coyoneda f t) = Const . f <$> t + +-- | convert a functor to its 'Coyoneda' representation +toCoyoneda :: t (Const a) -> Coyoneda t a +toCoyoneda = Coyoneda getConst + +instance Prelude.Functor (Coyoneda t) where + fmap f (Coyoneda k t) = Coyoneda (f . k) t + +instance Applicative t => Prelude.Applicative (Coyoneda t) where + pure a = toCoyoneda $ pure $ Const a + + Coyoneda kf tu <*> Coyoneda ka tv = Coyoneda (k kf ka) (t tu tv) where + k :: (forall x. u x -> a -> b) -> (forall x. v x -> a) -> (forall x. Both u v x -> b) + k kf ka (Both (ux, vx)) = kf ux $ ka vx + + t :: Applicative t => t u -> t v -> t (Both u v) + t = liftA2 $ curry Both + +newtype Both (a :: k -> *) (b :: k -> *) (x :: k) = Both (a x, b x) + -- XXX: Both (Compose f 'Left) (Compose g 'Right) ~ Coproduct f g + +instance Foldable t => Prelude.Foldable (Coyoneda t) where + foldr f b (Coyoneda k t) = foldr (f . k) b t + foldMap f (Coyoneda k t) = foldMap (f . k) t + +instance Traversable t => Prelude.Traversable (Coyoneda t) where + sequenceA (Coyoneda k t) = Prelude.fmap teardown . getDispose . sequenceA $ setup . k <$> t where + setup :: Prelude.Functor f => f a -> Compose (Dispose f y) (Curry (Const a)) x + setup = Compose . Dispose . Prelude.fmap (Curry . Const) + + teardown :: Functor t => Compose t (Flip (Curry (Const a))) y -> Coyoneda t a + teardown = Coyoneda (getConst . getCurry . getFlip) . getCompose + +{- Product ----------------------------------------------------------------------} + +-- | The product of two continuation kind functors is a continuation kind functor. +-- +-- >>> data A z where A :: Int -> [x] -> [y] -> A '(x,y) +-- >>> data B z where B :: [(x,y)] -> B '(x,y) +-- >>> foo = Product . Pure . Compose . Pure . Curry $ A 0 "abc" [True, False] +-- >>> :t foo +-- foo :: Product (Pure Char) (Pure Bool) A +-- >>> a2b :: A z -> B z ; a2b (A _ xs ys) = B $ zip xs ys +-- >>> :t fmap a2b foo +-- fmap a2b foo :: Product (Pure Char) (Pure Bool) B +-- +newtype Product (f :: (i -> *) -> *) (g :: (j -> *) -> *) (a :: (i,j) -> *) = + Product { getProduct :: f (Compose g (Curry a)) } + +-- | helper to make a 'Product' when the inner type is already curried. +-- +-- >>> comma = Pure . Compose . Pure $ ('a', True) +-- >>> :t comma +-- comma :: Pure Char (Compose (Pure Bool) (,)) +-- >>> :t toProduct UncurryStrict comma +-- toProduct UncurryStrict comma +-- :: Product (Pure Char) (Pure Bool) (Uncurry (,)) +toProduct :: (Functor f, Functor g) => (forall x y. a x y -> b '(x,y)) -> f (Compose g a) -> Product f g b +toProduct f = Product . fmap (Compose . fmap (Curry . f) . getCompose) + +-- | helper to unwrap a 'Product' when the inner type is already curried. +-- +-- >>> comma' = toProduct UncurryStrict . Pure . Compose . Pure $ ('a', True) +-- >>> :t comma' +-- comma' :: Product (Pure Char) (Pure Bool) (Uncurry (,)) +-- >>> :t getProduct comma' +-- getProduct comma' +-- :: Pure Char (Compose (Pure Bool) (Curry (Uncurry (,)))) +-- >>> :t fromProduct getUncurryStrict comma' +-- fromProduct getUncurryStrict comma' +-- :: Pure Char (Compose (Pure Bool) (,)) +fromProduct :: (Functor f, Functor g) => (forall x y. b '(x,y) -> a x y) -> Product f g b -> f (Compose g a) +fromProduct f = fmap (Compose . fmap (f . getCurry) . getCompose) . getProduct + +deriving instance Show (f (Compose g (Curry a))) => Show (Product f g a) +deriving instance Eq (f (Compose g (Curry a))) => Eq (Product f g a) +deriving instance Ord (f (Compose g (Curry a))) => Ord (Product f g a) + +instance (Functor f, Functor g) => Functor (Product f g) where + fmap h = Product . fmap (Compose . fmap (Curry . h . getCurry) . getCompose) . getProduct + +instance (Applicative f, Applicative g) => Applicative (Product f g) where + pure a = Product $ pure $ Compose $ pure $ Curry a + Product ff <*> Product fa = Product $ liftA2 (\(Compose gf) (Compose ga) -> Compose $ liftA2 (\(Curry f) (Curry a) -> Curry $ f ~$~ a) gf ga) ff fa + +instance (Foldable f, Foldable g) => Foldable (Product f g) where + foldMap h = foldMap (foldMap (h . getCurry) . getCompose) . getProduct + +instance (Traversable f, Traversable g) => Traversable (Product f g) where + sequenceA = fmap cleanup . traverse setup . getProduct where + setup :: (Applicative h, Traversable g) => Compose g (Curry (Compose h a)) x -> h (Compose2 (Compose2 (Compose g) Flip) (Curry2 a) x) + setup = fmap (Compose2 . Compose2) . traverse inner . getCompose + + inner :: Functor h => Curry (Compose h a) x y -> h (Curry2 a x y) + inner = fmap Curry2 . getCompose . getCurry + + cleanup :: (Functor f, Functor g) => Compose f (Flip (Compose2 (Compose2 (Compose g) Flip) (Curry2 a))) z -> Compose (Product f g) (Flip a) z + cleanup = Compose . Product . fmap (Compose . fmap (Curry . Flip . getCurry2 . getFlip) . getCompose . getCompose2 . getCompose2 . getFlip) . getCompose + +newtype Curry2 (a :: (i,j) -> k -> *) (x :: i) (y :: j) (z :: k) = Curry2 { getCurry2 :: a '(x,y) z } + +{- Coproduct --------------------------------------------------------------------} + +-- | The coproduct of two continuation kind functors is a continuation kind functor. +-- +-- >>> data A z where { AL :: i -> A ('Left i) ; AR :: j -> A ('Right j) } +-- >>> data B z where { BL :: i -> i -> B ('Left i) ; BR :: B ('Right j) } +-- >>> bar = Coproduct (Pure . Compose $ AL True, Pure . Compose $ AR 'a') +-- >>> :t bar +-- bar :: Coproduct (Pure Bool) (Pure Char) A +-- >>> a2b :: A z -> B z ; a2b (AL i) = BL i i ; a2b (AR _) = BR +-- >>> :t fmap a2b bar +-- fmap a2b bar :: Coproduct (Pure Bool) (Pure Char) B +newtype Coproduct (f :: (i -> *) -> *) (g :: (j -> *) -> *) (a :: Either i j -> *) = + Coproduct { getCoproduct :: (f (Compose a 'Left), g (Compose a 'Right)) } + +deriving instance (Show (f (Compose a 'Left)), Show (g (Compose a 'Right))) => Show (Coproduct f g a) +deriving instance (Eq (f (Compose a 'Left)), Eq (g (Compose a 'Right))) => Eq (Coproduct f g a) +deriving instance (Ord (f (Compose a 'Left)), Ord (g (Compose a 'Right))) => Ord (Coproduct f g a) + +instance (Functor f, Functor g) => Functor (Coproduct f g) where + fmap h (Coproduct (fal, gar)) = Coproduct (Compose . h . getCompose <$> fal, Compose . h . getCompose <$> gar) + +instance (Applicative f, Applicative g) => Applicative (Coproduct f g) where + pure ax = Coproduct (pure (Compose ax), pure (Compose ax)) + Coproduct (fhl, ghr) <*> Coproduct (fal, gar) = Coproduct (liftA2 go fhl fal, liftA2 go ghr gar) where + go (Compose hx) (Compose ax) = Compose (hx ~$~ ax) + +instance (Foldable f, Foldable g) => Foldable (Coproduct f g) where + foldMap h (Coproduct (fal, gar)) = foldMap (h . getCompose) fal <> foldMap (h . getCompose) gar + +instance (Traversable f, Traversable g) => Traversable (Coproduct f g) where + sequenceA (Coproduct (fhal, ghar)) = liftA2 teardown (setup fhal) (setup ghar) where + setup :: (Traversable t, Applicative h) => t (Compose (Compose h a) d) -> h (Compose t (Flip (Compose2 a d))) + setup = sequenceA . fmap (Compose . fmap Compose2 . getCompose . getCompose) + + teardown :: (Functor f, Functor g) => Compose f (Flip (Compose2 a 'Left)) y -> Compose g (Flip (Compose2 a 'Right)) y -> Compose (Coproduct f g) (Flip a) y + teardown faly gary = Compose $ Coproduct (cleanup faly, cleanup gary) + + cleanup :: Functor t => Compose t (Flip (Compose2 a d)) y -> t (Compose (Flip a y) d) + cleanup = fmap (Compose . Flip . getCompose2 . getFlip). getCompose + +newtype Compose2 (a :: j -> k -> *) (d :: i -> j) (x :: i) (y :: k) = Compose2 { getCompose2 :: a (d x) y } + +{- Pair -------------------------------------------------------------------------} + +-- | A continuation kind functor for pairs. +-- +-- >>> :t Pair (Identity True, Identity 'a') +-- Pair (Identity True, Identity 'a') :: Pair Bool Char Identity +newtype Pair (x0 :: k) (x1 :: k) (a :: k -> *) = + Pair { getPair :: (a x0, a x1) } + deriving (Show, Eq, Ord) + +instance Functor (Pair x0 x1) where + fmap f (Pair (ax0, ax1)) = Pair (f ax0, f ax1) + +instance Applicative (Pair x0 x1) where + pure ax = Pair (ax, ax) + Pair (fx0, fx1) <*> Pair (ax0, ax1) = Pair (fx0 ~$~ ax0, fx1 ~$~ ax1) + +instance Foldable (Pair x0 x1) where + foldMap f (Pair (ax0, ax1)) = f ax0 <> f ax1 + +instance Traversable (Pair x0 x1) where + sequenceA (Pair (gax0, gax1)) = liftT2 (curry Pair) gax0 gax1 + +{- Tuple ------------------------------------------------------------------------} + +-- | A continuation kind functor for tuples of arbitrary length. +-- +-- >>> :t Identity True `Cons` Identity 'a' `Cons` Nil +-- Identity True `Cons` Identity 'a' `Cons` Nil +-- :: Tuple '[Bool, Char] Identity +data Tuple (xs :: [k]) (a :: k -> *) where + Nil :: Tuple '[] a + Cons :: a x -> !(Tuple xs a) -> Tuple (x ': xs) a +infixr 5 `Cons` + +instance Show (Tuple '[] a) where + showsPrec _ Nil = showString "Nil" +instance (Show (a x), Show (Tuple xs a)) => Show (Tuple (x ': xs) a) where + showsPrec p (ax `Cons` t) = showParen (p > 5) $ showsPrec 6 ax . showString " `Cons` " . showsPrec 0 t + +instance Eq (Tuple '[] a) where + Nil == Nil = True +instance (Eq (a x), Eq (Tuple xs a)) => Eq (Tuple (x ': xs) a) where + Cons ax at == Cons bx bt = ax == bx && at == bt + +instance Ord (Tuple '[] a) where + Nil `compare` Nil = EQ +instance (Ord (a x), Ord (Tuple xs a)) => Ord (Tuple (x ': xs) a) where + Cons ax at `compare` Cons bx bt = compare ax bx `mappend` compare at bt + +instance Functor (Tuple xs) where + fmap _ Nil = Nil + fmap f (ax `Cons` axs) = f ax `Cons` fmap f axs + +instance Applicative (Tuple '[]) where + pure _ = Nil + _ <*> _ = Nil + +instance Applicative (Tuple xs) => Applicative (Tuple (x ': xs)) where + pure ax = ax `Cons` pure ax + Cons fx fxs <*> Cons ax axs = Cons (fx ~$~ ax) (fxs <*> axs) + +instance Foldable (Tuple xs) where + foldr _ z Nil = z + foldr f z (Cons fx fxs) = f fx (foldr f z fxs) + +instance Traversable (Tuple xs) where + sequenceA Nil = pure (Compose Nil) + sequenceA (Compose fax `Cons` cfaxs) = liftA2 go fax $ sequenceA cfaxs where + go :: forall a x y xs. a x y -> Compose (Tuple xs) (Flip a) y -> Compose (Tuple (x ': xs)) (Flip a) y + go axy (Compose ayxs) = Compose $ Cons (Flip axy) ayxs + +{- Tagged -----------------------------------------------------------------------} + +-- | A continuation kind functor for tagged unions +-- +-- >>> :t [ Here (Identity True), There $ Here (Identity 'a') ] +-- [ Here (Identity True), There $ Here (Identity 'a') ] +-- :: [Tagged (Bool : Char : xs) Identity] +data Tagged (xs :: [k]) (a :: k -> *) where + Here :: a x -> Tagged (x ': xs) a + There :: !(Tagged xs a) -> Tagged (x ': xs) a + +instance Show (Tagged '[] a) where + showsPrec _ t = seq t $ error "Tagged '[] a is uninhabited" + +instance Eq (Tagged '[] a) where + t == t' = seq t $ seq t' $ error "Tagged '[] a is uninhabited" + +instance Ord (Tagged '[] a) where + t `compare` t' = seq t $ seq t' $ error "Tagged '[] a is uninhabited" + +instance (Show (a x), Show (Tagged xs a)) => Show (Tagged (x ': xs) a) where + showsPrec p (Here ax) = showParen (p > 10) $ showString "Here " . showsPrec 11 ax + showsPrec p (There t) = showParen (p > 10) $ showString "There " . showsPrec 11 t + +instance (Eq (a x), Eq (Tagged xs a)) => Eq (Tagged (x ': xs) a) where + Here ax == Here bx = ax == bx + There t == There t' = t == t' + _ == _ = False + +instance (Ord (a x), Ord (Tagged xs a)) => Ord (Tagged (x ': xs) a) where + Here ax `compare` Here bx = ax `compare` bx + There t `compare` There t' = t `compare` t' + Here _ `compare` There _ = LT + There _ `compare` Here _ = GT + +instance Functor (Tagged xs) where + fmap f (Here ax) = Here (f ax) + fmap f (There t) = There (fmap f t) + +instance Foldable (Tagged xs) where + foldMap f (Here ax) = f ax + foldMap f (There t) = foldMap f t + +instance Traversable (Tagged xs) where + sequenceA (Here (Compose fax)) = Compose . Here . Flip <$> fax + sequenceA (There t) = Compose . There . getCompose <$> sequenceA t + +{- Const ------------------------------------------------------------------------} + +instance Functor (Const a) where + fmap _ = Const . getConst + +instance Monoid m => Applicative (Const m) where + pure _ = Const mempty + Const mf <*> Const ma = Const (mf <> ma) + +instance Foldable (Const m) where + foldMap _ _ = mempty + +instance Traversable (Const m) where + sequenceA (Const a) = pure $ Compose $ Const a + +{- Compose ----------------------------------------------------------------------} + +instance (Prelude.Functor f, Functor g) => Functor (Compose f g) where + fmap f = Compose . Prelude.fmap (fmap f) . getCompose + +instance (Prelude.Applicative f, Applicative g) => Applicative (Compose f g) where + pure a = Compose $ Prelude.pure $ pure a + Compose fgh <*> Compose fga = Compose $ Prelude.liftA2 (<*>) fgh fga + +instance (Prelude.Foldable f, Foldable g) => Foldable (Compose f g) where + foldMap f = Prelude.foldMap (foldMap f) . getCompose + +instance (Prelude.Traversable f, Traversable g) => Traversable (Compose f g) where + sequenceA = fmap teardown . sequenceA . setup where + setup :: (Prelude.Functor f, Traversable g, Applicative h) => Compose f g (Compose h a) -> Dispose f (Flip a) (Compose h (Compose g)) + setup = Dispose . Prelude.fmap (Compose . sequenceA) . getCompose + + teardown :: Prelude.Functor f => Compose (Dispose f (Flip a)) (Flip (Compose g)) y -> Compose (Compose f g) (Flip a) y + teardown = Compose . Compose . Prelude.fmap (getCompose . getFlip) . getDispose . getCompose + +{- Flip -------------------------------------------------------------------------} + +-- | a type-level version of 'Prelude.flip', it's used in the definition of +-- 'traverse' and 'sequenceA' as a way to reverse the order in which parameters +-- are passed. +-- +-- @Flip (Flip a)@ is isomorphic to @Identity a@ +-- +-- >>> :t Flip . Flip +-- Flip . Flip :: a y x -> Flip (Flip a) y x +-- >>> :t getFlip . getFlip +-- getFlip . getFlip :: Flip (Flip a) x y -> a x y +newtype Flip (a :: i -> j -> *) (y :: j) (x :: i) = + Flip { getFlip :: a x y } + deriving (Show, Eq, Ord) + -- XXX: Prelude.Bifunctor a => Prelude.Bifunctor (Flip a) + +{- Curry ------------------------------------------------------------------------} + +-- | a type-level version of 'Prelude.curry', it's used to convert between +-- types of kind @(i,j) -> *@ and types of kind @i -> j -> *@ +newtype Curry (a :: (i,j) -> *) (x :: i) (y :: j) = Curry { getCurry :: a '(x,y) } +-- XXX: Functor (a x) => Functor (Curry (Uncurry a) x) + +deriving instance Show (a '(x,y)) => Show (Curry a x y) +deriving instance Eq (a '(x,y)) => Eq (Curry a x y) +deriving instance Ord (a '(x,y)) => Ord (Curry a x y) + +{- Uncurry ----------------------------------------------------------------------} + +-- | A type-level version of 'Prelude.uncurry', it's used to convert between +-- types of kind @i -> j -> *@ and types of kind @(i,j) -> *@. +newtype Uncurry (a :: i -> j -> *) (z :: (i,j)) = + UncurryLazy { getUncurryLazy :: forall x y. (z ~ '(x,y)) => a x y } + -- ^ The 'UncurryLazy' constructor is useful when you need to + -- construct/destruct an @Uncurry a z@ value without placing restrictions on + -- @z@ + -- + -- >>> :t (\(UncurryLazy axy) -> UncurryLazy axy) :: Uncurry a z -> Uncurry a z + -- (\(UncurryLazy axy) -> UncurryLazy axy) :: Uncurry a z -> Uncurry a z + -- :: Uncurry a z -> Uncurry a z + -- >>> import Data.Tuple (swap) + -- >>> :t (\(UncurryLazy axy) -> UncurryLazy $ Flip $ swap axy) :: Uncurry (,) z -> Uncurry (Flip (,)) z + -- (\(UncurryLazy axy) -> UncurryLazy $ Flip $ swap axy) :: Uncurry (,) z -> Uncurry (Flip (,)) z + -- :: Uncurry (,) z -> Uncurry (Flip (,)) z + -- + -- It is slightly finnicky, and doesn't work well with function composition + -- (i.e. @.@), and requires more hints from the compiler. + -- + -- >>> :t (UncurryLazy . getUncurryLazy) :: Uncurry a z -> Uncurry a z + -- + -- :1:2: error: + -- • Couldn't match type ‘a1 x0 y0’ + -- with ‘forall x y. z1 ~ '(x, y) => a1 x y’ + -- ... + -- >>> :t (\(UncurryLazy axy) -> UncurryLazy axy) + -- + -- :1:36: error: + -- • Couldn't match type ‘z’ with ‘'(x, y)’ + -- arising from a use of ‘axy’ + -- because type variables ‘x’, ‘y’ would escape their scope + -- ... + + +-- | The 'UncurryStrict' pattern is useful when you need to construct/destruct +-- an 'Uncurry a '(x,y)' value +-- +-- >>> :t UncurryStrict . getUncurryStrict +-- UncurryStrict . getUncurryStrict +-- :: Uncurry a '(x, y) -> Uncurry a '(x, y) +-- >>> import Data.Tuple (swap) +-- >>> :t UncurryStrict . Flip . swap . getUncurryStrict +-- UncurryStrict . Flip . swap . getUncurryStrict +-- :: Uncurry (,) '(x, y) -> Uncurry (Flip (,)) '(x, y) +-- +-- It works well with function composition and requires fewer hints, but cannot +-- be used to construct or match values of type @Uncurry a z@, such as are +-- needed by 'fmap'. +-- +-- >>> :t (\(UncurryLazy axy) -> UncurryStrict axy) :: Uncurry a z -> Uncurry a z +-- +-- :1:38: error: +-- • Couldn't match type ‘z1’ with ‘'(x0, y0)’ +-- ... +-- • In the first argument of ‘UncurryStrict’, namely ‘axy’ +-- ... +-- >>> :t (\(UncurryStrict axy) -> UncurryLazy axy) :: Uncurry a z -> Uncurry a z +-- +-- :1:4: error: +-- • Couldn't match type ‘z1’ with ‘'(x0, y0)’ +-- ... +-- • In the pattern: UncurryStrict axy +-- ... +-- +-- However, it is very useful when paired with 'toProduct'. +pattern UncurryStrict :: a x y -> Uncurry a '(x,y) +pattern UncurryStrict axy <- (getUncurryStrict -> axy) + where UncurryStrict axy = UncurryLazy axy + +-- | a pseudo-record accessor, corresponding to matching the 'UncurryStrict' +-- pattern. Can be useful when paired with 'fromProduct' +getUncurryStrict :: Uncurry a '(x,y) -> a x y +getUncurryStrict = getUncurryLazy + +-- | a helper for lifting functions on curried types to functions +-- on their uncurried equivalents. Very useful when using the 'Functor' +-- instance for 'Product's. +-- +-- >>> comma' = toProduct UncurryStrict . Pure . Compose . Pure $ ('a', True) +-- >>> :t comma' +-- comma' :: Product (Pure Char) (Pure Bool) (Uncurry (,)) +-- >>> :t uncurried (const . snd) <$> comma' +-- uncurried (const . snd) <$> comma' +-- :: Product (Pure Char) (Pure Bool) (Uncurry (->)) +uncurried :: (forall x y. a x y -> b x y) -> Uncurry a z -> Uncurry b z +uncurried f u = UncurryLazy $ f $ getUncurryLazy u + +deriving instance Show (a x y) => Show (Uncurry a '(x,y)) +deriving instance Eq (a x y) => Eq (Uncurry a '(x,y)) +deriving instance Ord (a x y) => Ord (Uncurry a '(x,y)) + +{- Pure -------------------------------------------------------------------------} + +-- | A type-level version of 'Prelude.pure' for 'Control.Monad.Cont' +-- +-- Mainly useful when constructing continuation kind functors using +-- 'Product' and 'Coproduct'. +newtype Pure (x :: k) (a :: k -> *) = Pure { getPure :: a x } + deriving (Show, Eq, Ord) + +instance Functor (Pure x) where + fmap h = Pure . h . getPure + +instance Applicative (Pure x) where + pure = Pure + Pure fx <*> Pure ax = Pure (fx ~$~ ax) + +instance Foldable (Pure x) where + foldMap h (Pure ax) = h ax + +instance Traversable (Pure x) where + sequenceA (Pure ax) = liftT1 Pure ax + +{--------------------------------------------------------------------------------} + +-- XXX: Is ForAll useful? +-- +-- newtype ForAll (a :: k -> *) = ForAll { getForAll :: forall x. a x } +-- (Functor, Applicative, Foldable, Traversable?) + +-- XXX: Is Arr useful? +-- +-- newtype Arr (a :: k -> *) (b :: k -> *) = Arr { runArr :: forall (x :: k). a x -> b x } +-- (Functor, Applicative) diff --git a/README.lhs b/README.lhs new file mode 100644 --- /dev/null +++ b/README.lhs @@ -0,0 +1,707 @@ +One thing I haven't often seen people talk about doing in Haskell is working with data in [column-major order](https://en.wikipedia.org/wiki/Row-_and_column-major_order), or as a [struct of arrays](https://en.wikipedia.org/wiki/AOS_and_SOA). If we take a look though, there's some interesting possibilities and theory underlying this relatively simple concept. + +The `conkin` library is the result of my explorations along this line of thinking. + + + +# An example of use + +Suppose we have a list of items we wish to manipulate in column-major order: + +```haskell +items :: [Item] +items = [ chocolateBar, toiletPaper, ibuprofen ] + +chocolateBar, toiletPaper, ibuprofen :: Item + +chocolateBar = Item 0xDE1EC7AB1E "chocolate bar" 1.50 +toiletPaper = Item 0xDEFEC8 "toilet paper" 9.99 +ibuprofen = Item 0x43A1A11 "ibuprofen" 5.25 +``` + +Using the `Functor` instance for lists, we can easily extract each field into its own list: + +```haskell +extractFields0 :: [Item] -> ([UPC], [String], [Double]) +extractFields0 items = ( upc <$> items, name <$> items, price <$> items ) + +{-$----------------------------------------------------------------------------- +>>> extractFields0 items +( [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] +, [ "chocolate bar" , "toilet paper" , "ibuprofen" ] +, [ 1.5 , 9.99 , 5.25 ] +) +-} +``` + +We've lost bit of semantic meaning, however, as we've switched from our own custom data type to a generic tuple. We can regain this meaning if we define a type specifically for a collection of items, parameterized by the item type: + +```haskell +extractFields1 :: [Item] -> ItemF [] +extractFields1 items = ItemF (upc <$> items) (name <$> items) (price <$> items) + +{-$----------------------------------------------------------------------------- +>>> extractFields1 items +ItemF + { _upc = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] + , _name = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] + , _price = [ 1.5 , 9.99 , 5.25 ] + } +-} +data ItemF f = ItemF + { _upc :: f UPC + , _name :: f String + , _price :: f Dollars + } +deriving instance (Show (f String), Show (f Dollars), Show (f UPC)) => Show (ItemF f) +deriving instance (Eq (f String), Eq (f Dollars), Eq (f UPC)) => Eq (ItemF f) +``` + +With a little help from `PatternSynonyms` we can derive the `Item` type from `ItemF`, making sure the two definitions don't slip out of step: + +```haskell +{-$----------------------------------------------------------------------------- +>>> items +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +-} + +-- import Data.Functor.Identity (Identity(..)) +-- ... +type Item = ItemF Identity + +-- {-# LANGUAGE PatternSynonyms #-} +-- ... +pattern Item :: UPC -> String -> Dollars -> Item +pattern Item upc name price = ItemF (Identity upc) (Identity name) (Identity price) + +upc :: Item -> UPC +upc = runIdentity . _upc + +name :: Item -> String +name = runIdentity . _name + +price :: Item -> Dollars +price = runIdentity . _price +``` + +So what else can we do with `ItemF`? We can't make it a `Functor`, it's got the wrong *kind*. + +```haskell +{-$----------------------------------------------------------------------------- +>>> instance Functor ItemF where fmap = undefined + +... + • Expected kind ‘* -> *’, but ‘ItemF’ has kind ‘(* -> *) -> *’ + • In the first argument of ‘Functor’, namely ‘ItemF’ + In the instance declaration for ‘Functor ItemF’ +-} +``` + +But it's still got this parameter that it's covariant and homogenous in - all the fields must use the same container of kind `* -> *`, and changing what container we're using should be easy. + +So let's define a different `Functor` class for types of kind `(k -> *) -> *`. + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Functor +class Conkin.Functor (f :: (k -> *) -> *) where + Conkin.fmap :: forall (a :: k -> *) (b :: k -> *). + (forall (x :: k). a x -> b x) -> f a -> f b +... +-} + +-- import qualified Conkin +-- ... +instance Conkin.Functor ItemF where + fmap f (ItemF {..}) = ItemF + { _upc = f _upc + , _name = f _name + , _price = f _price + } +``` + +Now we can use `Conkin.fmap` to convert an individual `Item` into a `ItemF []` + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t Conkin.fmap (\(Identity x) -> [x]) +Conkin.fmap (\(Identity x) -> [x]) + :: Conkin.Functor f => f Identity -> f [] +>>> Conkin.fmap (\(Identity x) -> [x]) chocolateBar +ItemF + { _upc = [ 0xDE1EC7AB1E ] + , _name = [ "chocolate bar" ] + , _price = [ 1.5 ] + } +-} +``` + +We could stitch together multiple of these `ItemF []` into one if `ItemF []` had a `Monoid` instance: + +```haskell +extractFields2 :: [Item] -> ItemF [] +extractFields2 = foldMap $ Conkin.fmap $ pure . runIdentity + +{-$----------------------------------------------------------------------------- +>>> extractFields2 items +ItemF + { _upc = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] + , _name = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] + , _price = [ 1.5 , 9.99 , 5.25 ] + } +-} + +-- import Control.Applicative (Alternative(..)) +-- ... +instance Alternative a => Monoid (ItemF a) where + mempty = ItemF empty empty empty + left `mappend` right = ItemF + { _upc = _upc left <|> _upc right + , _name = _name left <|> _name right + , _price = _price left <|> _price right + } +``` + +Of course we could do this before with `extractFields1`, but there's nothing specific to `ItemF` in the definition of `extractFields2`. The same definition would work for any `Conkin.Functor` that formed a `Monoid`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t foldMap $ Conkin.fmap $ pure . runIdentity +foldMap $ Conkin.fmap $ pure . runIdentity + :: (Applicative b, Conkin.Functor f, Monoid (f b), Foldable t) => + t (f Identity) -> f b +-} +``` + +Another useful monoid is `ItemF Maybe`. This could let us combine multiple partially specified items into one: + +```haskell +{-$----------------------------------------------------------------------------- +>>> mempty { _price = Just 2.99 } +ItemF { _upc = Nothing , _name = Nothing , _price = Just 2.99 } +>>> mempty { _price = Just 2.99 } <> mempty { _upc = Just 0x0 } +ItemF { _upc = Just 0x0 , _name = Nothing , _price = Just 2.99 } +-} +``` + +(Side note - I love being able to partially specify `ItemF Maybe` using `mempty` with record notation. All the succinctness of `ItemF { _price = Just 2.99 }`, but none of the missing fields.) + +We can use `<>` (aka `mappend`) to transform a partially specified item into a fully specified one: + +```haskell +withDefaults0 :: ItemF Maybe -> Item +withDefaults0 partial = Conkin.fmap (Identity . fromJust) $ partial <> ItemF + { _upc = Just 0x0 + , _name = Just "unknown" + , _price = Just 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults0 mempty +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults0 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +However, I'm not a big fan of this solution. We've abandoned some safety by using the partial `fromJust`. If a future developer alters a default to be `Nothing`, the compiler won't complain, we'll just get a runtime error. + +What I'd rather be using is the safer `fromMaybe`, but since that's a two-argument function, I can't just use it via `fmap`. I need `ItemF` to be an `Applicative`. + +We'll need a slightly different `Applicative` class than `Prelude`'s, as `ItemF` again has the wrong kind: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Applicative +class Conkin.Functor f => + Conkin.Applicative (f :: (k -> *) -> *) where + Conkin.pure :: forall (a :: k -> *). (forall (x :: k). a x) -> f a + (Conkin.<*>) :: forall (a :: k -> *) (b :: k -> *). + f (a ~> b) -> f a -> f b +... +>>> :i (~>) +type role (~>) representational representational nominal +newtype (~>) (a :: k -> *) (b :: k -> *) (x :: k) + = Conkin.Arrow {(~$~) :: a x -> b x} +... +-} + +instance Conkin.Applicative ItemF where + pure a = ItemF a a a + ItemF fi fs fd <*> ItemF ai as ad + = ItemF (fi ~$~ ai) (fs ~$~ as) (fd ~$~ ad) +``` + +Now we can lift `fromMaybe`: + +```haskell +withDefaults1 :: ItemF Maybe -> Item +withDefaults1 = Conkin.liftA2 (\(Identity x) -> Identity . fromMaybe x) ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults1 mempty +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults1 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +Using `data-default`'s `Default` class, we can generalize this idea to create a function that converts any partially-specified `Conkin.Applicative` to a fully specified one. + +```haskell +withDefaults2 :: (Conkin.Applicative f, Default (f Identity)) => f Maybe -> f Identity +withDefaults2 = Conkin.liftA2 (\(Identity x) -> Identity . fromMaybe x) def + +instance Default Item where + def = ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults2 mempty :: ItemF Identity +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults2 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +What also might be nice is a way to test whether a `ItemF Maybe` is actually fully specified: + +```haskell +isAllJust :: Conkin.Foldable f => f Maybe -> Bool +isAllJust = getAll . Conkin.foldMap (All . isJust) + +{-$----------------------------------------------------------------------------- +>>> isAllJust mempty { _upc = Just 0x1111111111 } +False +>>> isAllJust ItemF { _upc = Just 0xDEADBEEF, _name = Just "hamburger", _price = Just 1.99 } +True +-} +``` + +At this point, it should not be surprising that we need a slightly different `Foldable` in order to collapse `ItemF` values: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Foldable +class Conkin.Foldable (t :: (k -> *) -> *) where + Conkin.foldr :: forall (a :: k -> *) b. + (forall (x :: k). a x -> b -> b) -> b -> t a -> b + Conkin.foldMap :: forall m (a :: k -> *). + Monoid m => + (forall (x :: k). a x -> m) -> t a -> m +... +-} + +instance Conkin.Foldable ItemF where + foldMap f (ItemF {..}) = f _upc <> f _name <> f _price +``` + +We could use `isAllJust` to safely create an `Item` from a fully-specified `ItemF Maybe`: + +```haskell +toItem0 :: ItemF Maybe -> Maybe Item +toItem0 i | isAllJust i = Just $ Conkin.fmap (Identity . fromJust) i + | otherwise = Nothing +``` + +But the `conkin` package already provides a function that does just that: + +```haskell +{-$----------------------------------------------------------------------------- +>>> Conkin.apportion mempty { _upc = Just 0x1111111111 } +Nothing +>>> Conkin.apportion ItemF { _upc = Just 0xDEADBEEF, _name = Just "hamburger", _price = Just 1.99 } +Just + ItemF + { _upc = Identity 0xDEADBEEF + , _name = Identity "hamburger" + , _price = Identity 1.99 + } +>>> :t Conkin.apportion +Conkin.apportion + :: (Conkin.Traversable g, Applicative f) => g f -> f (g Identity) +-} +``` + +Although `conkin` does require that `ItemF` implement its custom `Traversable` class, it provides helpers for tuple-like classes like `ItemF`. + +```haskell +{-$----------------------------------------------------------------------------- +>>> :m +Data.Functor.Compose +>>> :i Conkin.Traversable +class (Conkin.Foldable t, Conkin.Functor t) => + Conkin.Traversable (t :: (i -> *) -> *) where + Conkin.traverse :: forall j (f :: (j -> *) -> *) (a :: i + -> *) (b :: i -> j -> *). + Conkin.Applicative f => + (forall (x :: i). a x -> f (b x)) + -> t a -> f (Compose t (Conkin.Flip b)) + Conkin.sequenceA :: forall j (f :: (j -> *) -> *) (a :: i + -> j -> *). + Conkin.Applicative f => + t (Compose f a) -> f (Compose t (Conkin.Flip a)) +... +-} +instance Conkin.Traversable ItemF where + sequenceA (ItemF {..}) = Conkin.liftT3 ItemF _upc _name _price +``` + +We could also attempt to use `apportion` to invert `extractFields2`, but it mixes +up the columns: + +```haskell +{-$----------------------------------------------------------------------------- +>>> items +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +>>> Conkin.apportion (extractFields2 items) +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 5.25 + } +... +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +-} +``` + +This is because of `[]`'s `Applicative` instance. If we use the `ZipList` newtype wrapper, we can get the behaviour we desire: + +```haskell +{-$----------------------------------------------------------------------------- +>>> import Control.Applicative (ZipList(..)) +>>> Conkin.align (ZipList items) +ItemF + { _upc = + ZipList { getZipList = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] } + , _name = + ZipList + { getZipList = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] } + , _price = ZipList { getZipList = [ 1.5 , 9.99 , 5.25 ] } + } +>>> Conkin.apportion (Conkin.align (ZipList items)) +ZipList + { getZipList = + [ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } + , ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } + , ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } + ] + } +-} +``` + +Here we use the handy `align` function as yet another way to implement `extractFields`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t Conkin.align +Conkin.align + :: (Conkin.Applicative g, Traversable f) => f (g Identity) -> g f +-} +``` + +# A little bit of theory + +Typically in Haskell, we talk about the category *Hask*, where the objects are types of kind `*` and the arrows are normal Haskell functions. In general, a *functor* is a mapping between categories, mapping each object or arrow in one category to an object or arrow (respectively) in another. + +The `Prelude`'s `Functor` typeclass actually describes *endofunctors* from Hask to Hask; given a `Functor f`, we can map any type `a` in `Hask` to the type `f a` in Hask (so `f` must have kind `* -> *`), and we can map any arrow (function) `a -> b` in Hask to an arrow `f a -> f b` in Hask (using `fmap`). + +The `conkin` package focuses on the functors from *Haskk* to *Hask*. In Haskk, the objects are types of kind `k -> *`, and the arrows are transformations `a ~> b` where `(a ~> b) x ~ (a x -> b x)`. A functor from Haskk to Hask must then be able to map any type `a :: k -> *` in Haskk to a type `f a :: *` in Hask (so `f` must have kind `(k -> *) -> *`), and must be able to map any arrow `a ~> b` in Haskk to an arrow `f a -> f b` in Hask. + +(I'm not very well read in category theory, so it's thoroughly possible Haskk has a more common name in literature, I just chose that one out of similarity with type exponentials.) + +You can lift any functor from Hask to Hask to a functor from Haskk to Hask using `Dispose`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Dispose +type role Conkin.Dispose representational nominal nominal +newtype Conkin.Dispose (f :: * -> *) (x :: k) (a :: k -> *) + = Conkin.Dispose {Conkin.getDispose :: f (a x)} +... +-} +``` + +And any functor from Haskk to Hask can be lifted to a functor from Hask to Hask using `Coyoneda`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Coyoneda +type role Conkin.Coyoneda representational representational +data Conkin.Coyoneda (t :: (k -> *) -> *) u where + Conkin.Coyoneda :: forall k (t :: (k -> *) -> *) u (a :: k -> *). + (forall (x :: k). a x -> u) -> (t a) -> Conkin.Coyoneda t u +... +-} +``` + +Not only do both of these encodings preserve functorality, but they also preserve foldability, applicativity, and traversability (e.g. `Traversable t => Conkin.Traversable (Conkin.Dispose t x)`). + +Another interesting facet of functors from Haskk to Hask is the similarity between their kind, `(k -> *) -> *`, and the type of continuations, `type Cont r a = (a -> r) -> r`. This **con**tinuation **kin**d is where the `conkin` package gets its name from. + +If we start to look at these functors as types of kind `Cont Type i`, then we can can start thinking of how to compose them +in an algebra, using + +* `Conkin.Product f g :: Cont Type (i,j)` as the product type of functors `f :: Cont Type i` and `g :: Cont Type j` +* `Conkin.Coproduct f g :: Cont Type (Either i j)` as the coproduct type of functors `f :: Cont Type i` and `g :: Cont Type j` + +Interestingly, `Conkin.Product f g a` is isomorphic to `f (Compose g a)`, making `Conkin.sequenceA` the equivalent of [`Data.Tuple.swap`](http://hackage.haskell.org/package/base-4.10.0.0/docs/Data-Tuple.html#v:swap). + +# Notes and concerns + +## Existing Work + +The `conkin` package isn't unprecedented. In addition to Edward Kmett's [even more general `categories` package](http://hackage.haskell.org/package/categories), there's also Gracjan Polak's [`fieldwise` package](http://hackage.haskell.org/package/fieldwise), which supports a similar set of operations for types of kind `(k -> *) -> *`. + +## Boilerplate instances + +Instances of `Conkin`'s `Functor`, `Applicative`, `Foldable`, and `Traversable` classes are mainly mechanical, and seem like excellent candidates for using `-XDeriveGeneric` and `-XDefaultSignatures` to reduce the amount of boilerplate needed for use. This is not currently true, as you cannot encode a type like `ItemF` using the fundamental representational types GHC knows about: + +```haskell +{-$----------------------------------------------------------------------------- +>>> deriving instance Generic1 (ItemF) +... + • Can't make a derived instance of ‘Generic1 ItemF’: + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> *, and + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> *, and + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> * + • In the stand-alone deriving instance for ‘Generic1 (ItemF)’ +-} +``` + +It's very possible to hand-write instances of `Generic1` for functors from Haskk to Hask +using an fundamental representational type, `Par2`: + +```haskell +newtype Par2 (x :: k) (a :: k -> *) = Par2 { unPar2 :: a x } + +instance Generic1 ItemF where + type Rep1 ItemF = + D1 ('MetaData "ItemF" "Main" "conkin" 'True) + (C1 ('MetaCons "ItemF" 'PrefixI 'True) + (S1 ('MetaSel ('Just "_upc") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 UPC) + :*: + S1 ('MetaSel ('Just "_name") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 String) + :*: + S1 ('MetaSel ('Just "_cost") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 Dollars))) + from1 (ItemF {..}) = M1 (M1 (M1 (Par2 _upc) :*: M1 (Par2 _name) :*: M1 (Par2 _price))) + to1 (M1 (M1 (M1 (Par2 _upc) :*: M1 (Par2 _name) :*: M1 (Par2 _price)))) = ItemF {..} +``` + +However the verbosity of the above makes it less useful as a way to avoid boilerplate. + +This is not necessarily the end of all hope; I could make a pull request to GHC including `Par2` and updates to the `DeriveGeneric` mechanism, or write some `TemplateHaskell` macros to generate the instances. Until I do so, I've gone the fairly low-effort route of providing a few helper functions to make `Conkin.Traversable` instances easier to write. + +## Use of `unsafeCoerce` + +In my personal Haskell experience, my only uses of `unsafeCoerce` until this package had been for `newtype` wrappers and such (i.e. excellent candidates to use `coerce` instead). This library marks the first time I found myself using `unsafeCoerce` because I just couldn't think of another way to convince the compiler of something, in `Dispose`'s implementation of `Conkin.Traversable`: + +``` +instance Prelude.Traversable t => Traversable (Dispose t x) where + sequenceA = teardown . Prelude.traverse setup . getDispose where + setup :: Compose f a x -> Coyoneda f (Exists (a x)) + setup = Coyoneda Exists . getCompose + + teardown :: (Functor f, Prelude.Functor t) => Coyoneda f (t (Exists (a x))) -> f (Compose (Dispose t x) (Flip a)) + teardown (Coyoneda k fax) = Compose . Dispose . Prelude.fmap Flip . unwrap k <$> fax + + -- by parametricity, `t`'s implementation of `Prelude.sequenceA :: t (g e) -> + -- g (t e)` can't inspect the value of `e`, so all `Exists a` values + -- must be wrapped `a x` values, so this should be an okay use + -- of `unsafeGetExists`. + unwrap :: Prelude.Functor t => (b x -> t (Exists a)) -> b x -> t (a x) + unwrap k bx = Prelude.fmap (unsafeGetExists bx) $ k bx + + unsafeGetExists :: proxy x -> Exists a -> a x + unsafeGetExists _ (Exists az) = unsafeCoerce az + +data Exists (a :: k -> *) where + Exists :: a x -> Exists a +``` + +I've managed to convince myself that my use of `unsafeCoerce` is, well, safe, but only until someone finds a law-abiding `Traversable` that proves me wrong. I should probably come back to this, and either come up with a more formal proof of validity, rather than the loose argument I present in the code. + +# Literate Haskell + +This `README.md` file is a literate haskell file, for use with [`markdown-unlit`](https://github.com/sol/markdown-unlit#readme). To allow GHC to recognize it, it's softlinked as `README.lhs`, which you can compile with + + $ ghc -pgmL markdown-unlit README.lhs + +Many of the above examples are [`doctest`](https://github.com/sol/doctest#readme)-compatible, and can be run with + + $ doctest -pgmL markdown-unlit README.lhs + +Alternately, you can have cabal manage the dependencies and compile and test this with: + + $ cabal install happy + $ cabal install --enable-tests + $ cabal test readme diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,707 @@ +One thing I haven't often seen people talk about doing in Haskell is working with data in [column-major order](https://en.wikipedia.org/wiki/Row-_and_column-major_order), or as a [struct of arrays](https://en.wikipedia.org/wiki/AOS_and_SOA). If we take a look though, there's some interesting possibilities and theory underlying this relatively simple concept. + +The `conkin` library is the result of my explorations along this line of thinking. + + + +# An example of use + +Suppose we have a list of items we wish to manipulate in column-major order: + +```haskell +items :: [Item] +items = [ chocolateBar, toiletPaper, ibuprofen ] + +chocolateBar, toiletPaper, ibuprofen :: Item + +chocolateBar = Item 0xDE1EC7AB1E "chocolate bar" 1.50 +toiletPaper = Item 0xDEFEC8 "toilet paper" 9.99 +ibuprofen = Item 0x43A1A11 "ibuprofen" 5.25 +``` + +Using the `Functor` instance for lists, we can easily extract each field into its own list: + +```haskell +extractFields0 :: [Item] -> ([UPC], [String], [Double]) +extractFields0 items = ( upc <$> items, name <$> items, price <$> items ) + +{-$----------------------------------------------------------------------------- +>>> extractFields0 items +( [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] +, [ "chocolate bar" , "toilet paper" , "ibuprofen" ] +, [ 1.5 , 9.99 , 5.25 ] +) +-} +``` + +We've lost bit of semantic meaning, however, as we've switched from our own custom data type to a generic tuple. We can regain this meaning if we define a type specifically for a collection of items, parameterized by the item type: + +```haskell +extractFields1 :: [Item] -> ItemF [] +extractFields1 items = ItemF (upc <$> items) (name <$> items) (price <$> items) + +{-$----------------------------------------------------------------------------- +>>> extractFields1 items +ItemF + { _upc = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] + , _name = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] + , _price = [ 1.5 , 9.99 , 5.25 ] + } +-} +data ItemF f = ItemF + { _upc :: f UPC + , _name :: f String + , _price :: f Dollars + } +deriving instance (Show (f String), Show (f Dollars), Show (f UPC)) => Show (ItemF f) +deriving instance (Eq (f String), Eq (f Dollars), Eq (f UPC)) => Eq (ItemF f) +``` + +With a little help from `PatternSynonyms` we can derive the `Item` type from `ItemF`, making sure the two definitions don't slip out of step: + +```haskell +{-$----------------------------------------------------------------------------- +>>> items +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +-} + +-- import Data.Functor.Identity (Identity(..)) +-- ... +type Item = ItemF Identity + +-- {-# LANGUAGE PatternSynonyms #-} +-- ... +pattern Item :: UPC -> String -> Dollars -> Item +pattern Item upc name price = ItemF (Identity upc) (Identity name) (Identity price) + +upc :: Item -> UPC +upc = runIdentity . _upc + +name :: Item -> String +name = runIdentity . _name + +price :: Item -> Dollars +price = runIdentity . _price +``` + +So what else can we do with `ItemF`? We can't make it a `Functor`, it's got the wrong *kind*. + +```haskell +{-$----------------------------------------------------------------------------- +>>> instance Functor ItemF where fmap = undefined + +... + • Expected kind ‘* -> *’, but ‘ItemF’ has kind ‘(* -> *) -> *’ + • In the first argument of ‘Functor’, namely ‘ItemF’ + In the instance declaration for ‘Functor ItemF’ +-} +``` + +But it's still got this parameter that it's covariant and homogenous in - all the fields must use the same container of kind `* -> *`, and changing what container we're using should be easy. + +So let's define a different `Functor` class for types of kind `(k -> *) -> *`. + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Functor +class Conkin.Functor (f :: (k -> *) -> *) where + Conkin.fmap :: forall (a :: k -> *) (b :: k -> *). + (forall (x :: k). a x -> b x) -> f a -> f b +... +-} + +-- import qualified Conkin +-- ... +instance Conkin.Functor ItemF where + fmap f (ItemF {..}) = ItemF + { _upc = f _upc + , _name = f _name + , _price = f _price + } +``` + +Now we can use `Conkin.fmap` to convert an individual `Item` into a `ItemF []` + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t Conkin.fmap (\(Identity x) -> [x]) +Conkin.fmap (\(Identity x) -> [x]) + :: Conkin.Functor f => f Identity -> f [] +>>> Conkin.fmap (\(Identity x) -> [x]) chocolateBar +ItemF + { _upc = [ 0xDE1EC7AB1E ] + , _name = [ "chocolate bar" ] + , _price = [ 1.5 ] + } +-} +``` + +We could stitch together multiple of these `ItemF []` into one if `ItemF []` had a `Monoid` instance: + +```haskell +extractFields2 :: [Item] -> ItemF [] +extractFields2 = foldMap $ Conkin.fmap $ pure . runIdentity + +{-$----------------------------------------------------------------------------- +>>> extractFields2 items +ItemF + { _upc = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] + , _name = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] + , _price = [ 1.5 , 9.99 , 5.25 ] + } +-} + +-- import Control.Applicative (Alternative(..)) +-- ... +instance Alternative a => Monoid (ItemF a) where + mempty = ItemF empty empty empty + left `mappend` right = ItemF + { _upc = _upc left <|> _upc right + , _name = _name left <|> _name right + , _price = _price left <|> _price right + } +``` + +Of course we could do this before with `extractFields1`, but there's nothing specific to `ItemF` in the definition of `extractFields2`. The same definition would work for any `Conkin.Functor` that formed a `Monoid`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t foldMap $ Conkin.fmap $ pure . runIdentity +foldMap $ Conkin.fmap $ pure . runIdentity + :: (Applicative b, Conkin.Functor f, Monoid (f b), Foldable t) => + t (f Identity) -> f b +-} +``` + +Another useful monoid is `ItemF Maybe`. This could let us combine multiple partially specified items into one: + +```haskell +{-$----------------------------------------------------------------------------- +>>> mempty { _price = Just 2.99 } +ItemF { _upc = Nothing , _name = Nothing , _price = Just 2.99 } +>>> mempty { _price = Just 2.99 } <> mempty { _upc = Just 0x0 } +ItemF { _upc = Just 0x0 , _name = Nothing , _price = Just 2.99 } +-} +``` + +(Side note - I love being able to partially specify `ItemF Maybe` using `mempty` with record notation. All the succinctness of `ItemF { _price = Just 2.99 }`, but none of the missing fields.) + +We can use `<>` (aka `mappend`) to transform a partially specified item into a fully specified one: + +```haskell +withDefaults0 :: ItemF Maybe -> Item +withDefaults0 partial = Conkin.fmap (Identity . fromJust) $ partial <> ItemF + { _upc = Just 0x0 + , _name = Just "unknown" + , _price = Just 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults0 mempty +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults0 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +However, I'm not a big fan of this solution. We've abandoned some safety by using the partial `fromJust`. If a future developer alters a default to be `Nothing`, the compiler won't complain, we'll just get a runtime error. + +What I'd rather be using is the safer `fromMaybe`, but since that's a two-argument function, I can't just use it via `fmap`. I need `ItemF` to be an `Applicative`. + +We'll need a slightly different `Applicative` class than `Prelude`'s, as `ItemF` again has the wrong kind: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Applicative +class Conkin.Functor f => + Conkin.Applicative (f :: (k -> *) -> *) where + Conkin.pure :: forall (a :: k -> *). (forall (x :: k). a x) -> f a + (Conkin.<*>) :: forall (a :: k -> *) (b :: k -> *). + f (a ~> b) -> f a -> f b +... +>>> :i (~>) +type role (~>) representational representational nominal +newtype (~>) (a :: k -> *) (b :: k -> *) (x :: k) + = Conkin.Arrow {(~$~) :: a x -> b x} +... +-} + +instance Conkin.Applicative ItemF where + pure a = ItemF a a a + ItemF fi fs fd <*> ItemF ai as ad + = ItemF (fi ~$~ ai) (fs ~$~ as) (fd ~$~ ad) +``` + +Now we can lift `fromMaybe`: + +```haskell +withDefaults1 :: ItemF Maybe -> Item +withDefaults1 = Conkin.liftA2 (\(Identity x) -> Identity . fromMaybe x) ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults1 mempty +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults1 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +Using `data-default`'s `Default` class, we can generalize this idea to create a function that converts any partially-specified `Conkin.Applicative` to a fully specified one. + +```haskell +withDefaults2 :: (Conkin.Applicative f, Default (f Identity)) => f Maybe -> f Identity +withDefaults2 = Conkin.liftA2 (\(Identity x) -> Identity . fromMaybe x) def + +instance Default Item where + def = ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0 + } + +{-$----------------------------------------------------------------------------- +>>> withDefaults2 mempty :: ItemF Identity +ItemF + { _upc = Identity 0x0 + , _name = Identity "unknown" + , _price = Identity 0.0 + } +>>> withDefaults2 mempty { _price = Just 2.99, _name = Just "flyswatter" } +ItemF + { _upc = Identity 0x0 + , _name = Identity "flyswatter" + , _price = Identity 2.99 + } +-} +``` + +What also might be nice is a way to test whether a `ItemF Maybe` is actually fully specified: + +```haskell +isAllJust :: Conkin.Foldable f => f Maybe -> Bool +isAllJust = getAll . Conkin.foldMap (All . isJust) + +{-$----------------------------------------------------------------------------- +>>> isAllJust mempty { _upc = Just 0x1111111111 } +False +>>> isAllJust ItemF { _upc = Just 0xDEADBEEF, _name = Just "hamburger", _price = Just 1.99 } +True +-} +``` + +At this point, it should not be surprising that we need a slightly different `Foldable` in order to collapse `ItemF` values: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Foldable +class Conkin.Foldable (t :: (k -> *) -> *) where + Conkin.foldr :: forall (a :: k -> *) b. + (forall (x :: k). a x -> b -> b) -> b -> t a -> b + Conkin.foldMap :: forall m (a :: k -> *). + Monoid m => + (forall (x :: k). a x -> m) -> t a -> m +... +-} + +instance Conkin.Foldable ItemF where + foldMap f (ItemF {..}) = f _upc <> f _name <> f _price +``` + +We could use `isAllJust` to safely create an `Item` from a fully-specified `ItemF Maybe`: + +```haskell +toItem0 :: ItemF Maybe -> Maybe Item +toItem0 i | isAllJust i = Just $ Conkin.fmap (Identity . fromJust) i + | otherwise = Nothing +``` + +But the `conkin` package already provides a function that does just that: + +```haskell +{-$----------------------------------------------------------------------------- +>>> Conkin.apportion mempty { _upc = Just 0x1111111111 } +Nothing +>>> Conkin.apportion ItemF { _upc = Just 0xDEADBEEF, _name = Just "hamburger", _price = Just 1.99 } +Just + ItemF + { _upc = Identity 0xDEADBEEF + , _name = Identity "hamburger" + , _price = Identity 1.99 + } +>>> :t Conkin.apportion +Conkin.apportion + :: (Conkin.Traversable g, Applicative f) => g f -> f (g Identity) +-} +``` + +Although `conkin` does require that `ItemF` implement its custom `Traversable` class, it provides helpers for tuple-like classes like `ItemF`. + +```haskell +{-$----------------------------------------------------------------------------- +>>> :m +Data.Functor.Compose +>>> :i Conkin.Traversable +class (Conkin.Foldable t, Conkin.Functor t) => + Conkin.Traversable (t :: (i -> *) -> *) where + Conkin.traverse :: forall j (f :: (j -> *) -> *) (a :: i + -> *) (b :: i -> j -> *). + Conkin.Applicative f => + (forall (x :: i). a x -> f (b x)) + -> t a -> f (Compose t (Conkin.Flip b)) + Conkin.sequenceA :: forall j (f :: (j -> *) -> *) (a :: i + -> j -> *). + Conkin.Applicative f => + t (Compose f a) -> f (Compose t (Conkin.Flip a)) +... +-} +instance Conkin.Traversable ItemF where + sequenceA (ItemF {..}) = Conkin.liftT3 ItemF _upc _name _price +``` + +We could also attempt to use `apportion` to invert `extractFields2`, but it mixes +up the columns: + +```haskell +{-$----------------------------------------------------------------------------- +>>> items +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +>>> Conkin.apportion (extractFields2 items) +[ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 5.25 + } +... +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 1.5 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 9.99 + } +, ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } +] +-} +``` + +This is because of `[]`'s `Applicative` instance. If we use the `ZipList` newtype wrapper, we can get the behaviour we desire: + +```haskell +{-$----------------------------------------------------------------------------- +>>> import Control.Applicative (ZipList(..)) +>>> Conkin.align (ZipList items) +ItemF + { _upc = + ZipList { getZipList = [ 0xDE1EC7AB1E , 0xDEFEC8 , 0x43A1A11 ] } + , _name = + ZipList + { getZipList = [ "chocolate bar" , "toilet paper" , "ibuprofen" ] } + , _price = ZipList { getZipList = [ 1.5 , 9.99 , 5.25 ] } + } +>>> Conkin.apportion (Conkin.align (ZipList items)) +ZipList + { getZipList = + [ ItemF + { _upc = Identity 0xDE1EC7AB1E + , _name = Identity "chocolate bar" + , _price = Identity 1.5 + } + , ItemF + { _upc = Identity 0xDEFEC8 + , _name = Identity "toilet paper" + , _price = Identity 9.99 + } + , ItemF + { _upc = Identity 0x43A1A11 + , _name = Identity "ibuprofen" + , _price = Identity 5.25 + } + ] + } +-} +``` + +Here we use the handy `align` function as yet another way to implement `extractFields`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :t Conkin.align +Conkin.align + :: (Conkin.Applicative g, Traversable f) => f (g Identity) -> g f +-} +``` + +# A little bit of theory + +Typically in Haskell, we talk about the category *Hask*, where the objects are types of kind `*` and the arrows are normal Haskell functions. In general, a *functor* is a mapping between categories, mapping each object or arrow in one category to an object or arrow (respectively) in another. + +The `Prelude`'s `Functor` typeclass actually describes *endofunctors* from Hask to Hask; given a `Functor f`, we can map any type `a` in `Hask` to the type `f a` in Hask (so `f` must have kind `* -> *`), and we can map any arrow (function) `a -> b` in Hask to an arrow `f a -> f b` in Hask (using `fmap`). + +The `conkin` package focuses on the functors from *Haskk* to *Hask*. In Haskk, the objects are types of kind `k -> *`, and the arrows are transformations `a ~> b` where `(a ~> b) x ~ (a x -> b x)`. A functor from Haskk to Hask must then be able to map any type `a :: k -> *` in Haskk to a type `f a :: *` in Hask (so `f` must have kind `(k -> *) -> *`), and must be able to map any arrow `a ~> b` in Haskk to an arrow `f a -> f b` in Hask. + +(I'm not very well read in category theory, so it's thoroughly possible Haskk has a more common name in literature, I just chose that one out of similarity with type exponentials.) + +You can lift any functor from Hask to Hask to a functor from Haskk to Hask using `Dispose`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Dispose +type role Conkin.Dispose representational nominal nominal +newtype Conkin.Dispose (f :: * -> *) (x :: k) (a :: k -> *) + = Conkin.Dispose {Conkin.getDispose :: f (a x)} +... +-} +``` + +And any functor from Haskk to Hask can be lifted to a functor from Hask to Hask using `Coyoneda`: + +```haskell +{-$----------------------------------------------------------------------------- +>>> :i Conkin.Coyoneda +type role Conkin.Coyoneda representational representational +data Conkin.Coyoneda (t :: (k -> *) -> *) u where + Conkin.Coyoneda :: forall k (t :: (k -> *) -> *) u (a :: k -> *). + (forall (x :: k). a x -> u) -> (t a) -> Conkin.Coyoneda t u +... +-} +``` + +Not only do both of these encodings preserve functorality, but they also preserve foldability, applicativity, and traversability (e.g. `Traversable t => Conkin.Traversable (Conkin.Dispose t x)`). + +Another interesting facet of functors from Haskk to Hask is the similarity between their kind, `(k -> *) -> *`, and the type of continuations, `type Cont r a = (a -> r) -> r`. This **con**tinuation **kin**d is where the `conkin` package gets its name from. + +If we start to look at these functors as types of kind `Cont Type i`, then we can can start thinking of how to compose them +in an algebra, using + +* `Conkin.Product f g :: Cont Type (i,j)` as the product type of functors `f :: Cont Type i` and `g :: Cont Type j` +* `Conkin.Coproduct f g :: Cont Type (Either i j)` as the coproduct type of functors `f :: Cont Type i` and `g :: Cont Type j` + +Interestingly, `Conkin.Product f g a` is isomorphic to `f (Compose g a)`, making `Conkin.sequenceA` the equivalent of [`Data.Tuple.swap`](http://hackage.haskell.org/package/base-4.10.0.0/docs/Data-Tuple.html#v:swap). + +# Notes and concerns + +## Existing Work + +The `conkin` package isn't unprecedented. In addition to Edward Kmett's [even more general `categories` package](http://hackage.haskell.org/package/categories), there's also Gracjan Polak's [`fieldwise` package](http://hackage.haskell.org/package/fieldwise), which supports a similar set of operations for types of kind `(k -> *) -> *`. + +## Boilerplate instances + +Instances of `Conkin`'s `Functor`, `Applicative`, `Foldable`, and `Traversable` classes are mainly mechanical, and seem like excellent candidates for using `-XDeriveGeneric` and `-XDefaultSignatures` to reduce the amount of boilerplate needed for use. This is not currently true, as you cannot encode a type like `ItemF` using the fundamental representational types GHC knows about: + +```haskell +{-$----------------------------------------------------------------------------- +>>> deriving instance Generic1 (ItemF) +... + • Can't make a derived instance of ‘Generic1 ItemF’: + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> *, and + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> *, and + Constructor ‘ItemF’ applies a type to an argument involving the last parameter + but the applied type is not of kind * -> * + • In the stand-alone deriving instance for ‘Generic1 (ItemF)’ +-} +``` + +It's very possible to hand-write instances of `Generic1` for functors from Haskk to Hask +using an fundamental representational type, `Par2`: + +```haskell +newtype Par2 (x :: k) (a :: k -> *) = Par2 { unPar2 :: a x } + +instance Generic1 ItemF where + type Rep1 ItemF = + D1 ('MetaData "ItemF" "Main" "conkin" 'True) + (C1 ('MetaCons "ItemF" 'PrefixI 'True) + (S1 ('MetaSel ('Just "_upc") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 UPC) + :*: + S1 ('MetaSel ('Just "_name") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 String) + :*: + S1 ('MetaSel ('Just "_cost") 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy) + (Par2 Dollars))) + from1 (ItemF {..}) = M1 (M1 (M1 (Par2 _upc) :*: M1 (Par2 _name) :*: M1 (Par2 _price))) + to1 (M1 (M1 (M1 (Par2 _upc) :*: M1 (Par2 _name) :*: M1 (Par2 _price)))) = ItemF {..} +``` + +However the verbosity of the above makes it less useful as a way to avoid boilerplate. + +This is not necessarily the end of all hope; I could make a pull request to GHC including `Par2` and updates to the `DeriveGeneric` mechanism, or write some `TemplateHaskell` macros to generate the instances. Until I do so, I've gone the fairly low-effort route of providing a few helper functions to make `Conkin.Traversable` instances easier to write. + +## Use of `unsafeCoerce` + +In my personal Haskell experience, my only uses of `unsafeCoerce` until this package had been for `newtype` wrappers and such (i.e. excellent candidates to use `coerce` instead). This library marks the first time I found myself using `unsafeCoerce` because I just couldn't think of another way to convince the compiler of something, in `Dispose`'s implementation of `Conkin.Traversable`: + +``` +instance Prelude.Traversable t => Traversable (Dispose t x) where + sequenceA = teardown . Prelude.traverse setup . getDispose where + setup :: Compose f a x -> Coyoneda f (Exists (a x)) + setup = Coyoneda Exists . getCompose + + teardown :: (Functor f, Prelude.Functor t) => Coyoneda f (t (Exists (a x))) -> f (Compose (Dispose t x) (Flip a)) + teardown (Coyoneda k fax) = Compose . Dispose . Prelude.fmap Flip . unwrap k <$> fax + + -- by parametricity, `t`'s implementation of `Prelude.sequenceA :: t (g e) -> + -- g (t e)` can't inspect the value of `e`, so all `Exists a` values + -- must be wrapped `a x` values, so this should be an okay use + -- of `unsafeGetExists`. + unwrap :: Prelude.Functor t => (b x -> t (Exists a)) -> b x -> t (a x) + unwrap k bx = Prelude.fmap (unsafeGetExists bx) $ k bx + + unsafeGetExists :: proxy x -> Exists a -> a x + unsafeGetExists _ (Exists az) = unsafeCoerce az + +data Exists (a :: k -> *) where + Exists :: a x -> Exists a +``` + +I've managed to convince myself that my use of `unsafeCoerce` is, well, safe, but only until someone finds a law-abiding `Traversable` that proves me wrong. I should probably come back to this, and either come up with a more formal proof of validity, rather than the loose argument I present in the code. + +# Literate Haskell + +This `README.md` file is a literate haskell file, for use with [`markdown-unlit`](https://github.com/sol/markdown-unlit#readme). To allow GHC to recognize it, it's softlinked as `README.lhs`, which you can compile with + + $ ghc -pgmL markdown-unlit README.lhs + +Many of the above examples are [`doctest`](https://github.com/sol/doctest#readme)-compatible, and can be run with + + $ doctest -pgmL markdown-unlit README.lhs + +Alternately, you can have cabal manage the dependencies and compile and test this with: + + $ cabal install happy + $ cabal install --enable-tests + $ cabal test readme diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/conkin.cabal b/conkin.cabal new file mode 100644 --- /dev/null +++ b/conkin.cabal @@ -0,0 +1,59 @@ +name: conkin +version: 1.0.2 +synopsis: Tools for functors from Hask^k to Hask +description: Tools for functors from Hask^k to Hask +homepage: http://github.com/rampion/conkin +category: Control +license: PublicDomain +author: Noah Luck Easterly +maintainer: noah.easterly@gmail.com +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com/rampion/conkin.git + +source-repository this + type: git + location: git://github.com/rampion/conkin.git + tag: v1.0.2 + +flag Development + description: Enable all warnings and upgrade warnings to errors + default: False + manual: True + +library + exposed-modules: Conkin + build-depends: base >=4.9 && <4.11 + default-language: Haskell2010 + if flag(development) + ghc-options: -Wall -Wextra -Werror + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + build-depends: base + , doctest >=0.11.2 && <0.12 + , pretty-show >= 1.6.13 && <2.0.0 + default-language: Haskell2010 + if flag(development) + ghc-options: -Wall -Wextra -Werror + + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + build-depends: base + , markdown-unlit >=0.4.0 && <0.5 + , doctest >=0.11.2 && <0.12 + , pretty-show >= 1.6.13 && <2.0.0 + , data-default >= 0.7.0 && <0.8 + , conkin + default-language: Haskell2010 + if flag(development) + ghc-options: -pgmL markdown-unlit -Wall -Wextra -Werror + else + ghc-options: -pgmL markdown-unlit diff --git a/doctests.hs b/doctests.hs new file mode 100644 --- /dev/null +++ b/doctests.hs @@ -0,0 +1,5 @@ +module Main where +import Test.DocTest + +main :: IO () +main = doctest $ words "Conkin.hs"