diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,45 @@ Changelog ========= +Version 0.4.0.0 +--------------- + +*September 3, 2021* + + + +* Finally add *Data.Functor.Invariant.Inplicative* and + *Data.Functor.Internative*, with the typlecasses `Inply`, `Inplicative`, + `Inalt`, `Inplus`, and `Internative`, the invariant versions of + `Apply`/`Divise`, `Applicative`/`Divisible`, `Alt`/`Decide`, + `Plus`/`Choose`, and `Alternative`/`Decidable`. +* Move *Data.Functor.Invariant.DivAp* and *Data.Functor.Invariant.DecAlt* to + *Data.Functor.Invariant.Inplicative.Free* and + *Data.Functor.Invariant.Internative.Free*, respectively. + + Their specialized `gather`/`knot`/`swerve`/`reject` are now a part of the + typeclasses. +* `concatDivAp` family and `concatDecAlt` family of functions generalized to + work for all *Inplicative* and *Inplus*, respectively, and moved to the + modules for their respective typeclasses as `concatInplicative`, + `concatInply`, `concatInplus`, and `concatInalt`. +* Changed the order of arguments on `gather` and `swerve` to be consistent + with the arguments of `invmap`, `Day`, and `Night`. +* Changed the order of arguments in the `Gather`, and `Swerve` patterns to + be more consistent with the new order of arguments for `gather`/`swerve`. +* Changed the order of arguments in the `DivAp1` and `DecAlt1` patterns to + be more consistent with the order of arguments for `Day` and `Night`. +* Add `runDay` and `runNight` for invariant `Day` and `Night`, using the + `Inply` and `Inalt` typeclasses, respectively. `runDay` is found in + *Data.Functor.Invariant.Inplicative*, even though it should belong in + *Data.Functor.Invariant.Day*, but that's in a different package. +* Add `dather`, `necide`, and `nerve` to invariant `Day`, contravariant + `Night`, invariant `Night`, in parallel to `dap` for covariant `Day`. Uses + the `Inply`, `Divise`, and `Inalt` typeclasses, respectively. `dather` is + found in *Data.Functor.Invariant.Inplicative*, even though it should + belong in *Data.Functor.Invariant.Day*, but that's in a different package. +* Add `hfor` and `hfor1` to *Data.HFunctor.HTraversable*. + Version 0.3.6.0 --------------- diff --git a/functor-combinators.cabal b/functor-combinators.cabal --- a/functor-combinators.cabal +++ b/functor-combinators.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 9070db16766f843e9ffef9a8370e247bb1136ef2d5903a49c7411b5cb1227af7 +-- hash: 8d3d33fe70d8907a40e1b80e5ac37a52e0bd94fcadf9ff26258211521fb5f22c name: functor-combinators -version: 0.3.6.0 +version: 0.4.0.0 synopsis: Tools for functor combinator-based program design description: Tools for working with /functor combinators/: types that take functors (or other indexed types) and returns a new functor that "enhances" or "mixes" @@ -59,8 +59,10 @@ Data.Functor.Contravariant.Divise Data.Functor.Contravariant.Divisible.Free Data.Functor.Contravariant.Night - Data.Functor.Invariant.DecAlt - Data.Functor.Invariant.DivAp + Data.Functor.Invariant.Inplicative + Data.Functor.Invariant.Inplicative.Free + Data.Functor.Invariant.Internative + Data.Functor.Invariant.Internative.Free Data.Functor.Invariant.Night Data.HBifunctor Data.HBifunctor.Associative diff --git a/src/Data/Functor/Contravariant/Decide.hs b/src/Data/Functor/Contravariant/Decide.hs --- a/src/Data/Functor/Contravariant/Decide.hs +++ b/src/Data/Functor/Contravariant/Decide.hs @@ -27,14 +27,7 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.List import Control.Monad.Trans.Maybe -import qualified Control.Monad.Trans.RWS.Lazy as Lazy -import qualified Control.Monad.Trans.RWS.Strict as Strict import Control.Monad.Trans.Reader -import qualified Control.Monad.Trans.State.Lazy as Lazy -import qualified Control.Monad.Trans.State.Strict as Strict -import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import qualified Control.Monad.Trans.Writer.Strict as Strict - import Data.Either import Data.Functor.Apply import Data.Functor.Compose @@ -43,6 +36,12 @@ import Data.Functor.Contravariant.Divisible import Data.Functor.Product import Data.Functor.Reverse +import qualified Control.Monad.Trans.RWS.Lazy as Lazy +import qualified Control.Monad.Trans.RWS.Strict as Strict +import qualified Control.Monad.Trans.State.Lazy as Lazy +import qualified Control.Monad.Trans.State.Strict as Strict +import qualified Control.Monad.Trans.Writer.Lazy as Lazy +import qualified Control.Monad.Trans.Writer.Strict as Strict #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) diff --git a/src/Data/Functor/Contravariant/Night.hs b/src/Data/Functor/Contravariant/Night.hs --- a/src/Data/Functor/Contravariant/Night.hs +++ b/src/Data/Functor/Contravariant/Night.hs @@ -15,7 +15,7 @@ module Data.Functor.Contravariant.Night ( Night(..) , night - , runNight + , runNight, necide , assoc, unassoc , swapped , trans1, trans2 @@ -81,6 +81,15 @@ -> (g ~> h) -> Night f g ~> h runNight f g (Night x y z) = decide z (f x) (g y) + +-- | Squash the two items in a 'Night' using their natural 'Decide' +-- instances. +-- +-- @since 0.4.0.0 +necide + :: Decide f + => Night f f ~> f +necide (Night x y z) = decide z x y -- | 'Night' is associative. assoc :: Night f (Night g h) ~> Night (Night f g) h diff --git a/src/Data/Functor/Invariant/DecAlt.hs b/src/Data/Functor/Invariant/DecAlt.hs deleted file mode 100644 --- a/src/Data/Functor/Invariant/DecAlt.hs +++ /dev/null @@ -1,354 +0,0 @@ - --- | --- Module : Data.Functor.Invariant.DecAlt --- Copyright : (c) Justin Le 2019 --- License : BSD3 --- --- Maintainer : justin@jle.im --- Stability : experimental --- Portability : non-portable --- --- Provide an invariant functor combinator choice-collector, like a combination of --- 'ListF' and 'Dec'. --- --- @since 0.3.5.0 -module Data.Functor.Invariant.DecAlt ( - -- * Chain - DecAlt(.., Swerve, Reject) - , runCoDecAlt - , runContraDecAlt - , decAltListF - , decAltListF_ - , decAltDec - , foldDecAlt - , swerve, swerved - , assembleDecAlt - , concatDecAlt - -- * Nonempty Chain - , DecAlt1(.., DecAlt1) - , runCoDecAlt1 - , runContraDecAlt1 - , decAltNonEmptyF - , decAltNonEmptyF_ - , decAltDec1 - , foldDecAlt1 - , swerve1, swerved1 - , assembleDecAlt1 - , concatDecAlt1 - ) where - -import Control.Applicative.ListF -import Control.Natural -import Data.Coerce -import Data.Functor.Alt -import Data.Functor.Contravariant.Conclude -import Data.Functor.Contravariant.Decide -import Data.Functor.Contravariant.Divisible.Free -import Data.Functor.Invariant -import Data.Functor.Invariant.Night -import Data.Functor.Plus -import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) -import Data.HFunctor -import Data.HFunctor.Chain -import Data.HFunctor.Chain.Internal -import Data.SOP -import Data.Void -import qualified Control.Monad.Trans.Compose as CT -import qualified Data.Functor.Coyoneda as CY -import qualified Data.List.NonEmpty as NE - - --- | In the covariant direction, we can interpret out of a 'Chain1' of 'Night' --- into any 'Alt'. -runCoDecAlt1 - :: forall f g. Alt g - => f ~> g - -> DecAlt1 f ~> g -runCoDecAlt1 f = foldDecAlt1 f (runNightAlt f id) - --- | In the contravariant direction, we can interpret out of a 'Chain1' of --- 'Night' into any 'Decide'. -runContraDecAlt1 - :: forall f g. Decide g - => f ~> g - -> DecAlt1 f ~> g -runContraDecAlt1 f = foldDecAlt1 f (runNightDecide f id) - --- | Extract the 'Dec' part out of a 'DecAlt', shedding the --- covariant bits. -decAltDec :: DecAlt f ~> Dec f -decAltDec = runContraDecAlt inject - --- | Extract the 'Dec1' part out of a 'DecAlt1', shedding the --- covariant bits. -decAltDec1 :: DecAlt1 f ~> Dec1 f -decAltDec1 = runContraDecAlt1 inject - --- | In the covariant direction, we can interpret out of a 'Chain' of 'Night' --- into any 'Plus'. -runCoDecAlt - :: forall f g. Plus g - => f ~> g - -> DecAlt f ~> g -runCoDecAlt f = foldDecAlt (const zero) (runNightAlt f id) - --- | In the contravariant direction, we can interpret out of a 'Chain' of --- 'Night' into any 'Conclude'. -runContraDecAlt - :: forall f g. Conclude g - => f ~> g - -> DecAlt f ~> g -runContraDecAlt f = foldDecAlt conclude (runNightDecide f id) - --- | Extract the 'ListF' part out of a 'DecAlt', shedding the --- contravariant bits. --- --- @since 0.3.2.0 -decAltListF :: Functor f => DecAlt f ~> ListF f -decAltListF = runCoDecAlt inject - --- | Extract the 'ListF' part out of a 'DecAlt', shedding the --- contravariant bits. --- --- This version does not require a 'Functor' constraint because it converts --- to the coyoneda-wrapped product, which is more accurately the true --- conversion to a covariant chain. --- --- @since 0.3.2.0 -decAltListF_ :: DecAlt f ~> CT.ComposeT ListF CY.Coyoneda f -decAltListF_ = foldDecAlt (const (CT.ComposeT (ListF []))) $ \case - Night x (CT.ComposeT (ListF xs)) _ f g -> CT.ComposeT . ListF $ - CY.Coyoneda f x : (map . fmap) g xs - --- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the --- contravariant bits. --- --- @since 0.3.2.0 -decAltNonEmptyF :: Functor f => DecAlt1 f ~> NonEmptyF f -decAltNonEmptyF = runCoDecAlt1 inject - --- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the --- contravariant bits. --- --- This version does not require a 'Functor' constraint because it converts --- to the coyoneda-wrapped product, which is more accurately the true --- conversion to a covariant chain. --- --- @since 0.3.2.0 -decAltNonEmptyF_ :: DecAlt1 f ~> CT.ComposeT NonEmptyF CY.Coyoneda f -decAltNonEmptyF_ = foldDecAlt1 inject $ \case - Night x (CT.ComposeT (NonEmptyF xs)) _ f g -> CT.ComposeT . NonEmptyF $ - CY.Coyoneda f x NE.<| (fmap . fmap) g xs - --- | General-purpose folder of 'DecAlt'. Provide a way to handle the --- identity ('empty'/'conclude'/'Reject') and a way to handle a cons --- (''/'decide'/'swerve'). --- --- @since 0.3.5.0 -foldDecAlt - :: (forall x. (x -> Void) -> g x) - -> (Night f g ~> g) - -> DecAlt f ~> g -foldDecAlt f g = foldChain (f . refute) g . unDecAlt - --- | General-purpose folder of 'DecAlt1'. Provide a way to handle the --- individual leaves and a way to handle a cons (''/'decide'/'swerve1'). --- --- @since 0.3.5.0 -foldDecAlt1 - :: (f ~> g) - -> (Night f g ~> g) - -> DecAlt1 f ~> g -foldDecAlt1 f g = foldChain1 f g . unDecAlt1 - --- | Match on a non-empty 'DecAlt'; contains the splitting function, --- the two rejoining functions, the first @f@, and the rest of the chain. --- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Choose' --- constructor. -pattern Swerve :: (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> DecAlt f c -> DecAlt f a -pattern Swerve f g h x xs <- (unSwerve_->MaybeF (Just (Night x xs f g h))) - where - Swerve f g h x xs = DecAlt $ More $ Night x (unDecAlt xs) f g h - -unSwerve_ :: DecAlt f ~> MaybeF (Night f (DecAlt f)) -unSwerve_ = \case - DecAlt (More (Night x xs g f h)) -> MaybeF . Just $ Night x (DecAlt xs) g f h - DecAlt (Done _ ) -> MaybeF Nothing - - --- | Match on an "empty" 'DecAlt'; contains no @f@s, but only the --- terminal value. Analogous to the --- 'Data.Functor.Contravariant.Divisible.Free.Lose' constructor. -pattern Reject :: (a -> Void) -> DecAlt f a -pattern Reject x = DecAlt (Done (Not x)) -{-# COMPLETE Swerve, Reject #-} - --- | Match on a 'DecAlt1' to get the head and the rest of the items. --- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Dec1' --- constructor. -pattern DecAlt1 :: Invariant f => (a -> Either b c) -> (b -> a) -> (c -> a) -> f b -> DecAlt f c -> DecAlt1 f a -pattern DecAlt1 f g h x xs <- (coerce splitChain1->Night x xs f g h) - where - DecAlt1 f g h x xs = unsplitNE $ Night x xs f g h -{-# COMPLETE DecAlt1 #-} - --- | Invariantly combine two 'DecAlt's. --- --- Analogous to '<|>' and 'decide'. If there was some typeclass that --- represented semigroups on invariant 'Night', this would be the method of that --- typeclass. --- --- The identity of this is 'Reject'. --- --- @since 0.3.4.0 -swerve - :: (a -> Either b c) - -> (b -> a) - -> (c -> a) - -> DecAlt f b - -> DecAlt f c - -> DecAlt f a -swerve f g h x y = coerce appendChain (Night x y f g h) - --- | Convenient wrapper over 'swerve' that simply combines the two options --- in an 'Either'. Analogous to '<|>' and 'decided'. --- --- @since 0.3.4.0 -swerved - :: DecAlt f a - -> DecAlt f b - -> DecAlt f (Either a b) -swerved = swerve id Left Right - --- | Invariantly combine two 'DecAlt1's. --- --- Analogous to '<|>' and 'decide'. If there was some typeclass that --- represented semigroups on invariant 'Night', this would be the method of that --- typeclass. --- --- @since 0.3.4.0 -swerve1 - :: Invariant f - => (a -> Either b c) - -> (b -> a) - -> (c -> a) - -> DecAlt1 f b - -> DecAlt1 f c - -> DecAlt1 f a -swerve1 f g h x y = coerce appendChain1 (Night x y f g h) - --- | Convenient wrapper over 'swerve1' that simply combines the two options --- in an 'Either'. Analogous to '<|>' and 'decided'. --- --- @since 0.3.4.0 -swerved1 - :: Invariant f - => DecAlt1 f a - -> DecAlt1 f b - -> DecAlt1 f (Either a b) -swerved1 = swerve1 id Left Right - --- | Convenient wrapper to build up a 'DecAlt' on by providing each --- component of it. This makes it much easier to build up longer chains --- because you would only need to write the splitting/joining functions in --- one place. --- --- For example, if you had a data type --- --- @ --- data MyType = MTI Int | MTB Bool | MTS String --- @ --- --- and an invariant functor @Prim@ (representing, say, a bidirectional --- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), --- then you could assemble a bidirectional parser for a @MyType@ using: --- --- @ --- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) --- (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $ --- assembleDecAlt $ intPrim --- :* boolPrim --- :* stringPrim --- :* Nil --- @ --- --- Some notes on usefulness depending on how many components you have: --- --- * If you have 0 components, use 'Reject' directly. --- * If you have 1 component, use 'inject' or 'injectChain' directly. --- * If you have 2 components, use 'toListBy' or 'toChain'. --- * If you have 3 or more components, these combinators may be useful; --- otherwise you'd need to manually peel off eithers one-by-one. -assembleDecAlt - :: NP f as - -> DecAlt f (NS I as) -assembleDecAlt = \case - Nil -> DecAlt $ Done $ Not (\case {}) - x :* xs -> DecAlt $ More $ Night - x - (unDecAlt $ assembleDecAlt xs) - unconsNSI - (Z . I) - S - --- | A version of 'assembleDecAlt' where each component is itself --- a 'DecAlt'. --- --- @ --- assembleDecAlt (x :* y :* z :* Nil) --- = concatDecAlt (injectChain x :* injectChain y :* injectChain z :* Nil) --- @ -concatDecAlt - :: NP (DecAlt f) as - -> DecAlt f (NS I as) -concatDecAlt = \case - Nil -> DecAlt $ Done $ Not (\case {}) - x :* xs -> coerce appendChain $ Night - x - (unDecAlt $ concatDecAlt xs) - unconsNSI - (Z . I) - S - --- | A version of 'assembleDecAlt' but for 'DecAlt1' instead. Can --- be useful if you intend on interpreting it into something with only --- a 'Decide' or 'Alt' instance, but no --- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or --- 'Control.Applicative.Alternative'. -assembleDecAlt1 - :: Invariant f - => NP f (a ': as) - -> DecAlt1 f (NS I (a ': as)) -assembleDecAlt1 = \case - x :* xs -> DecAlt1_ $ case xs of - Nil -> Done1 $ invmap (Z . I) (unI . unZ) x - _ :* _ -> More1 $ Night - x - (unDecAlt1 $ assembleDecAlt1 xs) - unconsNSI - (Z . I) - S - --- | A version of 'concatDecAlt' but for 'DecAlt1' instead. Can be --- useful if you intend on interpreting it into something with only --- a 'Decide' or 'Alt' instance, but no --- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or --- 'Control.Applicative.Alternative'. -concatDecAlt1 - :: Invariant f - => NP (DecAlt1 f) (a ': as) - -> DecAlt1 f (NS I (a ': as)) -concatDecAlt1 = \case - x :* xs -> case xs of - Nil -> invmap (Z . I) (unI . unZ) x - _ :* _ -> coerce appendChain1 $ Night - x - (unDecAlt1 $ concatDecAlt1 xs) - unconsNSI - (Z . I) - S - -unconsNSI :: NS I (a ': as) -> Either a (NS I as) -unconsNSI = \case - Z (I x) -> Left x - S xs -> Right xs diff --git a/src/Data/Functor/Invariant/DivAp.hs b/src/Data/Functor/Invariant/DivAp.hs deleted file mode 100644 --- a/src/Data/Functor/Invariant/DivAp.hs +++ /dev/null @@ -1,422 +0,0 @@ - --- | --- Module : Data.Functor.Invariant.Day --- Copyright : (c) Justin Le 2019 --- License : BSD3 --- --- Maintainer : justin@jle.im --- Stability : experimental --- Portability : non-portable --- --- Provide an invariant functor combinator sequencer, like a combination of --- 'Ap' and 'Div'. --- --- @since 0.3.5.0 -module Data.Functor.Invariant.DivAp ( - -- * Chain - DivAp(.., Gather, Knot) - , runCoDivAp - , runContraDivAp - , divApAp - , divApDiv - , foldDivAp - , gather, gathered - , assembleDivAp - , assembleDivApRec - , concatDivAp - , concatDivApRec - -- * Nonempty Chain - , DivAp1(.., DivAp1) - , runCoDivAp1 - , runContraDivAp1 - , divApAp1 - , divApDiv1 - , foldDivAp1 - , gather1, gathered1 - , assembleDivAp1 - , assembleDivAp1Rec - , concatDivAp1 - , concatDivAp1Rec - -- * Day Utility - , runDayApply - , runDayDivise - ) where - -import Control.Applicative -import Control.Applicative.Free (Ap(..)) -import Control.Applicative.ListF (MaybeF(..)) -import Control.Natural -import Data.Coerce -import Data.Functor.Apply -import Data.Functor.Apply.Free (Ap1(..)) -import Data.Functor.Contravariant.Divise -import Data.Functor.Contravariant.Divisible -import Data.Functor.Contravariant.Divisible.Free (Div(..), Div1) -import Data.Functor.Identity -import Data.Functor.Invariant -import Data.Functor.Invariant.Day -import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) -import Data.HFunctor -import Data.HFunctor.Chain -import Data.HFunctor.Chain.Internal -import Data.SOP hiding (hmap) -import qualified Data.Vinyl as V -import qualified Data.Vinyl.Functor as V - --- | Interpret the covariant part of a 'Day' into a target context @h@, --- as long as the context is an instance of 'Apply'. The 'Apply' is used to --- combine results back together using '<*>'. -runDayApply - :: forall f g h. Apply h - => f ~> h - -> g ~> h - -> Day f g ~> h -runDayApply f g (Day x y j _) = liftF2 j (f x) (g y) - --- | Interpret the contravariant part of a 'Day' into a target context --- @h@, as long as the context is an instance of 'Divise'. The 'Divise' is --- used to split up the input to pass to each of the actions. -runDayDivise - :: forall f g h. Divise h - => f ~> h - -> g ~> h - -> Day f g ~> h -runDayDivise f g (Day x y _ h) = divise h (f x) (g y) - --- | In the covariant direction, we can interpret out of a 'Chain1' of 'Day' --- into any 'Apply'. -runCoDivAp1 - :: forall f g. Apply g - => f ~> g - -> DivAp1 f ~> g -runCoDivAp1 f = foldDivAp1 f (runDayApply f id) - --- | In the contravariant direction, we can interpret out of a 'Chain1' of --- 'Day' into any 'Divise'. -runContraDivAp1 - :: forall f g. Divise g - => f ~> g - -> DivAp1 f ~> g -runContraDivAp1 f = foldDivAp1 f (runDayDivise f id) - --- | In the covariant direction, we can interpret out of a 'Chain' of 'Day' --- into any 'Applicative'. -runCoDivAp - :: forall f g. Applicative g - => f ~> g - -> DivAp f ~> g -runCoDivAp f = foldDivAp pure (\case Day x y h _ -> liftA2 h (f x) y) - --- | In the contravariant direction, we can interpret out of a 'Chain' of --- 'Day' into any 'Divisible'. -runContraDivAp - :: forall f g. Divisible g - => f ~> g - -> DivAp f ~> g -runContraDivAp f = foldDivAp (const conquer) (\case Day x y _ g -> divide g (f x) y) - --- | General-purpose folder of 'DivAp'. Provide a way to handle the --- identity ('pure'/'conquer'/'Knot') and a way to handle a cons --- ('liftA2'/'divide'/'Gather'). --- --- @since 0.3.5.0 -foldDivAp - :: (forall x. x -> g x) - -> (Day f g ~> g) - -> DivAp f ~> g -foldDivAp f g = foldChain (f . runIdentity) g . unDivAp - --- | General-purpose folder of 'DivAp1'. Provide a way to handle the --- individual leaves and a way to handle a cons ('liftF2/'divise'/'Gather'). --- --- @since 0.3.5.0 -foldDivAp1 - :: (f ~> g) - -> (Day f g ~> g) - -> DivAp1 f ~> g -foldDivAp1 f g = foldChain1 f g . unDivAp1 - - - - - --- | Extract the 'Ap' part out of a 'DivAp', shedding the --- contravariant bits. --- --- @since 0.3.2.0 -divApAp :: DivAp f ~> Ap f -divApAp = runCoDivAp inject - --- | Extract the 'Ap1' part out of a 'DivAp1', shedding the --- contravariant bits. --- --- @since 0.3.2.0 -divApAp1 :: DivAp1 f ~> Ap1 f -divApAp1 = runCoDivAp1 inject - --- | Extract the 'Div' part out of a 'DivAp', shedding the --- covariant bits. --- --- @since 0.3.2.0 -divApDiv :: DivAp f ~> Div f -divApDiv = runContraDivAp inject - --- | Extract the 'Div1' part out of a 'DivAp1', shedding the --- covariant bits. --- --- @since 0.3.2.0 -divApDiv1 :: DivAp1 f ~> Div1 f -divApDiv1 = runContraDivAp1 inject - --- | Match on a non-empty 'DivAp'; contains no @f@s, but only the --- terminal value. Analogous to the 'Control.Applicative.Free.Ap' --- constructor. -pattern Gather :: (a -> (b, c)) -> (b -> c -> a) -> f b -> DivAp f c -> DivAp f a -pattern Gather f g x xs <- (unGather_->MaybeF (Just (Day x xs g f))) - where - Gather f g x xs = DivAp $ More $ Day x (unDivAp xs) g f - -unGather_ :: DivAp f ~> MaybeF (Day f (DivAp f)) -unGather_ = \case - DivAp (More (Day x xs g f)) -> MaybeF . Just $ Day x (DivAp xs) g f - DivAp (Done _ ) -> MaybeF Nothing - --- | Match on an "empty" 'DivAp'; contains no @f@s, but only the --- terminal value. Analogous to 'Control.Applicative.Free.Pure'. -pattern Knot :: a -> DivAp f a -pattern Knot x = DivAp (Done (Identity x)) -{-# COMPLETE Gather, Knot #-} - --- | Match on a 'DivAp1' to get the head and the rest of the items. --- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor. -pattern DivAp1 :: Invariant f => (a -> (b, c)) -> (b -> c -> a) -> f b -> DivAp f c -> DivAp1 f a -pattern DivAp1 f g x xs <- (coerce splitChain1->Day x xs g f) - where - DivAp1 f g x xs = unsplitNE $ Day x xs g f -{-# COMPLETE DivAp1 #-} - --- | Invariantly combine two 'DivAp's. --- --- Analogous to 'liftA2' and 'divise'. If there was some typeclass that --- represented semigroups on invariant 'Day', this would be the method of --- that typeclass. --- --- The identity of this is 'Knot'. --- --- @since 0.3.4.0 -gather - :: (a -> (b, c)) - -> (b -> c -> a) - -> DivAp f b - -> DivAp f c - -> DivAp f a -gather f g x y = coerce appendChain (Day x y g f) - --- | Convenient wrapper over 'gather' that simply combines the two options --- in a tuple. Analogous to 'divised'. --- --- @since 0.3.4.0 -gathered - :: DivAp f a - -> DivAp f b - -> DivAp f (a, b) -gathered = gather id (,) - --- | Invariantly combine two 'DivAp1's. --- --- Analogous to 'liftA2' and 'divise'. If there was some typeclass that --- represented semigroups on invariant 'Day', this would be the method of --- that typeclass. --- --- @since 0.3.4.0 -gather1 - :: Invariant f - => (a -> (b, c)) - -> (b -> c -> a) - -> DivAp1 f b - -> DivAp1 f c - -> DivAp1 f a -gather1 f g x y = coerce appendChain1 (Day x y g f) - --- | Convenient wrapper over 'gather1' that simply combines the two options --- in a tuple. Analogous to 'divised'. --- --- @since 0.3.4.0 -gathered1 - :: Invariant f - => DivAp1 f a - -> DivAp1 f b - -> DivAp1 f (a, b) -gathered1 = gather1 id (,) - --- | Convenient wrapper to build up a 'DivAp' by providing each --- component of it. This makes it much easier to build up longer chains --- because you would only need to write the splitting/joining functions in --- one place. --- --- For example, if you had a data type --- --- @ --- data MyType = MT Int Bool String --- @ --- --- and an invariant functor @Prim@ (representing, say, a bidirectional --- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), --- then you could assemble a bidirectional parser for a @MyType@ using: --- --- @ --- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil) --- (\(I x :* I y :* I z :* Nil) -> MyType x y z) $ --- assembleDivAp $ intPrim --- :* boolPrim --- :* stringPrim --- :* Nil --- @ --- --- Some notes on usefulness depending on how many components you have: --- --- * If you have 0 components, use 'Knot' directly. --- * If you have 1 component, use 'inject' or 'injectChain' directly. --- * If you have 2 components, use 'toListBy' or 'toChain'. --- * If you have 3 or more components, these combinators may be useful; --- otherwise you'd need to manually peel off tuples one-by-one. -assembleDivAp - :: NP f as - -> DivAp f (NP I as) -assembleDivAp = \case - Nil -> DivAp $ Done $ Identity Nil - x :* xs -> DivAp $ More $ Day - x - (unDivAp (assembleDivAp xs)) - consNPI - unconsNPI - --- | A version of 'assembleDivAp' where each component is itself --- a 'DivAp'. --- --- @ --- assembleDivAp (x :* y :* z :* Nil) --- = concatDivAp (injectChain x :* injectChain y :* injectChain z :* Nil) --- @ -concatDivAp - :: NP (DivAp f) as - -> DivAp f (NP I as) -concatDivAp = \case - Nil -> DivAp $ Done $ Identity Nil - x :* xs -> coerce appendChain $ Day - x - (concatDivAp xs) - consNPI - unconsNPI - --- | A version of 'assembleDivAp' but for 'DivAp1' instead. Can be --- useful if you intend on interpreting it into something with only --- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'. -assembleDivAp1 - :: Invariant f - => NP f (a ': as) - -> DivAp1 f (NP I (a ': as)) -assembleDivAp1 = \case - x :* xs -> DivAp1_ $ case xs of - Nil -> Done1 $ invmap ((:* Nil) . I) (unI . hd) x - _ :* _ -> More1 $ Day - x - (unDivAp1 (assembleDivAp1 xs)) - consNPI - unconsNPI - --- | A version of 'concatDivAp' but for 'DivAp1' instead. Can be --- useful if you intend on interpreting it into something with only --- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'. -concatDivAp1 - :: Invariant f - => NP (DivAp1 f) (a ': as) - -> DivAp1 f (NP I (a ': as)) -concatDivAp1 = \case - x :* xs -> case xs of - Nil -> invmap ((:* Nil) . I) (unI . hd) x - _ :* _ -> coerce appendChain1 $ Day - x - (concatDivAp1 xs) - consNPI - unconsNPI - -unconsNPI :: NP I (a ': as) -> (a, NP I as) -unconsNPI (I y :* ys) = (y, ys) - -consNPI :: a -> NP I as -> NP I (a ': as) -consNPI y ys = I y :* ys - --- | A version of 'assembleDivAp' using 'V.XRec' from /vinyl/ instead of --- 'NP' from /sop-core/. This can be more convenient because it doesn't --- require manual unwrapping/wrapping of components. --- --- @ --- data MyType = MT Int Bool String --- --- invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil) --- (\(x ::& y ::& z ::& RNil) -> MyType x y z) $ --- assembleDivApRec $ intPrim --- :& boolPrim --- :& stringPrim --- :& Nil --- @ -assembleDivApRec - :: V.Rec f as - -> DivAp f (V.XRec V.Identity as) -assembleDivApRec = \case - V.RNil -> DivAp $ Done $ Identity V.RNil - x V.:& xs -> DivAp $ More $ Day - x - (unDivAp (assembleDivApRec xs)) - (V.::&) - unconsRec - --- | A version of 'concatDivAp' using 'V.XRec' from /vinyl/ instead of --- 'NP' from /sop-core/. This can be more convenient because it doesn't --- require manual unwrapping/wrapping of components. -concatDivApRec - :: V.Rec (DivAp f) as - -> DivAp f (V.XRec V.Identity as) -concatDivApRec = \case - V.RNil -> DivAp $ Done $ Identity V.RNil - x V.:& xs -> coerce appendChain $ Day - x - (concatDivApRec xs) - (V.::&) - unconsRec - --- | A version of 'assembleDivAp1' using 'V.XRec' from /vinyl/ instead of --- 'NP' from /sop-core/. This can be more convenient because it doesn't --- require manual unwrapping/wrapping of components. -assembleDivAp1Rec - :: Invariant f - => V.Rec f (a ': as) - -> DivAp1 f (V.XRec V.Identity (a ': as)) -assembleDivAp1Rec = \case - x V.:& xs -> case xs of - V.RNil -> DivAp1_ $ Done1 $ invmap (V.::& V.RNil) (\case z V.::& _ -> z) x - _ V.:& _ -> DivAp1_ $ More1 $ Day - x - (unDivAp1 (assembleDivAp1Rec xs)) - (V.::&) - unconsRec - --- | A version of 'concatDivAp1' using 'V.XRec' from /vinyl/ instead of --- 'NP' from /sop-core/. This can be more convenient because it doesn't --- require manual unwrapping/wrapping of components. -concatDivAp1Rec - :: Invariant f - => V.Rec (DivAp1 f) (a ': as) - -> DivAp1 f (V.XRec V.Identity (a ': as)) -concatDivAp1Rec = \case - x V.:& xs -> case xs of - V.RNil -> invmap (V.::& V.RNil) (\case z V.::& _ -> z) x - _ V.:& _ -> coerce appendChain1 $ Day - x - (concatDivAp1Rec xs) - (V.::&) - unconsRec - -unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as) -unconsRec (y V.::& ys) = (y, ys) diff --git a/src/Data/Functor/Invariant/Inplicative.hs b/src/Data/Functor/Invariant/Inplicative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/Inplicative.hs @@ -0,0 +1,224 @@ +-- | +-- Module : Data.Functor.Invariant.Inplicative +-- Copyright : (c) Justin Le 2021 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Contains the classes 'Inply' and 'Inplicative', the invariant +-- counterparts to 'Apply'/'Divise' and 'Applicative'/'Divisible'. +-- +-- @since 0.4.0.0 +module Data.Functor.Invariant.Inplicative ( + -- * Typeclass + Inply(..) + , Inplicative(..) + -- * Invariant 'Day' + , runDay + , dather + -- * Assembling Helpers + , concatInplicative + , concatInply + , concatInplicativeRec + , concatInplyRec + ) where + +import Control.Natural +import Data.Functor.Invariant +import Data.Functor.Invariant.Day +import Data.SOP hiding (hmap) +import qualified Data.Vinyl as V +import qualified Data.Vinyl.Functor as V + +-- | The invariant counterpart of 'Apply' and 'Divise'. +-- +-- Conceptually you can think of 'Apply' as, given a way to "combine" @a@ and +-- @b@ to @c@, lets you merge @f a@ (producer of @a@) and @f b@ (producer +-- of @b@) into a @f c@ (producer of @c@). 'Divise' can be thought of as, +-- given a way to "split" a @c@ into an @a@ and a @b@, lets you merge @f +-- a@ (consumer of @a@) and @f b@ (consumder of @b@) into a @f c@ (consumer +-- of @c@). +-- +-- 'Inply', for 'gather', requires both a combining function and +-- a splitting function in order to merge @f b@ (producer and consumer of +-- @b@) and @f c@ (producer and consumer of @c@) into a @f a@. You can +-- think of it as, for the @f a@, it "splits" the a into @b@ and @c@ with +-- the @a -> (b, c)@, feeds it to the original @f b@ and @f c@, and then +-- re-combines the output back into a @a@ with the @b -> c -> a@. +-- +-- @since 0.4.0.0 +class Invariant f => Inply f where + -- | Like '<.>', '<*>', 'divise', or 'divide', but requires both + -- a splitting and a recombining function. '<.>' and '<*>' require + -- only a combining function, and 'divise' and 'divide' require only + -- a splitting function. + -- + -- It is used to merge @f b@ (producer and consumer of @b@) and @f c@ + -- (producer and consumer of @c@) into a @f a@. You can think of it + -- as, for the @f a@, it "splits" the a into @b@ and @c@ with the @a -> + -- (b, c)@, feeds it to the original @f b@ and @f c@, and then + -- re-combines the output back into a @a@ with the @b -> c -> a@. + -- + -- An important property is that it will always use @both@ of the + -- ccomponents given in order to fulfil its job. If you gather an @f + -- a@ and an @f b@ into an @f c@, in order to consume/produdce the @c@, + -- it will always use both the @f a@ or the @f b@ -- exactly one of + -- them. + -- + -- @since 0.4.0.0 + gather + :: (b -> c -> a) + -> (a -> (b, c)) + -> f b + -> f c + -> f a + gather f g x y = invmap (uncurry f) g (gathered x y) + -- | A simplified version of 'gather' that combines into a tuple. You + -- can then use 'invmap' to reshape it into the proper shape. + -- + -- @since 0.4.0.0 + gathered + :: f a + -> f b + -> f (a, b) + gathered = gather (,) id + + {-# MINIMAL gather | gathered #-} + +-- | The invariant counterpart of 'Applicative' and 'Divisible'. +-- +-- The main important action is described in 'Inply', but this adds 'knot', +-- which is the counterpart to 'pure' and 'conquer'. It's the identity to +-- 'gather'; if combine two @f a@s with 'gather', and one of them is +-- 'knot', it will leave the structure unchanged. +-- +-- Conceptually, if you think of 'gather' as "splitting and re-combining" +-- along multiple forks, then 'knot' introduces a fork that is never taken. +-- +-- @since 0.4.0.0 +class Inply f => Inplicative f where + knot :: a -> f a + +-- | Interpret out of a contravariant 'Day' into any instance of 'Inply' by +-- providing two interpreting functions. +-- +-- This should go in "Data.Functor.Invariant.Day", but that module is in +-- a different package. +-- +-- @since 0.4.0.0 +runDay + :: Inply h + => (f ~> h) + -> (g ~> h) + -> Day f g ~> h +runDay f g (Day x y a b) = gather a b (f x) (g y) + +-- | Squash the two items in a 'Day' using their natural 'Inply' +-- instances. +-- +-- This should go in "Data.Functor.Invariant.Day", but that module is in +-- a different package. +-- +-- @since 0.4.0.0 +dather + :: Inply f + => Day f f ~> f +dather (Day x y a b) = gather a b x y + +-- | Convenient wrapper to build up an 'Inplicative' instance by providing +-- each component of it. This makes it much easier to build up longer +-- chains because you would only need to write the splitting/joining +-- functions in one place. +-- +-- For example, if you had a data type +-- +-- @ +-- data MyType = MT Int Bool String +-- @ +-- +-- and an invariant functor and 'Inplicative' instance @Prim@ +-- (representing, say, a bidirectional parser, where @Prim Int@ is +-- a bidirectional parser for an 'Int'@), then you could assemble +-- a bidirectional parser for a @MyType@ using: +-- +-- @ +-- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil) +-- (\(I x :* I y :* I z :* Nil) -> MyType x y z) $ +-- concatInplicative $ intPrim +-- :* boolPrim +-- :* stringPrim +-- :* Nil +-- @ +-- +-- Some notes on usefulness depending on how many components you have: +-- +-- * If you have 0 components, use 'knot' directly. +-- * If you have 1 component, use 'inject' directly. +-- * If you have 2 components, use 'gather' directly. +-- * If you have 3 or more components, these combinators may be useful; +-- otherwise you'd need to manually peel off tuples one-by-one. +-- +-- @since 0.4.0.0 +concatInplicative + :: Inplicative f + => NP f as + -> f (NP I as) +concatInplicative = \case + Nil -> knot Nil + x :* xs -> gather + (\y ys -> I y :* ys) + (\case I y :* ys -> (y, ys)) + x + (concatInplicative xs) + +-- | A version of 'concatInplicative' for non-empty 'NP', but only +-- requiring an 'Inply' instance. +-- +-- @since 0.4.0.0 +concatInply + :: Inply f + => NP f (a ': as) + -> f (NP I (a ': as)) +concatInply (x :* xs) = case xs of + Nil -> invmap ((:* Nil) . I) (\case I y :* _ -> y) x + _ :* _ -> gather + (\y ys -> I y :* ys) + (\case I y :* ys -> (y, ys)) + x + (concatInply xs) + +-- | A version of 'concatInplicative' using 'V.XRec' from /vinyl/ instead of +-- 'NP' from /sop-core/. This can be more convenient because it doesn't +-- require manual unwrapping/wrapping of components. +-- +-- @since 0.4.0.0 +concatInplicativeRec + :: Inplicative f + => V.Rec f as + -> f (V.XRec V.Identity as) +concatInplicativeRec = \case + V.RNil -> knot V.RNil + x V.:& xs -> gather + (V.::&) + (\case y V.::& ys -> (y, ys)) + x + (concatInplicativeRec xs) + +-- | A version of 'concatInply' using 'V.XRec' from /vinyl/ instead of +-- 'NP' from /sop-core/. This can be more convenient because it doesn't +-- require manual unwrapping/wrapping of components. +-- +-- @since 0.4.0.0 +concatInplyRec + :: Inply f + => V.Rec f (a ': as) + -> f (V.XRec V.Identity (a ': as)) +concatInplyRec (x V.:& xs) = case xs of + V.RNil -> invmap (V.::& V.RNil) (\case z V.::& _ -> z) x + _ V.:& _ -> gather + (V.::&) + (\case y V.::& ys -> (y, ys)) + x + (concatInplyRec xs) diff --git a/src/Data/Functor/Invariant/Inplicative/Free.hs b/src/Data/Functor/Invariant/Inplicative/Free.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/Inplicative/Free.hs @@ -0,0 +1,332 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Data.Functor.Invariant.Inplicative.Free +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provide an invariant functor combinator sequencer, like a combination of +-- 'Ap' and 'Div'. +-- +-- This module was named 'Data.Functor.Invariant.DecAlt' before v0.4.0.0 +-- +-- @since 0.4.0.0 +module Data.Functor.Invariant.Inplicative.Free ( + -- * Chain + DivAp(.., Gather, Knot) + , runCoDivAp + , runContraDivAp + , divApAp + , divApDiv + , foldDivAp + , assembleDivAp + , assembleDivApRec + -- * Nonempty Chain + , DivAp1(.., DivAp1) + , runCoDivAp1 + , runContraDivAp1 + , divApAp1 + , divApDiv1 + , foldDivAp1 + , assembleDivAp1 + , assembleDivAp1Rec + -- * Day Utility + , runDayApply + , runDayDivise + ) where + +import Control.Applicative +import Control.Applicative.Free (Ap(..)) +import Control.Applicative.ListF (MaybeF(..)) +import Control.Natural +import Data.Coerce +import Data.Functor.Apply +import Data.Functor.Apply.Free (Ap1(..)) +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Contravariant.Divisible.Free (Div(..), Div1) +import Data.Functor.Identity +import Data.Functor.Invariant +import Data.Functor.Invariant.Day +import Data.Functor.Invariant.Inplicative +import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) +import Data.HFunctor +import Data.HFunctor.Chain +import Data.HFunctor.Chain.Internal +import Data.HFunctor.Interpret +import Data.SOP hiding (hmap) +import qualified Data.Vinyl as V +import qualified Data.Vinyl.Functor as V + +-- | Interpret the covariant part of a 'Day' into a target context @h@, +-- as long as the context is an instance of 'Apply'. The 'Apply' is used to +-- combine results back together using '<*>'. +runDayApply + :: forall f g h. Apply h + => f ~> h + -> g ~> h + -> Day f g ~> h +runDayApply f g (Day x y j _) = liftF2 j (f x) (g y) + +-- | Interpret the contravariant part of a 'Day' into a target context +-- @h@, as long as the context is an instance of 'Divise'. The 'Divise' is +-- used to split up the input to pass to each of the actions. +runDayDivise + :: forall f g h. Divise h + => f ~> h + -> g ~> h + -> Day f g ~> h +runDayDivise f g (Day x y _ h) = divise h (f x) (g y) + +-- | In the covariant direction, we can interpret out of a 'Chain1' of 'Day' +-- into any 'Apply'. +runCoDivAp1 + :: forall f g. Apply g + => f ~> g + -> DivAp1 f ~> g +runCoDivAp1 f = foldDivAp1 f (runDayApply f id) + +-- | In the contravariant direction, we can interpret out of a 'Chain1' of +-- 'Day' into any 'Divise'. +runContraDivAp1 + :: forall f g. Divise g + => f ~> g + -> DivAp1 f ~> g +runContraDivAp1 f = foldDivAp1 f (runDayDivise f id) + +-- | In the covariant direction, we can interpret out of a 'Chain' of 'Day' +-- into any 'Applicative'. +runCoDivAp + :: forall f g. Applicative g + => f ~> g + -> DivAp f ~> g +runCoDivAp f = foldDivAp pure (\case Day x y h _ -> liftA2 h (f x) y) + +-- | In the contravariant direction, we can interpret out of a 'Chain' of +-- 'Day' into any 'Divisible'. +runContraDivAp + :: forall f g. Divisible g + => f ~> g + -> DivAp f ~> g +runContraDivAp f = foldDivAp (const conquer) (\case Day x y _ g -> divide g (f x) y) + +-- | General-purpose folder of 'DivAp'. Provide a way to handle the +-- identity ('pure'/'conquer'/'Knot') and a way to handle a cons +-- ('liftA2'/'divide'/'Gather'). +-- +-- @since 0.3.5.0 +foldDivAp + :: (forall x. x -> g x) + -> (Day f g ~> g) + -> DivAp f ~> g +foldDivAp f g = foldChain (f . runIdentity) g . unDivAp + +-- | General-purpose folder of 'DivAp1'. Provide a way to handle the +-- individual leaves and a way to handle a cons ('liftF2/'divise'/'Gather'). +-- +-- @since 0.3.5.0 +foldDivAp1 + :: (f ~> g) + -> (Day f g ~> g) + -> DivAp1 f ~> g +foldDivAp1 f g = foldChain1 f g . unDivAp1 + + + + + +-- | Extract the 'Ap' part out of a 'DivAp', shedding the +-- contravariant bits. +-- +-- @since 0.3.2.0 +divApAp :: DivAp f ~> Ap f +divApAp = runCoDivAp inject + +-- | Extract the 'Ap1' part out of a 'DivAp1', shedding the +-- contravariant bits. +-- +-- @since 0.3.2.0 +divApAp1 :: DivAp1 f ~> Ap1 f +divApAp1 = runCoDivAp1 inject + +-- | Extract the 'Div' part out of a 'DivAp', shedding the +-- covariant bits. +-- +-- @since 0.3.2.0 +divApDiv :: DivAp f ~> Div f +divApDiv = runContraDivAp inject + +-- | Extract the 'Div1' part out of a 'DivAp1', shedding the +-- covariant bits. +-- +-- @since 0.3.2.0 +divApDiv1 :: DivAp1 f ~> Div1 f +divApDiv1 = runContraDivAp1 inject + +-- | Match on a non-empty 'DivAp'; contains no @f@s, but only the +-- terminal value. Analogous to the 'Control.Applicative.Free.Ap' +-- constructor. +-- +-- Note that the order of the first two arguments has swapped as of +-- v0.4.0.0 +pattern Gather :: (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp f a +pattern Gather f g x xs <- (unGather_->MaybeF (Just (Day x xs f g))) + where + Gather f g x xs = DivAp $ More $ Day x (unDivAp xs) f g + +unGather_ :: DivAp f ~> MaybeF (Day f (DivAp f)) +unGather_ = \case + DivAp (More (Day x xs g f)) -> MaybeF . Just $ Day x (DivAp xs) g f + DivAp (Done _ ) -> MaybeF Nothing + +-- | Match on an "empty" 'DivAp'; contains no @f@s, but only the +-- terminal value. Analogous to 'Control.Applicative.Free.Pure'. +pattern Knot :: a -> DivAp f a +pattern Knot x = DivAp (Done (Identity x)) +{-# COMPLETE Gather, Knot #-} + +instance Inply (DivAp f) where + gather = coerce (gather @(Chain Day Identity _)) + +-- | The free 'Inplicative' +instance Inplicative (DivAp f) where + knot = coerce (knot @(Chain Day Identity _)) + +-- | Match on a 'DivAp1' to get the head and the rest of the items. +-- Analogous to the 'Data.Functor.Apply.Free.Ap1' constructor. +-- +-- Note that the order of the first two arguments has swapped as of +-- v0.4.0.0 +pattern DivAp1 :: Invariant f => (b -> c -> a) -> (a -> (b, c)) -> f b -> DivAp f c -> DivAp1 f a +pattern DivAp1 f g x xs <- (coerce splitChain1->Day x xs f g) + where + DivAp1 f g x xs = unsplitNE $ Day x xs f g +{-# COMPLETE DivAp1 #-} + +-- | The free 'Inplicative' +instance Invariant f => Inply (DivAp1 f) where + gather = coerce (gather @(Chain1 Day _)) + +-- | Convenient wrapper to build up a 'DivAp' by providing each +-- component of it. This makes it much easier to build up longer chains +-- because you would only need to write the splitting/joining functions in +-- one place. +-- +-- For example, if you had a data type +-- +-- @ +-- data MyType = MT Int Bool String +-- @ +-- +-- and an invariant functor @Prim@ (representing, say, a bidirectional +-- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), +-- then you could assemble a bidirectional parser for a @MyType@ using: +-- +-- @ +-- invmap (\(MyType x y z) -> I x :* I y :* I z :* Nil) +-- (\(I x :* I y :* I z :* Nil) -> MyType x y z) $ +-- assembleDivAp $ intPrim +-- :* boolPrim +-- :* stringPrim +-- :* Nil +-- @ +-- +-- Some notes on usefulness depending on how many components you have: +-- +-- * If you have 0 components, use 'Knot' directly. +-- * If you have 1 component, use 'inject' or 'injectChain' directly. +-- * If you have 2 components, use 'toListBy' or 'toChain'. +-- * If you have 3 or more components, these combinators may be useful; +-- otherwise you'd need to manually peel off tuples one-by-one. +-- +-- If each component is itself a @'DivAp' f@ (instead of @f@), you can use +-- 'concatInplicative'. +assembleDivAp + :: NP f as + -> DivAp f (NP I as) +assembleDivAp = \case + Nil -> DivAp $ Done $ Identity Nil + x :* xs -> DivAp $ More $ Day + x + (unDivAp (assembleDivAp xs)) + (\y ys -> I y :* ys) + (\case I y :* ys -> (y, ys)) + +-- | A version of 'assembleDivAp' but for 'DivAp1' instead. Can be +-- useful if you intend on interpreting it into something with only +-- a 'Divise' or 'Apply' instance, but no 'Divisible' or 'Applicative'. +-- +-- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use +-- 'concatInply'. +assembleDivAp1 + :: Invariant f + => NP f (a ': as) + -> DivAp1 f (NP I (a ': as)) +assembleDivAp1 (x :* xs) = DivAp1_ $ case xs of + Nil -> Done1 $ invmap ((:* Nil) . I) (unI . hd) x + _ :* _ -> More1 $ Day + x + (unDivAp1 (assembleDivAp1 xs)) + (\y ys -> I y :* ys) + (\case I y :* ys -> (y, ys)) + +-- | A version of 'assembleDivAp' using 'V.XRec' from /vinyl/ instead of +-- 'NP' from /sop-core/. This can be more convenient because it doesn't +-- require manual unwrapping/wrapping of components. +-- +-- @ +-- data MyType = MT Int Bool String +-- +-- invmap (\(MyType x y z) -> x ::& y ::& z ::& RNil) +-- (\(x ::& y ::& z ::& RNil) -> MyType x y z) $ +-- assembleDivApRec $ intPrim +-- :& boolPrim +-- :& stringPrim +-- :& Nil +-- @ +-- +-- If each component is itself a @'DivAp' f@ (instead of @f@), you can use +-- 'concatDivApRec'. +assembleDivApRec + :: V.Rec f as + -> DivAp f (V.XRec V.Identity as) +assembleDivApRec = \case + V.RNil -> DivAp $ Done $ Identity V.RNil + x V.:& xs -> DivAp $ More $ Day + x + (unDivAp (assembleDivApRec xs)) + (V.::&) + unconsRec + +-- | A version of 'assembleDivAp1' using 'V.XRec' from /vinyl/ instead of +-- 'NP' from /sop-core/. This can be more convenient because it doesn't +-- require manual unwrapping/wrapping of components. +-- +-- If each component is itself a @'DivAp1' f@ (instead of @f@), you can use +-- 'concatDivAp1Rec'. +assembleDivAp1Rec + :: Invariant f + => V.Rec f (a ': as) + -> DivAp1 f (V.XRec V.Identity (a ': as)) +assembleDivAp1Rec (x V.:& xs) = case xs of + V.RNil -> DivAp1_ $ Done1 $ invmap (V.::& V.RNil) (\case z V.::& _ -> z) x + _ V.:& _ -> DivAp1_ $ More1 $ Day + x + (unDivAp1 (assembleDivAp1Rec xs)) + (V.::&) + unconsRec + +unconsRec :: V.XRec V.Identity (a ': as) -> (a, V.XRec V.Identity as) +unconsRec (y V.::& ys) = (y, ys) + +-- | A free 'Inply' +instance Inply f => Interpret DivAp1 f where + interpret f (DivAp1_ x) = foldChain1 f (runDay f id) x + +-- | A free 'Inplicative' +instance Inplicative f => Interpret DivAp f where + interpret f (DivAp x) = foldChain (knot . runIdentity) (runDay f id) x diff --git a/src/Data/Functor/Invariant/Internative.hs b/src/Data/Functor/Invariant/Internative.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/Internative.hs @@ -0,0 +1,170 @@ +-- | +-- Module : Data.Functor.Invariant.Internative +-- Copyright : (c) Justin Le 2021 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Contains the classes 'Inalt' and 'Inplus', the invariant +-- counterparts to 'Alt'/'Plus' and 'Decide'/'Conclude' and +-- 'Alternative'/'Decidable'. +-- +-- @since 0.4.0.0 +module Data.Functor.Invariant.Internative ( + -- * Typeclass + Inalt(..) + , Inplus(..) + , Internative + -- * Assembling Helpers + , concatInplus + , concatInalt + ) where + +import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative +import Data.SOP hiding (hmap) +import Data.Void + +-- | The invariant counterpart of 'Alt' and 'Decide'. +-- +-- Conceptually you can think of 'Alt' as, given a way to "inject" @a@ and +-- @b@ as @c@, lets you merge @f a@ (producer of @a@) and @f b@ (producer +-- of @b@) into a @f c@ (producer of @c@), in an "either-or" fashion. +-- 'Decide' can be thought of as, given a way to "discriminate" a @c@ as +-- either a @a@ or a @b@, lets you merge @f a@ (consumer of @a@) and @f b@ +-- (consumder of @b@) into a @f c@ (consumer of @c@) in an "either-or" +-- forking fashion (split the @c@ into @a@ or @b@, and use the appropriate +-- handler). +-- +-- 'Inalt', for 'swerve', requires both an injecting function and +-- a choosing function in order to merge @f b@ (producer and consumer of +-- @b@) and @f c@ (producer and consumer of @c@) into a @f a@ in an +-- either-or manner. You can think of it as, for the @f a@, it "chooses" +-- if the @a@ is actually a @b@ or a @c@ with the @a -> 'Either' b c@, +-- feeds it to either the original @f b@ or the original @f c@, and then +-- re-injects the output back into a @a@ with the @b -> a@ or the @c -> a@. +-- +-- @since 0.4.0.0 +class Invariant f => Inalt f where + -- | Like '', 'decide', or 'choose', but requires both + -- an injecting and a choosing function. + -- + -- It is used to merge @f b@ (producer and consumer of @b@) and @f c@ + -- (producer and consumer of @c@) into a @f a@ in an either-or manner. + -- You can think of it as, for the @f a@, it "chooses" if the @a@ is + -- actually a @b@ or a @c@ with the @a -> 'Either' b c@, feeds it to + -- either the original @f b@ or the original @f c@, and then re-injects + -- the output back into a @a@ with the @b -> a@ or the @c -> a@. + -- + -- An important property is that it will only ever use exactly @one@ of + -- the options given in order to fulfil its job. If you swerve an @f + -- a@ and an @f b@ into an @f c@, in order to consume/produdce the @c@, + -- it will only use either the @f a@ or the @f b@ -- exactly one of + -- them. + -- + -- @since 0.4.0.0 + swerve + :: (b -> a) + -> (c -> a) + -> (a -> Either b c) + -> f b + -> f c + -> f a + swerve f g h x y = invmap (either f g) h (swerved x y) + -- | A simplified version of 'swerive' that splits to and from an + -- 'Either'. You can then use 'invmap' to reshape it into the proper + -- shape. + -- + -- @since 0.4.0.0 + swerved + :: f a + -> f b + -> f (Either a b) + swerved = swerve Left Right id + {-# MINIMAL swerve | swerved #-} + +-- | The invariant counterpart of 'Alt' and 'Conclude'. +-- +-- The main important action is described in 'Inalt', but this adds 'reject', +-- which is the counterpart to 'empty' and 'conclude' and 'conquer'. It's the identity to +-- 'swerve'; if combine two @f a@s with 'swerve', and one of them is +-- 'reject', then that banch will never be taken. +-- +-- Conceptually, if you think of 'swerve' as "choosing one path and +-- re-injecting back", then 'reject' introduces a branch that is impossible +-- to take. + +-- @since 0.4.0.0 +class Inalt f => Inplus f where + reject :: (a -> Void) -> f a + +-- | The invariant counterpart to 'Alternative' and 'Decidable': represents +-- a combination of both 'Applicative' and 'Alt', or 'Divisible' and +-- 'Conclude'. There are laws? + +-- @since 0.4.0.0 +class (Inplus f, Inplicative f) => Internative f + +-- | Convenient wrapper to build up an 'Inplus' instance on by providing +-- each branch of it. This makes it much easier to build up longer chains +-- because you would only need to write the splitting/joining functions in +-- one place. +-- +-- For example, if you had a data type +-- +-- @ +-- data MyType = MTI Int | MTB Bool | MTS String +-- @ +-- +-- and an invariant functor and 'Inplus' instance @Prim@ (representing, say, +-- a bidirectional parser, where @Prim Int@ is a bidirectional parser for +-- an 'Int'@), then you could assemble a bidirectional parser for +-- a @MyType@ using: +-- +-- @ +-- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) +-- (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $ +-- concatInplus $ intPrim +-- :* boolPrim +-- :* stringPrim +-- :* Nil +-- @ +-- +-- Some notes on usefulness depending on how many components you have: +-- +-- * If you have 0 components, use 'reject' directly. +-- * If you have 1 component, use 'inject' directly. +-- * If you have 2 components, use 'swerve' directly. +-- * If you have 3 or more components, these combinators may be useful; +-- otherwise you'd need to manually peel off eithers one-by-one. +concatInplus + :: Inplus f + => NP f as + -> f (NS I as) +concatInplus = \case + Nil -> reject $ \case {} + x :* xs -> swerve + (Z . I) + S + (\case Z (I y) -> Left y; S ys -> Right ys) + x + (concatInplus xs) + +-- | A version of 'concatInplus' for non-empty 'NP', but only +-- requiring an 'Inalt' instance. +-- +-- @since 0.4.0.0 +concatInalt + :: Inalt f + => NP f (a ': as) + -> f (NS I (a ': as)) +concatInalt (x :* xs) = case xs of + Nil -> invmap (Z . I) (\case Z (I y) -> y; S ys -> case ys of {}) x + _ :* _ -> swerve + (Z . I) + S + (\case Z (I y) -> Left y; S ys -> Right ys) + x + (concatInalt xs) diff --git a/src/Data/Functor/Invariant/Internative/Free.hs b/src/Data/Functor/Invariant/Internative/Free.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Invariant/Internative/Free.hs @@ -0,0 +1,269 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | +-- Module : Data.Functor.Invariant.Internative.Free +-- Copyright : (c) Justin Le 2019 +-- License : BSD3 +-- +-- Maintainer : justin@jle.im +-- Stability : experimental +-- Portability : non-portable +-- +-- Provide an invariant functor combinator choice-collector, like +-- a combination of 'ListF' and 'Dec'. +-- +-- This module was named 'Data.Functor.Invariant.DecAlt' before v0.4.0.0 +-- +-- @since 0.4.0.0 +module Data.Functor.Invariant.Internative.Free ( + -- * Chain + DecAlt(.., Swerve, Reject) + , runCoDecAlt + , runContraDecAlt + , decAltListF + , decAltListF_ + , decAltDec + , foldDecAlt + , assembleDecAlt + -- * Nonempty Chain + , DecAlt1(.., DecAlt1) + , runCoDecAlt1 + , runContraDecAlt1 + , decAltNonEmptyF + , decAltNonEmptyF_ + , decAltDec1 + , foldDecAlt1 + , assembleDecAlt1 + ) where + +import Control.Applicative.ListF +import Control.Natural +import Data.Coerce +import Data.Functor.Alt +import Data.Functor.Contravariant.Conclude +import Data.Functor.Contravariant.Decide +import Data.Functor.Contravariant.Divisible.Free +import Data.Functor.Invariant +import Data.Functor.Invariant.Internative +import Data.Functor.Invariant.Night +import Data.Functor.Plus +import Data.HBifunctor.Tensor hiding (elim1, elim2, intro1, intro2) +import Data.HFunctor +import Data.HFunctor.Chain +import Data.HFunctor.Chain.Internal +import Data.SOP hiding (hmap) +import Data.Void +import qualified Control.Monad.Trans.Compose as CT +import qualified Data.Functor.Coyoneda as CY +import qualified Data.List.NonEmpty as NE + + +-- | In the covariant direction, we can interpret out of a 'Chain1' of 'Night' +-- into any 'Alt'. +runCoDecAlt1 + :: forall f g. Alt g + => f ~> g + -> DecAlt1 f ~> g +runCoDecAlt1 f = foldDecAlt1 f (runNightAlt f id) + +-- | In the contravariant direction, we can interpret out of a 'Chain1' of +-- 'Night' into any 'Decide'. +runContraDecAlt1 + :: forall f g. Decide g + => f ~> g + -> DecAlt1 f ~> g +runContraDecAlt1 f = foldDecAlt1 f (runNightDecide f id) + +-- | Extract the 'Dec' part out of a 'DecAlt', shedding the +-- covariant bits. +decAltDec :: DecAlt f ~> Dec f +decAltDec = runContraDecAlt inject + +-- | Extract the 'Dec1' part out of a 'DecAlt1', shedding the +-- covariant bits. +decAltDec1 :: DecAlt1 f ~> Dec1 f +decAltDec1 = runContraDecAlt1 inject + +-- | In the covariant direction, we can interpret out of a 'Chain' of 'Night' +-- into any 'Plus'. +runCoDecAlt + :: forall f g. Plus g + => f ~> g + -> DecAlt f ~> g +runCoDecAlt f = foldDecAlt (const zero) (runNightAlt f id) + +-- | In the contravariant direction, we can interpret out of a 'Chain' of +-- 'Night' into any 'Conclude'. +runContraDecAlt + :: forall f g. Conclude g + => f ~> g + -> DecAlt f ~> g +runContraDecAlt f = foldDecAlt conclude (runNightDecide f id) + +-- | Extract the 'ListF' part out of a 'DecAlt', shedding the +-- contravariant bits. +-- +-- @since 0.3.2.0 +decAltListF :: Functor f => DecAlt f ~> ListF f +decAltListF = runCoDecAlt inject + +-- | Extract the 'ListF' part out of a 'DecAlt', shedding the +-- contravariant bits. +-- +-- This version does not require a 'Functor' constraint because it converts +-- to the coyoneda-wrapped product, which is more accurately the true +-- conversion to a covariant chain. +-- +-- @since 0.3.2.0 +decAltListF_ :: DecAlt f ~> CT.ComposeT ListF CY.Coyoneda f +decAltListF_ = foldDecAlt (const (CT.ComposeT (ListF []))) $ \case + Night x (CT.ComposeT (ListF xs)) f g _ -> CT.ComposeT . ListF $ + CY.Coyoneda f x : (map . fmap) g xs + +-- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the +-- contravariant bits. +-- +-- @since 0.3.2.0 +decAltNonEmptyF :: Functor f => DecAlt1 f ~> NonEmptyF f +decAltNonEmptyF = runCoDecAlt1 inject + +-- | Extract the 'NonEmptyF' part out of a 'DecAlt1', shedding the +-- contravariant bits. +-- +-- This version does not require a 'Functor' constraint because it converts +-- to the coyoneda-wrapped product, which is more accurately the true +-- conversion to a covariant chain. +-- +-- @since 0.3.2.0 +decAltNonEmptyF_ :: DecAlt1 f ~> CT.ComposeT NonEmptyF CY.Coyoneda f +decAltNonEmptyF_ = foldDecAlt1 inject $ \case + Night x (CT.ComposeT (NonEmptyF xs)) f g _ -> CT.ComposeT . NonEmptyF $ + CY.Coyoneda f x NE.<| (fmap . fmap) g xs + +-- | General-purpose folder of 'DecAlt'. Provide a way to handle the +-- identity ('empty'/'conclude'/'Reject') and a way to handle a cons +-- (''/'decide'/'swerve'). +-- +-- @since 0.3.5.0 +foldDecAlt + :: (forall x. (x -> Void) -> g x) + -> (Night f g ~> g) + -> DecAlt f ~> g +foldDecAlt f g = foldChain (f . refute) g . unDecAlt + +-- | General-purpose folder of 'DecAlt1'. Provide a way to handle the +-- individual leaves and a way to handle a cons (''/'decide'/'swerve'). +-- +-- @since 0.3.5.0 +foldDecAlt1 + :: (f ~> g) + -> (Night f g ~> g) + -> DecAlt1 f ~> g +foldDecAlt1 f g = foldChain1 f g . unDecAlt1 + +-- | Match on a non-empty 'DecAlt'; contains the splitting function, +-- the two rejoining functions, the first @f@, and the rest of the chain. +-- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Choose' +-- constructor. +pattern Swerve :: (b -> a) -> (c -> a) -> (a -> Either b c) -> f b -> DecAlt f c -> DecAlt f a +pattern Swerve f g h x xs <- (unSwerve_->MaybeF (Just (Night x xs f g h))) + where + Swerve f g h x xs = DecAlt $ More $ Night x (unDecAlt xs) f g h + +unSwerve_ :: DecAlt f ~> MaybeF (Night f (DecAlt f)) +unSwerve_ = \case + DecAlt (More (Night x xs g f h)) -> MaybeF . Just $ Night x (DecAlt xs) g f h + DecAlt (Done _ ) -> MaybeF Nothing + + +-- | Match on an "empty" 'DecAlt'; contains no @f@s, but only the +-- terminal value. Analogous to the +-- 'Data.Functor.Contravariant.Divisible.Free.Lose' constructor. +pattern Reject :: (a -> Void) -> DecAlt f a +pattern Reject x = DecAlt (Done (Not x)) +{-# COMPLETE Swerve, Reject #-} + +instance Inalt (DecAlt f) where + swerve = coerce (swerve @(Chain Night Not _)) + +instance Inplus (DecAlt f) where + reject = coerce (reject @(Chain Night Not _)) + +-- | Match on a 'DecAlt1' to get the head and the rest of the items. +-- Analogous to the 'Data.Functor.Contravariant.Divisible.Free.Dec1' +-- constructor. +pattern DecAlt1 :: Invariant f => (b -> a) -> (c -> a) -> (a -> Either b c) -> f b -> DecAlt f c -> DecAlt1 f a +pattern DecAlt1 f g h x xs <- (coerce splitChain1->Night x xs f g h) + where + DecAlt1 f g h x xs = unsplitNE $ Night x xs f g h +{-# COMPLETE DecAlt1 #-} + +instance Invariant f => Inalt (DecAlt1 f) where + swerve = coerce (swerve @(Chain1 Night _)) + +-- | Convenient wrapper to build up a 'DecAlt' on by providing each +-- branch of it. This makes it much easier to build up longer chains +-- because you would only need to write the splitting/joining functions in +-- one place. +-- +-- For example, if you had a data type +-- +-- @ +-- data MyType = MTI Int | MTB Bool | MTS String +-- @ +-- +-- and an invariant functor @Prim@ (representing, say, a bidirectional +-- parser, where @Prim Int@ is a bidirectional parser for an 'Int'@), +-- then you could assemble a bidirectional parser for a @MyType@ using: +-- +-- @ +-- invmap (\case MTI x -> Z (I x); MTB y -> S (Z (I y)); MTS z -> S (S (Z (I z)))) +-- (\case Z (I x) -> MTI x; S (Z (I y)) -> MTB y; S (S (Z (I z))) -> MTS z) $ +-- assembleDecAlt $ intPrim +-- :* boolPrim +-- :* stringPrim +-- :* Nil +-- @ +-- +-- Some notes on usefulness depending on how many components you have: +-- +-- * If you have 0 components, use 'Reject' directly. +-- * If you have 1 component, use 'inject' or 'injectChain' directly. +-- * If you have 2 components, use 'toListBy' or 'toChain'. +-- * If you have 3 or more components, these combinators may be useful; +-- otherwise you'd need to manually peel off eithers one-by-one. +-- +-- If each component is itself a @'DecAlt' f@ (instead of @f@), you can use +-- 'concatInplus'. +assembleDecAlt + :: NP f as + -> DecAlt f (NS I as) +assembleDecAlt = \case + Nil -> DecAlt $ Done $ Not (\case {}) + x :* xs -> DecAlt $ More $ Night + x + (unDecAlt $ assembleDecAlt xs) + (Z . I) + S + (\case Z (I y) -> Left y; S ys -> Right ys) + +-- | A version of 'assembleDecAlt' but for 'DecAlt1' instead. Can +-- be useful if you intend on interpreting it into something with only +-- a 'Decide' or 'Alt' instance, but no +-- 'Data.Functor.Contravariant.Divisible.Decidable' or 'Plus' or +-- 'Control.Applicative.Alternative'. +-- +-- If each component is itself a @'DecAlt1' f@ (instead of @f@), you can +-- use 'concatInalt'. +assembleDecAlt1 + :: Invariant f + => NP f (a ': as) + -> DecAlt1 f (NS I (a ': as)) +assembleDecAlt1 (x :* xs) = DecAlt1_ $ case xs of + Nil -> Done1 $ invmap (Z . I) (unI . unZ) x + _ :* _ -> More1 $ Night + x + (unDecAlt1 $ assembleDecAlt1 xs) + (Z . I) + S + (\case Z (I y) -> Left y; S ys -> Right ys) diff --git a/src/Data/Functor/Invariant/Night.hs b/src/Data/Functor/Invariant/Night.hs --- a/src/Data/Functor/Invariant/Night.hs +++ b/src/Data/Functor/Invariant/Night.hs @@ -15,6 +15,8 @@ Night(..) , Not(..), refuted , night + , runNight + , nerve , runNightAlt , runNightDecide , toCoNight @@ -33,6 +35,7 @@ import Data.Functor.Contravariant.Decide import Data.Functor.Contravariant.Night (Not(..), refuted) import Data.Functor.Invariant +import Data.Functor.Invariant.Internative import Data.Kind import Data.Void import GHC.Generics @@ -63,19 +66,19 @@ data Night :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) where Night :: f b -> g c - -> (a -> Either b c) -> (b -> a) -> (c -> a) + -> (a -> Either b c) -> Night f g a instance Invariant (Night f g) where - invmap f g (Night x y h j k) = Night x y (h . g) (f . j) (f . k) + invmap f g (Night x y h j k) = Night x y (f . h) (f . j) (k . g) -- | Pair two invariant actions together into a 'Night'; assigns the first -- one to 'Left' inputs and outputs and the second one to 'Right' inputs -- and outputs. night :: f a -> g b -> Night f g (Either a b) -night x y = Night x y id Left Right +night x y = Night x y Left Right id -- | Interpret the covariant part of a 'Night' into a target context @h@, -- as long as the context is an instance of 'Alt'. The 'Alt' is used to @@ -85,7 +88,7 @@ => f ~> h -> g ~> h -> Night f g ~> h -runNightAlt f g (Night x y _ j k) = fmap j (f x) fmap k (g y) +runNightAlt f g (Night x y h j _) = fmap h (f x) fmap j (g y) -- | Interpret the contravariant part of a 'Night' into a target context -- @h@, as long as the context is an instance of 'Decide'. The 'Decide' is @@ -95,7 +98,7 @@ => f ~> h -> g ~> h -> Night f g ~> h -runNightDecide f g (Night x y h _ _) = decide h (f x) (g y) +runNightDecide f g (Night x y _ _ k) = decide k (f x) (g y) -- | Convert an invariant 'Night' into the covariant version, dropping the -- contravariant part. @@ -104,7 +107,7 @@ -- library, so we use an equivalent type (if @f@ and @g@ are 'Functor's) @f -- ':*:' g@. toCoNight :: (Functor f, Functor g) => Night f g ~> f :*: g -toCoNight (Night x y _ f g) = fmap f x :*: fmap g y +toCoNight (Night x y f g _) = fmap f x :*: fmap g y -- | Convert an invariant 'Night' into the covariant version, dropping the -- contravariant part. @@ -115,53 +118,75 @@ -- -- @since 0.3.2.0 toCoNight_ :: Night f g ~> CY.Coyoneda f :*: CY.Coyoneda g -toCoNight_ (Night x y _ f g) = CY.Coyoneda f x :*: CY.Coyoneda g y +toCoNight_ (Night x y f g _) = CY.Coyoneda f x :*: CY.Coyoneda g y -- | Convert an invariant 'Night' into the contravariant version, dropping -- the covariant part. toContraNight :: Night f g ~> CN.Night f g -toContraNight (Night x y f _ _) = CN.Night x y f +toContraNight (Night x y _ _ h) = CN.Night x y h +-- | Interpret out of a 'Night' into any instance of 'Inalt' by providing +-- two interpreting functions. +-- +-- @since 0.4.0.0 +runNight + :: Inalt h + => (f ~> h) + -> (g ~> h) + -> Night f g ~> h +runNight f g (Night x y a b c) = swerve a b c (f x) (g y) + +-- | Squash the two items in a 'Night' using their natural 'Inalt' +-- instances. +-- +-- @since 0.4.0.0 +nerve + :: Inalt f + => Night f f ~> f +nerve (Night x y a b c) = swerve a b c x y + -- | 'Night' is associative. assoc :: Night f (Night g h) ~> Night (Night f g) h assoc (Night x (Night y z f g h) j k l) = - Night (Night x y id Left Right) z - (B.unassoc . second f . j) - (either k (l . g)) - (l . h) + Night (Night x y Left Right id) z + (either j (k . f)) + (k . g) + (B.unassoc . second h . l) -- | 'Night' is associative. unassoc :: Night (Night f g) h ~> Night f (Night g h) unassoc (Night (Night x y f g h) z j k l) = - Night x (Night y z id Left Right) - (B.assoc . first f . j) - (k . g) - (either (k . h) l) + Night x (Night y z Left Right id) + (j . f) + (either (j . g) k) + (B.assoc . first h . l) + -- (k . g) + -- (either (k . h) l) -- | The left identity of 'Night' is 'Not'; this is one side of that -- isomorphism. intro1 :: g ~> Night Not g -intro1 y = Night refuted y Right absurd id +intro1 y = Night refuted y absurd id Right -- | The right identity of 'Night' is 'Not'; this is one side of that -- isomorphism. intro2 :: f ~> Night f Not -intro2 x = Night x refuted Left id absurd +intro2 x = Night x refuted id absurd Left -- | The left identity of 'Night' is 'Not'; this is one side of that -- isomorphism. elim1 :: Invariant g => Night Not g ~> g -elim1 (Night x y f _ h) = invmap h (either (absurd . refute x) id . f) y +elim1 (Night x y _ g h) = invmap g (either (absurd . refute x) id . h) y -- | The right identity of 'Night' is 'Not'; this is one side of that -- isomorphism. elim2 :: Invariant f => Night f Not ~> f -elim2 (Night x y f g _) = invmap g (either id (absurd . refute y) . f) x +elim2 (Night x y f _ h) = invmap f (either id (absurd . refute y) . h) x -- | The two sides of a 'Night' can be swapped. swapped :: Night f g ~> Night g f -swapped (Night x y f g h) = Night y x (B.swap . f) h g +swapped (Night x y f g h) = Night y x g f (B.swap . h) -- | Hoist a function over the left side of a 'Night'. trans1 :: f ~> h -> Night f g ~> Night h g diff --git a/src/Data/HBifunctor/Associative.hs b/src/Data/HBifunctor/Associative.hs --- a/src/Data/HBifunctor/Associative.hs +++ b/src/Data/HBifunctor/Associative.hs @@ -76,6 +76,8 @@ import Data.Functor.Day (Day(..)) import Data.Functor.Identity import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative +import Data.Functor.Invariant.Internative import Data.Functor.Plus import Data.Functor.Product import Data.Functor.Sum @@ -521,6 +523,11 @@ (\a (b, c) -> g (j a b) c) (B.assoc . first h . f) +-- | @since 0.4.0.0 +instance Inply f => SemigroupIn ID.Day f where + biretract = dather + binterpret = runDay + instance Associative IN.Night where type NonEmptyBy IN.Night = DecAlt1 type FunctorBy IN.Night = Invariant @@ -536,10 +543,15 @@ appendNEINight_ (IN.Night xs ys f g h) = case xs of Done1 x -> More1 (IN.Night x ys f g h) More1 (IN.Night z zs j k l) -> More1 $ - IN.Night z (appendNEINight_ (IN.Night zs ys id Left Right)) - (B.assoc . first j . f) - (g . k) - (either (g . l) h) + IN.Night z (appendNEINight_ (IN.Night zs ys Left Right id)) + (f . j) + (either (f . k) g) + (B.assoc . first l . h) + +-- | @since 0.4.0.0 +instance Inalt f => SemigroupIn IN.Night f where + biretract = IN.nerve + binterpret = IN.runNight -- | @since 0.3.0.0 instance Associative Night where diff --git a/src/Data/HBifunctor/Tensor.hs b/src/Data/HBifunctor/Tensor.hs --- a/src/Data/HBifunctor/Tensor.hs +++ b/src/Data/HBifunctor/Tensor.hs @@ -95,6 +95,8 @@ import Data.Functor.Day (Day(..)) import Data.Functor.Identity import Data.Functor.Invariant +import Data.Functor.Invariant.Internative +import Data.Functor.Invariant.Inplicative import Data.Functor.Plus import Data.Functor.Product import Data.Functor.Sum @@ -497,6 +499,9 @@ Done x -> L1 x More xs -> R1 $ unsplitNEIDay_ xs +instance Inplicative f => MonoidIn ID.Day Identity f where + pureT (Identity x) = knot x + instance Tensor IN.Night IN.Not where type ListBy IN.Night = DecAlt @@ -506,13 +511,13 @@ elim2 = IN.elim1 appendLB (IN.Night (DecAlt xs) (DecAlt ys) f g h) = DecAlt $ case xs of - Done r -> invmap h (either (absurd . refute r) id . f) ys + Done r -> invmap g (either (absurd . refute r) id . h) ys More (IN.Night z zs j k l) -> More $ IN.Night z - (unDecAlt $ appendLB (IN.Night (DecAlt zs) (DecAlt ys) id Left Right)) - (B.assoc . first j . f) - (g . k) - (either (g . l) h) + (unDecAlt $ appendLB (IN.Night (DecAlt zs) (DecAlt ys) Left Right id)) + (f . j) + (either (f . k) g) + (B.assoc . first l . h) splitNE = coerce splitChain1 splittingLB = coercedF . splittingChain . coercedF @@ -524,13 +529,17 @@ unsplitNEINight_ :: Invariant f => IN.Night f (Chain IN.Night Not f) ~> Chain1 IN.Night f unsplitNEINight_ (IN.Night x xs f g h) = case xs of - Done r -> Done1 $ invmap g (either id (absurd . refute r) . f) x + Done r -> Done1 $ invmap f (either id (absurd . refute r) . h) x More ys -> More1 $ IN.Night x (unsplitNEINight_ ys) f g h matchLBINight_ :: Invariant f => Chain IN.Night Not f ~> (Not :+: Chain1 IN.Night f) matchLBINight_ = \case Done x -> L1 x More xs -> R1 $ unsplitNEINight_ xs + +-- | @since 0.4.0.0 +instance Inplus f => MonoidIn IN.Night IN.Not f where + pureT (Not x) = reject x -- | @since 0.3.0.0 instance Tensor Night Not where diff --git a/src/Data/HBifunctor/Tensor/Internal.hs b/src/Data/HBifunctor/Tensor/Internal.hs --- a/src/Data/HBifunctor/Tensor/Internal.hs +++ b/src/Data/HBifunctor/Tensor/Internal.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide, not-home #-} module Data.HBifunctor.Tensor.Internal ( Tensor(..) diff --git a/src/Data/HFunctor/Chain.hs b/src/Data/HFunctor/Chain.hs --- a/src/Data/HFunctor/Chain.hs +++ b/src/Data/HFunctor/Chain.hs @@ -69,6 +69,9 @@ import Data.Functor.Contravariant.Divisible import Data.Functor.Day hiding (intro1, intro2, elim1, elim2) import Data.Functor.Identity +import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative +import Data.Functor.Invariant.Internative import Data.Functor.Plus import Data.Functor.Product import Data.HBifunctor @@ -82,6 +85,8 @@ import GHC.Generics import qualified Data.Functor.Contravariant.Day as CD import qualified Data.Functor.Contravariant.Night as N +import qualified Data.Functor.Invariant.Day as ID +import qualified Data.Functor.Invariant.Night as IN instance (HBifunctor t, SemigroupIn t f) => Interpret (Chain1 t) f where retract = \case @@ -175,9 +180,17 @@ instance Contravariant f => Decide (Chain1 N.Night f) where decide f x y = appendChain1 $ N.Night x y f +-- | @since 0.4.0.0 +instance Invariant f => Inply (Chain1 ID.Day f) where + gather f g x y = appendChain1 (ID.Day x y f g) + instance Tensor t i => Inject (Chain t i) where inject = injectChain +-- | @since 0.4.0.0 +instance Invariant f => Inalt (Chain1 IN.Night f) where + swerve f g h x y = appendChain1 (IN.Night x y f g h) + -- | We can collapse and interpret an @'Chain' t i@ if we have @'Tensor' t@. instance MonoidIn t i f => Interpret (Chain t i) f where interpret @@ -287,6 +300,22 @@ divide f x y = appendChain $ CD.Day x y f conquer = Done Proxy +-- | @since 0.4.0.0 +instance Inply (Chain ID.Day Identity f) where + gather f g x y = appendChain (ID.Day x y f g) + +-- | @since 0.4.0.0 +instance Inplicative (Chain ID.Day Identity f) where + knot = Done . Identity + +-- | @since 0.4.0.0 +instance Inalt (Chain IN.Night IN.Not f) where + swerve f g h x y = appendChain (IN.Night x y f g h) + +-- | @since 0.4.0.0 +instance Inplus (Chain IN.Night IN.Not f) where + reject = Done . IN.Not + -- | @since 0.3.0.0 instance Decide (Chain N.Night N.Not f) where decide f x y = appendChain $ N.Night x y f @@ -332,3 +361,4 @@ -- 'Plus'. instance Functor f => Plus (Chain Product Proxy f) where zero = Done Proxy + diff --git a/src/Data/HFunctor/Chain/Internal.hs b/src/Data/HFunctor/Chain/Internal.hs --- a/src/Data/HFunctor/Chain/Internal.hs +++ b/src/Data/HFunctor/Chain/Internal.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_HADDOCK hide, not-home #-} module Data.HFunctor.Chain.Internal ( Chain1(..) @@ -23,8 +24,10 @@ import Data.Functor.Contravariant import Data.Functor.Identity import Data.Functor.Invariant +import Data.Functor.Invariant.Internative import Data.HBifunctor import Data.HFunctor +import Data.HFunctor.Interpret import Data.HFunctor.HTraversable import Data.Kind import Data.Typeable @@ -378,26 +381,20 @@ -- all @f x@s to each interpret, and then re-combined again to produce the -- resulting @a@. -- --- You run this in any 'Apply' context if you want to interpret it --- covariantly, treating @'DivAp1' f a@ as a /producer/ of @a@, using --- 'runCoDivAp1'. You can run this in any 'Divise' context if you you --- want to interpret it contravariantly, treating @'DivAp1' f a@ as --- a /consumer/ of @a@s, using 'runContraDivAp1'. --- --- Because there is no typeclass that combines both 'Apply' and --- 'Divise', this type is a little bit tricker to construct/use than --- 'Ap1' or 'Div1'. +-- To do this, the main tools to combine 'DivAp1's are its 'Inply' +-- instance, using 'gather' to combine two 'DivAp1's in +-- a parallel-fork-like manner (with the splitting and re-combining +-- function). -- --- * Instead of '<.>' and 'divide' (typeclass methods), use --- 'Data.Functor.Invariant.DivAp.gather1' and other variants, which work --- specifically on this type only. --- * Instead of using 'interpret' (to run in a typeclass), either use --- 'runCoDivAp1' (to run in 'Apply'), 'runContraDivAp1' (to run in --- 'Divise'), or 'foldDivAp1' (to interpret by manually providing --- handlers) +-- This does have an 'Interpret' function, but the target typeclass +-- ('Inply') doesn't have too many useful instances. Instead, you are +-- probably going to run it into either 'Apply' instance (to "produce" an +-- @a@ from a @'DivAp1' f a@) with 'runCoDivAp1', or a 'Divise' instance +-- (to "consume" an @a@ from a @'DivAp1' f a@) with 'runContraDivAp1'. -- --- You can also extract the 'Ap1' part out using 'divApAp1', and extract the --- 'Div1' part out using 'divApDiv1'. +-- If you think of this type as a combination of 'Ap1' and 'Div1', then +-- you can also extract the 'Ap1' part out using 'divApAp1', and +-- extract the 'Div1' part out using 'divApDiv1'. -- -- Note that this type's utility is similar to that of @'PreT' 'Ap1'@, -- except @'PreT' 'Ap1'@ lets you use 'Apply' typeclass methods to assemble @@ -435,28 +432,22 @@ -- When interpreting this, each @a@ is distributed across all @f x@s to -- each interpret, and then re-combined again to produce the resulting @a@. -- --- You run this in any 'Applicative' context if you want to interpret it --- covariantly, treating @'DivAp' f a@ as a /producer/ of @a@, using --- 'runCoDivAp'. You can run this in any 'Divisible' context if you you --- want to interpret it contravariantly, treating @'DivAp' f a@ as --- a /consumer/ of @a@s, using 'runContraDivAp'. --- --- Because there is no typeclass that combines both 'Applicative' and --- 'Divisible', this type is a little bit tricker to construct/use than --- 'Ap' or 'Div'. +-- To do this, the main tools to combine 'DivAp's are its 'Inply' +-- instance, using 'gather' to combine two 'DivAp's in a choice-like +-- manner (with the splitting and re-combining function), and its +-- 'Inplicative' instance, using 'knot' to create an "empty" branch that +-- does not contribute to the structure. -- --- * Instead of '<*>' and 'divide' (typeclass methods), use --- 'Data.Functor.Invariant.DivAp.gather' and other variants, which work --- specifically on this type only. --- * Instead of 'pure' and 'conquer' (typeclass methods), use --- 'Data.Functor.Invariant.DivAp.Knot'. --- * Instead of using 'interpret' (to run in a typeclass), either use --- 'runCoDivAp' (to run in 'Applicative'), 'runContraDivAp' (to run in --- 'Divisible'), or 'foldDivAp' (to interpret by manually providing --- handlers) +-- This does have an 'Interpret' function, but the target typeclass +-- ('Inplicative') doesn't have too many useful instances. Instead, you +-- are probably going to run it into either 'Applicative' instance (to +-- "produce" an @a@ from a @'DivAp' f a@) with 'runCoDivAp', or +-- a 'Divisible' instance (to "consume" an @a@ from a @'DivAp' f a@) with +-- 'runContraDivAp'. -- --- You can also extract the 'Ap' part out using 'divApAp', and extract the --- 'Div' part out using 'divApDiv'. +-- If you think of this type as a combination of 'Ap' and 'Div', then +-- you can also extract the 'Ap' part out using 'divApAp', and +-- extract the 'Div' part out using 'divApDiv'. -- -- Note that this type's utility is similar to that of @'PreT' 'Ap'@, -- except @'PreT' 'Ap'@ lets you use 'Applicative' typeclass methods to @@ -489,26 +480,19 @@ -- handle the interpreting; the @a@ is sent to that @f@, and the single -- result is returned back out. -- --- You run this in any 'Alt' context if you want to interpret it --- covariantly, treating @'DecAlt1' f a@ as a /producer/ of @a@, using --- 'runCoDecAlt1'. You can run this in any 'Decide' context if you you --- want to interpret it contravariantly, treating @'DecAlt1' f a@ as --- a /consumer/ of @a@s, using 'runContraDecAlt1'. --- --- Because there is no typeclass that combines both 'Alt' and --- 'Decide', this type is a little bit tricker to construct/use than --- 'NonEmptyF' or 'Dec1'. +-- To do this, the main tools to combine 'DecAlt1's are its 'Inalt' +-- instance, using 'swerve' to combine two 'DecAlt1's in a choice-like +-- manner (with the choosing and re-injecting function). -- --- * Instead of '' and 'decide' (typeclass methods), use --- 'Data.Functor.Invariant.DecAlt.swerve1' and other variants, which --- work specifically on this type only. --- * Instead of using 'interpret' (to run in a typeclass), either use --- 'runCoDecAlt1' (to run in 'Alt'), 'runContraDecAlt1' (to run in --- 'Decide'), or 'foldDecAlt1' (to interpret by manually providing --- handlers) +-- This does have an 'Interpret' function, but the target typeclass +-- ('Inalt') doesn't have too many useful instances. Instead, you are +-- probably going to run it into either an 'Alt' instance (to "produce" an +-- @a@ from a @'DecAlt1' f a@) with 'runCoDecAlt1', or a 'Decide' instance +-- (to "consume" an @a@ from a @'DecAlt1' f a@) with 'runContraDecAlt1'. -- --- You can also extract the 'NonEmptyF' part out using 'decAltNonEmptyF', and --- extract the 'Dec1' part out using 'decAltDec1'. +-- If you think of this type as a combination of 'NonEmptyF' and 'Dec1', +-- then you can also extract the 'NonEmptyF' part out using +-- 'decAltNonEmptyF', and extract the 'Dec1' part out using 'decAltDec1'. -- -- Note that this type's utility is similar to that of @'PostT' 'Dec1'@, -- except @'PostT' 'Dec1'@ lets you use 'Decide' typeclass methods to @@ -538,6 +522,10 @@ ) . unDecAlt1 +-- | A free 'Inalt' +instance Inalt f => Interpret DecAlt1 f where + interpret f (DecAlt1_ x) = foldChain1 f (IN.runNight f id) x + -- | The invariant version of 'ListF' and 'Dec': combines the capabilities of -- both 'ListF' and 'Dec' together. -- @@ -547,27 +535,20 @@ -- interpreting; the @a@ is sent to that @f@, and the single result is -- returned back out. -- --- You run this in any 'Plus' context if you want to interpret it --- covariantly, treating @'DecAlt' f a@ as a /producer/ of @a@, using --- 'runCoDecAlt'. You can run this in any 'Conclude' context if you you --- want to interpret it contravariantly, treating @'DecAlt' f a@ as --- a /consumer/ of @a@s, using 'runContraDecAlt'. --- --- Because there is no typeclass that combines both 'Plus' and --- 'Conclude', this type is a little bit tricker to construct/use than --- 'ListF' or 'Dec'. +-- To do this, the main tools to combine 'DecAlt's are its 'Inalt' +-- instance, using 'swerve' to combine two 'DecAlt's in a choice-like +-- manner (with the choosing and re-injecting function), and its 'Inplus' +-- instance, using 'reject' to create an "empty" choice that is never +-- taken. -- --- * Instead of '' and 'decide' (typeclass methods), use --- 'Data.Functor.Invariant.DecAlt.swerve' and other variants, which work --- specifically on this type only. --- * Instead of 'empty' and 'conclude' (typeclass methods), use --- 'Data.Functor.Invariant.DecAlt.Reject'. --- * Instead of using 'interpret' (to run in a typeclass), either use --- 'runCoDecAlt' (to run in 'Plus'), 'runContraDecAlt' (to run in --- 'Conclude'), or 'foldDecAlt' (to interpret by manually providing --- handlers) +-- This does have an 'Interpret' function, but the target typeclass +-- ('Inplus') doesn't have too many useful instances. Instead, you are +-- probably going to run it into either 'Plus' instance (to "produce" an +-- @a@ from a @'DecAlt' f a@) with 'runCoDecAlt', or a 'Choose' instance +-- (to "consume" an @a@ from a @'DecAlt' f a@) with 'runContraDecAlt'. -- --- You can also extract the 'ListF' part out using 'decAltListF', and +-- If you think of this type as a combination of 'ListF' and 'Dec', then +-- you can also extract the 'ListF' part out using 'decAltListF', and -- extract the 'Dec' part out using 'decAltDec'. -- -- Note that this type's utility is similar to that of @'PostT' 'Dec'@, @@ -579,7 +560,7 @@ deriving (Invariant, HFunctor) instance Inject DecAlt where - inject x = DecAlt $ More (IN.Night x (Done IN.refuted) Left id absurd) + inject x = DecAlt $ More (IN.Night x (Done IN.refuted) id absurd Left) instance HTraversable DecAlt where htraverse f = @@ -590,3 +571,6 @@ ) . unDecAlt +-- | A free 'Inplus' +instance Inplus f => Interpret DecAlt f where + interpret f (DecAlt x) = foldChain (reject . IN.refute) (IN.runNight f id) x diff --git a/src/Data/HFunctor/Final.hs b/src/Data/HFunctor/Final.hs --- a/src/Data/HFunctor/Final.hs +++ b/src/Data/HFunctor/Final.hs @@ -41,6 +41,10 @@ import Data.Functor.Contravariant.Divisible.Free import Data.Functor.Coyoneda import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative +import Data.Functor.Invariant.Inplicative.Free +import Data.Functor.Invariant.Internative +import Data.Functor.Invariant.Internative.Free import Data.Functor.Plus import Data.HFunctor import Data.HFunctor.Interpret @@ -287,6 +291,62 @@ instance Invariant (Final Invariant f) where invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Invariant (Final Inply f) where + invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Inply (Final Inply f) where + gather f g = liftFinal2 (gather f g) + gathered = liftFinal2 gathered + +-- | @since 0.4.0.0 +instance Invariant (Final Inplicative f) where + invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Inply (Final Inplicative f) where + gather f g = liftFinal2 (gather f g) + gathered = liftFinal2 gathered +-- | @since 0.4.0.0 +instance Inplicative (Final Inplicative f) where + knot x = liftFinal0 (knot x) + +-- | @since 0.4.0.0 +instance Invariant (Final Inalt f) where + invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Inalt (Final Inalt f) where + swerve f g h = liftFinal2 (swerve f g h) + swerved = liftFinal2 swerved + +-- | @since 0.4.0.0 +instance Invariant (Final Inplus f) where + invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Inalt (Final Inplus f) where + swerve f g h = liftFinal2 (swerve f g h) + swerved = liftFinal2 swerved +-- | @since 0.4.0.0 +instance Inplus (Final Inplus f) where + reject f = liftFinal0 (reject f) + +-- | @since 0.4.0.0 +instance Invariant (Final Internative f) where + invmap f g = liftFinal1 (invmap f g) +-- | @since 0.4.0.0 +instance Inply (Final Internative f) where + gather f g = liftFinal2 (gather f g) + gathered = liftFinal2 gathered +-- | @since 0.4.0.0 +instance Inplicative (Final Internative f) where + knot x = liftFinal0 (knot x) +-- | @since 0.4.0.0 +instance Inalt (Final Internative f) where + swerve f g h = liftFinal2 (swerve f g h) + swerved = liftFinal2 swerved +-- | @since 0.4.0.0 +instance Inplus (Final Internative f) where + reject f = liftFinal0 (reject f) + -- | Re-interpret the context under a 'Final'. hoistFinalC :: (forall g x. (c g => g x) -> (d g => g x)) @@ -413,4 +473,12 @@ instance FreeOf Decide Dec1 -- | @since 0.3.0.0 instance FreeOf Conclude Dec +-- | @since 0.4.0.0 +instance FreeOf Inply DivAp1 where type FreeFunctorBy DivAp1 = Invariant +-- | @since 0.4.0.0 +instance FreeOf Inplicative DivAp +-- | @since 0.4.0.0 +instance FreeOf Inalt DecAlt1 where type FreeFunctorBy DecAlt1 = Invariant +-- | @since 0.4.0.0 +instance FreeOf Inplus DecAlt instance FreeOf Unconstrained IdentityT diff --git a/src/Data/HFunctor/HTraversable.hs b/src/Data/HFunctor/HTraversable.hs --- a/src/Data/HFunctor/HTraversable.hs +++ b/src/Data/HFunctor/HTraversable.hs @@ -26,10 +26,10 @@ module Data.HFunctor.HTraversable ( -- * 'HTraversable' HTraversable(..) - , hsequence, hfoldMap, htoList, hmapDefault + , hsequence, hfoldMap, htoList, hmapDefault, hfor -- * 'HTraversable1' , HTraversable1(..) - , hsequence1, hfoldMap1, htoNonEmpty + , hsequence1, hfoldMap1, htoNonEmpty, hfor1 ) where import Control.Applicative @@ -114,6 +114,12 @@ htoNonEmpty :: HTraversable1 t => (forall x. f x -> b) -> t f a -> NonEmpty b htoNonEmpty f = fromNDL . hfoldMap1 (ndlSingleton . f) +-- | A flipped version of 'htraverse1'. +-- +-- @since 0.4.0.0 +hfor1 :: (HTraversable1 t, Apply h) => t f a -> (forall x. f x -> h (g x)) -> h (t g a) +hfor1 x f = htraverse1 f x + -- | A higher-kinded version of 'Traversable', in the same way that -- 'HFunctor' is the higher-kinded version of 'Functor'. Gives you an -- "effectful" 'hmap', in the same way that 'traverse' gives you an @@ -151,6 +157,12 @@ -- @since 0.3.6.0 htoList :: HTraversable t => (forall x. f x -> b) -> t f a -> [b] htoList f = flip appEndo [] . hfoldMap (Endo . (:) . f) + +-- | A flipped version of 'htraverse'. +-- +-- @since 0.4.0.0 +hfor :: (HTraversable t, Applicative h) => t f a -> (forall x. f x -> h (g x)) -> h (t g a) +hfor x f = htraverse f x -- | An implementation of 'hmap' defined using 'htraverse'. -- diff --git a/src/Data/HFunctor/Internal.hs b/src/Data/HFunctor/Internal.hs --- a/src/Data/HFunctor/Internal.hs +++ b/src/Data/HFunctor/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK hide, not-home #-} module Data.HFunctor.Internal ( HFunctor(..) diff --git a/src/Data/HFunctor/Route.hs b/src/Data/HFunctor/Route.hs --- a/src/Data/HFunctor/Route.hs +++ b/src/Data/HFunctor/Route.hs @@ -38,6 +38,8 @@ ) where import Control.Natural +import Data.Functor.Invariant.Inplicative +import Data.Functor.Invariant.Internative import Data.Functor.Bind import Data.Functor.Contravariant import Data.Functor.Contravariant.Conclude @@ -557,6 +559,16 @@ ProPre x ProPre y = ProPre (x y) -- | @since 0.3.4.1 deriving instance Invariant (t (Pre a f)) => Invariant (ProPre t f a) +-- | @since 0.4.0.0.0 +deriving instance Inply (t (Pre a f)) => Inply (ProPre t f a) +-- | @since 0.4.0.0.0 +deriving instance Inplicative (t (Pre a f)) => Inplicative (ProPre t f a) +-- | @since 0.4.0.0.0 +deriving instance Inalt (t (Pre a f)) => Inalt (ProPre t f a) +-- | @since 0.4.0.0.0 +deriving instance Inplus (t (Pre a f)) => Inplus (ProPre t f a) +-- | @since 0.4.0.0.0 +deriving instance Internative (t (Pre a f)) => Internative (ProPre t f a) -- | @since 0.3.4.1 deriving instance Semigroup (t (Pre a f) b) => Semigroup (ProPre t f a b) -- | @since 0.3.4.1