diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for functor-monad + +## 0.1.0.0 (review) -- 2023-12-23 + +* First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Koji Miyazato (c) 2022-2024 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,148 @@ +# functor-monad: Monads on category of Functors + +This package provides `FFunctor` and `FMonad`, +each corresponds to `Functor` and `Monad` but higher-order. + +| | a Functor `f` | a FFunctor `ff` | +|----|----|----| +| Takes | `a :: Type` | `g :: Type -> Type`, `Functor g` | +| Makes | `f a :: Type` | `ff g :: Type -> Type`, `Functor (ff g)` | +| Methods | `fmap :: (a -> b) -> f a -> f b` | `ffmap :: (Functor g, Functor h) => (g ~> h) -> (ff g ~> ff h)` | + +| | a Monad `m` | a FMonad `mm` | +|----|----|----| +| Superclass | Functor | FFunctor | +| Methods | `return = pure :: a -> m a` | `fpure :: (Functor g) => g ~> mm g` | +| | `(=<<) :: (a -> m b) -> m a -> m b` | `fbind :: (Functor g, Functor h) => (g ~> mm h) -> (mm g ~> mm h)` | +| | `join :: m (m a) -> m a` | `fjoin :: (Functor g) => mm (mm g) ~> mm g` | + +See also: https://viercc.github.io/blog/posts/2020-08-23-fmonad.html (Japanese article) + +## Motivational examples + +Many types defined in [base](https://hackage.haskell.org/package/base-4.18.1.0) and popolar libraries like +[transformers](https://hackage.haskell.org/package/transformers-0.6.1.1) take a parameter expecting a `Functor`. +Here are two, simple examples. + +```haskell +-- From "base", Data.Functor.Sum +data Sum f g x = InL (f x) | InR (g x) +instance (Functor f, Functor g) => Functor (Sum f g) + +-- From "transformers", Control.Monad.Trans.Reader +newtype ReaderT r m x = ReaderT { runReaderT :: r -> m x } +instance (Functor m) => Functor (ReaderT r m) +``` + +These types often have a way to map a natural transformation, an arrow between two `Functor`s, +over that parameter. + +```haskell +-- The type of natural transformations +type (~>) f g = forall x. f x -> g x + +mapRight :: (g ~> g') -> Sum f g ~> Sum f g' +mapRight _ (InL fx) = InL fx +mapRight nt (InR gx) = InR (nt gx) + +mapReaderT :: (m a -> n b) -> ReaderT r m a -> ReaderT r n b + +-- mapReaderT can be used to map natural transformation +mapReaderT' :: (m ~> n) -> (ReaderT r m ~> ReaderT r n) +mapReaderT' naturalTrans = mapReaderT naturalTrans +``` + +The type class `FFunctor` abstracts type constructors equipped with such a function. + +```haskell +class (forall g. Functor g => Functor (ff g)) => FFunctor ff where + ffmap :: (Functor g, Functor h) => (g ~> h) -> ff g x -> ff h x + +ffmap :: (Functor g, Functor g') => (g ~> g') -> Sum f g x -> Sum f g' x +ffmap :: (Functor m, Functor n) => (m ~> n) -> ReaderT r m x -> ReaderT r n x +``` + +Not all but many `FFunctor` instances can, in addition to `ffmap`, support `Monad`-like operations. +This package provide another type class `FMonad` to represent such operations. + +```haskell +class (FFunctor mm) => FMonad mm where + fpure :: (Functor g) => g ~> mm g + fbind :: (Functor g, Functor h) => (g ~> ff h) -> ff g a -> ff h a +``` + +Both of the above examples, `Sum` and `ReaderT r`, have `FMonad` instances. + +```haskell +instance Functor f => FMonad (Sum f) where + fpure :: (Functor g) => g ~> Sum f g + fpure = InR + + fbind :: (Functor g, Functor h) => (g ~> Sum f h) -> Sum f g a -> Sum f h a + fbind _ (InL fa) = InL fa + fbind k (InR ga) = k ga + +instance FMonad (ReaderT r) where + fpure :: (Functor m) => m ~> ReaderT r m + -- return :: x -> (e -> x) + fpure = ReaderT . return + + fbind :: (Functor m, Functor n) => (m ~> ReaderT r n) -> ReaderT r m a -> ReaderT r n a + -- join :: (e -> e -> x) -> (e -> x) + fbind k = ReaderT . (>>= runReaderT . k) . runReaderT +``` + +## Comparison against similar type classes + +There are packages with very similar type classes, but they are more or less different to this package. + +* From [hkd](https://hackage.haskell.org/package/hkd): `FFunctor` + + There is a class named `FFunctor` in `hkd` package too. It represents a functor from /category of type constructors/ `k -> Type` to + the category of usual types and functions. + + Since it is not an endofunctor, there can be no `Monad`-like classes on them. + + Another package [rank2classes](https://hackage.haskell.org/package/rank2classes) also provides the same class `Rank2.Functor`. + +* From [mmorph](https://hackage.haskell.org/package/mmorph-1.2.0): `MFunctor`, `MMonad` + + `MFunctor` is a class for endofunctors on the category of `Monad`s and monad homomorphisms. + If `T` is a `MFunctor`, it takes a `Monad m` and constructs `Monad (T m)`, + and its `hoist` method takes a *Monad morphism* `m ~> n` and returns a new *Monad morphism* `T m ~> T n`. + + On the other hand, this library is about endofunctors on the category of `Functor`s and natural transformations, + which are similar but definitely distinct concept. + + For example, `Sum f` in the example above is not an instance of `MFunctor`, since there are no general way to make `Sum f m` a `Monad` + for arbitrary `Monad m`. + + ``` + instance Functor f => FFunctor (Sum f) + instance Functor f => MFunctor (Sum f) -- Can be written, but it will violate the requirement to be MFunctor + ``` + +* From [index-core](https://hackage.haskell.org/package/index-core): `IFunctor`, `IMonad` + + They are endofunctors on the category of type constructors of kind `k -> Type` and polymorphic functions `t :: forall (x :: k). f x -> g x`. + + While any instance of `FFunctor` from this package can be faithfully represented as a `IFunctor`, some instances can't be an instance of `IFunctor` _as is_. + Most notably, [Free](https://hackage.haskell.org/package/free-5.1.8/docs/Control-Monad-Free.html#t:Free) can't be an instance of `IFunctor` directly, + because `Free` needs `Functor h` to be able to implement `fmapI`, the method of `IFunctor`. + + ```haskell + class IFunctor ff where + fmapI :: (g ~> h) -> (ff g ~> ff h) + ``` + + There exists a workaround: you can use another representation of `Free f` which doesn't require `Functor f` to be a `Functor` itself, + for example `Program` from [operational](https://hackage.haskell.org/package/operational) package. + + This package avoids the neccesity of the workaround by admitting the restriction that the parameter of `FFunctor` must always be a `Functor`. + Therefore, `FFunctor` gives up instances which don't take `Functor` parameter, for example, a type constructor `F` with kind `F :: (Nat -> Type) -> Nat -> Type`. + +* From [functor-combinators](https://hackage.haskell.org/package/functor-combinators-0.4.1.2): `HFunctor`, `Inject`, `HBind` + + This package can be thought of as a more developed version of `index-core`, since they share the base assumption. + The tradeoff between this package is the same: some `FFunctor` instances can only be `HFunctor` via alternative representations. + Same applies for `FMonad` versus `Inject + HBind`. 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/examples/ListTVia.hs b/examples/ListTVia.hs new file mode 100644 --- /dev/null +++ b/examples/ListTVia.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE + StandaloneKindSignatures, + DerivingVia, + DerivingStrategies, + DeriveFunctor, + StandaloneDeriving, + RankNTypes, + ScopedTypeVariables, + InstanceSigs, + TypeOperators, + TupleSections, + QuantifiedConstraints +#-} +module Main(main) where + +import Data.Kind ( Type ) + +import Data.Monoid (Ap(..)) +import Control.Monad.Trans.Class +import Control.Monad.Trans.Free +import FMonad.FreeT +import Control.Monad.Trail + +{- + +This example is inspired by a question raised at r/haskell (in fact, it inspired me to make +this package itself!) + +ListT instances and -XDerivingVia: https://www.reddit.com/r/haskell/comments/i76yx2/listt_instances_and_xderivingvia/ + +> how can we derive @Monad@, @Alternative@, @Monoid@.. instances for @ListT@? + +-} + +type ListT :: (Type -> Type) -> (Type -> Type) +newtype ListT m a = ListT { runListT :: FreeT ((,) a) m () } + deriving stock (Eq, Ord, Show, Read) + deriving (Functor, Applicative, Monad) + via (Trail (FreeT' m)) + deriving (Semigroup, Monoid) + via (Ap (FreeT ((,) a) m) ()) + +-- MonadTrans is specific to ListT +instance MonadTrans ListT where + lift ma = ListT $ lift ma >>= \a -> liftF (a, ()) + +-- For test: +forEach :: Monad m => ListT m a -> (a -> m ()) -> m () +forEach as f = iterT (\(a, m) -> f a >> m) . runListT $ as + +test1, test2, test3 :: ListT IO Int +test1 = lift (putStrLn "SideEffect: A") >> mempty +test2 = lift (putStrLn "SideEffect: B") >> pure 1 +test3 = lift (putStrLn "SideEffect: C") >> (pure 2 <> pure 3) + +main :: IO () +main = forEach test print + where test = (test1 <> test2 <> test3) >>= \n -> pure 100 <> pure n diff --git a/functor-monad.cabal b/functor-monad.cabal new file mode 100644 --- /dev/null +++ b/functor-monad.cabal @@ -0,0 +1,77 @@ +cabal-version: 3.0 +name: functor-monad +synopsis: + FFunctor: functors on (the usual) Functors +description: + @FFunctor@ is a type class for endofunctors on the category of @Functor@s. + + @FMonad@ is a type class for monads in the category of @Functor@s. + +version: 0.1.1.0 +license: BSD-3-Clause +license-file: LICENSE +author: Koji Miyazato +category: Monads, Comonads, Functors +maintainer: Koji Miyazato +copyright: 2018-2023 Koji Miyazato +homepage: https://github.com/viercc/functor-monad/tree/main/functor-monad +bug-reports: https://github.com/viercc/functor-monad/issue +build-type: Simple +extra-doc-files: CHANGELOG.md, README.md +tested-with: GHC ==9.4.8, GHC ==9.6.4, GHC ==9.8.1 + +library + hs-source-dirs: src + exposed-modules: + FFunctor, + FFunctor.FCompose, + FFunctor.Adjunction, + FMonad, + FMonad.FFree, + FMonad.FreeT, + FMonad.Adjoint, + FMonad.State.Day, + FMonad.State.Ran, + FMonad.State.Lan, + FMonad.State.Simple.Inner, + FMonad.State.Simple.Outer, + FMonad.Cont.Curried, + FMonad.Cont.Exp, + + FStrong, + + FComonad, + FComonad.Adjoint, + + Control.Monad.Trail, + + Data.Functor.Precompose, + Data.Functor.Bicompose, + Data.Functor.Flip1, + Data.Functor.Day.Extra, + Data.Functor.Exp + other-modules: + Data.Bifunctor.Product.Extra, + Control.Monad.Trans.Free.Extra + build-depends: + base >= 4.16 && < 5, + adjunctions >= 4.4.2 && < 4.5, + comonad >= 5.0.8 && < 5.1, + transformers >= 0.6.1 && < 0.7, + free >= 5.2 && < 5.3, + bifunctors >= 5.6.1 && < 5.7, + auto-lift-classes >= 1.0.1 && < 1.2, + kan-extensions >= 5 && < 5.3, + free-applicative-t >= 0.1.0 && < 0.2, + day-comonoid >= 0.1 && < 0.2 + ghc-options: -Wall -Wcompat + -Wunused-packages -Wwarn=unused-packages + default-language: Haskell2010 + +test-suite functor-monad-examples + type: exitcode-stdio-1.0 + hs-source-dirs: examples + main-is: ListTVia.hs + build-depends: base, transformers, free, functor-monad + ghc-options: -Wall -Wwarn=unused-packages + default-language: Haskell2010 diff --git a/src/Control/Monad/Trail.hs b/src/Control/Monad/Trail.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trail.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 'Trail' type which makes an ordinary 'Monad' out of 'FMonad' +module Control.Monad.Trail (Trail (..)) where + +import Control.Monad (ap) +import Data.Bifunctor +import FMonad + +-- | For any @'FMonad' mm@, @Trail mm@ is a 'Monad'. +-- +-- ==== Example +-- +-- @Trail mm@ can become variantions of @Monad@ for different @FMonad mm@. +-- +-- * @mm = 'FMonad.Compose.ComposePost' m@ +-- +-- For any @Monad m@, @Trail (ComposePost m)@ is isomorphic to @m@. +-- +-- @ +-- Trail (ComposePost m) a +-- ~ ComposePost m ((,) a) () +-- ~ m (a, ()) +-- ~ m a +-- @ +-- +-- * @mm = 'Control.Monad.Free.Free'@ +-- +-- @Trail Free@ is isomorphic to the list monad @[]@. +-- +-- @ +-- Trail Free a +-- ~ Free ((,) a) () +-- ~ [a] +-- @ +-- +-- +-- * @mm = 'FMonad.FreeT.FreeT'' m@ +-- +-- For any @Monad m@, @Trail (FreeT' m)@ is isomorphic to @ListT m@, +-- where @ListT@ is so-called \"ListT done right.\" +-- +-- @ +-- Trail (FreeT' m) a +-- ~ FreeT ((,) a) m () +-- ~ ListT m a +-- @ +-- +-- See more for examples\/ListTVia.hs +newtype Trail mm a = Trail {runTrail :: mm ((,) a) ()} + +instance (FFunctor mm) => Functor (Trail mm) where + fmap f = Trail . ffmap (first f) . runTrail + +-- f :: a -> b +-- first f :: forall c. (a, c) -> (b, c) + +instance (FMonad mm) => Applicative (Trail mm) where + pure a = Trail $ fpure (a, ()) + (<*>) = ap + +instance (FMonad mm) => Monad (Trail mm) where + ma >>= k = Trail . fjoin . ffmap (plug . first (runTrail . k)) . runTrail $ ma + +plug :: forall f x. Functor f => (f (), x) -> f x +plug (f_, a) = a <$ f_ diff --git a/src/Control/Monad/Trans/Free/Extra.hs b/src/Control/Monad/Trans/Free/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Trans/Free/Extra.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Various utility functions on 'FreeT' +module Control.Monad.Trans.Free.Extra where + +import Control.Arrow ((>>>)) +import Control.Monad.Trans.Free +import FFunctor (type (~>)) + +ffmapFreeF :: forall f g a. (f ~> g) -> FreeF f a ~> FreeF g a +ffmapFreeF _ (Pure a) = Pure a +ffmapFreeF fg (Free fb) = Free (fg fb) + +transFreeT_ :: forall f g m. (Functor g, Functor m) => (f ~> g) -> FreeT f m ~> FreeT g m +transFreeT_ fg = + let go = FreeT . fmap (fmap go . ffmapFreeF fg) . runFreeT in go + +traverseFreeT_ :: + (Traversable f, Traversable m, Applicative g) => + (a -> g b) -> + FreeT f m a -> + g (FreeT f m b) +traverseFreeT_ f = go + where + go (FreeT x) = FreeT <$> traverse goF x + goF (Pure a) = Pure <$> f a + goF (Free fmx) = Free <$> traverse go fmx + +inr :: Functor m => m ~> FreeT f m +inr = FreeT . fmap Pure + +inl :: (Functor f, Monad m) => f ~> FreeT f m +inl = FreeT . return . Free . fmap return + +eitherFreeT_ :: Monad n => (f ~> n) -> (m ~> n) -> (FreeT f m ~> n) +eitherFreeT_ nt1 nt2 = go + where + go ma = + do + v <- nt2 (runFreeT ma) + case v of + Pure a -> return a + Free fm -> nt1 fm >>= go + +caseFreeF :: (a -> r) -> (f b -> r) -> FreeF f a b -> r +caseFreeF pureCase freeCase freef = case freef of + Pure a -> pureCase a + Free fb -> freeCase fb + +fbindFreeT_ :: forall f m n a. (Functor f, Functor m, Functor n) => (m ~> FreeT f n) -> FreeT f m a -> FreeT f n a +fbindFreeT_ k = outer + where + outer :: FreeT f m a -> FreeT f n a + outer = runFreeT >>> k >>> inner + + inner :: FreeT f n (FreeF f a (FreeT f m a)) -> FreeT f n a + inner = + -- T m (F a (T m a)) + runFreeT + >>> fmap (caseFreeF (caseFreeF Pure (Free . fmap outer)) (Free . fmap inner)) + >>> FreeT + +fconcatFreeT_ :: forall f m. (Functor f, Functor m) => FreeT f (FreeT f m) ~> FreeT f m +fconcatFreeT_ = fbindFreeT_ id diff --git a/src/Data/Bifunctor/Product/Extra.hs b/src/Data/Bifunctor/Product/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Product/Extra.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE PolyKinds #-} +module Data.Bifunctor.Product.Extra where + +import Data.Bifunctor.Product + +proj1 :: Product p q a b -> p a b +proj1 (Pair p _) = p + +proj2 :: Product p q a b -> q a b +proj2 (Pair _ q) = q diff --git a/src/Data/Functor/Bicompose.hs b/src/Data/Functor/Bicompose.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Bicompose.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +module Data.Functor.Bicompose where + +import Control.Applicative (Alternative) +import Control.Monad (join) +import Data.Functor.Classes (Eq1, Ord1) +import Data.Functor.Compose +import Data.Kind (Type) +import FMonad +import FComonad + +import Data.Functor.Precompose (type (:.:)) +import Control.Comonad + +-- | Both-side composition of Monad. +-- +-- If both of @f@ and @g@ are @Monad@, @Bicompose f g@ is an instance of 'FMonad' in a similar way +-- 'Compose' and 'Data.Functor.Precompose.Precompose' are. +type Bicompose :: (k2 -> Type) -> (k0 -> k1) -> (k1 -> k2) -> k0 -> Type +newtype Bicompose f g h a = Bicompose {getBicompose :: f (h (g a))} + deriving stock (Show, Read, Functor, Foldable) + +deriving stock instance + (Traversable f, Traversable g, Traversable h) => Traversable (Bicompose f g h) + +deriving via + ((f :.: h :.: g) a) + instance + (Eq1 f, Eq1 g, Eq1 h, Eq a) => Eq (Bicompose f g h a) + +deriving via + ((f :.: h :.: g) a) + instance + (Ord1 f, Ord1 g, Ord1 h, Ord a) => Ord (Bicompose f g h a) + +deriving via + (f :.: h :.: g) + instance + (Applicative f, Applicative g, Applicative h) => Applicative (Bicompose f g h) + +deriving via + (f :.: h :.: g) + instance + (Alternative f, Applicative g, Applicative h) => Alternative (Bicompose f g h) + +instance (Functor f, Functor g) => FFunctor (Bicompose f g) where + ffmap gh = Bicompose . fmap gh . getBicompose + +instance (Monad f, Monad g) => FMonad (Bicompose f g) where + fpure = Bicompose . return . fmap return + fbind k = Bicompose . fmap (fmap join) . (getBicompose . k =<<) . getBicompose + +instance (Comonad f, Comonad g) => FComonad (Bicompose f g) where + fextract = fmap extract . extract . getBicompose + fextend tr = Bicompose . extend (tr . Bicompose) . fmap (fmap duplicate) . getBicompose diff --git a/src/Data/Functor/Day/Extra.hs b/src/Data/Functor/Day/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Day/Extra.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} + +module Data.Functor.Day.Extra where + +import Data.Functor.Day +import Data.Functor.Day.Curried +import Data.Functor.Identity +import FFunctor (type (~>)) + +import Control.Monad.Trans.Reader +import Control.Comonad.Trans.Env +import Control.Comonad.Trans.Traced +import Control.Monad.Trans.Writer + +-- @'uncurry' :: (a -> b -> c) -> (a,b) -> c@ +uncurried :: forall f g h c. (Functor f, Functor g) => Curried f (Curried g h) c -> Curried (Day f g) h c +uncurried = toCurried (applied . trans2 applied . disassoc . trans1 swapped) + +-- @'curry' :: ((a,b) -> c) -> (a -> b -> c)@ +curried :: forall f g h c. (Functor f, Functor g) => Curried (Day f g) h c -> Curried f (Curried g h) c +curried = toCurried (toCurried (applied . trans1 swapped . assoc)) + +-- | Internal identity of natural transformation. +-- +-- @ unitCurried = 'toCurried' 'elim2' @ +unitCurried :: Functor g => Identity ~> Curried g g +unitCurried = toCurried elim2 + +-- | Internal composition of natural transformations. +-- +-- @ composeCurried = 'toCurried' ('applied' . 'trans1' 'applied' . 'assoc') @ +composeCurried :: (Functor f, Functor g, Functor h) => Day (Curried f g) (Curried g h) ~> Curried f h +composeCurried = toCurried (applied . trans1 applied . assoc) + +-- * Conversions to Monad/Comonad transformers + +dayToEnv :: Functor f => Day ((,) s0) f ~> EnvT s0 f +dayToEnv (Day (s0,b) fc op) = EnvT s0 (op b <$> fc) + +envToDay :: EnvT s0 f ~> Day ((,) s0) f +envToDay (EnvT s0 f) = day (s0, id) f + +curriedToReader :: Curried ((,) s0) f ~> ReaderT s0 f +curriedToReader (Curried sf) = ReaderT \s0 -> sf (s0, id) + +readerToCurried :: Functor f => ReaderT s0 f ~> Curried ((,) s0) f +readerToCurried (ReaderT sf) = Curried \(s0,k) -> fmap k (sf s0) + +dayToTraced :: Functor f => Day ((->) s1) f ~> TracedT s1 f +dayToTraced (Day sb fc op) = TracedT $ fmap (\c s -> op (sb s) c) fc + +tracedToDay :: TracedT s1 f ~> Day ((->) s1) f +tracedToDay (TracedT fk) = Day id fk (\s k -> k s) + +curriedToWriter :: Curried ((->) s1) f ~> WriterT s1 f +curriedToWriter (Curried sf) = WriterT $ sf (\s a -> (a,s)) + +writerToCurried :: Functor f => WriterT s1 f ~> Curried ((->) s1) f +writerToCurried (WriterT fas) = Curried $ \sar -> fmap (\(a,s) -> sar s a) fas diff --git a/src/Data/Functor/Exp.hs b/src/Data/Functor/Exp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Exp.hs @@ -0,0 +1,86 @@ +{- | Exponentiation of a @Functor@ by a @Functor@. + +For reference: + +Powers of polynomial monads by David Spivak + +-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +module Data.Functor.Exp where + +import FFunctor +import GHC.Generics ((:*:)(..)) +import Control.Monad (ap) +import Control.Comonad +import Control.Applicative +import FMonad +import FStrong +import Data.Functor.Day (Day(..)) + +newtype Exp1 f g a = Exp1 { unExp1 :: forall r. f r -> (a -> r) -> g r } + deriving Functor + +type (:^:) f g = Exp1 g f + +toExp1 :: forall f g h. Functor g => ((f :*: g) ~> h) -> (g ~> Exp1 f h) +toExp1 fg2h gx = Exp1 (\fr xr -> fg2h (fr :*: fmap xr gx)) + +fromExp1 :: forall f g h. (g ~> Exp1 f h) -> ((f :*: g) ~> h) +fromExp1 g2fh (fx :*: gx) = unExp1 (g2fh gx) fx id + +evalExp1 :: (f :*: Exp1 f g) ~> g +evalExp1 = fromExp1 id + +coevalExp1 :: Functor g => g ~> Exp1 f (f :*: g) +coevalExp1 = toExp1 id + +fromExp1' :: Functor f => Exp1 f g b -> f a -> g (Either a b) +fromExp1' e fa = unExp1 e (Left <$> fa) Right + +toExp1' :: Functor g => (forall a. f a -> g (Either a b)) -> Exp1 f g b +toExp1' fg = Exp1 $ \fr br -> either id br <$> fg fr + +instance (Functor f, Monad g) => Applicative (Exp1 f g) where + pure a = Exp1 $ \_ ar -> pure (ar a) + (<*>) = ap + +instance (Functor f, Monad g) => Monad (Exp1 f g) where + ma >>= k = Exp1 $ \fr br -> + fromExp1' ma fr >>= \case + Left r -> pure r + Right a -> unExp1 (k a) fr br + +-- | Equivalent to @'Data.Monoid.Alt' (Exp1 f g) a@ +instance (Comonad f, Monad g) => Semigroup (Exp1 f g a) where + (<>) = (<|>) + +-- | Equivalent to @'Data.Monoid.Alt' (Exp1 f g) a@ +instance (Comonad f, Monad g) => Monoid (Exp1 f g a) where + mempty = empty + +instance (Comonad f, Monad g) => Alternative (Exp1 f g) where + empty = Exp1 $ \fr _ -> pure (extract fr) + m1 <|> m2 = Exp1 $ \fr ar -> + fromExp1' m1 (duplicate fr) >>= \case + Left fr' -> unExp1 m2 fr' ar + Right a -> pure (ar a) + + +instance FFunctor (Exp1 f) where + ffmap gh (Exp1 e) = Exp1 $ \fr ar -> gh (e fr ar) + +-- | @g ~ Exp1 Proxy g@; @Exp1 f (Exp1 f g) ~ Exp1 (f :*: f) g@ +instance Functor f => FMonad (Exp1 f) where + fpure gx = Exp1 $ \_ br -> br <$> gx + fbind k fgx = Exp1 $ \fr yr -> + unExp1 (k (fromExp1' fgx fr)) fr (either id yr) + +instance Functor f => FStrong (Exp1 f) where + fstrength (Day mb hc op) = + Exp1 $ \fr ar -> + let op' (Left r) _ = r + op' (Right b) c = ar (op b c) + in Day (fromExp1' mb fr) hc op' diff --git a/src/Data/Functor/Flip1.hs b/src/Data/Functor/Flip1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Flip1.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Functor.Flip1 where + +import AutoLift (Reflected1 (..)) +import Control.Applicative +import Control.Monad +import Control.Monad.Free (MonadFree (..)) +import Data.Coerce +import Data.Functor.Classes +import Data.Kind (Type) + +-- | Swaps the order of parameters. 'Flip1' is like 'Data.Bifunctor.Flip.Flip' but has +-- an additional parameter. +-- +-- > newtype Flip1 t a b c = Flip1 {unFlip1 :: t b a c} +type Flip1 :: (k1 -> k2 -> k3 -> Type) -> k2 -> k1 -> k3 -> Type +newtype Flip1 t a b c = Flip1 {unFlip1 :: t b a c} + deriving stock (Eq, Ord, Show, Read, Traversable) + deriving + ( Functor, + Eq1, + Ord1, + Foldable, + Applicative, + Alternative, + Monad, + MonadPlus, + MonadFail + ) + via (t b a) + +deriving via + (Reflected1 (Flip1 t a b)) + instance + ( forall c. Show c => Show (t b a c), + forall x y. Coercible x y => Coercible (t b a x) (t b a y) + ) => + Show1 (Flip1 t a b) + +deriving via + (Reflected1 (Flip1 t a b)) + instance + ( forall c. Read c => Read (t b a c), + forall x y. Coercible x y => Coercible (t b a x) (t b a y) + ) => + Read1 (Flip1 t a b) + +instance (Functor h, MonadFree h (t g f)) => MonadFree h (Flip1 t f g) where + wrap = Flip1 . wrap . fmap unFlip1 diff --git a/src/Data/Functor/Precompose.hs b/src/Data/Functor/Precompose.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Precompose.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Functor.Precompose where + +import Data.Kind (Type) + +import Control.Applicative (Alternative) +import Control.Monad (join) +import Control.Comonad(Comonad(..)) +import Data.Functor.Classes (Eq1, Ord1) +import Data.Functor.Compose ( Compose(..) ) + +import FMonad +import FComonad + +-- | Single-kinded type alias of Compose +type (:.:) :: (Type -> Type) -> (Type -> Type) -> Type -> Type +type (:.:) = Compose + +-- | Flipped-order Compose. +-- +-- When @f@ is a @Monad@, @Precompose f@ is a 'FMonad' in the similar way 'Compose' is. +-- +-- The only difference is @Precompose f@ composes @f@ to the right (_pre_compose) +-- compared to @Compose f@ which composes to the left (_post_compose). +type Precompose :: (j -> k) -> (k -> Type) -> j -> Type +newtype Precompose f g a = Precompose {getPrecompose :: g (f a)} + deriving stock (Show, Read, Functor, Foldable) + +deriving stock instance (Traversable f, Traversable g) => Traversable (Precompose f g) + +deriving via + ((g :.: f) a) + instance + (Eq1 f, Eq1 g, Eq a) => Eq (Precompose f g a) + +deriving via + ((g :.: f) a) + instance + (Ord1 f, Ord1 g, Ord a) => Ord (Precompose f g a) + +deriving via + (g :.: f) + instance + (Eq1 f, Eq1 g) => Eq1 (Precompose f g) + +deriving via + (g :.: f) + instance + (Ord1 f, Ord1 g) => Ord1 (Precompose f g) + +deriving via + (g :.: f) + instance + (Applicative f, Applicative g) => Applicative (Precompose f g) + +deriving via + (g :.: f) + instance + (Applicative f, Alternative g) => Alternative (Precompose f g) + +instance Functor f => FFunctor (Precompose f) where + ffmap gh = Precompose . gh . getPrecompose + +instance Monad f => FMonad (Precompose f) where + fpure = Precompose . fmap return + fbind k = Precompose . fmap join . getPrecompose . k . getPrecompose + +instance Comonad f => FComonad (Precompose f) where + fextract = fmap extract . getPrecompose + fextend tr = Precompose . tr . Precompose . fmap duplicate . getPrecompose diff --git a/src/FComonad.hs b/src/FComonad.hs new file mode 100644 --- /dev/null +++ b/src/FComonad.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Comonads in the cateogory of @Functor@s. +module FComonad + ( type (~>), + FFunctor (..), + FComonad (..), + fduplicate + ) where + +import Control.Comonad + +import Data.Functor.Product +import Data.Functor.Compose +import qualified Data.Bifunctor.Sum as Bi +import Control.Comonad.Trans.Identity +import Control.Comonad.Env ( EnvT(..) ) +import Control.Comonad.Traced (TracedT(..)) +import Control.Comonad.Cofree (Cofree(..)) +import qualified Control.Comonad.Cofree as Cofree + +import FFunctor +import Data.Coerce (coerce) + +-- | @FComonad@ is to 'FFunctor' what 'Comonad' is to 'Functor'. +class FFunctor ff => FComonad ff where + fextract :: Functor g => ff g ~> g + fextend :: (Functor g, Functor h) => (ff g ~> h) -> (ff g ~> ff h) + +fduplicate :: (FComonad ff, Functor g) => ff g ~> ff (ff g) +fduplicate = fextend id + +instance FComonad IdentityT where + fextract = coerce + fextend tr = coerce . tr + +instance Functor f => FComonad (Product f) where + fextract (Pair _ g) = g + fextend tr fg@(Pair f _) = Pair f (tr fg) + +instance Comonad f => FComonad (Compose f) where + fextract = extract . getCompose + fextend tr = Compose . extend (tr . Compose) . getCompose + +instance (FComonad ff, FComonad gg) => FComonad (Bi.Sum ff gg) where + fextract (Bi.L2 ffx) = fextract ffx + fextract (Bi.R2 ggx) = fextract ggx + + fextend tr ffgg = case ffgg of + Bi.L2 ffx -> Bi.L2 (fextend (tr . Bi.L2) ffx) + Bi.R2 ggx -> Bi.R2 (fextend (tr . Bi.R2) ggx) + +instance FComonad (EnvT e) where + fextract (EnvT _ gx) = gx + fextend tr eg@(EnvT e _) = EnvT e (tr eg) + +instance Monoid m => FComonad (TracedT m) where + fextract (TracedT g) = ($ mempty) <$> g + fextend tr (TracedT g) = TracedT $ tr (TracedT $ fmap (\k m1 m2 -> k (m1 <> m2)) g) + +instance FComonad Cofree where + fextract :: Functor g => Cofree g ~> g + fextract = fmap extract . Cofree.unwrap + + fextend :: (Functor g, Functor h) => (Cofree g ~> h) -> (Cofree g ~> Cofree h) + fextend tr = ffmap tr . Cofree.section + + {- + + fextract $ fduplicate gs + = fextract $ extract gs :< fmap fduplicate_ (duplicate gs) + = fmap extract (fmap fduplicate_ (duplicate gs)) + = fmap (extract . fduplicate_) (duplicate gs) + = fmap extract (duplicate gs) + = gs + + ffmap fextract $ fduplicate gs + = ffmap fextract $ extract gs :< fmap fduplicate_ (duplicate gs) + = extract gs :< (fmap (ffmap fextract) . fextract . fmap fduplicate_) (duplicate gs) + = extract gs :< (fmap (ffmap fextract . fduplicate_) . fextract) (duplicate gs) + -- gs = (a :< gs') + = extract (a :< gs') :< fmap (ffmap fextract . fduplicate_) (fextract (duplicate (a :< gs'))) + = a :< fmap (ffmap fextract . fduplicate_) (fextract ((a :< gs') :< fmap duplicate gs')) + = a :< fmap (ffmap fextract . fduplicate_) (fmap extract (fmap duplicate gs')) + = a :< fmap (ffmap fextract . fduplicate_) gs' + ffmap fextract . fduplicate_ + = let go (a :< gs) = a :< fmap go gs + in go + = id + + -} diff --git a/src/FComonad/Adjoint.hs b/src/FComonad/Adjoint.hs new file mode 100644 --- /dev/null +++ b/src/FComonad/Adjoint.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +module FComonad.Adjoint(Adjoint, adjoint, runAdjoint, AdjointT(..), fffmap, ungeneralize) where + +import Control.Monad.Trans.Identity ( IdentityT(..) ) + +import FFunctor +import FComonad +import FStrong +import FFunctor.FCompose +import FFunctor.Adjunction + +newtype AdjointT ff uu ww g x = AdjointT { runAdjointT :: ff (ww (uu g)) x } + deriving Functor + +type Adjoint ff uu = AdjointT ff uu IdentityT + +deriving + via FCompose (FCompose ff ww) uu + instance (FFunctor ff, FFunctor ww, FFunctor uu) => FFunctor (AdjointT ff uu ww) + +deriving + via FCompose (FCompose ff ww) uu + instance (FStrong ff, FStrong ww, FStrong uu) => FStrong (AdjointT ff uu ww) + +instance (Adjunction ff uu, FComonad ww) => FComonad (AdjointT ff uu ww) where + fextract = counit . ffmap fextract . runAdjointT + fextend tr = ffmap (tr . AdjointT) . AdjointT . ffmap (fextend unit) . runAdjointT + +adjoint :: (FFunctor ff, FFunctor uu, Functor x) => ff (uu x) ~> Adjoint ff uu x +adjoint = AdjointT . ffmap IdentityT + +runAdjoint :: (FFunctor ff, FFunctor uu, Functor x) => Adjoint ff uu x ~> ff (uu x) +runAdjoint = ffmap runIdentityT . runAdjointT + +fffmap :: forall mm nn ff uu x. + (FFunctor mm, FFunctor nn, FFunctor ff, FFunctor uu, Functor x) + => (forall y. (Functor y) => mm y ~> nn y) + -> (AdjointT ff uu mm x ~> AdjointT ff uu nn x) +fffmap trans = AdjointT . ffmap trans . runAdjointT + +ungeneralize :: (FComonad ww, FFunctor ff, FFunctor uu, Functor x) => AdjointT ff uu ww x ~> Adjoint ff uu x +ungeneralize = fffmap (IdentityT . fextract) diff --git a/src/FFunctor.hs b/src/FFunctor.hs new file mode 100644 --- /dev/null +++ b/src/FFunctor.hs @@ -0,0 +1,250 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} + +-- | Functors on the category of @Functor@ s. +module FFunctor + ( type (~>), + FFunctor (..), + + -- * Utilities to kind-annotate FFunctor instances + FUNCTOR, + FF, + ) +where + +import qualified Control.Applicative.Free as FreeAp +import qualified Control.Applicative.Free.Final as FreeApFinal +import Control.Applicative.Lift +import qualified Control.Applicative.Trans.FreeAp as FreeApT +import qualified Control.Monad.Free as FreeM +import qualified Control.Monad.Free.Church as FreeMChurch +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import Data.Functor.Compose +import Data.Functor.Day +import Data.Functor.Day.Curried +import Data.Functor.Flip1 +import Data.Functor.Kan.Lan +import Data.Functor.Kan.Ran +import Data.Functor.Product +import Data.Functor.Sum +import Data.Kind (Constraint, Type) + +import qualified Data.Bifunctor.Sum as Bi +import qualified Data.Bifunctor.Product as Bi + +import Control.Comonad.Env (EnvT(..)) +import Control.Comonad.Traced (TracedT(..)) +import Control.Comonad.Store (StoreT (..)) +import Control.Comonad.Cofree (Cofree, hoistCofree) +import Control.Monad.Trans.Free (FreeT, hoistFreeT) + +import GHC.Generics + ( Rec1(..), + M1(..), + type (:+:)(..), + type (:*:)(..), + type (:.:)(..) ) + +-- | Natural transformation arrow +type (~>) :: (k -> Type) -> (k -> Type) -> Type +type (~>) f g = forall x. f x -> g x + +-- | The kind of a @Functor@ +type FUNCTOR = Type -> Type + +-- | The kind of a @FFunctor@. +type FF = FUNCTOR -> FUNCTOR + +{- | Endofunctors on the category of 'Functor's. + ++----------------+-----------------------------+------------------------------------+ +| | @'Functor' f@ | @'FFunctor' ff@ | ++================+=============================+====================================+ +| Takes | A type @a@ | A @Functor g@ | ++----------------+-----------------------------+------------------------------------+ +| Makes | A type @f a@ | A @Functor (ff g)@ | ++----------------+-----------------------------+------------------------------------+ +| Feature | @ | @ | +| | fmap | ffmap | +| | :: (a -> b) -> f a -> f b | :: (Functor g, Functor h) | +| | @ | => (g ~> h) -> (ff g ~> ff h) | +| | | @ | ++----------------+-----------------------------+------------------------------------+ + +FFunctor laws: + +[Identity] + + > ffmap id = id + +[Composition] + + > ffmap f . ffmap g = ffmap (f . g) + +==== Examples + +This is the @FFunctor@ instance of @'Sum' f@. +Just like the 'fmap' from @Functor (Either a)@ instance which applies a function to the \"Right\" value, +@ffmap@ applies @gh :: g ~> h@ to the @InR (g a)@ value. + +@ +data Sum f g a = InL (f a) | InR (g a) +instance (Functor f) => FFunctor (Sum f) where + ffmap gh fgx = case fgx of + InL fx -> InL fx + InR gx -> InR (gh gx) +@ + +Like @Sum f@, some instances of @FFunctor@ are modified @Functor@s in such a way that +its parameter is swapped for @g a@. +But not every instance of @FFunctor@ is like this. The following data type @Foo g a@ +is a @FFunctor@ which uses a @Functor g@ and a type parameter @a@ separately. + +@ +data Foo g a = Foo (String -> a) (g String) + +instance Functor (Foo g) where + fmap :: (a -> b) -> Foo g a -> Foo g b + fmap f (Foo strToA gStr) = Foo (f . strToA) gStr + +instance FFunctor Foo where + ffmap :: (g ~> h) -> Foo g a -> Foo h a + ffmap gh (Foo strToA gStr) = Foo strToA (gh gStr) +@ + +An @FFunctor@ instance can use its @Functor@ parameter nested. The following @Bar g a@ example uses +@g@ nested twice. + +@ +newtype Bar g a = Bar (g (g a)) + +instance Functor g => Functor (Bar g) where + fmap f (Bar gga) = Bar $ fmap (fmap f gga) + +instance FFunctor Bar where + ffmap gh (Bar gga) = Bar $ fmap gh (gh gga) +@ + +==== Non-example + +@'Control.Monad.Trans.Cont.ContT' r@ has the right kind to be an @FFunctor@, that is, +@(Type -> Type) -> Type -> Type@. But there can be no instances of @FFunctor (ContT r)@, +because @ContT r m@ uses @m@ in negative position. + +> newtype ContT r m a = ContT { +> runContT :: (a -> m r) -> m r +> -- ^ ^ positive position +> -- | negative position +> } + +-} +type FFunctor :: FF -> Constraint +class (forall g. Functor g => Functor (ff g)) => FFunctor ff where + ffmap :: (Functor g, Functor h) => (g ~> h) -> (ff g x -> ff h x) + +instance Functor f => FFunctor (Sum f) where + ffmap _ (InL fa) = InL fa + ffmap gh (InR ga) = InR (gh ga) + +instance Functor f => FFunctor (Product f) where + ffmap gh (Pair fa ga) = Pair fa (gh ga) + +instance Functor f => FFunctor (Compose f) where + ffmap gh = Compose . fmap gh . getCompose + +instance Functor f => FFunctor ((:+:) f) where + ffmap _ (L1 fa) = L1 fa + ffmap gh (R1 ga) = R1 (gh ga) + +instance Functor f => FFunctor ((:*:) f) where + ffmap gh (fa :*: ga) = fa :*: gh ga + +deriving + via (Compose (f :: Type -> Type)) + instance Functor f => FFunctor ((:.:) f) + +deriving + via IdentityT + instance FFunctor (M1 c m) + +deriving + via IdentityT + instance FFunctor Rec1 + +instance FFunctor Lift where + ffmap gh = mapLift gh + +instance FFunctor FreeM.Free where + ffmap = FreeM.hoistFree + +instance FFunctor FreeMChurch.F where + ffmap = FreeMChurch.hoistF + +instance FFunctor FreeAp.Ap where + ffmap = FreeAp.hoistAp + +instance FFunctor FreeApFinal.Ap where + ffmap = FreeApFinal.hoistAp + +instance FFunctor IdentityT where + ffmap fg = IdentityT . fg . runIdentityT + +instance FFunctor (ReaderT e) where + ffmap fg = ReaderT . fmap fg . runReaderT + +instance FFunctor (WriterT m) where + ffmap fg = WriterT . fg . runWriterT + +instance FFunctor (StateT s) where + ffmap fg = StateT . fmap fg . runStateT + +instance FFunctor (Ran f) where + ffmap gh (Ran ran) = Ran (gh . ran) + +instance FFunctor (Lan f) where + ffmap gh (Lan e g) = Lan e (gh g) + +instance FFunctor (Day f) where + ffmap = trans2 + +instance Functor f => FFunctor (Curried f) where + ffmap gh (Curried t) = Curried (gh . t) + +instance FFunctor (FreeApT.ApT f) where + ffmap = FreeApT.hoistApT + +instance Functor f => FFunctor (FreeT f) where + ffmap = hoistFreeT + +instance Functor g => FFunctor (Flip1 FreeApT.ApT g) where + ffmap f2g = Flip1 . FreeApT.transApT f2g . unFlip1 + +instance (FFunctor ff, FFunctor gg) => FFunctor (Bi.Sum ff gg) where + ffmap t (Bi.L2 ff) = Bi.L2 (ffmap t ff) + ffmap t (Bi.R2 gg) = Bi.R2 (ffmap t gg) + +instance (FFunctor ff, FFunctor gg) => FFunctor (Bi.Product ff gg) where + ffmap t (Bi.Pair ff gg) = Bi.Pair (ffmap t ff) (ffmap t gg) + +instance FFunctor (EnvT e) where + ffmap gh (EnvT e g) = EnvT e (gh g) + +instance FFunctor (TracedT m) where + ffmap gh (TracedT g) = TracedT (gh g) + +instance FFunctor (StoreT s) where + ffmap gh (StoreT g s) = StoreT (gh g) s + +instance FFunctor Cofree where + ffmap = hoistCofree diff --git a/src/FFunctor/Adjunction.hs b/src/FFunctor/Adjunction.hs new file mode 100644 --- /dev/null +++ b/src/FFunctor/Adjunction.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE BlockArguments #-} +module FFunctor.Adjunction (Adjunction(..)) where + + +import Data.Coerce ( coerce, Coercible ) +import Data.Kind (Constraint) + +import Control.Monad.Trans.Identity +import Data.Functor.Day +import Data.Functor.Day.Curried + +import Data.Functor.Kan.Lan +import Data.Functor.Kan.Ran +import Data.Functor.Precompose (Precompose(..)) +import Data.Functor.Compose (Compose(..)) + +import qualified Data.Bifunctor.Sum as Bi +import qualified Data.Bifunctor.Product as Bi +import qualified Data.Bifunctor.Product.Extra as Bi + +import qualified Data.Functor.Adjunction as Rank1 +import qualified Control.Monad.Trans.Reader as Rank1 +import qualified Control.Monad.Trans.Writer as Rank1 +import qualified Control.Monad.Trans.State.Lazy as Rank1 +import qualified Control.Comonad.Trans.Env as Rank1 +import qualified Control.Comonad.Trans.Traced as Rank1 +import qualified Control.Comonad.Trans.Store as Rank1 + +import FFunctor +import FFunctor.FCompose ( FCompose(..) ) +import Data.Functor.Exp +import GHC.Generics ((:*:)) + +-- | An adjunction between \(\mathrm{Hask}^{\mathrm{Hask}}\) and \(\mathrm{Hask}^{\mathrm{Hask}}\). +type Adjunction :: FF -> FF -> Constraint +class (FFunctor ff, FFunctor uu) => Adjunction ff uu | ff -> uu, uu -> ff where + {-# MINIMAL (unit, counit) | (leftAdjunct, rightAdjunct) #-} + unit :: forall g. Functor g => g ~> uu (ff g) + unit = leftAdjunct id + counit :: forall g. Functor g => ff (uu g) ~> g + counit = rightAdjunct id + + leftAdjunct :: forall g h. (Functor g, Functor h) => (ff g ~> h) -> (g ~> uu h) + leftAdjunct ffg_h = ffmap ffg_h . unit + rightAdjunct :: forall g h. (Functor g, Functor h) => (g ~> uu h) -> (ff g ~> h) + rightAdjunct g_uuh = counit . ffmap g_uuh + +natCoerce :: forall f' f g g'. (Coercible f' f, Coercible g g') => (f ~> g) -> (f' ~> g') +natCoerce fg = + let f'g' :: forall x. f' x -> g' x + f'g' = coerce (fg @x) + in f'g' + +instance Adjunction IdentityT IdentityT where + unit = coerce + counit = coerce + leftAdjunct = natCoerce + rightAdjunct = natCoerce + +instance Functor f => Adjunction (Day f) (Curried f) where + unit = unapplied + counit = applied + + leftAdjunct = toCurried + rightAdjunct = fromCurried + +instance Functor f => Adjunction (Lan f) (Precompose f) where + unit :: (Functor g) => g ~> Precompose f (Lan f g) + unit g = Precompose $ Lan id g + counit :: (Functor g) => Lan f (Precompose f g) ~> g + counit (Lan unF (Precompose gf)) = fmap unF gf + +instance Functor f => Adjunction (Precompose f) (Ran f) where + unit :: (Functor g) => g ~> Ran f (Precompose f g) + -- g ~> Ran f (g :.: f) + -- ∀x. g x -> (∀y. (x -> f y) -> g (f y)) + unit g = Ran $ \toF -> Precompose (fmap toF g) + + counit :: (Functor g) => Precompose f (Ran f g) ~> g + -- Ran f g :.: f ~> g + -- ∀x. (∀y. (f x -> f y) -> g y) -> g x + counit (Precompose ffg) = runRan ffg id + +instance (Adjunction ff uu, Adjunction gg vv) => Adjunction (FCompose ff gg) (FCompose vv uu) where + unit :: Functor h => h ~> FCompose vv uu (FCompose ff gg h) + unit = ffmap FCompose . FCompose . ffmap unit . unit + + counit :: Functor h => FCompose ff gg (FCompose vv uu h) ~> h + counit = counit . ffmap counit . getFCompose . ffmap getFCompose + + leftAdjunct :: forall h k. (Functor h, Functor k) + => (FCompose ff gg h ~> k) -> h ~> FCompose vv uu k + leftAdjunct lefty = FCompose . leftAdjunct (leftAdjunct (lefty . FCompose)) + + rightAdjunct :: (Functor h, Functor k) + => (h ~> FCompose vv uu k) -> FCompose ff gg h ~> k + rightAdjunct righty = rightAdjunct (rightAdjunct (getFCompose . righty)) . getFCompose + +instance (Adjunction ff uu, Adjunction gg vv) => Adjunction (Bi.Sum ff gg) (Bi.Product uu vv) where + unit :: (Functor h) + => h ~> Bi.Product uu vv (Bi.Sum ff gg h) + unit h = Bi.Pair (ffmap Bi.L2 (unit h)) (ffmap Bi.R2 (unit h)) + + counit :: (Functor h) + => Bi.Sum ff gg (Bi.Product uu vv h) ~> h + counit (Bi.L2 ffP) = counit (ffmap Bi.proj1 ffP) + counit (Bi.R2 ggP) = counit (ffmap Bi.proj2 ggP) + + leftAdjunct :: (Functor h, Functor k) => (Bi.Sum ff gg h ~> k) -> h ~> Bi.Product uu vv k + leftAdjunct lefty h = Bi.Pair (leftAdjunct (lefty . Bi.L2) h) (leftAdjunct (lefty . Bi.R2) h) + + rightAdjunct :: (Functor h, Functor k) => (h ~> Bi.Product uu vv k) -> Bi.Sum ff gg h ~> k + rightAdjunct righty (Bi.L2 ff) = rightAdjunct (Bi.proj1 . righty) ff + rightAdjunct righty (Bi.R2 gg) = rightAdjunct (Bi.proj2 . righty) gg + +instance (Rank1.Adjunction f u) => Adjunction (Compose f) (Compose u) where + unit :: (Functor g) => g ~> Compose u (Compose f g) + unit gx = Compose . fmap Compose $ Rank1.unit gx + counit :: (Functor g) => Compose f (Compose u g) ~> g + counit = Rank1.counit . fmap getCompose . getCompose + +instance Adjunction (Rank1.EnvT e) (Rank1.ReaderT e) where + unit gx = Rank1.ReaderT \e -> Rank1.EnvT e gx + counit (Rank1.EnvT e (Rank1.ReaderT f)) = f e + +instance Adjunction (Rank1.TracedT m) (Rank1.WriterT m) where + unit gx = Rank1.WriterT $ Rank1.TracedT $ fmap (,) gx + + counit (Rank1.TracedT (Rank1.WriterT gwx)) = fmap (\(f, m) -> f m) gwx + +instance Adjunction (Rank1.StoreT s) (Rank1.StateT s) where + unit gx = Rank1.StateT $ Rank1.StoreT (fmap (,) gx) + counit (Rank1.StoreT (Rank1.StateT state) s0) = fmap (\(f, m) -> f m) (state s0) + +instance Functor f => Adjunction ((:*:) f) (Exp1 f) where + leftAdjunct :: (Functor f, Functor g, Functor h) => ((f :*: g) ~> h) -> g ~> Exp1 f h + leftAdjunct = toExp1 + + rightAdjunct :: (Functor f, Functor g, Functor h) => (g ~> Exp1 f h) -> (f :*: g) ~> h + rightAdjunct = fromExp1 diff --git a/src/FFunctor/FCompose.hs b/src/FFunctor/FCompose.hs new file mode 100644 --- /dev/null +++ b/src/FFunctor/FCompose.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE KindSignatures #-} + +-- | Composition of two @FFunctor@s +module FFunctor.FCompose where + +import FFunctor + +-- | Composision of @FFunctor@s. +-- Just like any functor, composition of two @FFunctor@ is @FFunctor@ again. +type FCompose :: FF -> FF -> FF +newtype FCompose ff gg h x = FCompose {getFCompose :: ff (gg h) x} + deriving (Show, Eq, Ord, Foldable, Traversable) + +deriving + via ((ff :: FF) ((gg :: FF) h)) + instance (FFunctor ff, FFunctor gg, Functor h) => Functor (FCompose ff gg h) + +instance (FFunctor ff, FFunctor gg) => FFunctor (FCompose ff gg) where + ffmap gh = FCompose . ffmap (ffmap gh) . getFCompose + +-- | Infix type operator for @FCompose@ +type (⊚) = FCompose + +infixl 7 ⊚ diff --git a/src/FMonad.hs b/src/FMonad.hs new file mode 100644 --- /dev/null +++ b/src/FMonad.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} + +-- | Monads in the cateogory of @Functor@s. +module FMonad + ( type (~>), + -- * FMonad + + FMonad (..), + fjoin, + + -- * FMonad laws + + -- ** Laws + -- + -- $fmonad_laws_in_fbind + + -- ** Laws (in terms of @fjoin@) + -- + -- $fmonad_laws_in_fjoin + + + -- * Re-export + FFunctor (..) + ) +where + +import Control.Comonad (Comonad (..), (=>=)) +import Control.Monad (join) + +import qualified Control.Applicative.Free as FreeAp +import qualified Control.Applicative.Free.Final as FreeApFinal +import Control.Applicative.Lift +import qualified Control.Applicative.Trans.FreeAp as FreeApT +import qualified Control.Monad.Free as FreeM +import qualified Control.Monad.Free.Church as FreeMChurch +import Control.Monad.Trans.Free (FreeT) +import Control.Monad.Trans.Free.Extra ( inr, fbindFreeT_ ) + +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Reader +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import Data.Functor.Compose +import Data.Functor.Day +import Data.Functor.Day.Comonoid hiding (Comonad(..)) +import Data.Functor.Day.Curried +import Data.Functor.Day.Extra (uncurried) +import Data.Functor.Flip1 +import Data.Functor.Kan.Lan +import Data.Functor.Kan.Ran +import Data.Functor.Product +import Data.Functor.Sum +import FFunctor + +import qualified Data.Bifunctor.Product as Bi +import qualified Data.Bifunctor.Product.Extra as Bi +import GHC.Generics +import Data.Kind (Type) + + +{- $fmonad_laws_in_fbind + +Like 'Monad', there is a set of laws which every instance of 'FMonad' should satisfy. + +[fpure is natural in g] + + Let @g, h@ be arbitrary @Functor@s. For any natural transformation @n :: g ~> h@, + + > ffmap n . fpure = fpure . n + +[fbind is natural in g,h] + + Let @g, g', h, h'@ be arbitrary @Functor@s. For all natural transformations + @k :: g ~> ff h@, @nat_g :: g' ~> g@, and @nat_h :: h ~> h'@, the following holds. + + > fbind (ffmap nat_h . k . nat_g) = ffmap nat_h . fbind k . ffmap nat_g + +[Left unit] + + > fbind k . fpure = k + +[Right unit] + + > fbind fpure = id + +[Associativity] + + > fbind k . fbind j = fbind (fbind k . j) +-} + +{- $fmonad_laws_in_fjoin + +Alternatively, 'FMonad' laws can be stated using 'fjoin' instead. + +[fpure is natural in g] + + For all @Functor g@, @Functor h@, and @n :: g ~> h@, + + > ffmap n . fpure = fpure . n + +[fjoin is natural in g] + + For all @Functor g@, @Functor h@, and @n :: g ~> h@, + + > ffmap n . fjoin = fjoin . ffmap (ffmap n) + +[Left unit] + + > fjoin . fpure = id + +[Right unit] + + > fjoin . ffmap fpure = id + +[Associativity] + + > fjoin . fjoin = fjoin . ffmap fjoin + +-} + +{- | @FMonad@ is to 'FFunctor' what 'Monad' is to 'Functor'. + + ++----------------+-----------------------------+------------------------------------+ +| | @'Monad' m@ | @'FMonad' mm@ | ++================+=============================+====================================+ +| Superclass | @'Functor' m@ | @'FFunctor' mm@ | ++----------------+-----------------------------+------------------------------------+ +| Features | @ | @ | +| | return = pure | fpure | +| | :: a -> m a | :: (Functor g) | +| | @ | => g ~> mm g | +| | | @ | ++----------------+-----------------------------+------------------------------------+ +| | @ | @ | +| | (=<<) | fbind | +| | :: (a -> m b) | :: (Functor g, Functor h) | +| | -> (m a -> m b) | => (g ~> mm h) | +| | @ | -> (mm g ~> mm h) | +| | | @ | ++----------------+-----------------------------+------------------------------------+ + + + +-} +class FFunctor ff => FMonad ff where + fpure :: (Functor g) => g ~> ff g + fbind :: (Functor g, Functor h) => (g ~> ff h) -> ff g a -> ff h a + +-- | 'join' but for 'FMonad' instead of 'Monad'. +fjoin :: (FMonad ff, Functor g) => ff (ff g) ~> ff g +fjoin = fbind id + +instance Functor f => FMonad (Sum f) where + fpure = InR + + fbind _ (InL fa) = InL fa + fbind k (InR ga) = k ga + +instance (Functor f, forall a. Monoid (f a)) => FMonad (Product f) where + fpure = Pair mempty + fbind k (Pair fa1 ga) = case k ga of + (Pair fa2 ha) -> Pair (fa1 <> fa2) ha + +instance Monad f => FMonad (Compose f) where + fpure = Compose . return + fbind k = Compose . (>>= (getCompose . k)) . getCompose + +instance Functor f => FMonad ((:+:) f) where + fpure = R1 + fbind k ff = case ff of + L1 fx -> L1 fx + R1 gx -> k gx + +instance (Functor f, forall a. Monoid (f a)) => FMonad ((:*:) f) where + fpure = (mempty :*:) + fbind k (fa :*: ga) = case k ga of + fa' :*: ha -> (fa <> fa') :*: ha + +deriving + via (Compose (f :: Type -> Type)) + instance Monad f => FMonad ((:.:) f) + +deriving + via IdentityT + instance FMonad (M1 c m) + +deriving + via IdentityT + instance FMonad Rec1 + +instance FMonad Lift where + fpure = Other + fbind _ (Pure a) = Pure a + fbind k (Other ga) = k ga + +instance FMonad FreeM.Free where + fpure = FreeM.liftF + fbind = FreeM.foldFree + +instance FMonad FreeMChurch.F where + fpure = FreeMChurch.liftF + fbind = FreeMChurch.foldF + +instance FMonad FreeAp.Ap where + fpure = FreeAp.liftAp + fbind = FreeAp.runAp + +instance FMonad FreeApFinal.Ap where + fpure = FreeApFinal.liftAp + fbind = FreeApFinal.runAp + +instance FMonad IdentityT where + fpure = IdentityT + fbind k = k . runIdentityT + +instance FMonad (ReaderT e) where + -- See the similarity between 'Compose' @((->) e)@ + + -- return :: x -> (e -> x) + fpure = ReaderT . return + + -- join :: (e -> e -> x) -> (e -> x) + fbind k = ReaderT . (>>= runReaderT . k) . runReaderT + +instance Monoid m => FMonad (WriterT m) where + -- See the similarity between 'FlipCompose' @(Writer m)@ + + -- fmap return :: f x -> f (Writer m x) + fpure = WriterT . fmap (,mempty) + + -- fmap join :: f (Writer m (Writer m x)) -> f (Writer m x) + fbind k = WriterT . fmap (\((x, m1), m2) -> (x, m2 <> m1)) . runWriterT . runWriterT . ffmap k + +{- + +If everything is unwrapped, FMonad @(StateT s)@ is + + fpure :: forall f. Functor f => f x -> s -> f (x, s) + fjoin :: forall f. Functor f => (s -> s -> f ((x, s), s)) -> s -> f (x, s) + +And if this type was generic in @s@ without any constraint like @Monoid s@, +the only possible implementations are + + -- fpure is uniquely: + fpure fx s = (,s) <$> fx + + -- fjoin is one of the following three candidates + fjoin1 stst s = (\((x,_),_) -> (x,s)) <$> stst s s + fjoin2 stst s = (\((x,_),s) -> (x,s)) <$> stst s s + fjoin3 stst s = (\((x,s),_) -> (x,s)) <$> stst s s + +But none of them satisfy the FMonad law. + + (fjoin1 . fpure) st + = fjoin1 $ \s1 s2 -> (,s1) <$> st s2 + = \s -> (\((x,_),_) -> (x,s)) <$> ((,s) <$> st s) + = \s -> (\(x,_) -> (x,s)) <$> st s + /= st + (fjoin2 . fpure) st + = fjoin2 $ \s1 s2 -> (,s1) <$> st s2 + = \s -> (\((x,_),s') -> (x,s')) <$> ((,s) <$> st s) + = \s -> (\(x,_) -> (x,s)) <$> st s + /= st + (fjoin3 . ffmap fpure) st + = fjoin2 $ \s1 s2 -> fmap (fmap (,s2)) . st s1 + = \s -> ((\((x,s'),_) -> (x,s')) . fmap (,s)) <$> st s + = \s -> (\(x,_) -> (x,s)) <$> st s + /= st + +So the lawful @FMonad (StateT s)@ will utilize some structure +on @s@. + +One way would be seeing StateT as the composision of Reader s and +Writer s: + + StateT s m ~ Reader s ∘ m ∘ Writer s + where (∘) = Compose + +By this way + + StateT s (StateT s m) ~ Reader s ∘ Reader s ∘ m ∘ Writer s ∘ Writer s + +And you can collapse the nesting by applying @join@ for @Reader s ∘ Reader s@ +and @Writer s ∘ Writer s@. To do so, it will need @Monoid s@ for @Monad (Writer s)@. + +-} + +instance Monoid s => FMonad (StateT s) where + -- Note that this is different to @lift@ in 'MonadTrans', + -- whilst having similar type and actually equal in + -- several other 'FMonad' instances. + -- + -- See the discussion below. + fpure fa = StateT $ \_ -> (,mempty) <$> fa + + fbind k = StateT . fjoin_ . fmap runStateT . runStateT . ffmap k + where + fjoin_ :: forall f a. (Functor f) => (s -> s -> f ((a, s), s)) -> s -> f (a, s) + fjoin_ = fmap (fmap joinWriter) . joinReader + where + joinReader :: forall x. (s -> s -> x) -> s -> x + joinReader = join + + joinWriter :: forall x. ((x, s), s) -> (x, s) + joinWriter ((a, s1), s2) = (a, s2 <> s1) + +{- + +Note [About FMonad (StateT s) instance] + +@fpure@ has a similar (Functor instead of Monad) type signature +with 'lift', but due to the different laws expected on them, +they aren't necessarily same. + +@lift@ for @StateT s@ must be, by the 'MonadTrans' laws, +the one currently used. And this is not because the parameter @s@ +is generic, so it applies if we have @Monoid s =>@ constraints like +the above instance. + +One way to have @lift = fpure@ here is requiring @s@ to be a type with +group operations, @Monoid@ + @inv@ for inverse operator, +instead of just being a monoid. + +> fpure fa = StateT $ \s -> (,s) <$> fa +> fjoin = StateT . fjoin_ . fmap runStateT . runStateT +> where fjoin_ mma s = fmap (fmap (joinGroup s)) $ joinReader mma s +> joinReader = join +> joinGroup s ((x,s1),s2) = (x, s2 <> inv s <> s1) + +-} + +-- | @Ran w (Ran w f) ~ Ran ('Compose' w w) f@ +instance (Comonad w) => FMonad (Ran w) where + fpure :: + forall f x. + (Functor f) => + f x -> + Ran w f x + -- f x -> (forall b. (x -> w b) -> f b) + fpure f = Ran $ \k -> fmap (extract . k) f + + fbind :: (Functor g, Functor h) => + (g ~> Ran w h) -> (Ran w g ~> Ran w h) + fbind k wg = Ran $ \xd -> runRan (k (runRan wg (duplicate . xd))) id + +-- | @Lan w (Lan w f) ~ Lan ('Compose' w w) f@ +instance (Comonad w) => FMonad (Lan w) where + fpure :: + forall f x. + (Functor f) => + f x -> + Lan w f x + -- f x -> exists b. (w b -> x, f b) + fpure f = Lan extract f + + fbind :: (Functor g, Functor h) => + (g ~> Lan w h) -> (Lan w g ~> Lan w h) + fbind k (Lan j1 g) = case k g of + Lan j2 h -> Lan (j2 =>= j1) h + +instance (Applicative f) => FMonad (Day f) where + fpure :: g ~> Day f g + fpure = day (pure id) + + {- + day :: f (a -> b) -> g a -> Day f g b + -} + + fbind k = trans1 dap . assoc . trans2 k + +{- + trans2 k :: Day f g ~> Day f (Day f h) + assoc :: Day f (Day f h) ~> Day (Day f f) h + trans1 dap :: Day (Day f f) h ~> Day f h +-} + +instance Comonoid f => FMonad (Curried f) where + fpure :: Functor g => g a -> Curried f g a + fpure g = Curried $ \f -> extract f <$> g + + fbind k m = Curried $ \f -> runCurried (uncurried (ffmap k m)) (coapply f) + +instance FMonad (FreeApT.ApT f) where + fpure = FreeApT.liftT + fbind k = FreeApT.fjoinApTLeft . ffmap k + +instance Applicative g => FMonad (Flip1 FreeApT.ApT g) where + fpure = Flip1 . FreeApT.liftF + fbind k = Flip1 . FreeApT.foldApT (unFlip1 . k) FreeApT.liftT . unFlip1 + +instance Functor f => FMonad (FreeT f) where + fpure = inr + fbind = fbindFreeT_ + +instance (FMonad ff, FMonad gg) => FMonad (Bi.Product ff gg) where + fpure h = Bi.Pair (fpure h) (fpure h) + fbind k (Bi.Pair ff gg) = Bi.Pair (fbind (Bi.proj1 . k) ff) (fbind (Bi.proj2 . k) gg) diff --git a/src/FMonad/Adjoint.hs b/src/FMonad/Adjoint.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/Adjoint.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +module FMonad.Adjoint(Adjoint, adjoint, runAdjoint, AdjointT(..), fffmap, generalize) where + +import Control.Monad.Trans.Identity ( IdentityT(..) ) + +import FFunctor +import FMonad +import FStrong +import FFunctor.FCompose +import FFunctor.Adjunction + +newtype AdjointT ff uu mm g x = AdjointT { runAdjointT :: uu (mm (ff g)) x } + +type Adjoint ff uu = AdjointT ff uu IdentityT + +deriving + via FCompose (FCompose uu mm) ff g + instance (FFunctor ff, FFunctor mm, FFunctor uu, Functor g) => Functor (AdjointT ff uu mm g) + +deriving + via FCompose (FCompose uu mm) ff + instance (FFunctor ff, FFunctor mm, FFunctor uu) => FFunctor (AdjointT ff uu mm) + +deriving + via FCompose (FCompose uu mm) ff + instance (FStrong ff, FStrong mm, FStrong uu) => FStrong (AdjointT ff uu mm) + +instance (Adjunction ff uu, FMonad mm) => FMonad (AdjointT ff uu mm) where + fpure = AdjointT . ffmap fpure . unit + fbind k = AdjointT . ffmap (fbind counit) . runAdjointT . ffmap (runAdjointT . k) + +adjoint :: (FFunctor ff, FFunctor uu, Functor x) => uu (ff x) ~> Adjoint ff uu x +adjoint = AdjointT . ffmap IdentityT + +runAdjoint :: (FFunctor ff, FFunctor uu, Functor x) => Adjoint ff uu x ~> uu (ff x) +runAdjoint = ffmap runIdentityT . runAdjointT + +fffmap :: forall mm nn ff uu x. + (FFunctor mm, FFunctor nn, FFunctor ff, FFunctor uu, Functor x) + => (forall y. (Functor y) => mm y ~> nn y) + -> (AdjointT ff uu mm x ~> AdjointT ff uu nn x) +fffmap trans = AdjointT . ffmap trans . runAdjointT + +generalize :: (FMonad mm, FFunctor ff, FFunctor uu, Functor x) => Adjoint ff uu x ~> AdjointT ff uu mm x +generalize = fffmap (fpure . runIdentityT) diff --git a/src/FMonad/Cont/Curried.hs b/src/FMonad/Cont/Curried.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/Cont/Curried.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module FMonad.Cont.Curried( + Cont(..) +) where + +import FFunctor +import FMonad + +import Data.Functor.Day.Curried + +-- | \"Continuation monad\" using 'Curried'. +newtype Cont k f a = Cont { runCont :: ((f `Curried` k) `Curried` k) a } + deriving Functor + +flmap :: (f ~> g) -> ((g `Curried` h) ~> (f `Curried` h)) +flmap fg gh = Curried $ \f -> runCurried gh (fg f) + +instance FFunctor (Cont k) where + ffmap gh (Cont gkk) = Cont $ flmap (flmap gh) gkk + +unit :: Functor g => g ~> ((g `Curried` k) `Curried` k) +unit gx = Curried $ \gk -> runCurried gk (flip ($) <$> gx) + +instance FMonad (Cont k) where + fpure :: Functor g => g ~> Cont k g + fpure gx = Cont (unit gx) + + fbind :: forall g h a. (Functor g, Functor h) => (g ~> Cont k h) -> Cont k g a -> Cont k h a + fbind rest (Cont gkk) = + let hkkkk :: ((((h `Curried` k) `Curried` k) `Curried` k) `Curried` k) a + hkkkk = flmap (flmap (runCont . rest)) gkk + + hkk = flmap unit hkkkk + in Cont hkk diff --git a/src/FMonad/Cont/Exp.hs b/src/FMonad/Cont/Exp.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/Cont/Exp.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} +module FMonad.Cont.Exp( + Cont(..) +) where + +import FFunctor +import FMonad + +import Data.Functor.Exp + +-- | \"Continuation monad\" using 'Exp1'. +newtype Cont k f a = Cont { runCont :: ((f `Exp1` k) `Exp1` k) a } + deriving Functor + +flmap :: (f ~> g) -> Exp1 g h ~> Exp1 f h +flmap fg gh = Exp1 $ \f ar -> unExp1 gh (fg f) ar + +instance FFunctor (Cont k) where + ffmap gh (Cont gkk) = Cont $ flmap (flmap gh) gkk + +unit :: Functor g => g ~> ((g `Exp1` k) `Exp1` k) +unit gx = Exp1 $ \gk ar -> unExp1 gk (ar <$> gx) id + +instance FMonad (Cont k) where + fpure :: Functor g => g ~> Cont k g + fpure gx = Cont (unit gx) + + fbind :: forall g h a. (Functor g, Functor h) => (g ~> Cont k h) -> Cont k g a -> Cont k h a + fbind rest (Cont gkk) = + let hkkkk :: ((((h `Exp1` k) `Exp1` k) `Exp1` k) `Exp1` k) a + hkkkk = flmap (flmap (runCont . rest)) gkk + + hkk = flmap unit hkkkk + in Cont hkk diff --git a/src/FMonad/FFree.hs b/src/FMonad/FFree.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/FFree.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Free 'FMonad' +module FMonad.FFree where + +import Data.Functor.Day (Day (..), day, dap) +import FFunctor +import FMonad +import FStrong + +-- | The free 'FMonad' for a @'FFunctor' ff@. +data FFree ff g x = FPure (g x) | FFree (ff (FFree ff g) x) + +deriving instance (Show (g a), Show (ff (FFree ff g) a)) => Show (FFree ff g a) + +deriving instance (Eq (g a), Eq (ff (FFree ff g) a)) => Eq (FFree ff g a) + +deriving instance (Ord (g a), Ord (ff (FFree ff g) a)) => Ord (FFree ff g a) + +deriving instance (Functor g, Functor (ff (FFree ff g))) => Functor (FFree ff g) + +deriving instance (Foldable g, Foldable (ff (FFree ff g))) => Foldable (FFree ff g) + +deriving instance (Traversable g, Traversable (ff (FFree ff g))) => Traversable (FFree ff g) + +instance (FFunctor ff) => FFunctor (FFree ff) where + ffmap gh (FPure gx) = FPure (gh gx) + ffmap gh (FFree fmx) = FFree (ffmap (ffmap gh) fmx) + +instance (FFunctor ff) => FMonad (FFree ff) where + fpure = FPure + fbind k (FPure gx) = k gx + fbind k (FFree fmmx) = FFree (ffmap (fbind k) fmmx) + +instance (FStrong ff) => FStrong (FFree ff) where + fstrength (Day ffg h op) = case ffg of + FPure g -> FPure (Day g h op) + FFree ffr -> FFree (ffmap fstrength $ fstrength (Day ffr h op)) + +fffmap :: forall ff gg h. + (FFunctor ff, FFunctor gg, Functor h) + => (forall h'. (Functor h') => ff h' ~> gg h') + -> (FFree ff h ~> FFree gg h) +fffmap _ (FPure hx) = FPure hx +fffmap t (FFree ffm) = FFree $ ffmap (fffmap t) (t ffm) + +-- | Iteratively fold a @FFree@ term down, given a way to fold one layer of @ff@. +iter :: forall ff g. (FFunctor ff, Functor g) => (ff g ~> g) -> FFree ff g ~> g +iter step = go + where + go :: FFree ff g ~> g + go (FPure gx) = gx + go (FFree fmx) = step (ffmap go fmx) + +-- | Fold a @FFree@ term to another @FMonad mm@. +foldFFree :: forall ff mm g. (FFunctor ff, FMonad mm, Functor g) => (forall h. Functor h => ff h ~> mm h) -> FFree ff g ~> mm g +foldFFree toMM = go + where + go :: FFree ff g ~> mm g + go (FPure gx) = fpure gx + go (FFree ftx) = fjoin (ffmap go (toMM ftx)) + +-- | @retract = 'foldFFree' id@ +retract :: (FMonad ff, Functor g) => FFree ff g ~> ff g +retract = foldFFree id + +instance (FStrong ff, Applicative g) => Applicative (FFree ff g) where + pure = FPure . pure + FPure gx <*> y = ffmap dap $ fstrength' (day gx y) + FFree ffr <*> y = FFree $ innerAp ffr y + +-- | Lift a single layer of @ff@ into @FFree ff@ +liftF :: (FFunctor ff, Functor g) => ff g ~> FFree ff g +liftF fgx = FFree (ffmap FPure fgx) diff --git a/src/FMonad/FreeT.hs b/src/FMonad/FreeT.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/FreeT.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +-- | Another way to make 'FreeT' an instance of 'FMonad' +-- +-- 'FreeT' can be 'FMonad' in two different ways. There is already an instance: +-- +-- @ +-- instance Functor f => FMonad (FreeT f) where +-- fpure :: Functor m => m ~> FreeT f m +-- fbind :: (Functor m, Functor n) => (m ~> FreeT f n) -> (FreeT f m ~> FreeT f n) +-- @ +-- +-- In addition to this standard instance, @FreeT f m@ have @FMonad@-like structure by treating +-- @f@ as the parameter while fixing @m@ to some arbitrary @Monad@. +-- +-- @ +-- 'fpureFst' :: (Monad m) => (Functor f) => f ~> FreeT f m +-- 'fbindFst' :: (Monad m) => (Functor f, Functor g) => (f ~> FreeT g m) -> (FreeT f m ~> FreeT g m) +-- @ +-- +-- This module provides a newtype wrapper 'FreeT'' to use these as a real @FMonad@ +-- instance. +module FMonad.FreeT + ( FreeT' (..), liftM', fpureFst, fbindFst ) +where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus) +import Control.Monad.Trans.Free +import Control.Monad.Trans.Free.Extra +import Data.Functor.Classes +import FMonad + +-- | @FreeT'@ is a @FreeT@, but with the order of its arguments flipped. +-- +-- @ +-- FreeT' m f a ≡ FreeT f m a +-- @ +newtype FreeT' m f b = WrapFreeT' {unwrapFreeT' :: FreeT f m b} + deriving + (Functor) + via (FreeT f m) + deriving + ( Applicative, + Alternative, + Monad, + MonadPlus, + Foldable, + Eq1, + Ord1, + Show1, + Read1 + ) + via (FreeT f m) + deriving + (Show, Read, Eq, Ord) + via (FreeT f m b) + +-- | Lift of the Monad side. +liftM' :: Functor m => m a -> FreeT' m f a +liftM' = WrapFreeT' . inr + +-- | @fpure@ to the first parameter of @FreeT@ +fpureFst :: (Monad m) => (Functor f) => f ~> FreeT f m +fpureFst = liftF + +-- | @fbind@ to the first parameter of @FreeT@ +fbindFst :: (Monad m) => (Functor f, Functor g) => (f ~> FreeT g m) -> (FreeT f m ~> FreeT g m) +fbindFst k = eitherFreeT_ k inr + +instance (Traversable f, Traversable m) => Traversable (FreeT' f m) where + traverse f (WrapFreeT' mx) = WrapFreeT' <$> traverseFreeT_ f mx + +instance Functor m => FFunctor (FreeT' m) where + ffmap f = WrapFreeT' . transFreeT_ f . unwrapFreeT' + +instance Monad m => FMonad (FreeT' m) where + fpure :: forall g. Functor g => g ~> FreeT' m g + fpure = WrapFreeT' . fpureFst + + fbind :: forall g h a. (Functor g, Functor h) => (g ~> FreeT' m h) -> FreeT' m g a -> FreeT' m h a + fbind k = WrapFreeT' . fbindFst (unwrapFreeT' . k) . unwrapFreeT' diff --git a/src/FMonad/State/Day.hs b/src/FMonad/State/Day.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/State/Day.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFunctor #-} + +module FMonad.State.Day + (StateT(..), + flift, + toOuter, fromOuter, toInner, fromInner, + + State, state, state_, get, put, + runState +) where + +import Control.Monad.Trans.Identity +import Data.Functor.Day ( Day(..), day ) +import Data.Functor.Day.Curried ( Curried(Curried) ) +import Data.Functor.Day.Comonoid + +import FMonad +import FMonad.Adjoint +import FStrong + +import qualified FMonad.State.Simple.Inner as Simple.Inner +import qualified FMonad.State.Simple.Outer as Simple.Outer + +import Data.Functor.Day.Extra +import Data.Coerce (coerce) +import Data.Functor.Identity +import Data.Function ((&)) + +newtype StateT s mm x a = StateT { runStateT :: forall r. s (a -> r) -> mm (Day s x) r } + deriving stock Functor + deriving (FFunctor, FMonad) via (AdjointT (Day s) (Curried s) mm) + +toAdjointT :: StateT s mm x ~> AdjointT (Day s) (Curried s) mm x +toAdjointT = coerce + +fromAdjointT :: AdjointT (Day s) (Curried s) mm x ~> StateT s mm x +fromAdjointT = coerce + +flift :: (Functor s, FStrong mm, Functor x) + => mm x ~> StateT s mm x +flift mm = StateT $ \sf -> fstrength' (day sf mm) + +toOuter :: (Functor x, FFunctor mm) => StateT ((,) s0) mm x ~> Simple.Outer.StateT s0 mm x +toOuter = Simple.Outer.fromAdjointT . AdjointT . ffmap (ffmap dayToEnv) . curriedToReader . runAdjointT . toAdjointT + +fromOuter :: (Functor x, FFunctor mm) => Simple.Outer.StateT s0 mm x ~> StateT ((,) s0) mm x +fromOuter = fromAdjointT . AdjointT . ffmap (ffmap envToDay) . readerToCurried . runAdjointT . Simple.Outer.toAdjointT + +toInner :: (Functor x, FFunctor mm) => StateT ((->) s1) mm x ~> Simple.Inner.StateT s1 mm x +toInner = Simple.Inner.fromAdjointT . AdjointT . ffmap (ffmap dayToTraced) . curriedToWriter . runAdjointT . toAdjointT + +fromInner :: (Functor x, FFunctor mm) => Simple.Inner.StateT s1 mm x ~> StateT ((->) s1) mm x +fromInner = fromAdjointT . AdjointT . ffmap (ffmap tracedToDay) . writerToCurried . runAdjointT . Simple.Inner.toAdjointT + +type State s = StateT s IdentityT + +state :: (FMonad mm) + => (forall r. s (a -> r) -> Day s x r) + -> StateT s mm x a +state f = StateT $ \sar -> fpure (f sar) + +state_ :: (Functor s, FMonad mm) + => (forall b. s b -> (s b, x a)) + -> StateT s mm x a +state_ f = state (uncurry day . f) + +get :: (Comonoid s, FMonad mm) => StateT s mm s () +get = state (fmap ($ ()) . coapply) + +put :: (Comonad s, FMonad mm) => s a -> StateT s mm Identity a +put sa = state (\sar -> Day sa (Identity (extract sar)) (&)) + +runState :: State s x a -> s (a -> r) -> Day s x r +runState sx = runIdentityT . runStateT sx diff --git a/src/FMonad/State/Lan.hs b/src/FMonad/State/Lan.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/State/Lan.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DerivingVia #-} +module FMonad.State.Lan + (StateT(..), + fromAdjointT, + toAdjointT, + toInner, fromInner, + + State, + state, runState + ) where + +import Control.Monad.Trans.Identity +import Data.Functor.Kan.Lan +import Data.Functor.Precompose +import qualified FMonad.State.Simple.Inner as Simple.Inner + +import FMonad +import FMonad.Adjoint +import Data.Tuple (swap) +import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Comonad.Traced (TracedT(..)) +import Data.Coerce (coerce) + +-- type StateT s = AdjointT (Lan s) (Precompose s) +newtype StateT s mm x a = StateT { runStateT :: mm (Lan s x) (s a) } + deriving (FFunctor, FMonad) via (AdjointT (Lan s) (Precompose s) mm) + +deriving + stock instance (FFunctor mm, Functor s) => Functor (StateT s mm x) + +toAdjointT :: StateT s mm x ~> AdjointT (Lan s) (Precompose s) mm x +toAdjointT = coerce + +fromAdjointT :: AdjointT (Lan s) (Precompose s) mm x ~> StateT s mm x +fromAdjointT = coerce + +toInner :: (Functor x, FFunctor mm) => StateT ((,) s1) mm x ~> Simple.Inner.StateT s1 mm x +toInner = Simple.Inner.fromAdjointT . AdjointT . ffmap (ffmap lanToTraced) . (WriterT . fmap swap . getPrecompose) . runAdjointT . toAdjointT + +fromInner :: (Functor x, FFunctor mm) => Simple.Inner.StateT s1 mm x ~> StateT ((,) s1) mm x +fromInner = fromAdjointT . AdjointT . ffmap (ffmap tracedToLan) . (Precompose . fmap swap . runWriterT) . runAdjointT . Simple.Inner.toAdjointT + +lanToTraced :: Functor f => Lan ((,) s1) f ~> TracedT s1 f +lanToTraced (Lan sr_a fr) = TracedT $ fmap (\r s -> sr_a (s,r)) fr + +tracedToLan :: TracedT s1 f ~> Lan ((,) s1) f +tracedToLan (TracedT fsa) = Lan (\(s1,sa) -> sa s1) fsa + +-- * Pure state + +type State s = StateT s IdentityT + +state :: (Functor s, FMonad mm, Functor x) + => (s b -> s a) -> x b -> StateT s mm x a +state f xb = StateT $ fpure (Lan f xb) + +runState :: State s x a -> Lan s x (s a) +runState = runIdentityT . runStateT diff --git a/src/FMonad/State/Ran.hs b/src/FMonad/State/Ran.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/State/Ran.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +module FMonad.State.Ran + (StateT(..), + toInner, fromInner, + + State, state, state_, get, put, + runState + ) where + +import Control.Monad.Trans.Identity +import Data.Functor.Kan.Ran +import Data.Functor.Precompose +import Data.Coerce (coerce) +import Control.Comonad (Comonad(..)) +import Data.Functor.Identity +import FMonad +import FMonad.Adjoint +import Control.Monad.Trans.Writer (WriterT(..)) +import Control.Comonad.Traced (TracedT(..)) + +import qualified FMonad.State.Simple.Inner as Simple.Inner + +-- type StateT s = AdjointT (Precompose s) (Ran s) +newtype StateT s mm x a = StateT { runStateT :: forall r. (a -> s r) -> mm (Precompose s x) r } + deriving (FFunctor, FMonad) via (AdjointT (Precompose s) (Ran s) mm) + +deriving + stock instance (FFunctor mm, Functor s) => Functor (StateT s mm x) + +fromAdjointT :: AdjointT (Precompose s) (Ran s) mm x ~> StateT s mm x +fromAdjointT = coerce + +toAdjointT :: StateT s mm x ~> AdjointT (Precompose s) (Ran s) mm x +toAdjointT = coerce + +toInner :: (Functor x, FFunctor mm) => StateT ((->) s1) mm x ~> Simple.Inner.StateT s1 mm x +toInner = Simple.Inner.fromAdjointT . AdjointT . ffmap (ffmap (TracedT . getPrecompose)) . ranToWriter . runAdjointT . toAdjointT + +fromInner :: (Functor x, FFunctor mm) => Simple.Inner.StateT s1 mm x ~> StateT ((->) s1) mm x +fromInner = fromAdjointT . AdjointT . ffmap (ffmap (Precompose . runTracedT)) . writerToRan . runAdjointT . Simple.Inner.toAdjointT + +ranToWriter :: Functor f => Ran ((->) s1) f ~> WriterT s1 f +ranToWriter (Ran ran) = WriterT $ ran (,) + +writerToRan :: Functor f => WriterT s1 f ~> Ran ((->) s1) f +writerToRan (WriterT f_as) = Ran $ \k -> fmap (uncurry k) f_as + +-- * Pure state + +type State s = StateT s IdentityT + +state :: (Functor s, Functor x, FMonad mm) + => (forall r. (a -> s r) -> x (s r)) + -> StateT s mm x a +state f = StateT $ \k -> fpure (Precompose (f k)) + +state_ :: (Functor s, Functor x, FMonad mm) + => (forall r. s r -> x (s r)) + -> StateT s mm x () +state_ f = state (\k -> f (k ())) + +get :: (Comonad s, FMonad mm) => StateT s mm s () +get = state_ duplicate + +put :: (Comonad s, FMonad mm) => s a -> StateT s mm Identity a +put sa = state (\k -> Identity (extract . k <$> sa)) + +runState :: State s x a -> (a -> s r) -> x (s r) +runState sm k = getPrecompose $ runIdentityT $ runStateT sm k diff --git a/src/FMonad/State/Simple/Inner.hs b/src/FMonad/State/Simple/Inner.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/State/Simple/Inner.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} + +module FMonad.State.Simple.Inner + (StateT(..), + flift, + toAdjointT, + fromAdjointT, + + State, + state, + runState +) where + +import Control.Monad.Trans.Identity ( IdentityT(..) ) +import Control.Comonad.Trans.Traced ( TracedT(..) ) +import Control.Monad.Trans.Writer ( WriterT(..) ) +import Data.Functor.Day (Day(..), swapped) +import Data.Functor.Day.Extra (dayToTraced) +import Data.Coerce (coerce) + +import FMonad +import FMonad.Adjoint +import FStrong + +newtype StateT s1 mm x a = StateT { runStateT :: mm (TracedT s1 x) (a, s1) } + deriving (FFunctor, FMonad) via (AdjointT (TracedT s1) (WriterT s1) mm) +type State s1 = StateT s1 IdentityT + +deriving + stock instance (FFunctor mm, Functor x) => Functor (StateT s1 mm x) + +toAdjointT :: StateT s1 mm x ~> AdjointT (TracedT s1) (WriterT s1) mm x +toAdjointT = coerce + +fromAdjointT :: AdjointT (TracedT s1) (WriterT s1) mm x ~> StateT s1 mm x +fromAdjointT = coerce + +flift :: (FStrong mm, Functor x) + => mm x ~> StateT s1 mm x +flift mm = fromAdjointT $ AdjointT $ WriterT $ ffmap (dayToTraced . swapped) (fstrength (Day mm id (,))) + +state :: forall s1 x mm a. (Functor x, FMonad mm) => x (s1 -> (a, s1)) -> StateT s1 mm x a +state = StateT . fpure . TracedT + +runState :: State s1 x a -> x (s1 -> (a, s1)) +runState = coerce diff --git a/src/FMonad/State/Simple/Outer.hs b/src/FMonad/State/Simple/Outer.hs new file mode 100644 --- /dev/null +++ b/src/FMonad/State/Simple/Outer.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} + +module FMonad.State.Simple.Outer + (StateT(..), flift, + fromAdjointT, toAdjointT, + + State, + state, runState, + ) where + +import Control.Monad.Trans.Identity ( IdentityT(..) ) +import Control.Comonad.Trans.Env +import Control.Monad.Trans.Reader +import Data.Tuple (swap) +import Data.Coerce (coerce) + +import FMonad +import FMonad.Adjoint + +newtype StateT s0 mm x a = StateT { runStateT :: s0 -> mm (EnvT s0 x) a } + deriving (FFunctor, FMonad) via (AdjointT (EnvT s0) (ReaderT s0) mm) +type State s0 = StateT s0 IdentityT + +deriving + stock instance (FFunctor mm, Functor x) => Functor (StateT s0 mm x) + +fromAdjointT :: AdjointT (EnvT s0) (ReaderT s0) mm x ~> StateT s0 mm x +fromAdjointT = coerce + +toAdjointT :: StateT s0 mm x ~> AdjointT (EnvT s0) (ReaderT s0) mm x +toAdjointT = coerce + +flift :: (FFunctor mm, Functor x) + => mm x ~> StateT s0 mm x +flift mm = StateT $ \s0 -> ffmap (EnvT s0) mm + +state :: forall s0 x mm a. (FMonad mm, Functor x) => (s0 -> (x a, s0)) -> StateT s0 mm x a +state stateX = StateT \s0 -> + let (x, s0') = stateX s0 + in fpure (EnvT s0' x) + +runState :: forall s0 x a. State s0 x a -> s0 -> (x a, s0) +runState stateX = swap . runEnvT . runIdentityT . runStateT stateX diff --git a/src/FStrong.hs b/src/FStrong.hs new file mode 100644 --- /dev/null +++ b/src/FStrong.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeOperators #-} + +-- | 'FFunctor' with tensorial strength with respect to 'Day'. +module FStrong where + +import Data.Coerce (coerce) + +import Data.Functor.Day +import Data.Functor.Day.Curried + +import FFunctor +import FMonad + +import Data.Functor.Compose +import FFunctor.FCompose +import Data.Functor.Precompose ( Precompose(..) ) +import Data.Functor.Bicompose ( Bicompose(..) ) +import Control.Monad.Trans.Identity (IdentityT (..)) +import Control.Monad.Trans.Reader (ReaderT (..)) +import Control.Monad.Trans.State (StateT (..)) +import Control.Monad.Trans.Writer (WriterT (..)) +import Control.Comonad.Env (EnvT(..)) +import Control.Comonad.Traced (TracedT(..)) +import Control.Comonad.Store (StoreT (..)) + +-- | 'FFunctor' with tensorial strength with respect to 'Day'. +class FFunctor ff => FStrong ff where + {-# MINIMAL fstrength | mapCurried #-} + + -- | Tensorial strength with respect to 'Day'. + -- + -- 'fstrength' can be thought as a higher-order version of @strength@ function below. + -- + -- @ + -- strength :: Functor f => (f a, b) -> f (a, b) + -- strength (fa, b) = fmap (\a -> (a,b)) fa + -- @ + -- + -- For the ordinary 'Functor', no additional type classes were needed to have @strength@ function, + -- because it works for any @Functor f@. This is not the case for 'FFunctor' and 'fstrength'. + -- + -- ==== Laws + -- + -- These two equations must hold. + -- + -- @ + -- ffmap 'elim2' . fstrength = 'elim2' + -- :: Day (ff g) 'Data.Functor.Identity.Identity' ~> ff g + -- fstrength . 'trans1' fstrength = ffmap 'assoc' . fstrength . 'disassoc' + -- :: Day (Day (ff g) h) k ~> ff (Day (Day g h) k)) + -- @ + -- + -- Alternatively, these diagrams must commute. + -- + -- > fstrength + -- > ff g ⊗ Identity -----------> ff (g ⊗ Identity) + -- > \ | + -- > \ | ffmap elim2 + -- > \ | + -- > elim2 \ v + -- > \----------------> ff g + -- + -- + -- > trans1 fstrength fstrength + -- > (ff g ⊗ h) ⊗ k --------------------> ff (g ⊗ h) ⊗ k -----------> ff ((g ⊗ h) ⊗ k) + -- > | ^ + -- > | disassoc ffmap assoc | + -- > | | + -- > v fstrength | + -- > ff g ⊗ (h ⊗ k) ---------------------------------------------------> ff (g ⊗ (h ⊗ k)) + -- + -- For readability, an infix operator @(⊗) was used instead of the type constructor @Day@. + fstrength :: (Functor g) => Day (ff g) h ~> ff (Day g h) + fstrength (Day ffg h op) = + runCurried (mapCurried (unapplied h)) (fmap op ffg) + + -- | Internal 'ffmap'. + -- + -- 'mapCurried' can be seen as @ffmap@ but by using "internal language" of + -- \(\mathrm{Hask}^{\mathrm{Hask}}\), the category of @Functor@s. + -- + -- @ + -- ffmap :: (g ~> h) -> (ff g ~> ff h) + -- mapCurried :: (Curried g h) ~> (Curried (ff g) (ff h)) + -- @ + -- + -- @ffmap@ takes a natural transformations @(~>)@, in other words morphism in \(\mathrm{Hask}^{\mathrm{Hask}}\), + -- and returns another @(~>)@. @ffmap@ itself is an usual function, which is an outsider for + -- \(\mathrm{Hask}^{\mathrm{Hask}}\). + -- + -- On the other hand, @mapCurried@ is a natural transformation @(~>)@ between @Curried _ _@, + -- objects of \(\mathrm{Hask}^{\mathrm{Hask}}\). + -- + -- The existence of 'mapCurried' is known to be equivalent to the existence of + -- 'fstrength'. + -- + -- ==== Laws + -- + -- These equations must hold. + -- + -- @ + -- mapCurried . 'Data.Functor.Day.Extra.unitCurried' = 'Data.Functor.Day.Extra.unitCurried' + -- :: Identity ~> Curried (ff g) (ff g) + -- mapCurried . 'Data.Functor.Day.Extra.composeCurried' = 'Data.Functor.Day.Extra.composeCurried' . trans1 mapCurried . trans2 mapCurried + -- :: Day (Curried g h) (Curried h k) ~> Curried (ff g) (ff k) + -- @ + mapCurried :: (Functor g, Functor h) => Curried g h ~> Curried (ff g) (ff h) + mapCurried gh = Curried $ \ffg -> ffmap applied (fstrength (day ffg gh)) + +-- | 'fstrength' but from left +fstrength' :: (FStrong ff, Functor h) => Day g (ff h) ~> ff (Day g h) +fstrength' = ffmap swapped . fstrength . swapped + +-- | Combine an applicative action(s) inside @ff@ to another action @h a@. +innerAp :: (FStrong ff, Applicative h) => ff h (a -> b) -> h a -> ff h b +innerAp ffh h = ffmap dap $ fstrength (day ffh h) + +-- | Cf. 'Control.Monad.ap' +fap :: (FStrong mm, FMonad mm, Functor g, Functor h) => Day (mm g) (mm h) ~> mm (Day g h) +fap = fjoin . ffmap fstrength' . fstrength + +instance FStrong IdentityT where + fstrength = coerce + +instance FStrong (Day f) where + fstrength = disassoc + +instance Functor f => FStrong (Curried f) where + fstrength = toCurried (trans1 applied . assoc) + +instance Functor f => FStrong (Compose f) where + fstrength (Day (Compose fg) h op) = Compose (fmap (\g -> Day g h op) fg) + +instance Functor f => FStrong (Precompose f) where + fstrength (Day (Precompose gf) h op) = Precompose (Day gf h (\fa b -> fmap (flip op b) fa)) + +instance (Functor f, Functor f') => FStrong (Bicompose f f') where + fstrength (Day (Bicompose fgf') h op) = + Bicompose $ + fmap (\gf' -> Day gf' h (\fa b -> fmap (flip op b) fa)) fgf' + +instance FStrong (ReaderT e) where + fstrength (Day (ReaderT eg) h op) = ReaderT $ \e -> Day (eg e) h op + +instance FStrong (WriterT m) where + fstrength (Day (WriterT gm) h op) = WriterT $ Day gm h (\(b, m) c -> (op b c, m)) + +instance FStrong (StateT s) where + -- StateT s = ReaderT s ∘ WriterT s = Compose ((->) s) ∘ WriterT s + fstrength (Day (StateT sgs) h op) = StateT $ \s -> Day (sgs s) h (\(b, s') c -> (op b c, s')) + +instance (FStrong ff, FStrong gg) => FStrong (FCompose ff gg) where + fstrength = FCompose . ffmap fstrength . fstrength . coerce + +instance FStrong (EnvT e) where + fstrength (Day (EnvT e g) h op) = EnvT e (Day g h op) + +instance FStrong (TracedT m) where + fstrength (Day (TracedT gf) h op) = TracedT (Day gf h (\mb c m -> op (mb m) c)) + +instance FStrong (StoreT s) where + fstrength (Day (StoreT gf s) h op) = StoreT (Day gf h (\sb c s' -> op (sb s') c)) s