Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Generalise encoder bifunctor instances #1090

Open
wants to merge 2 commits into
base: develop
Choose a base branch
from
Open

Generalise encoder bifunctor instances #1090

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
4ff826d
Generalise encoder bifunctor instances
alexfmpe Jun 30, 2024
204efd8
Merge branch 'develop' into bifunctor
alexfmpe Jan 18, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
58 changes: 16 additions & 42 deletions lib/route/src/Obelisk/Route.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -172,6 +172,7 @@ import qualified Control.Monad.State.Strict as State
import Control.Monad.Writer (execWriter, tell)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson
import Data.Bitraversable
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import Data.Dependent.Map (DMap)
Expand Down Expand Up @@ -398,25 +399,24 @@ instance Monad parse => Category (EncoderImpl parse) where
, _encoderImpl_encode = _encoderImpl_encode f . _encoderImpl_encode g
}

instance Monad parse => PFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
instance (Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => PFunctor p (EncoderImpl parse) (EncoderImpl parse) where
first f = bimap f id
instance Monad parse => QFunctor (,) (EncoderImpl parse) (EncoderImpl parse) where
instance (Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => QFunctor p (EncoderImpl parse) (EncoderImpl parse) where
second g = bimap id g
instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
instance (Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => Bifunctor p (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
Copy link
Collaborator Author

@alexfmpe alexfmpe Jun 30, 2024 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I do wonder whether there can be a Bifunctor p (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) that does anything different than bimap over p a b in the forward direction since it must be able to encode forall a b
As for whether it can do anything besides bitraverse in the backward direction, that equally applies to the Functor (EncoderImpl parse) (EncoderImpl parse) instance

bimap f g = EncoderImpl
{ _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
, _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)
, _encoderImpl_decode = bitraverse (_encoderImpl_decode f) (_encoderImpl_decode g)
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Just as

Naturality
  t . traverse f = traverse (t . f) for every applicative transformation t
Identity
  traverse Identity = Identity

give us

  traverse pure 
= traverse ((pure . runIdentity) . Identity)
= (pure . runIdentity) . traverse Identity
= pure

we also have bitraverse pure pure = pure and thus

  bitraverse df df . bimap ef eg
= bisequence . bimap df dg . bimap ef eg
= bisequence . bimap (df . ef) (dg . eg)
= bisequence . bimap pure pure 
= bitraverse pure pure 
= pure

}

instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where
instance (Monad parse, Applicative check, Bitraversable p, Symmetric (->) p) => Braided (Encoder check parse) p where
braid = viewEncoder (iso swap swap)


instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where
instance (Applicative check, Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => PFunctor p (Encoder check parse) (Encoder check parse) where
first f = bimap f id
instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where
instance (Applicative check, Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => QFunctor p (Encoder check parse) (Encoder check parse) where
second g = bimap id g
instance (Applicative check, Monad parse) => Bifunctor (,) (Encoder check parse) (Encoder check parse) (Encoder check parse) where
instance (Applicative check, Monad parse, Bitraversable p, Bifunctor p (->) (->) (->)) => Bifunctor p (Encoder check parse) (Encoder check parse) (Encoder check parse) where
bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)

instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (EncoderImpl parse) where
Expand All @@ -425,40 +425,14 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco
, _encoderImpl_decode = traverse $ _encoderImpl_decode ve
}

instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
first f = bimap f id
instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where
second g = bimap id g
instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where
bimap f g = EncoderImpl
{ _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)
, _encoderImpl_decode = \case
Left a -> Left <$> _encoderImpl_decode f a
Right b -> Right <$> _encoderImpl_decode g b
}

instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where
second g = bimap id g
instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where
first f = bimap f id
instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where
bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)

instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where
associate = viewEncoder (iso (associate @(->) @Either) disassociate)
disassociate = viewEncoder (iso disassociate associate)

instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where
braid = viewEncoder (iso swap swap)


instance (Monad parse, Applicative check, Bitraversable p, Symmetric (->) p) => Symmetric (Encoder check parse) p

instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where
fmap e = Encoder $ do
ve <- unEncoder e
pure $ Cat.fmap ve

instance Monad parse => Associative (EncoderImpl parse) (,) where
instance (Monad parse, Bitraversable p, Associative (->) p) => Associative (EncoderImpl parse) p where
associate = EncoderImpl
{ _encoderImpl_encode = associate
, _encoderImpl_decode = pure . disassociate
Expand All @@ -468,8 +442,8 @@ instance Monad parse => Associative (EncoderImpl parse) (,) where
, _encoderImpl_decode = pure . associate
}

instance Monad parse => Monoidal (EncoderImpl parse) (,) where
type Id (EncoderImpl parse) (,) = ()
instance (Monad parse, Bitraversable p, Monoidal (->) p) => Monoidal (EncoderImpl parse) p where
type Id (EncoderImpl parse) p = Id (->) p
idl = EncoderImpl
{ _encoderImpl_encode = idl
, _encoderImpl_decode = pure . coidl
Expand All @@ -487,12 +461,12 @@ instance Monad parse => Monoidal (EncoderImpl parse) (,) where
, _encoderImpl_decode = pure . idr
}

instance (Applicative check, Monad parse) => Associative (Encoder check parse) (,) where
instance (Applicative check, Monad parse, Bitraversable p, Associative (->) p) => Associative (Encoder check parse) p where
associate = Encoder $ pure associate
disassociate = Encoder $ pure disassociate

instance (Applicative check, Monad parse) => Monoidal (Encoder check parse) (,) where
type Id (Encoder check parse) (,) = ()
instance (Applicative check, Monad parse, Bitraversable p, Associative (->) p, Monoidal (EncoderImpl parse) p) => Monoidal (Encoder check parse) p where
type Id (Encoder check parse) p = Id (EncoderImpl parse) p
idl = Encoder $ pure idl
idr = Encoder $ pure idr
coidl = Encoder $ pure coidl
Expand Down
14 changes: 9 additions & 5 deletions lib/route/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,8 @@ import Prelude hiding (id, (.))
import Control.Applicative (liftA2)
import Control.Categorical.Bifunctor (bimap)
import Control.Category (Category((.), id))
import Control.Category.Associative (associate, Associative (disassociate))
import Control.Category.Associative (associate, disassociate)
import Control.Category.Braided (braid)
import Control.Category.Monoidal
import Control.Lens (Iso', Prism', lazy, lens, reversed, _Just, _Left, _Right)
import Data.Dependent.Map (DMap)
Expand Down Expand Up @@ -215,10 +216,13 @@ atomicEncoders = let t n e = (n, Ex e) in
, t "disassociate" $ disassociate @_ @(,) @Bool @Text @Word
, t "disassociate" $ disassociate @_ @Either @Bool @Text @Word

, t "idl" $ idl @_ @(,) @Text
, t "idr" $ idr @_ @(,) @Text
, t "coidl" $ coidl @_ @(,) @Text
, t "coidr" $ coidr @_ @(,) @Text
, t "idl" $ idl @_ @(,) @Text
, t "idr" $ idr @_ @(,) @Text
, t "coidl" $ coidl @_ @(,) @Text
, t "coidr" $ coidr @_ @(,) @Text

, t "braid" $ braid @_ @(,) @Word @Text
, t "braid" $ braid @_ @Either @Word @Text
]

-- No encoders as arguments
Expand Down