packages feed

functor-monad (empty) → 0.1.1.0

raw patch · 31 files changed

+2590/−0 lines, 31 filesdep +adjunctionsdep +auto-lift-classesdep +basesetup-changed

Dependencies added: adjunctions, auto-lift-classes, base, bifunctors, comonad, day-comonoid, free, free-applicative-t, functor-monad, kan-extensions, transformers

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for functor-monad++## 0.1.0.0 (review) -- 2023-12-23++* First version
+ LICENSE view
@@ -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.
+ README.md view
@@ -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`.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/ListTVia.hs view
@@ -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
+ functor-monad.cabal view
@@ -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 <viercc@gmail.com>+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
+ src/Control/Monad/Trail.hs view
@@ -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_
+ src/Control/Monad/Trans/Free/Extra.hs view
@@ -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
+ src/Data/Bifunctor/Product/Extra.hs view
@@ -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
+ src/Data/Functor/Bicompose.hs view
@@ -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
+ src/Data/Functor/Day/Extra.hs view
@@ -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
+ src/Data/Functor/Exp.hs view
@@ -0,0 +1,86 @@+{- | Exponentiation of a @Functor@ by a @Functor@.++For reference:++Powers of polynomial monads by David Spivak <https://topos.site/blog/2023/09/powers-of-polynomial-monads/>++-}+{-# 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'
+ src/Data/Functor/Flip1.hs view
@@ -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
+ src/Data/Functor/Precompose.hs view
@@ -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
+ src/FComonad.hs view
@@ -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+  +  -}
+ src/FComonad/Adjoint.hs view
@@ -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)
+ src/FFunctor.hs view
@@ -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
+ src/FFunctor/Adjunction.hs view
@@ -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
+ src/FFunctor/FCompose.hs view
@@ -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 ⊚
+ src/FMonad.hs view
@@ -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)
+ src/FMonad/Adjoint.hs view
@@ -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)
+ src/FMonad/Cont/Curried.hs view
@@ -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
+ src/FMonad/Cont/Exp.hs view
@@ -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
+ src/FMonad/FFree.hs view
@@ -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)
+ src/FMonad/FreeT.hs view
@@ -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'
+ src/FMonad/State/Day.hs view
@@ -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
+ src/FMonad/State/Lan.hs view
@@ -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
+ src/FMonad/State/Ran.hs view
@@ -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
+ src/FMonad/State/Simple/Inner.hs view
@@ -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
+ src/FMonad/State/Simple/Outer.hs view
@@ -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
+ src/FStrong.hs view
@@ -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