diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,21 @@ Changelog ========= +Version 0.4.1.0 +--------------- + +*September 29, 2021* + + + +* All of the missing instances to the typeclasses added in 0.4 that I could + remember. +* Variations of `concatInply` / `concatInplicative` / `concatInalt` / + `concatInplus` renamed to `gatheredN` / `swervedN` / `gatheredN1` / + `swervedN1`. +* `gatherN`, `gatherN1` added with typeclass-based multi-arity functions. +* GHC 9.0 compatibility (@ocharles) + Version 0.4.0.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: 8d3d33fe70d8907a40e1b80e5ac37a52e0bd94fcadf9ff26258211521fb5f22c +-- hash: c98f05061d45352f630dd964c7671a2a414e5708a12f8f4f8a39d61b986f6f5d name: functor-combinators -version: 0.4.0.0 +version: 0.4.1.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" @@ -82,7 +82,8 @@ default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification ExplicitNamespaces FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses OverloadedStrings PatternSynonyms QuantifiedConstraints RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeInType TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns ghc-options: -Wall -Wcompat -Wredundant-constraints -Werror=incomplete-patterns build-depends: - assoc + StateVar + , assoc , base >=4.12 && <5 , bifunctors , comonad @@ -91,12 +92,13 @@ , contravariant , deriving-compat , free + , hashable , invariant , kan-extensions , mmorph , mtl , natural-transformation - , nonempty-containers + , nonempty-containers >=0.3.4.4 , pointed , profunctors , semigroupoids @@ -105,6 +107,7 @@ , these , transformers , trivial-constraint >=0.5 + , unordered-containers , vinyl default-language: Haskell2010 @@ -127,7 +130,7 @@ , free , functor-combinators , hedgehog >=0.6 - , nonempty-containers + , nonempty-containers >=0.3.4.4 , semigroupoids , tasty , tasty-hedgehog diff --git a/src/Control/Natural/IsoF.hs b/src/Control/Natural/IsoF.hs --- a/src/Control/Natural/IsoF.hs +++ b/src/Control/Natural/IsoF.hs @@ -70,7 +70,7 @@ :: f ~> g -> g ~> f -> f <~> g -isoF = dimap +isoF f g a = dimap f g a -- | An isomorphism between two functors that are coercible/have the same -- internal representation. Useful for newtype wrappers. diff --git a/src/Data/Functor/Combinator/Unsafe.hs b/src/Data/Functor/Combinator/Unsafe.hs --- a/src/Data/Functor/Combinator/Unsafe.hs +++ b/src/Data/Functor/Combinator/Unsafe.hs @@ -26,15 +26,24 @@ , unsafePointed , unsafeConclude , unsafeDivise + , unsafeInvariantCo + , unsafeInvariantContra + , unsafeInplyCo + , unsafeInplyContra + , unsafeInplicativeCo + , unsafeInplicativeContra ) where import Control.Applicative import Data.Constraint import Data.Constraint.Unsafe import Data.Functor.Bind +import Data.Functor.Contravariant import Data.Functor.Contravariant.Conclude import Data.Functor.Contravariant.Divise import Data.Functor.Contravariant.Divisible +import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative import Data.Functor.Plus import Data.Pointed @@ -44,9 +53,6 @@ -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Plus' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -60,9 +66,6 @@ -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Apply' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -76,9 +79,6 @@ -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Bind' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -97,9 +97,6 @@ -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Pointed' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -113,9 +110,6 @@ -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Conclude' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -125,16 +119,12 @@ unsafeConclude _ x = case unsafeCoerceConstraint @(Conclude (WrappedDivisible f)) @(Conclude f) of Sub Dict -> x - -- | For any @'Divisible' f@, produce a value that would require @'Divise' -- f@. -- -- Always use with concrete and specific @f@ only, and never use with any -- @f@ that already has a 'Divise' instance. -- --- See documentation for 'Data.HBifunctor.Tensor.upgradeC' for example --- usages. --- -- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ -- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' -- \@MyFunctor@. @@ -142,5 +132,95 @@ -- @since 0.3.0.0 unsafeDivise :: forall f proxy r. Divisible f => proxy f -> (Divise f => r) -> r unsafeDivise _ x = case unsafeCoerceConstraint @(Divise (WrappedDivisible f)) @(Divise f) of + Sub Dict -> x + +-- | For any @'Functor' f@, produce a value that would require @'Invariant' +-- f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Invariant' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInvariantCo :: forall f proxy r. Functor f => proxy f -> (Invariant f => r) -> r +unsafeInvariantCo _ x = case unsafeCoerceConstraint @(Invariant (WrappedFunctor f)) @(Invariant f) of + Sub Dict -> x + +-- | For any @'Contravariant' f@, produce a value that would require @'Invariant' +-- f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Invariant' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInvariantContra :: forall f proxy r. Contravariant f => proxy f -> (Invariant f => r) -> r +unsafeInvariantContra _ x = case unsafeCoerceConstraint @(Invariant (WrappedContravariant f)) @(Invariant f) of + Sub Dict -> x + +-- | For any @'Apply' f@, produce a value that would require @'Inply' +-- f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Inply' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInplyCo :: forall f proxy r. Apply f => proxy f -> (Inply f => r) -> r +unsafeInplyCo _ x = case unsafeCoerceConstraint @(Inply (WrappedFunctor f)) @(Inply f) of + Sub Dict -> x + +-- | For any @'Divise' f@, produce a value that would require @'Inply' +-- f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Inply' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInplyContra :: forall f proxy r. Divise f => proxy f -> (Inply f => r) -> r +unsafeInplyContra _ x = case unsafeCoerceConstraint @(Inply (WrappedContravariant f)) @(Inply f) of + Sub Dict -> x + +-- | For any @'Applicative' f@, produce a value that would require +-- @'Inplicative' f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Inplicative' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInplicativeCo :: forall f proxy r. (Applicative f, Invariant f) => proxy f -> (Inplicative f => r) -> r +unsafeInplicativeCo _ x = case unsafeCoerceConstraint @(Inply (WrappedApplicativeOnly f)) @(Inplicative f) of + Sub Dict -> x + +-- | For any @'Divisibl3' f@, produce a value that would require +-- @'Inplicative' f@. +-- +-- Always use with concrete and specific @f@ only, and never use with any +-- @f@ that already has an 'Inplicative' instance. +-- +-- The 'Data.Proxy.Proxy' argument allows you to specify which specific @f@ +-- you want to enhance. You can pass in something like @'Data.Proxy.Proxy' +-- \@MyFunctor@. +-- +-- @since 0.4.1.0 +unsafeInplicativeContra :: forall f proxy r. (Divisible f, Invariant f) => proxy f -> (Inplicative f => r) -> r +unsafeInplicativeContra _ x = case unsafeCoerceConstraint @(Inply (WrappedDivisibleOnly f)) @(Inplicative f) of Sub Dict -> x diff --git a/src/Data/Functor/Contravariant/Divise.hs b/src/Data/Functor/Contravariant/Divise.hs --- a/src/Data/Functor/Contravariant/Divise.hs +++ b/src/Data/Functor/Contravariant/Divise.hs @@ -18,36 +18,36 @@ -- @since 0.3.0.0 module Data.Functor.Contravariant.Divise ( Divise(..) - , divised , (<:>) , dsum1 , WrappedDivisible(..) ) where -import Control.Applicative -import Control.Applicative.Backwards -import Control.Arrow -import Control.Monad.Trans.Error -import Control.Monad.Trans.Except -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 qualified Data.Semigroup.Foldable as F1 - -import Data.Functor.Apply -import Data.Functor.Compose -import Data.Functor.Constant -import Data.Functor.Contravariant -import Data.Functor.Contravariant.Divisible -import Data.Functor.Product -import Data.Functor.Reverse +import Control.Applicative +import Control.Applicative.Backwards +import Control.Arrow +import Control.Monad.Trans.Error +import Control.Monad.Trans.Except +import Control.Monad.Trans.Identity +import Control.Monad.Trans.List +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Deriving +import Data.Functor.Apply +import Data.Functor.Compose +import Data.Functor.Constant +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divisible +import Data.Functor.Invariant +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 +import qualified Data.Semigroup.Foldable as F1 #if MIN_VERSION_base(4,8,0) import Data.Monoid (Alt(..)) @@ -98,15 +98,12 @@ -- | Takes a "splitting" method and the two sub-consumers, and -- returns the wrapped/combined consumer. divise :: (a -> (b, c)) -> f b -> f c -> f a - --- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer of --- @(a, b)@. --- --- @ --- 'divised' = 'divise' 'id' --- @ -divised :: Divise f => f a -> f b -> f (a, b) -divised = divise id + divise f x y = contramap f (divised x y) + -- | Combine a consumer of @a@ with a consumer of @b@ to get a consumer + -- of @(a, b)@. + divised :: f a -> f b -> f (a, b) + divised = divise id + {-# MINIMAL divise | divised #-} -- | The Contravariant version of '<|>': split the same input over two -- different consumers. @@ -130,10 +127,17 @@ -- | Wrap a 'Divisible' to be used as a member of 'Divise' newtype WrappedDivisible f a = WrapDivisible { unwrapDivisible :: f a } + deriving (Generic, Eq, Show, Ord, Read, Functor, Foldable, Traversable) + deriving newtype (Divisible, Contravariant) -instance Contravariant f => Contravariant (WrappedDivisible f) where - contramap f (WrapDivisible a) = WrapDivisible (contramap f a) +deriveShow1 ''WrappedDivisible +deriveRead1 ''WrappedDivisible +deriveEq1 ''WrappedDivisible +deriveOrd1 ''WrappedDivisible +instance Contravariant f => Invariant (WrappedDivisible f) where + invmap _ g (WrapDivisible x) = WrapDivisible (contramap g x) + instance Divisible f => Divise (WrappedDivisible f) where divise f (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divide f x y) @@ -260,3 +264,5 @@ funzip :: Functor f => f (a, b) -> (f a, f b) funzip = fmap fst &&& fmap snd + +-- TODO: WrappedContravariant diff --git a/src/Data/Functor/Contravariant/Divisible/Free.hs b/src/Data/Functor/Contravariant/Divisible/Free.hs --- a/src/Data/Functor/Contravariant/Divisible/Free.hs +++ b/src/Data/Functor/Contravariant/Divisible/Free.hs @@ -31,14 +31,16 @@ import Data.Bifunctor import Data.Bifunctor.Assoc import Data.Foldable +import Data.Functor.Apply import Data.Functor.Contravariant import Data.Functor.Contravariant.Conclude import Data.Functor.Contravariant.Coyoneda import Data.Functor.Contravariant.Decide import Data.Functor.Contravariant.Divise -import Data.Functor.Apply import Data.Functor.Contravariant.Divisible import Data.Functor.Invariant +import Data.Functor.Invariant.Inplicative +import Data.Functor.Invariant.Internative import Data.HFunctor import Data.HFunctor.HTraversable import Data.HFunctor.Interpret @@ -71,6 +73,9 @@ instance Invariant (Div f) where invmap _ = contramap +deriving via WrappedDivisible (Div f) instance Inply (Div f) +deriving via WrappedDivisible (Div f) instance Inplicative (Div f) + -- | Pattern matching on an empty 'Div'. -- -- Before v0.3.3.0, this used to be the concrete constructor of 'Div'. @@ -146,6 +151,8 @@ instance Invariant (Div1 f) where invmap _ = contramap +deriving via WrappedDivisible (Div1 f) instance Inply (Div1 f) + instance Divise f => Interpret Div1 f where interpret = runDiv1 @@ -208,6 +215,8 @@ Choose g x xs -> Choose (g . f) x xs instance Invariant (Dec f) where invmap _ = contramap +deriving via WrappedDivisible (Dec f) instance Inalt (Dec f) +deriving via WrappedDivisible (Dec f) instance Inplus (Dec f) instance Decide (Dec f) where decide f = \case Lose g -> contramap (either (absurd . g) id . f) @@ -267,6 +276,7 @@ contramap f (Dec1 g x xs) = Dec1 (g . f) x xs instance Invariant (Dec1 f) where invmap _ = contramap +deriving via WrappedDivisible (Dec1 f) instance Inalt (Dec1 f) instance Decide (Dec1 f) where decide f (Dec1 g x xs) = Dec1 (assoc . first g . f) x . decide id xs diff --git a/src/Data/Functor/Invariant/Inplicative.hs b/src/Data/Functor/Invariant/Inplicative.hs --- a/src/Data/Functor/Invariant/Inplicative.hs +++ b/src/Data/Functor/Invariant/Inplicative.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + -- | -- Module : Data.Functor.Invariant.Inplicative -- Copyright : (c) Justin Le 2021 @@ -15,22 +19,77 @@ -- * Typeclass Inply(..) , Inplicative(..) + -- * Deriving + , WrappedApplicativeOnly(..) + , WrappedDivisibleOnly(..) -- * Invariant 'Day' , runDay , dather + , runDayApply + , runDayDivise -- * Assembling Helpers - , concatInplicative - , concatInply - , concatInplicativeRec - , concatInplyRec + , gatheredN + , gatheredNMap + , gatheredN1 + , gatheredN1Map + , gatheredNRec + , gatheredNMapRec + , gatheredN1Rec + , gatheredN1MapRec + , gatherN + , gatherN1 ) where +import Control.Applicative +import Control.Applicative.Backwards (Backwards(..)) +import Control.Applicative.Lift (Lift(Pure, Other)) +import Control.Arrow (Arrow) +import Control.Monad.Trans.Cont (ContT) +import Control.Monad.Trans.Error (ErrorT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +import Control.Monad.Trans.List (ListT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.RWS (RWST(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +import Control.Monad.Trans.State (StateT) +import Control.Monad.Trans.Writer (WriterT(..)) import Control.Natural +import Data.Complex (Complex) +import Data.Deriving +import Data.Functor.Apply +import Data.Functor.Bind.Class (Bind) +import Data.Functor.Constant (Constant) +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible +import Data.Functor.Identity 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 +import Data.Functor.Product (Product(..)) +import Data.Functor.Reverse (Reverse(..)) +import Data.Hashable (Hashable) +import Data.Kind +import Data.List.NonEmpty (NonEmpty) +import Data.SOP hiding (hmap) +import Data.Sequence (Seq) +import Data.StateVar (SettableStateVar) +import Data.Tagged (Tagged) +import Data.Tree (Tree) +import GHC.Generics (Generic) +import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) +import qualified Control.Monad.Trans.State.Strict as Strict (StateT) +import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT(..)) +import qualified Data.HashMap.Lazy as HM +import qualified Data.IntMap as IM +import qualified Data.Map as M +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence.NonEmpty as NESeq +import qualified Data.Vinyl as V +import qualified Data.Vinyl.Curry as V +import qualified Data.Vinyl.Functor as V +import qualified GHC.Generics as Generics -- | The invariant counterpart of 'Apply' and 'Divise'. -- @@ -84,7 +143,6 @@ -> f b -> f (a, b) gathered = gather (,) id - {-# MINIMAL gather | gathered #-} -- | The invariant counterpart of 'Applicative' and 'Divisible'. @@ -127,6 +185,383 @@ => Day f f ~> f dather (Day x y a b) = gather a b x y +-- | Ignores the contravariant part of 'gather' +instance Apply f => Inply (WrappedFunctor f) where + gather f _ (WrapFunctor x) (WrapFunctor y) = WrapFunctor (liftF2 f x y) + gathered (WrapFunctor x) (WrapFunctor y) = WrapFunctor (liftF2 (,) x y) +-- | @'knot' = 'pure'@ +instance (Applicative f, Apply f) => Inplicative (WrappedFunctor f) where + knot = pure + +-- | Ignores the covariant part of 'gather' +instance Divise f => Inply (WrappedContravariant f) where + gather _ g (WrapContravariant x) (WrapContravariant y) = WrapContravariant (divise g x y) + gathered (WrapContravariant x) (WrapContravariant y) = WrapContravariant (divised x y) +-- | @'knot' _ = 'conquer'@ +instance (Divisible f, Divise f) => Inplicative (WrappedContravariant f) where + knot _ = conquer + +-- | Ignores the covariant part of 'gather' +instance Divise f => Inply (WrappedDivisible f) where + gather _ g (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divise g x y) + gathered (WrapDivisible x) (WrapDivisible y) = WrapDivisible (divised x y) +-- | @'knot' _ = 'conquer'@ +instance (Divisible f, Divise f) => Inplicative (WrappedDivisible f) where + knot _ = conquer + +-- | Wrap an 'Applicative' that is not necessarily an 'Apply'. +newtype WrappedApplicativeOnly f a = + WrapApplicativeOnly { unwrapApplicativeOnly :: f a } + deriving (Generic, Eq, Show, Ord, Read, Functor, Foldable, Traversable) + deriving newtype (Applicative, Monad) + +deriveShow1 ''WrappedApplicativeOnly +deriveRead1 ''WrappedApplicativeOnly +deriveEq1 ''WrappedApplicativeOnly +deriveOrd1 ''WrappedApplicativeOnly + +instance Invariant f => Invariant (WrappedApplicativeOnly f) where + invmap f g (WrapApplicativeOnly x) = WrapApplicativeOnly (invmap f g x) +instance (Applicative f, Invariant f) => Apply (WrappedApplicativeOnly f) where + x <.> y = x <*> y +-- | Ignores the contravariant part of 'gather' +instance (Applicative f, Invariant f) => Inply (WrappedApplicativeOnly f) where + gather f _ (WrapApplicativeOnly x) (WrapApplicativeOnly y) = WrapApplicativeOnly (liftA2 f x y) + gathered (WrapApplicativeOnly x) (WrapApplicativeOnly y) = WrapApplicativeOnly (liftA2 (,) x y) +-- | @'knot' = 'pure'@ +instance (Applicative f, Invariant f) => Inplicative (WrappedApplicativeOnly f) where + knot = pure + +-- | Wrap an 'Divisible' that is not necessarily a 'Divise'. +newtype WrappedDivisibleOnly f a = + WrapDivisibleOnly { unwrapDivisibleOnly :: f a } + deriving (Generic, Eq, Show, Ord, Read, Functor, Foldable, Traversable) + deriving newtype (Divisible, Contravariant) + +deriveShow1 ''WrappedDivisibleOnly +deriveRead1 ''WrappedDivisibleOnly +deriveEq1 ''WrappedDivisibleOnly +deriveOrd1 ''WrappedDivisibleOnly + +instance Invariant f => Invariant (WrappedDivisibleOnly f) where + invmap f g (WrapDivisibleOnly x) = WrapDivisibleOnly (invmap f g x) +instance (Divisible f, Invariant f) => Divise (WrappedDivisibleOnly f) where + divise g (WrapDivisibleOnly x) (WrapDivisibleOnly y) = WrapDivisibleOnly (divide g x y) +-- | Ignores the covariant part of 'gather' +instance (Divisible f, Invariant f) => Inply (WrappedDivisibleOnly f) where + gather _ g (WrapDivisibleOnly x) (WrapDivisibleOnly y) = WrapDivisibleOnly (divide g x y) + gathered (WrapDivisibleOnly x) (WrapDivisibleOnly y) = WrapDivisibleOnly (divided x y) +-- | @'knot' _ = 'conquer'@ +instance (Divisible f, Invariant f) => Inplicative (WrappedDivisibleOnly f) where + knot _ = conquer + +funzip :: Functor f => f (a, b) -> (f a, f b) +funzip x = (fmap fst x, fmap snd x) + +-- | @since 0.4.1.0 +instance Inply f => Inply (MaybeT f) where + gather f g (MaybeT x) (MaybeT y) = MaybeT $ + gather (liftA2 f) (funzip . fmap g) x y +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (MaybeT f) where + knot x = MaybeT (knot (Just x)) + +-- | @since 0.4.1.0 +instance (Inply f, Semigroup w) => Inply (WriterT w f) where + gather f g (WriterT x) (WriterT y) = WriterT $ + gather (\case (a, q) -> \case (b, r) -> (f a b, q <> r)) + (\case (a, s) -> case g a of (b, c) -> ((b, s), (c, s))) + x y +-- | @since 0.4.1.0 +instance (Inplicative f, Monoid w) => Inplicative (WriterT w f) where + knot x = WriterT (knot (x, mempty)) + +-- | @since 0.4.1.0 +instance (Inply f, Semigroup w) => Inply (Strict.WriterT w f) where + gather f g (Strict.WriterT x) (Strict.WriterT y) = Strict.WriterT $ + gather (\(~(a, q)) (~(b, r)) -> (f a b, q <> r)) + (\(~(a, s)) -> let ~(b, c) = g a in ((b, s), (c, s))) + x y +-- | @since 0.4.1.0 +instance (Inplicative f, Monoid w) => Inplicative (Strict.WriterT w f) where + knot x = Strict.WriterT (knot (x, mempty)) + +-- | @since 0.4.1.0 +instance Inply f => Inply (ReaderT r f) where + gather f g (ReaderT x) (ReaderT y) = ReaderT $ \r -> + gather f g (x r) (y r) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (ReaderT r f) where + knot x = ReaderT (\_ -> knot x) + +-- | @since 0.4.1.0 +instance Inply f => Inply (ExceptT e f) where + gather f g (ExceptT x) (ExceptT y) = ExceptT $ + gather (liftA2 f) (funzip . fmap g) x y +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (ExceptT e f) where + knot x = ExceptT (knot (Right x)) + +-- | @since 0.4.1.0 +instance Inply f => Inply (ErrorT e f) where + gather f g (ErrorT x) (ErrorT y) = ErrorT $ + gather (liftA2 f) (funzip . fmap g) x y +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (ErrorT e f) where + knot x = ErrorT (knot (Right x)) + +-- | @since 0.4.1.0 +instance Inply f => Inply (ListT f) where + gather f g (ListT x) (ListT y) = ListT $ + gather (liftA2 f) (funzip . fmap g) x y +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (ListT f) where + knot x = ListT (knot [x]) + +-- | @since 0.4.1.0 +deriving via WrappedFunctor (RWST r w s m) instance (Bind m, Invariant m, Semigroup w) => Inply (RWST r w s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (RWST r w s m) instance (Monad m, Bind m, Invariant m, Monoid w) => Inplicative (RWST r w s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Strict.RWST r w s m) instance (Bind m, Invariant m, Semigroup w) => Inply (Strict.RWST r w s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Strict.RWST r w s m) instance (Monad m, Bind m, Invariant m, Monoid w) => Inplicative (Strict.RWST r w s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (StateT s m) instance (Bind m, Invariant m) => Inply (StateT s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (StateT s m) instance (Monad m, Bind m, Invariant m) => Inplicative (StateT s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Strict.StateT s m) instance (Bind m, Invariant m) => Inply (Strict.StateT s m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Strict.StateT s m) instance (Monad m, Bind m, Invariant m) => Inplicative (Strict.StateT s m) + +-- | @since 0.4.1.0 +instance Inply f => Inply (Generics.M1 i t f :: Type -> Type) where + gather f g (Generics.M1 x) (Generics.M1 y) = Generics.M1 (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (Generics.M1 i t f :: Type -> Type) where + knot = Generics.M1 . knot +-- | @since 0.4.1.0 +instance (Inply f, Inply g) => Inply (f Generics.:*: g) where + gather f g (x1 Generics.:*: y1) (x2 Generics.:*: y2) = + gather f g x1 x2 Generics.:*: gather f g y1 y2 +-- | @since 0.4.1.0 +instance (Inplicative f, Inplicative g) => Inplicative (f Generics.:*: g) where + knot x = knot x Generics.:*: knot x +-- | @since 0.4.1.0 +instance (Inply f, Inply g) => Inply (Product f g) where + gather f g (Pair x1 y1) (Pair x2 y2) = + gather f g x1 x2 `Pair` gather f g y1 y2 +-- | @since 0.4.1.0 +instance (Inplicative f, Inplicative g) => Inplicative (Product f g) where + knot x = knot x `Pair` knot x +-- | @since 0.4.1.0 +instance Inply f => Inply (Generics.Rec1 f :: Type -> Type) where + gather f g (Generics.Rec1 x) (Generics.Rec1 y) = Generics.Rec1 (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (Generics.Rec1 f :: Type -> Type) where + knot = Generics.Rec1 . knot +-- | @since 0.4.1.0 +instance Inply f => Inply (Monoid.Alt f) where + gather f g (Monoid.Alt x) (Monoid.Alt y) = Monoid.Alt (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (Monoid.Alt f) where + knot = Monoid.Alt . knot +-- | @since 0.4.1.0 +instance Inply f => Inply (IdentityT f :: Type -> Type) where + gather f g (IdentityT x) (IdentityT y) = IdentityT (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (IdentityT f :: Type -> Type) where + knot = IdentityT . knot +-- | @since 0.4.1.0 +instance Inply f => Inply (Reverse f :: Type -> Type) where + gather f g (Reverse x) (Reverse y) = Reverse (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (Reverse f :: Type -> Type) where + knot = Reverse . knot +-- | @since 0.4.1.0 +instance Inply f => Inply (Backwards f :: Type -> Type) where + gather f g (Backwards x) (Backwards y) = Backwards (gather f g x y) +-- | @since 0.4.1.0 +instance Inplicative f => Inplicative (Backwards f :: Type -> Type) where + knot = Backwards . knot +-- | @since 0.4.1.0 +instance Inply f => Inply (Lift f) where + gather f g = \case + Pure x -> \case + Pure y -> Pure (f x y) + Other y -> Other (invmap (f x) (snd . g) y) + Other x -> \case + Pure y -> Other (invmap (`f` y) (fst . g) x) + Other y -> Other (gather f g x y) +-- | @since 0.4.1.0 +instance Inply f => Inplicative (Lift f) where + knot = Pure + +-- | @since 0.4.1.0 +deriving via WrappedApplicativeOnly (Tagged a) instance Inply (Tagged a) +-- | @since 0.4.1.0 +deriving via WrappedApplicativeOnly (Tagged a) instance Inplicative (Tagged a) + +-- | @since 0.4.1.0 +deriving via WrappedFunctor Identity instance Inply Identity +-- | @since 0.4.1.0 +deriving via WrappedFunctor Identity instance Inplicative Identity +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Proxy :: Type -> Type) instance Inply Proxy +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Proxy :: Type -> Type) instance Inplicative Proxy +-- | @since 0.4.1.0 +deriving via WrappedFunctor [] instance Inply [] +-- | @since 0.4.1.0 +deriving via WrappedFunctor [] instance Inplicative [] +-- | @since 0.4.1.0 +deriving via WrappedFunctor ((->) r) instance Inply ((->) r) +-- | @since 0.4.1.0 +deriving via WrappedFunctor ((->) r) instance Inplicative ((->) r) +-- | @since 0.4.1.0 +deriving via WrappedFunctor Maybe instance Inply Maybe +-- | @since 0.4.1.0 +deriving via WrappedFunctor Maybe instance Inplicative Maybe +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Either e) instance Inply (Either e) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Either e) instance Inplicative (Either e) +-- | @since 0.4.1.0 +deriving via WrappedFunctor IO instance Inply IO +-- | @since 0.4.1.0 +deriving via WrappedFunctor IO instance Inplicative IO +-- | @since 0.4.1.0 +deriving via WrappedFunctor Generics.Par1 instance Inply Generics.Par1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor Generics.Par1 instance Inplicative Generics.Par1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.U1 :: Type -> Type) instance Inply Generics.U1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.U1 :: Type -> Type) instance Inplicative Generics.U1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.K1 i c :: Type -> Type) instance Semigroup c => Inply (Generics.K1 i c) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.K1 i c :: Type -> Type) instance Monoid c => Inplicative (Generics.K1 i c) +-- | @since 0.4.1.0 +deriving via WrappedFunctor Complex instance Inply Complex +-- | @since 0.4.1.0 +deriving via WrappedFunctor Complex instance Inplicative Complex +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Min instance Inply Semigroup.Min +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Min instance Inplicative Semigroup.Min +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Max instance Inply Semigroup.Max +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Max instance Inplicative Semigroup.Max +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.First instance Inply Semigroup.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.First instance Inplicative Semigroup.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Last instance Inply Semigroup.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Last instance Inplicative Semigroup.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Option instance Inply Semigroup.Option +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Option instance Inplicative Semigroup.Option +-- | @since 0.4.1.0 +deriving via WrappedFunctor ZipList instance Inply ZipList +-- | @since 0.4.1.0 +deriving via WrappedFunctor ZipList instance Inplicative ZipList +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.First instance Inply Monoid.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.First instance Inplicative Monoid.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Last instance Inply Monoid.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Last instance Inplicative Monoid.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Dual instance Inply Monoid.Dual +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Dual instance Inplicative Monoid.Dual +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Sum instance Inply Monoid.Sum +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Sum instance Inplicative Monoid.Sum +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Product instance Inply Monoid.Product +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Product instance Inplicative Monoid.Product +-- | @since 0.4.1.0 +deriving via WrappedFunctor NonEmpty instance Inply NonEmpty +-- | @since 0.4.1.0 +deriving via WrappedFunctor NonEmpty instance Inplicative NonEmpty +-- | @since 0.4.1.0 +deriving via WrappedFunctor Tree instance Inply Tree +-- | @since 0.4.1.0 +deriving via WrappedFunctor Tree instance Inplicative Tree +-- | @since 0.4.1.0 +deriving via WrappedFunctor Seq instance Inply Seq +-- | @since 0.4.1.0 +deriving via WrappedFunctor Seq instance Inplicative Seq +-- | @since 0.4.1.0 +deriving via WrappedFunctor NESeq.NESeq instance Inply NESeq.NESeq +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedArrow a b) instance Arrow a => Inply (WrappedArrow a b) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedArrow a b) instance Arrow a => Inplicative (WrappedArrow a b) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.V1 :: Type -> Type) instance Inply Generics.V1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor IM.IntMap instance Inply IM.IntMap +-- | @since 0.4.1.0 +deriving via WrappedFunctor (M.Map k) instance Ord k => Inply (M.Map k) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (HM.HashMap k) instance (Hashable k, Eq k) => Inply (HM.HashMap k) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Const w :: Type -> Type) instance Semigroup w => Inply (Const w) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Const w :: Type -> Type) instance Monoid w => Inplicative (Const w) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Constant w :: Type -> Type) instance Semigroup w => Inply (Constant w) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Constant w :: Type -> Type) instance Monoid w => Inplicative (Constant w) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (ContT r (m :: Type -> Type)) instance Inply (ContT r m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (ContT r (m :: Type -> Type)) instance Inplicative (ContT r m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedMonad m) instance Monad m => Inply (WrappedMonad m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedMonad m) instance Monad m => Inplicative (WrappedMonad m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor ((,) w :: Type -> Type) instance Semigroup w => Inply ((,) w) +-- | @since 0.4.1.0 +deriving via WrappedFunctor ((,) w :: Type -> Type) instance Monoid w => Inplicative ((,) w) + +-- | @since 0.4.1.0 +deriving via WrappedDivisible SettableStateVar instance Inply SettableStateVar +-- | @since 0.4.1.0 +deriving via WrappedDivisible SettableStateVar instance Inplicative SettableStateVar +-- | @since 0.4.1.0 +deriving via WrappedDivisible Predicate instance Inply Predicate +-- | @since 0.4.1.0 +deriving via WrappedDivisible Predicate instance Inplicative Predicate +-- | @since 0.4.1.0 +deriving via WrappedDivisible Comparison instance Inply Comparison +-- | @since 0.4.1.0 +deriving via WrappedDivisible Comparison instance Inplicative Comparison +-- | @since 0.4.1.0 +deriving via WrappedDivisible Equivalence instance Inply Equivalence +-- | @since 0.4.1.0 +deriving via WrappedDivisible Equivalence instance Inplicative Equivalence +-- | @since 0.4.1.0 +deriving via WrappedDivisible (Op r) instance Semigroup r => Inply (Op r) +-- | @since 0.4.1.0 +deriving via WrappedDivisible (Op r) instance Monoid r => Inplicative (Op r) + + + + -- | 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 @@ -146,7 +581,7 @@ -- @ -- 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 +-- gatheredN $ intPrim -- :* boolPrim -- :* stringPrim -- :* Nil @@ -155,70 +590,240 @@ -- 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 1 component, you don't need anything. -- * 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 +-- @since 0.4.1.0 +gatheredN :: Inplicative f => NP f as -> f (NP I as) -concatInplicative = \case +gatheredN = \case Nil -> knot Nil x :* xs -> gather (\y ys -> I y :* ys) (\case I y :* ys -> (y, ys)) x - (concatInplicative xs) + (gatheredN xs) --- | A version of 'concatInplicative' for non-empty 'NP', but only +-- | Given a function to "break out" a data type into a 'NP' (tuple) and one to +-- put it back together from the tuple, 'gather' all of the components +-- together. +-- +-- 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: +-- +-- @ +-- concaMapInplicative +-- (\(MyType x y z) -> I x :* I y :* I z :* Nil) +-- (\(I x :* I y :* I z :* Nil) -> MyType x y z) +-- $ intPrim +-- :* boolPrim +-- :* stringPrim +-- :* Nil +-- @ +-- +-- See notes on 'gatheredNMap' for more details and caveats. +-- +-- @since 0.4.1.0 +gatheredNMap + :: Inplicative f + => (NP I as -> b) + -> (b -> NP I as) + -> NP f as + -> f b +gatheredNMap f g = invmap f g . gatheredN + +-- | A version of 'gatheredN' for non-empty 'NP', but only -- requiring an 'Inply' instance. -- --- @since 0.4.0.0 -concatInply +-- @since 0.4.1.0 +gatheredN1 :: Inply f => NP f (a ': as) -> f (NP I (a ': as)) -concatInply (x :* xs) = case xs of +gatheredN1 (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) + (gatheredN1 xs) --- | A version of 'concatInplicative' using 'V.XRec' from /vinyl/ instead of +-- | A version of 'gatheredNMap' for non-empty 'NP', but only +-- requiring an 'Inply' instance. +-- +-- @since 0.4.1.0 +gatheredN1Map + :: Inplicative f + => (NP I (a ': as) -> b) + -> (b -> NP I (a ': as)) + -> NP f (a ': as) + -> f b +gatheredN1Map f g = invmap f g . gatheredN1 + +-- | A version of 'gatheredN' 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. +-- require manual unwrapping/wrapping of tuple components. -- --- @since 0.4.0.0 -concatInplicativeRec +-- @since 0.4.1.0 +gatheredNRec :: Inplicative f => V.Rec f as -> f (V.XRec V.Identity as) -concatInplicativeRec = \case +gatheredNRec = \case V.RNil -> knot V.RNil x V.:& xs -> gather (V.::&) (\case y V.::& ys -> (y, ys)) x - (concatInplicativeRec xs) + (gatheredNRec xs) --- | A version of 'concatInply' using 'V.XRec' from /vinyl/ instead of +-- | A version of 'gatheredNMap' 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 tuple components. +-- +-- @since 0.4.1.0 +gatheredNMapRec + :: Inplicative f + => (V.XRec V.Identity as -> b) + -> (b -> V.XRec V.Identity as) + -> V.Rec f as + -> f b +gatheredNMapRec f g = invmap f g . gatheredNRec + +-- | Convenient wrapper to 'gather' over multiple arguments using tine +-- vinyl library's multi-arity uncurrying facilities. Makes it a lot more +-- convenient than using 'gather' multiple times and needing to accumulate +-- intermediate types. +-- +-- 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: +-- +-- @ +-- 'gatherN' +-- MT -- ^ curried assembling function +-- (\(MT x y z) -> x ::& y ::& z ::& XRNil) -- ^ disassembling function +-- (intPrim :: Prim Int) +-- (boolPrim :: Prim Bool) +-- (stringPrim :: Prim String) +-- @ +-- +-- Really only useful with 3 or more arguments, since with two arguments +-- this is just 'gather' (and with zero arguments, you can just use +-- 'knot'). +-- +-- The generic type is a bit tricky to understand, but it's easier to +-- understand what's going on if you instantiate with concrete types: +-- +-- @ +-- ghci> :t gatherN @MyInplicative @'[Int, Bool, String] +-- (Int -> Bool -> String -> b) +-- -> (b -> XRec Identity '[Int, Bool, String]) +-- -> MyInplicative Int +-- -> MyInplicative Bool +-- -> MyInplicative String +-- -> MyInplicative b +-- @ +-- +-- @since 0.4.1.0 +gatherN + :: forall f as b. (Inplicative f, V.IsoXRec V.Identity as, V.RecordCurry as) + => V.Curried as b + -> (b -> V.XRec V.Identity as) + -> V.CurriedF f as (f b) +gatherN f g = V.rcurry @as @f $ + invmap (V.runcurry' f . V.fromXRec) g + . gatheredNRec + +-- | A version of 'gatheredN1' 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 +-- @since 0.4.1.0 +gatheredN1Rec :: Inply f => V.Rec f (a ': as) -> f (V.XRec V.Identity (a ': as)) -concatInplyRec (x V.:& xs) = case xs of +gatheredN1Rec (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) + (gatheredN1Rec xs) + +-- | A version of 'gatheredNMap' 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 tuple components. +-- +-- @since 0.4.1.0 +gatheredN1MapRec + :: Inplicative f + => (V.XRec V.Identity (a ': as) -> b) + -> (b -> V.XRec V.Identity (a ': as)) + -> V.Rec f (a ': as) + -> f b +gatheredN1MapRec f g = invmap f g . gatheredN1Rec + +-- | 'gatherN' but with at least one argument, so can be used with any +-- 'Inply'. +-- +-- @since 0.4.1.0 +gatherN1 + :: forall f a as b. (Inply f, V.IsoXRec V.Identity as, V.RecordCurry as) + => V.Curried (a ': as) b + -> (b -> V.XRec V.Identity (a ': as)) + -> V.CurriedF f (a ': as) (f b) +gatherN1 f g = V.rcurry @(a ': as) @f $ + invmap (V.runcurry' f . V.fromXRec) g + . gatheredN1Rec + +-- | Interpret out of a contravariant 'Day' into any instance of 'Apply' by +-- providing two interpreting functions. +-- +-- In theory, this should not need to exist, since you should always be +-- able to use 'runDay' because every instance of 'Apply' is also an +-- instance of 'Inply'. However, this can be handy if you are using an +-- instance of 'Apply' that has no 'Inply' instance. Consider also +-- 'unsafeInplyCo' if you are using a specific, concrete type for @h@. +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 out of a contravariant 'Day' into any instance of 'Divise' +-- by providing two interpreting functions. +-- +-- In theory, this should not need to exist, since you should always be +-- able to use 'runDay' because every instance of 'Divise' is also an +-- instance of 'Inply'. However, this can be handy if you are using an +-- instance of 'Divise' that has no 'Inply' instance. Consider also +-- 'unsafeInplyContra' if you are using a specific, concrete type for @h@. +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) + diff --git a/src/Data/Functor/Invariant/Inplicative/Free.hs b/src/Data/Functor/Invariant/Inplicative/Free.hs --- a/src/Data/Functor/Invariant/Inplicative/Free.hs +++ b/src/Data/Functor/Invariant/Inplicative/Free.hs @@ -34,9 +34,6 @@ , foldDivAp1 , assembleDivAp1 , assembleDivAp1Rec - -- * Day Utility - , runDayApply - , runDayDivise ) where import Control.Applicative @@ -62,52 +59,54 @@ 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'. +-- | In the covariant direction, we can interpret into any 'Apply'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Apply' is also an instance +-- of 'Inply'. However, this can be handy if you are using an instance of +-- 'Apply' that has no 'Inply' instance. Consider also 'unsafeInplyCo' if +-- you are using a specific, concrete type for @g@. 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'. +-- | In the contravariant direction, we can interpret into any 'Divise'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Divise' is also an instance +-- of 'Inply'. However, this can be handy if you are using an instance of +-- 'Divise' that has no 'Inply' instance. Consider also +-- 'unsafeInplyContra' if you are using a specific, concrete type for @g@. 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'. +-- | In the covariant direction, we can interpret into any 'Applicative'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Applicative' is also an +-- instance of 'Inplicative'. However, this can be handy if you are using +-- an instance of 'Applicative' that has no 'Inplicative' instance. +-- Consider also 'unsafeInplicativeCo' if you are using a specific, +-- concrete type for @g@. 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'. +-- | In the covariant direction, we can interpret into any 'Divisible'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Divisible' is also an +-- instance of 'Inplicative'. However, this can be handy if you are using +-- an instance of 'Divisible' that has no 'Inplicative' instance. Consider +-- also 'unsafeInplicativeContra' if you are using a specific, concrete +-- type for @g@. runContraDivAp :: forall f g. Divisible g => f ~> g diff --git a/src/Data/Functor/Invariant/Internative.hs b/src/Data/Functor/Invariant/Internative.hs --- a/src/Data/Functor/Invariant/Internative.hs +++ b/src/Data/Functor/Invariant/Internative.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DerivingVia #-} + -- | -- Module : Data.Functor.Invariant.Internative -- Copyright : (c) Justin Le 2021 @@ -18,14 +20,44 @@ , Inplus(..) , Internative -- * Assembling Helpers - , concatInplus - , concatInalt + , swervedN + , swervedNMap + , swervedN1 + , swervedN1Map ) where +import Control.Applicative +import Control.Applicative.Backwards (Backwards(..)) +import Control.Arrow (ArrowPlus) +import Control.Monad +import Control.Monad.Trans.Identity (IdentityT(..)) +import Data.Functor.Alt +import Data.Functor.Contravariant +import Data.Functor.Contravariant.Conclude +import Data.Functor.Contravariant.Decide +import Data.Functor.Contravariant.Divise +import Data.Functor.Contravariant.Divisible import Data.Functor.Invariant import Data.Functor.Invariant.Inplicative -import Data.SOP hiding (hmap) +import Data.Functor.Plus +import Data.Functor.Product (Product(..)) +import Data.Functor.Reverse (Reverse(..)) +import Data.Hashable (Hashable) +import Data.Kind +import Data.List.NonEmpty (NonEmpty) +import Data.SOP hiding (hmap) +import Data.Sequence (Seq) +import Data.StateVar (SettableStateVar) import Data.Void +import qualified Data.HashMap.Lazy as HM +import qualified Data.IntMap as IM +import qualified Data.IntMap.NonEmpty as NEIM +import qualified Data.Map as M +import qualified Data.Map.NonEmpty as NEM +import qualified Data.Monoid as Monoid +import qualified Data.Semigroup as Semigroup +import qualified Data.Sequence.NonEmpty as NESeq +import qualified GHC.Generics as Generics -- | The invariant counterpart of 'Alt' and 'Decide'. -- @@ -107,6 +139,228 @@ -- @since 0.4.0.0 class (Inplus f, Inplicative f) => Internative f +-- | Ignores the contravariant part of 'swerve' +instance Alt f => Inalt (WrappedFunctor f) where + swerved (WrapFunctor x) (WrapFunctor y) = WrapFunctor $ + (Left <$> x) (Right <$> y) +-- | @'reject' _ = 'zero'@ +instance Plus f => Inplus (WrappedFunctor f) where + reject _ = WrapFunctor zero +instance (Alternative f, Plus f, Apply f) => Internative (WrappedFunctor f) + +-- | Ignores the covariant part of 'gather' +instance Decide f => Inalt (WrappedContravariant f) where + swerve _ _ h (WrapContravariant x) (WrapContravariant y) = WrapContravariant (decide h x y) +-- | @'reject' = 'conclude'@ +instance Conclude f => Inplus (WrappedContravariant f) where + reject f = WrapContravariant (conclude f) +instance (Conclude f, Divisible f, Divise f) => Internative (WrappedContravariant f) + +-- | Ignores the covariant part of 'gather' +instance Decide f => Inalt (WrappedDivisible f) where + swerve _ _ h (WrapDivisible x) (WrapDivisible y) = WrapDivisible (decide h x y) +-- | @'reject' = 'conclude'@ +instance Conclude f => Inplus (WrappedDivisible f) where + reject f = WrapDivisible (conclude f) +instance (Conclude f, Divisible f, Divise f) => Internative (WrappedDivisible f) + +-- | Ignores the covariant part of 'gather' +instance (Decidable f, Invariant f) => Inalt (WrappedDivisibleOnly f) where + swerve _ _ h (WrapDivisibleOnly x) (WrapDivisibleOnly y) = WrapDivisibleOnly (choose h x y) +-- | @'reject' = 'lose'@ +instance (Decidable f, Invariant f) => Inplus (WrappedDivisibleOnly f) where + reject f = WrapDivisibleOnly (lose f) +instance (Decidable f, Invariant f) => Internative (WrappedDivisibleOnly f) + +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Proxy :: Type -> Type) instance Inalt Proxy +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Proxy :: Type -> Type) instance Inplus Proxy +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Proxy :: Type -> Type) instance Internative Proxy +-- | @since 0.4.1.0 +deriving via WrappedFunctor [] instance Inalt [] +-- | @since 0.4.1.0 +deriving via WrappedFunctor [] instance Inplus [] +-- | @since 0.4.1.0 +deriving via WrappedFunctor [] instance Internative [] +-- | @since 0.4.1.0 +deriving via WrappedFunctor Maybe instance Inalt Maybe +-- | @since 0.4.1.0 +deriving via WrappedFunctor Maybe instance Inplus Maybe +-- | @since 0.4.1.0 +deriving via WrappedFunctor Maybe instance Internative Maybe +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Either e) instance Inalt (Either e) +-- | @since 0.4.1.0 +deriving via WrappedFunctor IO instance Inalt IO +-- | @since 0.4.1.0 +deriving via WrappedFunctor IO instance Inplus IO +-- | @since 0.4.1.0 +deriving via WrappedFunctor IO instance Internative IO + +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.U1 :: Type -> Type) instance Inalt Generics.U1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.U1 :: Type -> Type) instance Inplus Generics.U1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.U1 :: Type -> Type) instance Internative Generics.U1 + +-- | @since 0.4.1.0 +instance Inalt f => Inalt (Generics.M1 i t f) where + swerve f g h (Generics.M1 x) (Generics.M1 y) = Generics.M1 (swerve f g h x y) +-- | @since 0.4.1.0 +instance Inplus f => Inplus (Generics.M1 i t f) where + reject = Generics.M1 . reject +-- | @since 0.4.1.0 +instance Internative f => Internative (Generics.M1 i t f) + +-- | @since 0.4.1.0 +instance (Inalt f, Inalt g) => Inalt (f Generics.:*: g) where + swerve f g h (x1 Generics.:*: y1) (x2 Generics.:*: y2) = + swerve f g h x1 x2 Generics.:*: swerve f g h y1 y2 +-- | @since 0.4.1.0 +instance (Inplus f, Inplus g) => Inplus (f Generics.:*: g) where + reject f = reject f Generics.:*: reject f +-- | @since 0.4.1.0 +instance (Internative f, Internative g) => Internative (f Generics.:*: g) + +-- | @since 0.4.1.0 +instance (Inalt f, Inalt g) => Inalt (Product f g) where + swerve f g h (Pair x1 y1) (Pair x2 y2) = + swerve f g h x1 x2 `Pair` swerve f g h y1 y2 +-- | @since 0.4.1.0 +instance (Inplus f, Inplus g) => Inplus (Product f g) where + reject f = reject f `Pair` reject f +-- | @since 0.4.1.0 +instance (Internative f, Internative g) => Internative (Product f g) + +-- | @since 0.4.1.0 +instance Inalt f => Inalt (Generics.Rec1 f) where + swerve f g h (Generics.Rec1 x) (Generics.Rec1 y) = Generics.Rec1 (swerve f g h x y) +-- | @since 0.4.1.0 +instance Inplus f => Inplus (Generics.Rec1 f) where + reject = Generics.Rec1 . reject +-- | @since 0.4.1.0 +instance Internative f => Internative (Generics.Rec1 f) + +-- | @since 0.4.1.0 +instance Inalt f => Inalt (IdentityT f) where + swerve f g h (IdentityT x) (IdentityT y) = IdentityT (swerve f g h x y) +-- | @since 0.4.1.0 +instance Inplus f => Inplus (IdentityT f) where + reject = IdentityT . reject +-- | @since 0.4.1.0 +instance Internative f => Internative (IdentityT f) where + +-- | @since 0.4.1.0 +instance Inalt f => Inalt (Reverse f) where + swerve f g h (Reverse x) (Reverse y) = Reverse (swerve f g h x y) +-- | @since 0.4.1.0 +instance Inplus f => Inplus (Reverse f) where + reject = Reverse . reject +-- | @since 0.4.1.0 +instance Internative f => Internative (Reverse f) where + +-- | @since 0.4.1.0 +instance Inalt f => Inalt (Backwards f) where + swerve f g h (Backwards x) (Backwards y) = Backwards (swerve f g h x y) +-- | @since 0.4.1.0 +instance Inplus f => Inplus (Backwards f) where + reject = Backwards . reject +-- | @since 0.4.1.0 +instance Internative f => Internative (Backwards f) where + +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.First instance Inalt Semigroup.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Last instance Inalt Semigroup.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Option instance Inalt Semigroup.Option +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Option instance Inplus Semigroup.Option +-- | @since 0.4.1.0 +deriving via WrappedFunctor Semigroup.Option instance Internative Semigroup.Option +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.First instance Inalt Monoid.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.First instance Inplus Monoid.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.First instance Internative Monoid.First +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Last instance Inalt Monoid.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Last instance Inplus Monoid.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor Monoid.Last instance Internative Monoid.Last +-- | @since 0.4.1.0 +deriving via WrappedFunctor NonEmpty instance Inalt NonEmpty +-- | @since 0.4.1.0 +deriving via WrappedFunctor Seq instance Inalt Seq +-- | @since 0.4.1.0 +deriving via WrappedFunctor Seq instance Inplus Seq +-- | @since 0.4.1.0 +deriving via WrappedFunctor Seq instance Internative Seq +-- | @since 0.4.1.0 +deriving via WrappedFunctor NESeq.NESeq instance Inalt NESeq.NESeq +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedArrow a b) instance ArrowPlus a => Inalt (WrappedArrow a b) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedArrow a b) instance ArrowPlus a => Inplus (WrappedArrow a b) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedArrow a b) instance ArrowPlus a => Internative (WrappedArrow a b) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (Generics.V1 :: Type -> Type) instance Inalt Generics.V1 +-- | @since 0.4.1.0 +deriving via WrappedFunctor IM.IntMap instance Inalt IM.IntMap +-- | @since 0.4.1.0 +deriving via WrappedFunctor NEIM.NEIntMap instance Inalt NEIM.NEIntMap +-- | @since 0.4.1.0 +deriving via WrappedFunctor (M.Map k) instance Ord k => Inalt (M.Map k) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (NEM.NEMap k) instance Ord k => Inalt (NEM.NEMap k) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (HM.HashMap k) instance (Hashable k, Eq k) => Inalt (HM.HashMap k) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedMonad m) instance MonadPlus m => Inalt (WrappedMonad m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedMonad m) instance MonadPlus m => Inplus (WrappedMonad m) +-- | @since 0.4.1.0 +deriving via WrappedFunctor (WrappedMonad m) instance MonadPlus m => Internative (WrappedMonad m) + +-- | @since 0.4.1.0 +deriving via WrappedDivisible SettableStateVar instance Inalt SettableStateVar +-- | @since 0.4.1.0 +deriving via WrappedDivisible SettableStateVar instance Inplus SettableStateVar +-- | @since 0.4.1.0 +deriving via WrappedDivisible SettableStateVar instance Internative SettableStateVar +-- | @since 0.4.1.0 +deriving via WrappedDivisible Predicate instance Inalt Predicate +-- | @since 0.4.1.0 +deriving via WrappedDivisible Predicate instance Inplus Predicate +-- | @since 0.4.1.0 +deriving via WrappedDivisible Predicate instance Internative Predicate +-- | @since 0.4.1.0 +deriving via WrappedDivisible Comparison instance Inalt Comparison +-- | @since 0.4.1.0 +deriving via WrappedDivisible Comparison instance Inplus Comparison +-- | @since 0.4.1.0 +deriving via WrappedDivisible Comparison instance Internative Comparison +-- | @since 0.4.1.0 +deriving via WrappedDivisible Equivalence instance Inalt Equivalence +-- | @since 0.4.1.0 +deriving via WrappedDivisible Equivalence instance Inplus Equivalence +-- | @since 0.4.1.0 +deriving via WrappedDivisible Equivalence instance Internative Equivalence +-- | @since 0.4.1.0 +deriving via WrappedDivisible (Op r) instance Inalt (Op r) +-- | @since 0.4.1.0 +deriving via WrappedDivisible (Op r) instance Inplus (Op r) +-- | @since 0.4.1.0 +deriving via WrappedDivisible (Op r) instance Monoid r => Internative (Op r) + + + -- | 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 @@ -126,7 +380,7 @@ -- @ -- 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 +-- swervedN $ intPrim -- :* boolPrim -- :* stringPrim -- :* Nil @@ -139,32 +393,91 @@ -- * 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 +-- +-- @since 0.4.1.0 +swervedN :: Inplus f => NP f as -> f (NS I as) -concatInplus = \case +swervedN = \case Nil -> reject $ \case {} x :* xs -> swerve (Z . I) S (\case Z (I y) -> Left y; S ys -> Right ys) x - (concatInplus xs) + (swervedN xs) --- | A version of 'concatInplus' for non-empty 'NP', but only +-- | Given a function to "discern out" a data type into possible 'NS' +-- (multi-way Either) branches and one to re-assemble each brann, 'swerve' +-- all of the components together. +-- +-- 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: +-- +-- @ +-- swervedNMap +-- (\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) $ +-- $ 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, you don't need anything. +-- * 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. +-- +-- See notes on 'swervedNMap' for more details and caveats. +-- +-- @since 0.4.1.0 +swervedNMap + :: Inplus f + => (NS I as -> b) + -> (b -> NS I as) + -> NP f as + -> f b +swervedNMap f g = invmap f g . swervedN + +-- | A version of 'swervedN' for non-empty 'NP', but only -- requiring an 'Inalt' instance. -- --- @since 0.4.0.0 -concatInalt +-- @since 0.4.1.0 +swervedN1 :: Inalt f => NP f (a ': as) -> f (NS I (a ': as)) -concatInalt (x :* xs) = case xs of +swervedN1 (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) + (swervedN1 xs) + +-- | A version of 'swervedNMap' for non-empty 'NS', but only +-- requiring an 'Inalt' instance. +-- +-- @since 0.4.1.0 +swervedN1Map + :: Inalt f + => (NS I (a ': as) -> b) + -> (b -> NS I (a ': as)) + -> NP f (a ': as) + -> f b +swervedN1Map f g = invmap f g . swervedN1 + diff --git a/src/Data/Functor/Invariant/Internative/Free.hs b/src/Data/Functor/Invariant/Internative/Free.hs --- a/src/Data/Functor/Invariant/Internative/Free.hs +++ b/src/Data/Functor/Invariant/Internative/Free.hs @@ -58,16 +58,26 @@ import qualified Data.List.NonEmpty as NE --- | In the covariant direction, we can interpret out of a 'Chain1' of 'Night' --- into any 'Alt'. +-- | In the covariant direction, we can interpret into any 'Alt'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Alt' is also an instance +-- of 'Inalt'. However, this can be handy if you are using an instance of +-- 'Alt' that has no 'Inalt' instance. Consider also 'unsafeInaltCo' if +-- you are using a specific, concrete type for @g@. 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'. +-- | In the contravariant direction, we can interpret into any 'Decide'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Decide' is also an instance +-- of 'Inalt'. However, this can be handy if you are using an instance of +-- 'Decide' that has no 'Inalt' instance. Consider also +-- 'unsafeInaltContra' if you are using a specific, concrete type for @g@. runContraDecAlt1 :: forall f g. Decide g => f ~> g @@ -84,16 +94,26 @@ decAltDec1 :: DecAlt1 f ~> Dec1 f decAltDec1 = runContraDecAlt1 inject --- | In the covariant direction, we can interpret out of a 'Chain' of 'Night' --- into any 'Plus'. +-- | In the covariant direction, we can interpret into any 'Plus'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Plus' is also an instance +-- of 'Inplus'. However, this can be handy if you are using an instance of +-- 'Plus' that has no 'Inplus' instance. Consider also 'unsafeInplusCo' if +-- you are using a specific, concrete type for @g@. 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'. +-- | In the contravariant direction, we can interpret into any 'Decide'. +-- +-- In theory, this shouldn't never be necessary, because you should just be +-- able to use 'interpret', since any instance of 'Conclude' is also an +-- instance of 'Inplus'. However, this can be handy if you are using an +-- instance of 'Conclude' that has no 'Inplus' instance. Consider also +-- 'unsafeInplusContra' if you are using a specific, concrete type for @g@. runContraDecAlt :: forall f g. Conclude g => f ~> g diff --git a/src/Data/HFunctor.hs b/src/Data/HFunctor.hs --- a/src/Data/HFunctor.hs +++ b/src/Data/HFunctor.hs @@ -556,7 +556,7 @@ hbind f (Coyoneda g x) = g <$> f x instance HBind Ap where - hbind = runAp + hbind f x = runAp f x instance HBind ListF where hbind f = foldMap f . runListF @@ -614,25 +614,25 @@ hbind f (M1 x) = f x instance HBind Alt.Alt where - hbind = Alt.runAlt + hbind f x = Alt.runAlt f x instance HBind Free where - hbind = interpretFree + hbind f x = interpretFree f x instance HBind Free1 where - hbind = interpretFree1 + hbind f x = interpretFree1 f x instance HBind FA.Ap where - hbind = FA.runAp + hbind f x = FA.runAp f x instance HBind FAF.Ap where - hbind = FAF.runAp + hbind f x = FAF.runAp f x instance HBind IdentityT where hbind f = f . runIdentityT instance HBind Lift where - hbind = elimLift point + hbind f x = elimLift point f x instance HBind MaybeApply where hbind f = either f point . runMaybeApply 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 @@ -358,7 +358,7 @@ hmap f x = Final $ \r -> runFinal x (r . f) instance Inject (Final c) where - inject x = Final ($ x) + inject x = Final $ \f -> f x instance c f => Interpret (Final c) f where retract x = runFinal x id 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 @@ -137,11 +137,11 @@ class HBifunctor (t :: (k -> Type) -> (k -> Type) -> k -> Type) where -- | Swap out the first transformed functor. hleft :: f ~> j -> t f g ~> t j g - hleft = (`hbimap` id) + hleft f x = hbimap f id x -- | Swap out the second transformed functor. hright :: g ~> l -> t f g ~> t f l - hright = hbimap id + hright f x = hbimap id f x -- | Swap out both transformed functors at the same time. hbimap :: f ~> j -> g ~> l -> t f g ~> t j l @@ -207,14 +207,14 @@ NDL x <> NDL y = NDL (x . toList . y) instance HFunctor Coyoneda where - hmap = hoistCoyoneda + hmap f x = hoistCoyoneda f x -- | @since 0.3.0.0 instance HFunctor CCY.Coyoneda where hmap f (CCY.Coyoneda g x) = CCY.Coyoneda g (f x) instance HFunctor Ap where - hmap = hoistAp + hmap f x = hoistAp f x instance HFunctor ListF where hmap f (ListF xs) = ListF (map f xs) @@ -232,7 +232,7 @@ hmap f (NEMapF xs) = NEMapF (fmap f xs) instance HFunctor Alt.Alt where - hmap = Alt.hoistAlt + hmap f x = Alt.hoistAlt f x -- | @since 0.3.6.0 instance HFunctor Alt.AltF where @@ -250,37 +250,37 @@ hmap f (Flagged b x) = Flagged b (f x) instance HFunctor Free where - hmap = hoistFree + hmap f x = hoistFree f x instance HFunctor Free1 where - hmap = hoistFree1 + hmap f x = hoistFree1 f x -- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or -- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires -- @'Functor' f@. instance HFunctor MC.F where - hmap = MC.hoistF + hmap f x = MC.hoistF f x -- | Note that there is no 'Data.HFunctor.Interpret.Interpret' or -- 'Data.HFunctor.Bind' instance, because 'Data.HFunctor.inject' requires -- @'Functor' f@. instance HFunctor MaybeT where - hmap f = mapMaybeT f + hmap f x = mapMaybeT f x instance HFunctor Yoneda where hmap f x = Yoneda $ f . runYoneda x instance HFunctor FA.Ap where - hmap = FA.hoistAp + hmap f x = FA.hoistAp f x instance HFunctor FAF.Ap where - hmap = FAF.hoistAp + hmap f x = FAF.hoistAp f x instance HFunctor IdentityT where - hmap = mapIdentityT + hmap f x = mapIdentityT f x instance HFunctor Lift where - hmap = mapLift + hmap f x = mapLift f x instance HFunctor MaybeApply where hmap f (MaybeApply x) = MaybeApply (first f x) @@ -292,10 +292,10 @@ hmap f (WrapApplicative x) = WrapApplicative (f x) instance HFunctor (ReaderT r) where - hmap = mapReaderT + hmap f x = mapReaderT f x instance HFunctor Tagged where - hmap _ = coerce + hmap _ x = coerce x instance HFunctor Reverse where hmap f (Reverse x) = Reverse (f x) @@ -310,13 +310,13 @@ hmap f (M1 x) = M1 (f x) instance HFunctor Void2 where - hmap _ = coerce + hmap _ x = coerce x instance HFunctor (EnvT e) where hmap f (EnvT e x) = EnvT e (f x) instance HFunctor Rec where - hmap = rmap + hmap f x = rmap f x instance HFunctor CoRec where hmap f (CoRec x) = CoRec (f x) @@ -330,7 +330,7 @@ hmap f = SOP.cata_NS (SOP.Z . f) SOP.S instance HFunctor (Joker f) where - hmap _ = coerce + hmap _ x = coerce x instance HFunctor (Void3 f) where hmap _ = \case {} @@ -349,14 +349,14 @@ hbimap f g (Pair x y) = Pair (f x) (g y) instance HBifunctor Day where - hleft = D.trans1 - hright = D.trans2 + hleft f x = D.trans1 f x + hright f x = D.trans2 f x hbimap f g (Day x y z) = Day (f x) (g y) z -- | @since 0.3.0.0 instance HBifunctor CD.Day where - hleft = CD.trans1 - hright = CD.trans2 + hleft f x = CD.trans1 f x + hright f x = CD.trans2 f x hbimap f g (CD.Day x y z) = CD.Day (f x) (g y) z -- | @since 0.3.4.0 @@ -368,8 +368,8 @@ -- | @since 0.3.0.0 instance HBifunctor Night where - hleft = N.trans1 - hright = N.trans2 + hleft f x = N.trans1 f x + hright f x = N.trans2 f x hbimap f g (Night x y z) = Night (f x) (g y) z instance HBifunctor (:+:) where diff --git a/src/Data/HFunctor/Interpret.hs b/src/Data/HFunctor/Interpret.hs --- a/src/Data/HFunctor/Interpret.hs +++ b/src/Data/HFunctor/Interpret.hs @@ -427,7 +427,7 @@ retract = \case Ap.Pure x -> pure x Ap.Ap x xs -> x <**> retract xs - interpret = Ap.runAp + interpret f x = Ap.runAp f x -- | A free 'Plus' instance Plus f => Interpret ListF f where @@ -491,7 +491,7 @@ -- | A free 'Alternative' instance Alternative f => Interpret Alt.Alt f where - interpret = Alt.runAlt + interpret f x = Alt.runAlt f x instance Plus g => Interpret ((:*:) g) f where retract (_ :*: y) = y @@ -528,22 +528,22 @@ -- | A free 'Monad' instance Monad f => Interpret Free f where retract = retractFree - interpret = interpretFree + interpret f x = interpretFree f x -- | A free 'Bind' instance Bind f => Interpret Free1 f where retract = retractFree1 - interpret = interpretFree1 + interpret f x = interpretFree1 f x -- | A free 'Applicative' instance Applicative f => Interpret FA.Ap f where retract = FA.retractAp - interpret = FA.runAp + interpret f x = FA.runAp f x -- | A free 'Applicative' instance Applicative f => Interpret FAF.Ap f where retract = FAF.retractAp - interpret = FAF.runAp + interpret f x = FAF.runAp f x instance Interpret IdentityT f where retract = coerce @@ -552,7 +552,7 @@ -- | A free 'Pointed' instance Pointed f => Interpret Lift f where retract = elimLift point id - interpret = elimLift point + interpret f x = elimLift point f x -- | A free 'Pointed' instance Pointed f => Interpret MaybeApply f where