diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,27 @@ +Copyright (c) 2026 Tony Morris + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,76 @@ +# either-n + +![System F Logo](https://logo.systemf.com.au/systemf-450x450.png) + +Data types like `Either` but with more constructors, and optics for the +constructors of any sum type. + +Download from [hackage](http://hackage.haskell.org/package/either-n). + +## `Either3` + +`Either3 a b c` is a value of one of three types: + +```haskell +data Either3 a b c + = First3 a + | Second3 b + | Third3 c +``` + +The `Functor`, `Applicative` and `Monad` instances act on the third type +parameter, so `First3` and `Second3` short-circuit, in the same way `Left` +does for `Either`. The `Bifunctor` instances act on the second and third type +parameters. + +## `Either3T` + +`Either3T f a b c` is an `Either3` inside a type constructor `f`, in the same +way that `ExceptT e m a` is `m (Either e a)`: + +```haskell +newtype Either3T f a b c = Either3T (f (Either3 a b c)) +``` + +Use `_Wrapped` to convert between `Either3T f a b c` and `f (Either3 a b c)`. +The `Monad` instance requires `Monad f`, and `MonadIO`, `MonadFail`, +`MonadState`, `MonadReader`, `MonadWriter`, `MonadError`, `MonadRWS`, +`MonadCont` and `MonadZip` are lifted from `f`. `either3Identity` is the isomorphism between `Either3 a b c` and +`Either3T Identity a b c`. + +The type parameters are in the order `f a b c` so that `Either3T f a` is a +`Bifunctor`. As a consequence, `Either3T` has no `MonadTrans` instance. + +## Injections + +`Data.Lens.Injection` provides the classes `Injection1` to `Injection19`, the +sum-type duals of `Field1` to `Field19` from `lens`. Where `_1` is a lens to +the first field of a product, `_I1` is a prism to the first constructor of a +sum: + +```haskell +>>> (Left 1 :: Either Int String) ^? _I1 +Just 1 + +>>> _I2 # True :: Either3 Int Bool String +Second3 True +``` + +Instances are provided for `Either`, `Maybe`, `Bool`, `Ordering`, lists, +`Identity`, `()`, `Data.Functor.Sum`, `GHC.Generics.:+:`, `Either3` and +`Either3T Identity`. Each class has a default implementation for any type with +a `Generic` instance, so an instance needs no body: + +```haskell +data T a = T1 a | T2 | T3 Int Bool + deriving Generic + +instance Injection1 (T a) (T b) a b +instance Injection2 (T a) (T a) () () +instance Injection3 (T a) (T a) (Int, Bool) (Int, Bool) +``` + +A constructor with no fields has the focus `()`, a constructor with one field +has that field as its focus, and a constructor with more than one field has +any type with a single constructor with the same fields, such as a tuple, as +its focus. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,48 @@ +# Changelog + +## 0.1.0.0 + +* Add Data.Either3, re-exporting Data.Either3.Either3 and Data.Either3.Either3T +* Add Either3 a b c, with constructors First3, Second3 and Third3, and + instances for Eq, Eq1, Eq2, Ord, Ord1, Ord2, Show, Show1, Show2, Generic, + Generic1, Data, NFData, Semigroup, Functor, Apply, Applicative, Bind, Monad, + Alt, Extend, Selective, Foldable, Traversable, Bifunctor, Bifoldable, + Bitraversable, Swap, FunctorWithIndex, FoldableWithIndex, + TraversableWithIndex, MonadZip, Each, Injection1, Injection2 and Injection3 +* Add Either3T f a b c, a newtype for f (Either3 a b c), as ExceptT e m a is + for m (Either e a), with Wrapped and Rewrapped instances for converting to + and from f (Either3 a b c). Instances for Generic, Generic1, Data, NFData, + Eq, Eq1, Eq2, Ord, Ord1, Ord2, Show, Show1, Show2, Semigroup, Functor, + Apply, Applicative, Bind, Monad, Alt, Extend, Selective, Foldable, + Traversable, Bifunctor, Bifoldable, Bitraversable, Swap, + FunctorWithIndex, FoldableWithIndex, TraversableWithIndex and Each, each + with the corresponding constraint on f; instances lifted from f, as for + MaybeT, for MonadIO, MonadFail, MonadState, MonadReader, MonadWriter, + MonadError, MonadRWS, MonadCont and MonadZip; and instances for + f = Identity for Injection1, Injection2, Injection3, GetEither3, + HasEither3 and AsEither3 +* Add either3Identity, the isomorphism between Either3 a b c and + Either3TIdentity a b c +* Add isomorphisms reordering the type parameters of Either3 (either3ACB, + either3BAC, either3BCA, either3CAB, either3CBA) and of Either3T + (either3TACB, either3TBAC, either3TBCA, either3TCAB, either3TCBA) +* Add classy optics GetEither3, HasEither3, ReviewEither3, AsEither3 and + GetEither3T, HasEither3T, ReviewEither3T, AsEither3T. Instances of HasX + define setX, and instances of AsX define matchX; the lens and prism follow + from them +* Add rewrite rules fusing compositions of fmap, bimap, foldMap, foldr, + traverse, bifoldMap and bitraverse for Either3 and Either3T +* Add hedgehog property tests for the laws of every instance, using + hedgehog-fn to generate functions +* Add Injection1 .. Injection19 classes (Data.Lens.Injection.InjectionN), the sum-type + duals of Field1 .. Field19 from lens, with prisms _I1 .. _I19, and a + Data.Lens.Injection module re-exporting them +* Add Injection instances for Either, Maybe, Bool, Ordering, [], Identity, + (), Data.Functor.Sum and GHC.Generics (:+:). The second injection of [] + focuses on NonEmpty +* Add a GHC.Generics default for each InjectionN class, so that an instance + for a type with a Generic instance needs no body +* Add Data.Lens.Injection.Generic, with injection, a prism to the nth + constructor of any type with a Generic instance, where n is given by a + proxy, such as Proxy @0. The generic machinery behind it is in + Data.Lens.Injection.Generic.Internal, which is not part of the stable API diff --git a/either-n.cabal b/either-n.cabal new file mode 100644 --- /dev/null +++ b/either-n.cabal @@ -0,0 +1,159 @@ +cabal-version: 2.4 +name: either-n +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENCE +author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> +copyright: Copyright (c) 2026 Tony Morris +synopsis: Data types like Either but with more constructors +category: Data +description: + <> + . + Data types like @Either@ but with more constructors, and optics for the + constructors of any sum type. + . + == @Either3@ + . + @Either3 a b c@ is a value of one of three types, with the constructors + @First3@, @Second3@ and @Third3@. The @Functor@, @Applicative@ and @Monad@ + instances act on the third type parameter, so @First3@ and @Second3@ + short-circuit, in the same way @Left@ does for @Either@. + . + == @Either3T@ + . + @Either3T f a b c@ is an @Either3@ inside a type constructor @f@, in the + same way that @ExceptT e m a@ is @m (Either e a)@. Use @_Wrapped@ to convert + between @Either3T f a b c@ and @f (Either3 a b c)@. The @mtl@ classes are + lifted from @f@. + . + == Injections + . + @Data.Lens.Injection@ provides the classes @Injection1@ to @Injection19@, + the sum-type duals of @Field1@ to @Field19@ from @lens@. Where @_1@ is a lens + to the first field of a product, @_I1@ is a prism to the first constructor + of a sum. Each class has a default implementation for any type with a + @Generic@ instance. + +homepage: https://gitlab.com/tonymorris/either-n +bug-reports: https://gitlab.com/tonymorris/either-n/issues +build-type: Simple +extra-doc-files: README.md + changelog.md +tested-with: GHC == 9.14.1, GHC == 9.12.4, GHC == 9.10.3, GHC == 9.8.4, GHC == 9.6.7 + +source-repository head + type: git + location: https://gitlab.com/tonymorris/either-n.git + +flag doctest + description: Build the doctest test suite, which runs doctest through cabal. It is enabled in cabal.project, and disabled by default so that builds from the source distribution do not need cabal or doctest at test time. + default: False + manual: True + +library + default-language: + Haskell2010 + + build-depends: + base >= 4.18 && < 5 + , assoc >= 1.1 && < 2 + , deepseq >= 1.4.8.1 && < 2 + , selective >= 0.7 && < 1 + , semigroupoids >= 6.0.0.1 && < 7 + , lens >= 5.2.1 && < 6 + , mtl >= 2.3.1 && < 2.4 + + ghc-options: + -Wall + + hs-source-dirs: + src + + exposed-modules: + Data.Either3 + Data.Either3.Either3 + Data.Either3.Either3T + Data.Lens.Injection + Data.Lens.Injection.Generic + Data.Lens.Injection.Generic.Internal + Data.Lens.Injection.Injection1 + Data.Lens.Injection.Injection2 + Data.Lens.Injection.Injection3 + Data.Lens.Injection.Injection4 + Data.Lens.Injection.Injection5 + Data.Lens.Injection.Injection6 + Data.Lens.Injection.Injection7 + Data.Lens.Injection.Injection8 + Data.Lens.Injection.Injection9 + Data.Lens.Injection.Injection10 + Data.Lens.Injection.Injection11 + Data.Lens.Injection.Injection12 + Data.Lens.Injection.Injection13 + Data.Lens.Injection.Injection14 + Data.Lens.Injection.Injection15 + Data.Lens.Injection.Injection16 + Data.Lens.Injection.Injection17 + Data.Lens.Injection.Injection18 + Data.Lens.Injection.Injection19 + +test-suite hedgehog + type: + exitcode-stdio-1.0 + + main-is: + hedgehog_tests.hs + + other-modules: + Either3Tests + Either3TTests + Gens + Laws + + default-language: + Haskell2010 + + build-depends: + base >= 4.18 && < 5 + , assoc >= 1.1 && < 2 + , deepseq >= 1.4.8.1 && < 2 + , hedgehog >= 1.2 && < 2 + , hedgehog-fn >= 1.1 && < 2 + , lens >= 5.2.1 && < 6 + , mtl >= 2.3.1 && < 2.4 + , selective >= 0.7 && < 1 + , semigroupoids >= 6.0.0.1 && < 7 + , either-n + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test + +test-suite doctest + type: + exitcode-stdio-1.0 + + if !flag(doctest) + buildable: False + + main-is: + doctest_tests.hs + + default-language: + Haskell2010 + + build-depends: + base >= 4.18 && < 5 + , process >= 1.6.19.0 && < 2 + , either-n + + ghc-options: + -Wall + -threaded + + hs-source-dirs: + test diff --git a/src/Data/Either3.hs b/src/Data/Either3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either3.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | Data types similar to @Data.Either@ with three constructors. +module Data.Either3 ( + module Data.Either3.Either3, + module Data.Either3.Either3T, +) where + +import Data.Either3.Either3 +import Data.Either3.Either3T diff --git a/src/Data/Either3/Either3.hs b/src/Data/Either3/Either3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either3/Either3.hs @@ -0,0 +1,667 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | A data type similar to @Data.Either@ with three constructors. +module Data.Either3.Either3 ( + -- * Data type + Either3 (..), + + -- * Catamorphism + foldEither3, + + -- * Isomorphisms + either3ACB, + either3BAC, + either3BCA, + either3CAB, + either3CBA, + + -- * Optics + + -- ** Classy lenses + GetEither3 (..), + HasEither3 (..), + + -- ** Classy prisms + ReviewEither3 (..), + AsEither3 (..), +) where + +import Control.DeepSeq (NFData) +import Control.Lens (Each (..), FoldableWithIndex (..), FunctorWithIndex (..), Getter, Iso, Lens', Prism', Review, TraversableWithIndex (..), iso, lens, prism', review, unto, view) +import Control.Monad.Zip (MonadZip (..)) +import Control.Selective (Selective (..), selectM) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor.Swap (Swap (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Data (Data) +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..), showsUnaryWith) +import Data.Functor.Extend (Extend (..)) +import Data.Lens.Injection.Injection1 (Injection1) +import Data.Lens.Injection.Injection2 (Injection2) +import Data.Lens.Injection.Injection3 (Injection3) +import GHC.Generics (Generic, Generic1) + +{- $setup +>>> import Control.Lens((^?), (#), over, view, review, toListOf, imap) +>>> import Control.DeepSeq(rnf) +>>> import Data.Data(toConstr) +>>> import GHC.Generics(from, to) +>>> import Control.Monad.Zip(mzip) +>>> import Control.Selective(select) +>>> import Data.Bifunctor(bimap) +>>> import Data.Bifoldable(bifoldMap) +>>> import Data.Bitraversable(bitraverse) +>>> import Data.Bifunctor.Swap(swap) +>>> import Data.Functor.Alt(()) +>>> import Data.Functor.Apply((<.>)) +>>> import Data.Functor.Bind((>>-)) +>>> import Data.Functor.Classes(liftEq, liftCompare) +>>> import Data.Functor.Extend(duplicated) +>>> import Data.Lens.Injection.Injection1(Injection1(..)) +>>> import Data.Lens.Injection.Injection2(Injection2(..)) +>>> import Data.Lens.Injection.Injection3(Injection3(..)) +-} + +{- | A value of one of three types, similar to 'Either'. + +The 'Functor', 'Applicative' and 'Monad' instances act on the third type +parameter, so 'First3' and 'Second3' short-circuit, in the same way 'Left' +does for 'Either'. + +>>> toConstr (Second3 True :: Either3 String Bool Int) +Second3 + +>>> to (from (Third3 1 :: Either3 String Bool Int)) :: Either3 String Bool Int +Third3 1 +-} +data Either3 a b c + = First3 a + | Second3 b + | Third3 c + deriving stock (Data, Eq, Generic, Generic1, Ord, Show) + deriving anyclass (NFData) + +{- | Case analysis for 'Either3'. + +>>> foldEither3 length fromEnum (+ 1) (First3 "abc" :: Either3 String Bool Int) +3 + +>>> foldEither3 length (const 0) (+ 1) (Third3 1 :: Either3 String Bool Int) +2 +-} +foldEither3 :: (a -> x) -> (b -> x) -> (c -> x) -> Either3 a b c -> x +foldEither3 f _ _ (First3 a) = + f a +foldEither3 _ g _ (Second3 b) = + g b +foldEither3 _ _ h (Third3 c) = + h c +{-# INLINE foldEither3 #-} + +{- | Reorder the type parameters of 'Either3' to @a c b@. + +>>> view either3ACB (Second3 True :: Either3 String Bool Int) +Third3 True + +>>> view either3ACB (Third3 1 :: Either3 String Bool Int) +Second3 1 + +>>> over either3ACB (bimap show not) (Second3 True :: Either3 String Bool Int) +Second3 False +-} +either3ACB :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 a c b) (Either3 a' c' b') +either3ACB = + iso (foldEither3 First3 Third3 Second3) (foldEither3 First3 Third3 Second3) +{-# INLINE either3ACB #-} + +{- | Reorder the type parameters of 'Either3' to @b a c@. + +>>> view either3BAC (First3 "x" :: Either3 String Bool Int) +Second3 "x" + +>>> view either3BAC (Second3 True :: Either3 String Bool Int) +First3 True +-} +either3BAC :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 b a c) (Either3 b' a' c') +either3BAC = + iso (foldEither3 Second3 First3 Third3) (foldEither3 Second3 First3 Third3) +{-# INLINE either3BAC #-} + +{- | Reorder the type parameters of 'Either3' to @b c a@. + +>>> view either3BCA (First3 "x" :: Either3 String Bool Int) +Third3 "x" + +>>> view either3BCA (Second3 True :: Either3 String Bool Int) +First3 True + +>>> review either3BCA (First3 True :: Either3 Bool Int String) +Second3 True +-} +either3BCA :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 b c a) (Either3 b' c' a') +either3BCA = + iso (foldEither3 Third3 First3 Second3) (foldEither3 Second3 Third3 First3) +{-# INLINE either3BCA #-} + +{- | Reorder the type parameters of 'Either3' to @c a b@. + +>>> view either3CAB (First3 "x" :: Either3 String Bool Int) +Second3 "x" + +>>> view either3CAB (Third3 1 :: Either3 String Bool Int) +First3 1 + +>>> review either3CAB (First3 1 :: Either3 Int String Bool) +Third3 1 +-} +either3CAB :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 c a b) (Either3 c' a' b') +either3CAB = + iso (foldEither3 Second3 Third3 First3) (foldEither3 Third3 First3 Second3) +{-# INLINE either3CAB #-} + +{- | Reorder the type parameters of 'Either3' to @c b a@. + +>>> view either3CBA (First3 "x" :: Either3 String Bool Int) +Third3 "x" + +>>> view either3CBA (Second3 True :: Either3 String Bool Int) +Second3 True +-} +either3CBA :: Iso (Either3 a b c) (Either3 a' b' c') (Either3 c b a) (Either3 c' b' a') +either3CBA = + iso (foldEither3 Third3 Second3 First3) (foldEither3 Third3 Second3 First3) +{-# INLINE either3CBA #-} + +{- | +>>> fmap (+ 1) (Third3 1 :: Either3 String Bool Int) +Third3 2 + +>>> fmap (+ 1) (Second3 True :: Either3 String Bool Int) +Second3 True +-} +instance Functor (Either3 a b) where + fmap = + mapEither3 + {-# INLINE fmap #-} + +{- | +>>> sum (Third3 1 :: Either3 String Bool Int) +1 + +>>> length (First3 "x" :: Either3 String Bool Int) +0 +-} +instance Foldable (Either3 a b) where + foldMap = + foldMapEither3 + {-# INLINE foldMap #-} + foldr = + foldrEither3 + {-# INLINE foldr #-} + +{- | +>>> traverse (\x -> [x, x + 1]) (Third3 1 :: Either3 String Bool Int) +[Third3 1,Third3 2] + +>>> traverse (\x -> [x, x + 1]) (Second3 True :: Either3 String Bool Int) +[Second3 True] +-} +instance Traversable (Either3 a b) where + traverse = + traverseEither3 + {-# INLINE traverse #-} + +{- Fusion + +The 'Functor', 'Foldable', 'Traversable', 'Bifunctor', 'Bifoldable' and +'Bitraversable' methods delegate to the functions below, which are not +inlined before phase 1, so that the rewrite rules, which are active before +phase 1, can fuse compositions of them. Each rule is an instance of the functor law +@fmap f . fmap g = fmap (f . g)@, or of the corresponding law for +'bimap', 'foldMap', 'traverse', 'bifoldMap' or 'bitraverse'. +-} + +mapEither3 :: (c -> d) -> Either3 a b c -> Either3 a b d +mapEither3 f = + foldEither3 First3 Second3 (Third3 . f) +{-# NOINLINE [1] mapEither3 #-} + +bimapEither3 :: (b -> b') -> (c -> c') -> Either3 a b c -> Either3 a b' c' +bimapEither3 f g = + foldEither3 First3 (Second3 . f) (Third3 . g) +{-# NOINLINE [1] bimapEither3 #-} + +foldMapEither3 :: (Monoid m) => (c -> m) -> Either3 a b c -> m +foldMapEither3 = + foldEither3 (const mempty) (const mempty) +{-# NOINLINE [1] foldMapEither3 #-} + +foldrEither3 :: (c -> x -> x) -> x -> Either3 a b c -> x +foldrEither3 f z = + foldEither3 (const z) (const z) (`f` z) +{-# NOINLINE [1] foldrEither3 #-} + +traverseEither3 :: (Applicative g) => (c -> g d) -> Either3 a b c -> g (Either3 a b d) +traverseEither3 f = + foldEither3 (pure . First3) (pure . Second3) (fmap Third3 . f) +{-# NOINLINE [1] traverseEither3 #-} + +bifoldMapEither3 :: (Monoid m) => (b -> m) -> (c -> m) -> Either3 a b c -> m +bifoldMapEither3 = + foldEither3 (const mempty) +{-# NOINLINE [1] bifoldMapEither3 #-} + +bitraverseEither3 :: (Applicative g) => (b -> g b') -> (c -> g c') -> Either3 a b c -> g (Either3 a b' c') +bitraverseEither3 f g = + foldEither3 (pure . First3) (fmap Second3 . f) (fmap Third3 . g) +{-# NOINLINE [1] bitraverseEither3 #-} + +{-# RULES +"Either3 fmap/fmap" [~1] forall f g x. + mapEither3 f (mapEither3 g x) = + mapEither3 (f . g) x +"Either3 bimap/bimap" [~1] forall f g h k x. + bimapEither3 f g (bimapEither3 h k x) = + bimapEither3 (f . h) (g . k) x +"Either3 fmap/bimap" [~1] forall f g h x. + mapEither3 f (bimapEither3 g h x) = + bimapEither3 g (f . h) x +"Either3 bimap/fmap" [~1] forall f g h x. + bimapEither3 f g (mapEither3 h x) = + bimapEither3 f (g . h) x +"Either3 foldMap/fmap" [~1] forall f g x. + foldMapEither3 f (mapEither3 g x) = + foldMapEither3 (f . g) x +"Either3 foldr/fmap" [~1] forall f g z x. + foldrEither3 f z (mapEither3 g x) = + foldrEither3 (f . g) z x +"Either3 traverse/fmap" [~1] forall f g x. + traverseEither3 f (mapEither3 g x) = + traverseEither3 (f . g) x +"Either3 bifoldMap/bimap" [~1] forall f g h k x. + bifoldMapEither3 f g (bimapEither3 h k x) = + bifoldMapEither3 (f . h) (g . k) x +"Either3 bitraverse/bimap" [~1] forall f g h k x. + bitraverseEither3 f g (bimapEither3 h k x) = + bitraverseEither3 (f . h) (g . k) x + #-} + +{- | +>>> liftEq2 (==) (==) (Second3 1 :: Either3 String Int Int) (Second3 1) +True + +>>> liftEq2 (==) (==) (Second3 1 :: Either3 String Int Int) (Third3 1) +False +-} +instance (Eq a) => Eq2 (Either3 a) where + liftEq2 _ _ (First3 x) (First3 y) = x == y + liftEq2 f _ (Second3 x) (Second3 y) = f x y + liftEq2 _ g (Third3 x) (Third3 y) = g x y + liftEq2 _ _ _ _ = False + {-# INLINE liftEq2 #-} + +{- | +>>> liftEq (==) (Third3 1 :: Either3 String Bool Int) (Third3 1) +True +-} +instance (Eq a, Eq b) => Eq1 (Either3 a b) where + liftEq = liftEq2 (==) + {-# INLINE liftEq #-} + +{- | Orders 'First3' before 'Second3' before 'Third3', as the derived 'Ord' does. + +>>> liftCompare2 compare compare (First3 "x" :: Either3 String Int Int) (Third3 1) +LT + +>>> liftCompare2 compare compare (Third3 2 :: Either3 String Int Int) (Third3 1) +GT +-} +instance (Ord a) => Ord2 (Either3 a) where + liftCompare2 _ _ (First3 x) (First3 y) = compare x y + liftCompare2 _ _ (First3 _) _ = LT + liftCompare2 _ _ _ (First3 _) = GT + liftCompare2 f _ (Second3 x) (Second3 y) = f x y + liftCompare2 _ _ (Second3 _) (Third3 _) = LT + liftCompare2 _ _ (Third3 _) (Second3 _) = GT + liftCompare2 _ g (Third3 x) (Third3 y) = g x y + {-# INLINE liftCompare2 #-} + +{- | +>>> liftCompare compare (Second3 True :: Either3 String Bool Int) (Third3 1) +LT +-} +instance (Ord a, Ord b) => Ord1 (Either3 a b) where + liftCompare = liftCompare2 compare + {-# INLINE liftCompare #-} + +instance (Show a) => Show2 (Either3 a) where + liftShowsPrec2 _ _ _ _ d (First3 x) = showsUnaryWith showsPrec "First3" d x + liftShowsPrec2 sp1 _ _ _ d (Second3 x) = showsUnaryWith sp1 "Second3" d x + liftShowsPrec2 _ _ sp2 _ d (Third3 x) = showsUnaryWith sp2 "Third3" d x + {-# INLINE liftShowsPrec2 #-} + +instance (Show a, Show b) => Show1 (Either3 a b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + {-# INLINE liftShowsPrec #-} + +{- | The first 'Third3' wins, otherwise the second value, like 'Either'. + +>>> First3 "x" <> Third3 1 :: Either3 String Bool Int +Third3 1 + +>>> Third3 1 <> Third3 2 :: Either3 String Bool Int +Third3 1 + +>>> First3 "x" <> Second3 True :: Either3 String Bool Int +Second3 True +-} +instance Semigroup (Either3 a b c) where + (<>) = + () + {-# INLINE (<>) #-} + +{- | +>>> Third3 (+ 1) <.> Third3 1 :: Either3 String Bool Int +Third3 2 + +>>> First3 "x" <.> Second3 True :: Either3 String Bool Int +First3 "x" +-} +instance Apply (Either3 a b) where + First3 a <.> _ = + First3 a + Second3 b <.> _ = + Second3 b + Third3 f <.> e = + fmap f e + {-# INLINE (<.>) #-} + +{- | +>>> pure 1 :: Either3 String Bool Int +Third3 1 + +>>> Third3 (+ 1) <*> Second3 True :: Either3 String Bool Int +Second3 True +-} +instance Applicative (Either3 a b) where + pure = + Third3 + {-# INLINE pure #-} + (<*>) = + (<.>) + {-# INLINE (<*>) #-} + +{- | +>>> Third3 1 >>- (\x -> Third3 (x + 1)) :: Either3 String Bool Int +Third3 2 +-} +instance Bind (Either3 a b) where + (>>-) = + (>>=) + {-# INLINE (>>-) #-} + +{- | +>>> Third3 1 >>= (\x -> if x > 0 then Third3 (x + 1) else Second3 False) :: Either3 String Bool Int +Third3 2 + +>>> Second3 True >>= (\x -> Third3 (x + 1)) :: Either3 String Bool Int +Second3 True +-} +instance Monad (Either3 a b) where + First3 a >>= _ = + First3 a + Second3 b >>= _ = + Second3 b + Third3 c >>= f = + f c + {-# INLINE (>>=) #-} + +{- | Combines two 'Third3' values, otherwise the first 'First3' or 'Second3', as 'Control.Applicative.liftA2' does. + +>>> mzip (Third3 1) (Third3 True) :: Either3 String Bool (Int, Bool) +Third3 (1,True) + +>>> mzip (Second3 False) (First3 "x") :: Either3 String Bool (Int, Bool) +Second3 False +-} +instance MonadZip (Either3 a b) where + mzipWith = + liftA2 + {-# INLINE mzipWith #-} + +{- | The first 'Third3' wins, otherwise the second value, like 'Either'. + +>>> First3 "x" Third3 1 :: Either3 String Bool Int +Third3 1 + +>>> Second3 True First3 "x" :: Either3 String Bool Int +First3 "x" +-} +instance Alt (Either3 a b) where + Third3 c _ = + Third3 c + _ e = + e + {-# INLINE () #-} + +{- | +>>> duplicated (Third3 1 :: Either3 String Bool Int) +Third3 (Third3 1) + +>>> duplicated (Second3 True :: Either3 String Bool Int) +Second3 True +-} +instance Extend (Either3 a b) where + duplicated (First3 a) = + First3 a + duplicated (Second3 b) = + Second3 b + duplicated w@(Third3 _) = + Third3 w + {-# INLINE duplicated #-} + +{- | +>>> select (Third3 (Left 1)) (Third3 (+ 1)) :: Either3 String Bool Int +Third3 2 + +>>> select (Third3 (Right 1)) (Second3 True) :: Either3 String Bool Int +Third3 1 +-} +instance Selective (Either3 a b) where + select = + selectM + {-# INLINE select #-} + +{- | Maps the second and third type parameters. + +>>> bimap not (+ 1) (Second3 True :: Either3 String Bool Int) +Second3 False + +>>> bimap not (+ 1) (Third3 1 :: Either3 String Bool Int) +Third3 2 +-} +instance Bifunctor (Either3 a) where + bimap = + bimapEither3 + {-# INLINE bimap #-} + +{- | +>>> bifoldMap show show (Second3 True :: Either3 String Bool Int) +"True" + +>>> bifoldMap show show (First3 "x" :: Either3 String Bool Int) +"" +-} +instance Bifoldable (Either3 a) where + bifoldMap = + bifoldMapEither3 + {-# INLINE bifoldMap #-} + +{- | +>>> bitraverse (\b -> [b, not b]) (\c -> [c]) (Second3 True :: Either3 String Bool Int) +[Second3 True,Second3 False] +-} +instance Bitraversable (Either3 a) where + bitraverse = + bitraverseEither3 + {-# INLINE bitraverse #-} + +{- | Swaps the second and third type parameters. + +>>> swap (Second3 True :: Either3 String Bool Int) +Third3 True + +>>> swap (First3 "x" :: Either3 String Bool Int) +First3 "x" +-} +instance Swap (Either3 a) where + swap (First3 a) = + First3 a + swap (Second3 b) = + Third3 b + swap (Third3 c) = + Second3 c + {-# INLINE swap #-} + +{- | The index is always @()@, as for 'Maybe'. + +>>> imap (\() x -> x + 1) (Third3 1 :: Either3 String Bool Int) +Third3 2 +-} +instance FunctorWithIndex () (Either3 a b) where + imap f = + fmap (f ()) + {-# INLINE imap #-} + +instance FoldableWithIndex () (Either3 a b) where + ifoldMap f = + foldMap (f ()) + {-# INLINE ifoldMap #-} + +instance TraversableWithIndex () (Either3 a b) where + itraverse f = + traverse (f ()) + {-# INLINE itraverse #-} + +{- | Traverses the single value, like the 'Each' instance for @Either a a@. + +>>> over each (+ 1) (Second3 1 :: Either3 Int Int Int) +Second3 2 + +>>> toListOf each (First3 1 :: Either3 Int Int Int) +[1] +-} +instance Each (Either3 a a a) (Either3 b b b) a b where + each f (First3 a) = + First3 <$> f a + each f (Second3 a) = + Second3 <$> f a + each f (Third3 a) = + Third3 <$> f a + {-# INLINE each #-} + +{- | +>>> (First3 1 :: Either3 Int Bool String) ^? _I1 +Just 1 + +>>> over _I1 show (First3 1 :: Either3 Int Bool String) +First3 "1" +-} +instance Injection1 (Either3 a b c) (Either3 a' b c) a a' + +{- | +>>> (Second3 True :: Either3 Int Bool String) ^? _I2 +Just True + +>>> _I2 # True :: Either3 Int Bool String +Second3 True +-} +instance Injection2 (Either3 a b c) (Either3 a b' c) b b' + +{- | +>>> (Third3 "x" :: Either3 Int Bool String) ^? _I3 +Just "x" + +>>> (First3 1 :: Either3 Int Bool String) ^? _I3 +Nothing +-} +instance Injection3 (Either3 a b c) (Either3 a b c') c c' + +{- | Class for types that can be viewed as an 'Either3'. + +>>> view getEither3 (Third3 1 :: Either3 String Bool Int) +Third3 1 +-} +class GetEither3 s a b c | s -> a b c where + getEither3 :: Getter s (Either3 a b c) + +instance GetEither3 (Either3 a b c) a b c where + getEither3 = id + {-# INLINE getEither3 #-} + +{- | Class for types that have a 'Lens'' to an 'Either3'. Instances define +'setEither3'; the lens 'either3' follows from it and from 'getEither3'. + +>>> setEither3 (Second3 True) (Third3 1 :: Either3 String Bool Int) +Second3 True + +>>> over either3 (fmap (+ 1)) (Third3 1 :: Either3 String Bool Int) +Third3 2 +-} +class (GetEither3 s a b c) => HasEither3 s a b c | s -> a b c where + {-# MINIMAL setEither3 #-} + + setEither3 :: Either3 a b c -> s -> s + + either3 :: Lens' s (Either3 a b c) + either3 = lens (view getEither3) (flip setEither3) + {-# INLINE either3 #-} + +instance HasEither3 (Either3 a b c) a b c where + setEither3 = const + {-# INLINE setEither3 #-} + +{- | Class for types that can be constructed from an 'Either3'. + +>>> review reviewEither3 (First3 "x") :: Either3 String Bool Int +First3 "x" +-} +class ReviewEither3 t a b c | t -> a b c where + reviewEither3 :: Review t (Either3 a b c) + +instance ReviewEither3 (Either3 a b c) a b c where + reviewEither3 = unto id + {-# INLINE reviewEither3 #-} + +{- | Class for types that have a 'Prism'' to an 'Either3'. Instances define +'matchEither3'; the prism '_Either3' follows from it and from 'reviewEither3'. + +>>> matchEither3 (Third3 1 :: Either3 String Bool Int) +Just (Third3 1) + +>>> (Third3 1 :: Either3 String Bool Int) ^? _Either3 +Just (Third3 1) +-} +class (ReviewEither3 t a b c) => AsEither3 t a b c | t -> a b c where + {-# MINIMAL matchEither3 #-} + + matchEither3 :: t -> Maybe (Either3 a b c) + + _Either3 :: Prism' t (Either3 a b c) + _Either3 = prism' (review reviewEither3) matchEither3 + {-# INLINE _Either3 #-} + +instance AsEither3 (Either3 a b c) a b c where + matchEither3 = Just + {-# INLINE matchEither3 #-} diff --git a/src/Data/Either3/Either3T.hs b/src/Data/Either3/Either3T.hs new file mode 100644 --- /dev/null +++ b/src/Data/Either3/Either3T.hs @@ -0,0 +1,785 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- The lifted MonadState, MonadReader, MonadWriter, MonadError and MonadRWS +-- instances fail the coverage condition for their functional dependencies, as +-- mtl's own lifting instances do, and +-- the Data instance has the context Data (f (Either3 a b c)), as a derived +-- instance for a type applied to a type variable must. Each instance context +-- is on a component of the instance head, so instance resolution terminates. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} + +{- | 'Either3' inside a type constructor @f@, in the same way that @ExceptT e m a@ is @m (Either e a)@. + +Use '_Wrapped' to convert between @Either3T f a b c@ and @f (Either3 a b c)@. +-} +module Data.Either3.Either3T ( + -- * Data type + Either3T (..), + + -- * Isomorphisms + either3Identity, + either3TACB, + either3TBAC, + either3TBCA, + either3TCAB, + either3TCBA, + + -- * Type aliases + Either3TIdentity, + Either3TIO, + Either3TMaybe, + Either3TList, + + -- * Optics + + -- ** Classy lenses + GetEither3T (..), + HasEither3T (..), + + -- ** Classy prisms + ReviewEither3T (..), + AsEither3T (..), +) where + +import Control.DeepSeq (NFData (..), NFData1 (..)) +import Control.Lens (Each (..), FoldableWithIndex (..), FunctorWithIndex (..), Getter, Iso, Lens', Prism', Review, Rewrapped, TraversableWithIndex (..), Unwrapped, Wrapped (..), iso, lens, mapping, prism', review, unto, view, _Unwrapped, _Wrapped) +import Control.Monad.Cont.Class (MonadCont (..)) +import Control.Monad.Error.Class (MonadError (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS.Class (MonadRWS) +import Control.Monad.Reader.Class (MonadReader (..)) +import Control.Monad.State.Class (MonadState (..)) +import Control.Monad.Writer.Class (MonadWriter (..)) +import Control.Monad.Zip (MonadZip (..)) +import Control.Selective (Selective (..), selectM) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor.Swap (Swap (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Data (Data, Typeable) +import Data.Either3.Either3 ( + AsEither3 (..), + Either3 (..), + GetEither3 (..), + HasEither3 (..), + ReviewEither3 (..), + either3ACB, + either3BAC, + either3BCA, + either3CAB, + either3CBA, + foldEither3, + ) +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..), compare1, eq1, showsPrec1, showsUnaryWith) +import Data.Functor.Extend (Extend (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Lens.Injection.Injection1 (Injection1 (..)) +import Data.Lens.Injection.Injection2 (Injection2 (..)) +import Data.Lens.Injection.Injection3 (Injection3 (..)) +import GHC.Generics (Generic, Generic1) + +{- $setup +>>> import Control.DeepSeq(rnf) +>>> import Data.Data(toConstr) +>>> import GHC.Generics(from, to) +>>> import Control.Lens((^?), (#), over, view, review, toListOf, _Wrapped) +>>> import Control.Monad.State(State, runState, modify) +>>> import Control.Monad.Reader(Reader, runReader) +>>> import Control.Monad.Writer(Writer, runWriter) +>>> import Control.Monad.Cont(Cont, runCont) +>>> import Control.Monad.Zip(mzip) +>>> import Control.Selective(select) +>>> import Data.Bifunctor(bimap) +>>> import Data.Bifoldable(bifoldMap) +>>> import Data.Bitraversable(bitraverse) +>>> import Data.Bifunctor.Swap(swap) +>>> import Data.Functor.Alt(()) +>>> import Data.Functor.Extend(duplicated) +>>> import Data.Functor.Identity(Identity(..)) +>>> import Data.Lens.Injection.Injection1(Injection1(..)) +>>> import Data.Lens.Injection.Injection2(Injection2(..)) +>>> import Data.Lens.Injection.Injection3(Injection3(..)) +>>> let e3 = review reviewEither3 :: Either3 String Bool Int -> Either3TIdentity String Bool Int +-} + +{- | An 'Either3' inside @f@. + +>>> toConstr (Either3T [Third3 1] :: Either3TList String Bool Int) +Either3T + +>>> to (from (Either3T [Third3 1] :: Either3TList String Bool Int)) :: Either3TList String Bool Int +Either3T [Third3 1] +-} +newtype Either3T f a b c + = Either3T (f (Either3 a b c)) + deriving stock (Generic, Generic1) + +deriving stock instance (Typeable f, Data a, Data b, Data c, Data (f (Either3 a b c))) => Data (Either3T f a b c) + +-- | 'Either3T' over 'Identity', equivalent to 'Either3'. +type Either3TIdentity = Either3T Identity + +-- | 'Either3T' over 'IO'. +type Either3TIO = Either3T IO + +-- | 'Either3T' over 'Maybe'. +type Either3TMaybe = Either3T Maybe + +-- | 'Either3T' over lists. +type Either3TList = Either3T [] + +{- | 'Either3' is isomorphic to 'Either3T' over 'Identity'. + +>>> view either3Identity (Third3 1 :: Either3 String Bool Int) +Either3T (Identity (Third3 1)) + +>>> review either3Identity (Either3T (Identity (Second3 True)) :: Either3TIdentity String Bool Int) +Second3 True + +It can change the type parameters: + +>>> over either3Identity (fmap show) (Third3 1 :: Either3 String Bool Int) +Third3 "1" +-} +either3Identity :: Iso (Either3 a b c) (Either3 a' b' c') (Either3TIdentity a b c) (Either3TIdentity a' b' c') +either3Identity = iso (Either3T . Identity) (runIdentity . view _Wrapped) +{-# INLINE either3Identity #-} + +{- | Reorder the type parameters of 'Either3T' to @a c b@, applying 'either3ACB' under @f@. + +>>> view either3TACB (Either3T [Second3 True, Third3 1] :: Either3TList String Bool Int) +Either3T [Third3 True,Second3 1] +-} +either3TACB :: (Functor f) => Iso (Either3T f a b c) (Either3T f a' b' c') (Either3T f a c b) (Either3T f a' c' b') +either3TACB = + _Wrapped . mapping either3ACB . _Unwrapped +{-# INLINE either3TACB #-} + +{- | Reorder the type parameters of 'Either3T' to @b a c@, applying 'either3BAC' under @f@. + +>>> view either3TBAC (Either3T [First3 "x", Second3 True] :: Either3TList String Bool Int) +Either3T [Second3 "x",First3 True] +-} +either3TBAC :: (Functor f) => Iso (Either3T f a b c) (Either3T f a' b' c') (Either3T f b a c) (Either3T f b' a' c') +either3TBAC = + _Wrapped . mapping either3BAC . _Unwrapped +{-# INLINE either3TBAC #-} + +{- | Reorder the type parameters of 'Either3T' to @b c a@, applying 'either3BCA' under @f@. + +>>> view either3TBCA (Either3T [First3 "x", Second3 True] :: Either3TList String Bool Int) +Either3T [Third3 "x",First3 True] +-} +either3TBCA :: (Functor f) => Iso (Either3T f a b c) (Either3T f a' b' c') (Either3T f b c a) (Either3T f b' c' a') +either3TBCA = + _Wrapped . mapping either3BCA . _Unwrapped +{-# INLINE either3TBCA #-} + +{- | Reorder the type parameters of 'Either3T' to @c a b@, applying 'either3CAB' under @f@. + +>>> view either3TCAB (Either3T [First3 "x", Third3 1] :: Either3TList String Bool Int) +Either3T [Second3 "x",First3 1] +-} +either3TCAB :: (Functor f) => Iso (Either3T f a b c) (Either3T f a' b' c') (Either3T f c a b) (Either3T f c' a' b') +either3TCAB = + _Wrapped . mapping either3CAB . _Unwrapped +{-# INLINE either3TCAB #-} + +{- | Reorder the type parameters of 'Either3T' to @c b a@, applying 'either3CBA' under @f@. + +>>> view either3TCBA (Either3T [First3 "x", Third3 1] :: Either3TList String Bool Int) +Either3T [Third3 "x",First3 1] +-} +either3TCBA :: (Functor f) => Iso (Either3T f a b c) (Either3T f a' b' c') (Either3T f c b a) (Either3T f c' b' a') +either3TCBA = + _Wrapped . mapping either3CBA . _Unwrapped +{-# INLINE either3TCBA #-} + +{- | +>>> view _Wrapped (Either3T [Third3 1, First3 "x"] :: Either3TList String Bool Int) +[Third3 1,First3 "x"] + +>>> review _Wrapped [Second3 True] :: Either3TList String Bool Int +Either3T [Second3 True] +-} +instance Wrapped (Either3T f a b c) where + type Unwrapped (Either3T f a b c) = f (Either3 a b c) + _Wrapped' = + iso (\(Either3T x) -> x) Either3T + {-# INLINE _Wrapped' #-} + +{- | +Changes the type constructor from lists to 'Maybe': + +>>> over _Wrapped (foldr (const . Just) Nothing) (Either3T [Third3 1, Third3 2] :: Either3TList String Bool Int) :: Either3TMaybe String Bool Int +Either3T (Just (Third3 1)) +-} +instance (t ~ Either3T f' a' b' c') => Rewrapped (Either3T f a b c) t + +{- | +>>> rnf (Either3T [Third3 1, First3 "x"] :: Either3TList String Bool Int) +() +-} +instance (NFData1 f, NFData a, NFData b, NFData c) => NFData (Either3T f a b c) where + rnf (Either3T x) = + liftRnf rnf x + {-# INLINE rnf #-} + +{- | +>>> Either3T [Third3 1] == (Either3T [Third3 1] :: Either3TList String Bool Int) +True + +>>> Either3T [Third3 1] == (Either3T [Second3 True] :: Either3TList String Bool Int) +False +-} +instance (Eq1 f, Eq a, Eq b, Eq c) => Eq (Either3T f a b c) where + Either3T x == Either3T y = + eq1 x y + {-# INLINE (==) #-} + +instance (Eq1 f, Eq a) => Eq2 (Either3T f a) where + liftEq2 f g (Either3T x) (Either3T y) = + liftEq (liftEq2 f g) x y + {-# INLINE liftEq2 #-} + +instance (Eq1 f, Eq a, Eq b) => Eq1 (Either3T f a b) where + liftEq = liftEq2 (==) + {-# INLINE liftEq #-} + +{- | +>>> compare (Either3T [First3 "x"]) (Either3T [Third3 1] :: Either3TList String Bool Int) +LT +-} +instance (Ord1 f, Ord a, Ord b, Ord c) => Ord (Either3T f a b c) where + compare (Either3T x) (Either3T y) = + compare1 x y + {-# INLINE compare #-} + +instance (Ord1 f, Ord a) => Ord2 (Either3T f a) where + liftCompare2 f g (Either3T x) (Either3T y) = + liftCompare (liftCompare2 f g) x y + {-# INLINE liftCompare2 #-} + +instance (Ord1 f, Ord a, Ord b) => Ord1 (Either3T f a b) where + liftCompare = liftCompare2 compare + {-# INLINE liftCompare #-} + +{- | +>>> Either3T [Third3 1, First3 "x"] :: Either3TList String Bool Int +Either3T [Third3 1,First3 "x"] + +>>> e3 (Second3 True) +Either3T (Identity (Second3 True)) +-} +instance (Show1 f, Show a, Show b, Show c) => Show (Either3T f a b c) where + showsPrec d (Either3T x) = + showsUnaryWith showsPrec1 "Either3T" d x + {-# INLINE showsPrec #-} + +instance (Show1 f, Show a) => Show2 (Either3T f a) where + liftShowsPrec2 sp1 sl1 sp2 sl2 d (Either3T x) = + showsUnaryWith (liftShowsPrec (liftShowsPrec2 sp1 sl1 sp2 sl2) (liftShowList2 sp1 sl1 sp2 sl2)) "Either3T" d x + {-# INLINE liftShowsPrec2 #-} + +instance (Show1 f, Show a, Show b) => Show1 (Either3T f a b) where + liftShowsPrec = liftShowsPrec2 showsPrec showList + {-# INLINE liftShowsPrec #-} + +{- | The first value that is 'Third3' wins, otherwise the second value, like 'Either'. + +>>> Either3T [First3 "x"] <> Either3T [Third3 1] :: Either3TList String Bool Int +Either3T [Third3 1] +-} +instance (Monad f) => Semigroup (Either3T f a b c) where + (<>) = + () + {-# INLINE (<>) #-} + +{- | +>>> fmap (+ 1) (Either3T [Third3 1, Second3 True] :: Either3TList String Bool Int) +Either3T [Third3 2,Second3 True] +-} +instance (Functor f) => Functor (Either3T f a b) where + fmap = + mapEither3T + {-# INLINE fmap #-} + +{- | Runs the effects of the second argument only when the first is 'Third3'. + +>>> Either3T [Third3 (+ 1), First3 "x"] <.> Either3T [Third3 1, Third3 2] :: Either3TList String Bool Int +Either3T [Third3 2,Third3 3,First3 "x"] +-} +instance (Monad f) => Apply (Either3T f a b) where + Either3T x <.> Either3T y = + Either3T $ + x >>= \case + First3 a -> pure (First3 a) + Second3 b -> pure (Second3 b) + Third3 g -> fmap (fmap g) y + {-# INLINE (<.>) #-} + +{- | +>>> pure 1 :: Either3TList String Bool Int +Either3T [Third3 1] +-} +instance (Monad f) => Applicative (Either3T f a b) where + pure = + Either3T . pure . Third3 + {-# INLINE pure #-} + (<*>) = + (<.>) + {-# INLINE (<*>) #-} + +instance (Monad f) => Bind (Either3T f a b) where + (>>-) = + (>>=) + {-# INLINE (>>-) #-} + +{- | +>>> Either3T [Third3 1, Second3 True] >>= (\x -> Either3T [Third3 x, Third3 (x + 1)]) :: Either3TList String Bool Int +Either3T [Third3 1,Third3 2,Second3 True] +-} +instance (Monad f) => Monad (Either3T f a b) where + Either3T x >>= k = + Either3T (x >>= foldEither3 (pure . First3) (pure . Second3) (\c -> let Either3T y = k c in y)) + {-# INLINE (>>=) #-} + +{- | The first value that is 'Third3' wins, otherwise the second value, like 'Either'. + +>>> Either3T [Second3 True] Either3T [Third3 1] :: Either3TList String Bool Int +Either3T [Third3 1] + +>>> Either3T [Second3 True] Either3T [First3 "x"] :: Either3TList String Bool Int +Either3T [First3 "x"] +-} +instance (Monad f) => Alt (Either3T f a b) where + Either3T x Either3T y = + Either3T (x >>= foldEither3 (const y) (const y) (pure . Third3)) + {-# INLINE () #-} + +{- | +>>> duplicated (Either3T [Third3 1, First3 "x"] :: Either3TList String Bool Int) +Either3T [Third3 (Either3T [Third3 1]),First3 "x"] +-} +instance (Applicative f) => Extend (Either3T f a b) where + duplicated = + fmap (Either3T . pure . Third3) + {-# INLINE duplicated #-} + +{- | +>>> select (pure (Left 1)) (pure (+ 1)) :: Either3TList String Bool Int +Either3T [Third3 2] +-} +instance (Monad f) => Selective (Either3T f a b) where + select = + selectM + {-# INLINE select #-} + +{- | Lifts 'liftIO' from @f@. + +>>> view _Wrapped (liftIO (pure 1) :: Either3TIO String Bool Int) +Third3 1 +-} +instance (MonadIO f) => MonadIO (Either3T f a b) where + liftIO = + Either3T . fmap Third3 . liftIO + {-# INLINE liftIO #-} + +{- | Lifts 'fail' from @f@. + +>>> fail "x" :: Either3TMaybe String Bool Int +Either3T Nothing +-} +instance (MonadFail f) => MonadFail (Either3T f a b) where + fail = + Either3T . fail + {-# INLINE fail #-} + +{- | Lifts 'state' from @f@. + +>>> runState (view _Wrapped (modify (+ 1) >> get :: Either3T (State Int) String Bool Int)) 1 +(Third3 2,2) +-} +instance (MonadState s f) => MonadState s (Either3T f a b) where + state = + Either3T . fmap Third3 . state + {-# INLINE state #-} + +{- | Lifts 'ask' and 'local' from @f@, as the instance for @ExceptT@ does. + +>>> runReader (view _Wrapped (local (+ 1) ask :: Either3T (Reader Int) String Bool Int)) 1 +Third3 2 +-} +instance (MonadReader r f) => MonadReader r (Either3T f a b) where + ask = + Either3T (fmap Third3 ask) + {-# INLINE ask #-} + local g (Either3T x) = + Either3T (local g x) + {-# INLINE local #-} + reader = + Either3T . fmap Third3 . reader + {-# INLINE reader #-} + +{- | Lifts 'tell', 'listen' and 'pass' from @f@, as the instance for @MaybeT@ does. + +>>> runWriter (view _Wrapped (tell [1] >> listen (tell [2] >> pure 'x') :: Either3T (Writer [Int]) String Bool (Char, [Int]))) +(Third3 ('x',[2]),[1,2]) + +>>> runWriter (view _Wrapped (pass (pure ('x', reverse)) <* tell [1, 2] :: Either3T (Writer [Int]) String Bool Char)) +(Third3 'x',[1,2]) + +>>> runWriter (view _Wrapped (pass (tell [1, 2] >> pure ('x', reverse)) :: Either3T (Writer [Int]) String Bool Char)) +(Third3 'x',[2,1]) +-} +instance (MonadWriter w f) => MonadWriter w (Either3T f a b) where + writer = + Either3T . fmap Third3 . writer + {-# INLINE writer #-} + tell = + Either3T . fmap Third3 . tell + {-# INLINE tell #-} + listen (Either3T x) = + Either3T $ do + (e, w) <- listen x + pure (fmap (,w) e) + {-# INLINE listen #-} + pass (Either3T x) = + Either3T $ + pass $ do + e <- x + pure $ case e of + First3 a -> (First3 a, id) + Second3 b -> (Second3 b, id) + Third3 (c, g) -> (Third3 c, g) + {-# INLINE pass #-} + +{- | Lifts 'throwError' and 'catchError' from @f@, as the instance for @MaybeT@ does. +'First3' and 'Second3' are values, not errors, so 'catchError' does not catch them. + +>>> view _Wrapped (throwError "e" `catchError` (\e -> pure (length e)) :: Either3T (Either String) String Bool Int) +Right (Third3 1) + +>>> view _Wrapped (review reviewEither3 (Second3 True) `catchError` (\_ -> pure 1) :: Either3T (Either String) String Bool Int) +Right (Second3 True) +-} +instance (MonadError e f) => MonadError e (Either3T f a b) where + throwError = + Either3T . throwError + {-# INLINE throwError #-} + catchError (Either3T x) h = + Either3T (catchError x (\e -> let Either3T y = h e in y)) + {-# INLINE catchError #-} + +-- | Lifts 'MonadRWS' from @f@. +instance (MonadRWS r w s f) => MonadRWS r w s (Either3T f a b) + +{- | Lifts 'callCC' from @f@, as the instance for @MaybeT@ does. + +>>> runCont (view _Wrapped (callCC (\k -> k 1 >> review reviewEither3 (Second3 True)) :: Either3T (Cont r) String Bool Int)) id +Third3 1 +-} +instance (MonadCont f) => MonadCont (Either3T f a b) where + callCC g = + Either3T $ callCC $ \k -> + let Either3T y = g (Either3T . k . Third3) + in y + {-# INLINE callCC #-} + +{- | Lifts 'mzipWith' from @f@, combining each pair of 'Either3' values with +'Control.Applicative.liftA2', as the instance for @MaybeT@ does. + +>>> mzip (Either3T [Third3 1, First3 "x"]) (Either3T [Third3 True, Third3 False]) :: Either3TList String Bool (Int, Bool) +Either3T [Third3 (1,True),First3 "x"] +-} +instance (MonadZip f) => MonadZip (Either3T f a b) where + mzipWith g (Either3T x) (Either3T y) = + Either3T (mzipWith (liftA2 g) x y) + {-# INLINE mzipWith #-} + +{- | Maps the second and third type parameters. + +>>> bimap not (+ 1) (Either3T [Second3 True, Third3 1] :: Either3TList String Bool Int) +Either3T [Second3 False,Third3 2] +-} +instance (Functor f) => Bifunctor (Either3T f a) where + bimap = + bimapEither3T + {-# INLINE bimap #-} + +{- | Swaps the second and third type parameters. + +>>> swap (Either3T [Second3 True, Third3 1] :: Either3TList String Bool Int) +Either3T [Third3 True,Second3 1] +-} +instance (Functor f) => Swap (Either3T f a) where + swap (Either3T x) = + Either3T (fmap swap x) + {-# INLINE swap #-} + +{- | +>>> sum (Either3T [Third3 1, First3 "x", Third3 2] :: Either3TList String Bool Int) +3 +-} +instance (Foldable f) => Foldable (Either3T f a b) where + foldMap = + foldMapEither3T + {-# INLINE foldMap #-} + +{- | +>>> traverse (\x -> Just (x + 1)) (Either3T [Third3 1, First3 "x"] :: Either3TList String Bool Int) +Just (Either3T [Third3 2,First3 "x"]) +-} +instance (Traversable f) => Traversable (Either3T f a b) where + traverse = + traverseEither3T + {-# INLINE traverse #-} + +{- | +>>> bifoldMap show show (Either3T [Second3 True, Third3 1] :: Either3TList String Bool Int) +"True1" +-} +instance (Foldable f) => Bifoldable (Either3T f a) where + bifoldMap = + bifoldMapEither3T + {-# INLINE bifoldMap #-} + +{- | +>>> bitraverse (Just . not) (Just . (+ 1)) (Either3T [Second3 True, Third3 1] :: Either3TList String Bool Int) +Just (Either3T [Second3 False,Third3 2]) +-} +instance (Traversable f) => Bitraversable (Either3T f a) where + bitraverse = + bitraverseEither3T + {-# INLINE bitraverse #-} + +{- Fusion + +The 'Functor', 'Foldable', 'Traversable', 'Bifunctor', 'Bifoldable' and +'Bitraversable' methods delegate to the functions below, which are not +inlined before phase 1, so that the rewrite rules, which are active before +phase 1, can fuse compositions of them. Each rule is an instance of the functor law +@fmap f . fmap g = fmap (f . g)@, or of the corresponding law for 'bimap', +'foldMap', 'traverse', 'bifoldMap' or 'bitraverse', for both 'Either3' and +@f@, so the rules assume that the instances for @f@ are lawful. +-} + +mapEither3T :: (Functor f) => (c -> d) -> Either3T f a b c -> Either3T f a b d +mapEither3T g (Either3T x) = + Either3T (fmap (fmap g) x) +{-# NOINLINE [1] mapEither3T #-} + +bimapEither3T :: (Functor f) => (b -> b') -> (c -> c') -> Either3T f a b c -> Either3T f a b' c' +bimapEither3T g h (Either3T x) = + Either3T (fmap (bimap g h) x) +{-# NOINLINE [1] bimapEither3T #-} + +foldMapEither3T :: (Foldable f, Monoid m) => (c -> m) -> Either3T f a b c -> m +foldMapEither3T g (Either3T x) = + foldMap (foldMap g) x +{-# NOINLINE [1] foldMapEither3T #-} + +traverseEither3T :: (Traversable f, Applicative g) => (c -> g d) -> Either3T f a b c -> g (Either3T f a b d) +traverseEither3T g (Either3T x) = + Either3T <$> traverse (traverse g) x +{-# NOINLINE [1] traverseEither3T #-} + +bifoldMapEither3T :: (Foldable f, Monoid m) => (b -> m) -> (c -> m) -> Either3T f a b c -> m +bifoldMapEither3T g h (Either3T x) = + foldMap (bifoldMap g h) x +{-# NOINLINE [1] bifoldMapEither3T #-} + +bitraverseEither3T :: (Traversable f, Applicative g) => (b -> g b') -> (c -> g c') -> Either3T f a b c -> g (Either3T f a b' c') +bitraverseEither3T g h (Either3T x) = + Either3T <$> traverse (bitraverse g h) x +{-# NOINLINE [1] bitraverseEither3T #-} + +{-# RULES +"Either3T fmap/fmap" [~1] forall f g x. + mapEither3T f (mapEither3T g x) = + mapEither3T (f . g) x +"Either3T bimap/bimap" [~1] forall f g h k x. + bimapEither3T f g (bimapEither3T h k x) = + bimapEither3T (f . h) (g . k) x +"Either3T fmap/bimap" [~1] forall f g h x. + mapEither3T f (bimapEither3T g h x) = + bimapEither3T g (f . h) x +"Either3T bimap/fmap" [~1] forall f g h x. + bimapEither3T f g (mapEither3T h x) = + bimapEither3T f (g . h) x +"Either3T foldMap/fmap" [~1] forall f g x. + foldMapEither3T f (mapEither3T g x) = + foldMapEither3T (f . g) x +"Either3T traverse/fmap" [~1] forall f g x. + traverseEither3T f (mapEither3T g x) = + traverseEither3T (f . g) x +"Either3T bifoldMap/bimap" [~1] forall f g h k x. + bifoldMapEither3T f g (bimapEither3T h k x) = + bifoldMapEither3T (f . h) (g . k) x +"Either3T bitraverse/bimap" [~1] forall f g h k x. + bitraverseEither3T f g (bimapEither3T h k x) = + bitraverseEither3T (f . h) (g . k) x + #-} + +-- | The index is always @()@, as for 'Maybe'. +instance (Functor f) => FunctorWithIndex () (Either3T f a b) where + imap g = + fmap (g ()) + {-# INLINE imap #-} + +instance (Foldable f) => FoldableWithIndex () (Either3T f a b) where + ifoldMap g = + foldMap (g ()) + {-# INLINE ifoldMap #-} + +instance (Traversable f) => TraversableWithIndex () (Either3T f a b) where + itraverse g = + traverse (g ()) + {-# INLINE itraverse #-} + +{- | Traverses every value inside @f@. + +>>> toListOf each (Either3T [First3 1, Second3 2, Third3 3] :: Either3TList Int Int Int) +[1,2,3] +-} +instance (Traversable f) => Each (Either3T f a a a) (Either3T f b b b) a b where + each g (Either3T x) = + Either3T <$> traverse (each g) x + {-# INLINE each #-} + +{- | +>>> e3 (First3 "x") ^? _I1 +Just "x" +-} +instance Injection1 (Either3T Identity a b c) (Either3T Identity a' b c) a a' where + _I1 = + _Wrapped . _Wrapped . _I1 + {-# INLINE _I1 #-} + +{- | +>>> e3 (Second3 True) ^? _I2 +Just True +-} +instance Injection2 (Either3T Identity a b c) (Either3T Identity a b' c) b b' where + _I2 = + _Wrapped . _Wrapped . _I2 + {-# INLINE _I2 #-} + +{- | +>>> e3 (Third3 1) ^? _I3 +Just 1 + +>>> e3 (First3 "x") ^? _I3 +Nothing +-} +instance Injection3 (Either3T Identity a b c) (Either3T Identity a b c') c c' where + _I3 = + _Wrapped . _Wrapped . _I3 + {-# INLINE _I3 #-} + +{- | +>>> view getEither3 (e3 (Third3 1)) +Third3 1 +-} +instance GetEither3 (Either3T Identity a b c) a b c where + getEither3 = + _Wrapped . _Wrapped + {-# INLINE getEither3 #-} + +{- | +>>> setEither3 (Second3 True) (e3 (Third3 1)) +Either3T (Identity (Second3 True)) +-} +instance HasEither3 (Either3T Identity a b c) a b c where + setEither3 e _ = + Either3T (Identity e) + {-# INLINE setEither3 #-} + +{- | Any 'Either3' can be put in an 'Applicative' @f@. + +>>> review reviewEither3 (Second3 True) :: Either3TMaybe String Bool Int +Either3T (Just (Second3 True)) +-} +instance (Applicative f) => ReviewEither3 (Either3T f a b c) a b c where + reviewEither3 = + unto (Either3T . pure) + {-# INLINE reviewEither3 #-} + +{- | +>>> matchEither3 (e3 (Third3 1)) +Just (Third3 1) + +>>> e3 (Third3 1) ^? _Either3 +Just (Third3 1) +-} +instance AsEither3 (Either3T Identity a b c) a b c where + matchEither3 (Either3T (Identity e)) = + Just e + {-# INLINE matchEither3 #-} + +-- | Class for types that can be viewed as an 'Either3T'. +class GetEither3T s f a b c | s -> f a b c where + getEither3T :: Getter s (Either3T f a b c) + +instance GetEither3T (Either3T f a b c) f a b c where + getEither3T = id + {-# INLINE getEither3T #-} + +{- | Class for types that have a 'Lens'' to an 'Either3T'. Instances define +'setEither3T'; the lens 'either3T' follows from it and from 'getEither3T'. + +>>> setEither3T (Either3T [Third3 2]) (Either3T [Third3 1] :: Either3TList String Bool Int) +Either3T [Third3 2] +-} +class (GetEither3T s f a b c) => HasEither3T s f a b c | s -> f a b c where + {-# MINIMAL setEither3T #-} + + setEither3T :: Either3T f a b c -> s -> s + + either3T :: Lens' s (Either3T f a b c) + either3T = lens (view getEither3T) (flip setEither3T) + {-# INLINE either3T #-} + +instance HasEither3T (Either3T f a b c) f a b c where + setEither3T = const + {-# INLINE setEither3T #-} + +-- | Class for types that can be constructed from an 'Either3T'. +class ReviewEither3T t f a b c | t -> f a b c where + reviewEither3T :: Review t (Either3T f a b c) + +instance ReviewEither3T (Either3T f a b c) f a b c where + reviewEither3T = unto id + {-# INLINE reviewEither3T #-} + +{- | Class for types that have a 'Prism'' to an 'Either3T'. Instances define +'matchEither3T'; the prism '_Either3T' follows from it and from 'reviewEither3T'. + +>>> matchEither3T (Either3T [Third3 1] :: Either3TList String Bool Int) +Just (Either3T [Third3 1]) +-} +class (ReviewEither3T t f a b c) => AsEither3T t f a b c | t -> f a b c where + {-# MINIMAL matchEither3T #-} + + matchEither3T :: t -> Maybe (Either3T f a b c) + + _Either3T :: Prism' t (Either3T f a b c) + _Either3T = prism' (review reviewEither3T) matchEither3T + {-# INLINE _Either3T #-} + +instance AsEither3T (Either3T f a b c) f a b c where + matchEither3T = Just + {-# INLINE matchEither3T #-} diff --git a/src/Data/Lens/Injection.hs b/src/Data/Lens/Injection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | Injections into sum types, as prisms. The sum-type duals of the @FieldN@ classes in "Control.Lens.Tuple". +module Data.Lens.Injection ( + module Data.Lens.Injection.Generic, + module Data.Lens.Injection.Injection1, + module Data.Lens.Injection.Injection2, + module Data.Lens.Injection.Injection3, + module Data.Lens.Injection.Injection4, + module Data.Lens.Injection.Injection5, + module Data.Lens.Injection.Injection6, + module Data.Lens.Injection.Injection7, + module Data.Lens.Injection.Injection8, + module Data.Lens.Injection.Injection9, + module Data.Lens.Injection.Injection10, + module Data.Lens.Injection.Injection11, + module Data.Lens.Injection.Injection12, + module Data.Lens.Injection.Injection13, + module Data.Lens.Injection.Injection14, + module Data.Lens.Injection.Injection15, + module Data.Lens.Injection.Injection16, + module Data.Lens.Injection.Injection17, + module Data.Lens.Injection.Injection18, + module Data.Lens.Injection.Injection19, +) where + +import Data.Lens.Injection.Generic +import Data.Lens.Injection.Injection1 +import Data.Lens.Injection.Injection10 +import Data.Lens.Injection.Injection11 +import Data.Lens.Injection.Injection12 +import Data.Lens.Injection.Injection13 +import Data.Lens.Injection.Injection14 +import Data.Lens.Injection.Injection15 +import Data.Lens.Injection.Injection16 +import Data.Lens.Injection.Injection17 +import Data.Lens.Injection.Injection18 +import Data.Lens.Injection.Injection19 +import Data.Lens.Injection.Injection2 +import Data.Lens.Injection.Injection3 +import Data.Lens.Injection.Injection4 +import Data.Lens.Injection.Injection5 +import Data.Lens.Injection.Injection6 +import Data.Lens.Injection.Injection7 +import Data.Lens.Injection.Injection8 +import Data.Lens.Injection.Injection9 diff --git a/src/Data/Lens/Injection/Generic.hs b/src/Data/Lens/Injection/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Generic.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall #-} + +{- | A prism to the @n@th constructor of any type with a 'Generic' instance. + +This is the default implementation of each of the @InjectionN@ classes. +The class 'GInjection' is exported so that it can be named in constraints; +the machinery behind it is in "Data.Lens.Injection.Generic.Internal". +-} +module Data.Lens.Injection.Generic ( + -- * Prism + injection, + + -- * Generic machinery + GInjection, +) where + +import Control.Lens (Prism, iso) +import Data.Lens.Injection.Generic.Internal (GInjection (..)) +import GHC.Generics (Generic (..)) + +{- $setup +>>> :set -XDataKinds -XDeriveGeneric -XTypeApplications +>>> import Control.Lens((^?), (#), over) +>>> import Data.Proxy(Proxy(..)) +>>> import GHC.Generics(Generic) +>>> data T a = T1 a | T2 | T3 Int Bool deriving (Show, Generic) +-} + +{- | A prism to the @n@th constructor (counting from 0) of a type with a 'Generic' instance, +where @n@ is given by a proxy, such as @Proxy \@0@. + +The focus of the prism depends on the fields of the constructor: + +* No fields: the focus is @()@. +* One field: the focus is that field. +* More than one field: the focus is any type with a single constructor + that has the same fields, such as a tuple. + +>>> T1 'x' ^? injection (Proxy @0) +Just 'x' + +>>> T2 ^? injection (Proxy @0) +Nothing + +Unlike the @InjectionN@ classes, 'injection' has no functional dependencies, +so a type-changing use may need a type annotation. + +>>> over (injection (Proxy @0)) show (T1 1) :: T String +T1 "1" + +>>> (T2 :: T Char) ^? injection (Proxy @1) +Just () + +>>> (T3 1 True :: T Char) ^? injection (Proxy @2) :: Maybe (Int, Bool) +Just (1,True) + +>>> injection (Proxy @2) # (1, True) :: T Char +T3 1 True +-} +injection :: (Generic s, Generic t, GInjection n (Rep s) (Rep t) a b) => proxy n -> Prism s t a b +injection n = + iso from to . gInjection n +{-# INLINE injection #-} diff --git a/src/Data/Lens/Injection/Generic/Internal.hs b/src/Data/Lens/Injection/Generic/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Generic/Internal.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- UndecidableInstances is needed because finding the nth constructor computes +-- with type families in instance contexts: GCount (f :+: g) adds the counts of +-- its branches, and the instances for :+: compare and subtract that count. +-- Resolution terminates: GCount recurses only on the smaller branches f and g +-- of f :+: g, and every GInjection, GInjectionSum and GProduct constraint in an +-- instance context is on a component of the instance head (the inside of an +-- M1, a branch of a :+:, or a factor of a :*:), so each step of resolution is +-- on a smaller representation type. Rep, CmpNat, + and - are evaluated by GHC, +-- and IsLT and AssertZero are not recursive. +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wall #-} + +{- | The generic machinery behind 'Data.Lens.Injection.Generic.injection'. + +This module is internal: its contents may change in any release, without a +major version bump. Use "Data.Lens.Injection.Generic" instead. +-} +module Data.Lens.Injection.Generic.Internal ( + GInjection (..), + GInjectionSum (..), + GProduct (..), + GCount, + IsLT, + AssertZero, +) where + +import Control.Lens (Prism, iso, prism, withPrism) +import Data.Bifunctor (first) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy (..)) +import GHC.Generics (C, C1, D, D1, Generic (..), K1 (..), M1 (..), S, U1 (..), (:*:) (..), (:+:) (..)) +import GHC.TypeLits (CmpNat, ErrorMessage (..), Nat, TypeError, type (+), type (-)) + +-- | The number of constructors in a generic sum. +type family GCount (f :: Type -> Type) :: Nat where + GCount (f :+: g) = GCount f + GCount g + GCount _ = 1 + +-- | Whether an 'Ordering' is 'LT'. +type family IsLT (o :: Ordering) :: Bool where + IsLT 'LT = 'True + IsLT _ = 'False + +-- | The index has reached a constructor, so it must be 0, otherwise it was out of range. +type family AssertZero (n :: Nat) :: Constraint where + AssertZero 0 = () + AssertZero n = TypeError ('Text "Injection index out of range: it is " ':<>: 'ShowType n ':<>: 'Text " past the last constructor") + +-- | A prism to the @n@th constructor of a generic representation. +class GInjection (n :: Nat) (s :: Type -> Type) (t :: Type -> Type) a b where + gInjection :: proxy n -> Prism (s x) (t x) a b + +instance (GInjection n s t a b) => GInjection n (M1 D m s) (M1 D m' t) a b where + gInjection n = + iso unM1 M1 . gInjection n + {-# INLINE gInjection #-} + +instance (GInjectionSum (IsLT (CmpNat n (GCount f))) n f g f' g' a b) => GInjection n (f :+: g) (f' :+: g') a b where + gInjection = + gInjectionSum (Proxy :: Proxy (IsLT (CmpNat n (GCount f)))) + {-# INLINE gInjection #-} + +-- | A constructor with no fields. +instance (AssertZero n, a ~ (), b ~ ()) => GInjection n (M1 C m U1) (M1 C m' U1) a b where + gInjection _ = + iso (const ()) (const (M1 U1)) + {-# INLINE gInjection #-} + +-- | A constructor with one field. +instance (AssertZero n, x ~ a, y ~ b) => GInjection n (M1 C m (M1 S ms (K1 i x))) (M1 C m' (M1 S ms' (K1 i' y))) a b where + gInjection _ = + iso (unK1 . unM1 . unM1) (M1 . M1 . K1) + {-# INLINE gInjection #-} + +-- | A constructor with more than one field. +instance + ( AssertZero n + , Generic a + , Generic b + , Rep a ~ D1 da (C1 ca p) + , Rep b ~ D1 db (C1 cb q) + , GProduct (f :*: g) p + , GProduct (f' :*: g') q + ) => + GInjection n (M1 C m (f :*: g)) (M1 C m' (f' :*: g')) a b + where + gInjection _ = + iso + (\(M1 x) -> to (M1 (M1 (gProductTo x)))) + (\b -> case from b of M1 (M1 y) -> M1 (gProductFrom y)) + {-# INLINE gInjection #-} + +{- | Descend into the left (@'True@) or right (@'False@) of a generic sum. +The other side of the sum is unchanged. +-} +class GInjectionSum (left :: Bool) (n :: Nat) f g f' g' a b where + gInjectionSum :: proxy left -> proxy' n -> Prism ((f :+: g) x) ((f' :+: g') x) a b + +instance (GInjection n f f' a b, g ~ g') => GInjectionSum 'True n f g f' g' a b where + gInjectionSum _ n = + withPrism (gInjection n :: Prism (f x) (f' x) a b) $ \bt sta -> + prism (L1 . bt) $ \case + L1 x -> first L1 (sta x) + R1 y -> Left (R1 y) + {-# INLINE gInjectionSum #-} + +instance (GInjection (n - GCount f) g g' a b, f ~ f') => GInjectionSum 'False n f g f' g' a b where + gInjectionSum _ _ = + withPrism (gInjection (Proxy :: Proxy (n - GCount f)) :: Prism (g x) (g' x) a b) $ \bt sta -> + prism (R1 . bt) $ \case + L1 x -> Left (L1 x) + R1 y -> first R1 (sta y) + {-# INLINE gInjectionSum #-} + +-- | Convert between generic products with the same fields, ignoring metadata. +class GProduct p q where + gProductTo :: p x -> q x + gProductFrom :: q x -> p x + +instance (GProduct f f', GProduct g g') => GProduct (f :*: g) (f' :*: g') where + gProductTo (f :*: g) = + gProductTo f :*: gProductTo g + {-# INLINE gProductTo #-} + gProductFrom (f :*: g) = + gProductFrom f :*: gProductFrom g + {-# INLINE gProductFrom #-} + +instance (x ~ y) => GProduct (M1 S m (K1 i x)) (M1 S m' (K1 i' y)) where + gProductTo (M1 (K1 x)) = + M1 (K1 x) + {-# INLINE gProductTo #-} + gProductFrom (M1 (K1 y)) = + M1 (K1 y) + {-# INLINE gProductFrom #-} diff --git a/src/Data/Lens/Injection/Injection1.hs b/src/Data/Lens/Injection/Injection1.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection1.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The first injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field1'. +module Data.Lens.Injection.Injection1 ( + Injection1 (..), +) where + +import Control.Lens (Prism, iso, prism) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Sum (Sum (..)) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep, (:+:) (..)) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import GHC.Generics(Generic) +>>> import Control.Lens((^?), (#), over) +>>> import Data.Functor.Identity(Identity(..)) +>>> import Data.Functor.Sum(Sum(..)) +>>> import GHC.Generics((:+:)(..)) +-} + +{- | Access the first constructor of a sum type. + +Where 'Control.Lens._1' is the first projection out of a product, '_I1' is the first +injection into a sum. + +The default implementation is the prism to the first constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 0)@. + +>>> data T = C1 Int | C2 deriving (Show, Generic) +>>> instance Injection1 T T Int Int +>>> C1 1 ^? _I1 +Just 1 + +>>> C2 ^? _I1 +Nothing + +>>> _I1 # 1 :: T +C1 1 +-} +class Injection1 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I1 :: Prism s t a b + default _I1 :: (Generic s, Generic t, GInjection 0 (Rep s) (Rep t) a b) => Prism s t a b + _I1 = + injection (Proxy :: Proxy 0) + {-# INLINE _I1 #-} + +{- | +>>> (Left 1 :: Either Int String) ^? _I1 +Just 1 + +>>> (Right "x" :: Either Int String) ^? _I1 +Nothing + +>>> _I1 # 1 :: Either Int String +Left 1 + +>>> over _I1 show (Left 1 :: Either Int Bool) +Left "1" +-} +instance Injection1 (Either a c) (Either b c) a b where + _I1 = + prism Left $ \case + Left a -> Right a + Right c -> Left (Right c) + {-# INLINE _I1 #-} + +{- | +>>> (Nothing :: Maybe Int) ^? _I1 +Just () + +>>> Just 1 ^? _I1 +Nothing + +>>> _I1 # () :: Maybe Int +Nothing +-} +instance Injection1 (Maybe a) (Maybe a) () () where + _I1 = + prism (const Nothing) $ \case + Nothing -> Right () + Just a -> Left (Just a) + {-# INLINE _I1 #-} + +{- | +>>> False ^? _I1 +Just () + +>>> True ^? _I1 +Nothing + +>>> _I1 # () :: Bool +False +-} +instance Injection1 Bool Bool () () where + _I1 = + prism (const False) $ \case + False -> Right () + True -> Left True + {-# INLINE _I1 #-} + +{- | +>>> LT ^? _I1 +Just () + +>>> EQ ^? _I1 +Nothing + +>>> GT ^? _I1 +Nothing + +>>> _I1 # () :: Ordering +LT +-} +instance Injection1 Ordering Ordering () () where + _I1 = + prism (const LT) $ \case + LT -> Right () + o -> Left o + {-# INLINE _I1 #-} + +{- | A list is the sum of the empty list and a cons cell. + +>>> ([] :: [Int]) ^? _I1 +Just () + +>>> [1, 2, 3] ^? _I1 +Nothing + +>>> _I1 # () :: [Int] +[] +-} +instance Injection1 [a] [a] () () where + _I1 = + prism (const []) $ \case + [] -> Right () + h : t -> Left (h : t) + {-# INLINE _I1 #-} + +{- | A sum of one constructor, so '_I1' always matches. + +>>> Identity 1 ^? _I1 +Just 1 + +>>> _I1 # 1 :: Identity Int +Identity 1 + +>>> over _I1 show (Identity 1) +Identity "1" +-} +instance Injection1 (Identity a) (Identity b) a b where + _I1 = + iso runIdentity Identity + {-# INLINE _I1 #-} + +{- | A sum of one nullary constructor, so '_I1' always matches. + +>>> () ^? _I1 +Just () + +>>> _I1 # () :: () +() +-} +instance Injection1 () () () () where + _I1 = + iso (const ()) (const ()) + {-# INLINE _I1 #-} + +{- | +>>> (InL (Just 1) :: Sum Maybe [] Int) ^? _I1 +Just (Just 1) + +>>> (InR [1] :: Sum Maybe [] Int) ^? _I1 +Nothing + +>>> _I1 # Just 1 :: Sum Maybe [] Int +InL (Just 1) +-} +instance Injection1 (Sum f g a) (Sum f' g a) (f a) (f' a) where + _I1 = + prism InL $ \case + InL x -> Right x + InR y -> Left (InR y) + {-# INLINE _I1 #-} + +{- | +>>> (L1 (Just 1) :: (Maybe :+: []) Int) ^? _I1 +Just (Just 1) + +>>> (R1 [1] :: (Maybe :+: []) Int) ^? _I1 +Nothing + +>>> _I1 # Just 1 :: (Maybe :+: []) Int +L1 (Just 1) +-} +instance Injection1 ((f :+: g) p) ((f' :+: g) p) (f p) (f' p) where + _I1 = + prism L1 $ \case + L1 x -> Right x + R1 y -> Left (R1 y) + {-# INLINE _I1 #-} diff --git a/src/Data/Lens/Injection/Injection10.hs b/src/Data/Lens/Injection/Injection10.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection10.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The tenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field10'. +module Data.Lens.Injection.Injection10 ( + Injection10 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the tenth constructor of a sum type. + +Where 'Control.Lens._10' is the tenth projection out of a product, '_I10' is the tenth +injection into a sum. + +The default implementation is the prism to the tenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 9)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 Int | C11 deriving (Show, Generic) +>>> instance Injection10 T T Int Int +>>> C10 1 ^? _I10 +Just 1 + +>>> C11 ^? _I10 +Nothing + +>>> _I10 # 1 :: T +C10 1 +-} +class Injection10 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I10 :: Prism s t a b + default _I10 :: (Generic s, Generic t, GInjection 9 (Rep s) (Rep t) a b) => Prism s t a b + _I10 = + injection (Proxy :: Proxy 9) + {-# INLINE _I10 #-} diff --git a/src/Data/Lens/Injection/Injection11.hs b/src/Data/Lens/Injection/Injection11.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection11.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The eleventh injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field11'. +module Data.Lens.Injection.Injection11 ( + Injection11 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the eleventh constructor of a sum type. + +Where 'Control.Lens._11' is the eleventh projection out of a product, '_I11' is the eleventh +injection into a sum. + +The default implementation is the prism to the eleventh constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 10)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 Int | C12 deriving (Show, Generic) +>>> instance Injection11 T T Int Int +>>> C11 1 ^? _I11 +Just 1 + +>>> C12 ^? _I11 +Nothing + +>>> _I11 # 1 :: T +C11 1 +-} +class Injection11 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I11 :: Prism s t a b + default _I11 :: (Generic s, Generic t, GInjection 10 (Rep s) (Rep t) a b) => Prism s t a b + _I11 = + injection (Proxy :: Proxy 10) + {-# INLINE _I11 #-} diff --git a/src/Data/Lens/Injection/Injection12.hs b/src/Data/Lens/Injection/Injection12.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection12.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The twelfth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field12'. +module Data.Lens.Injection.Injection12 ( + Injection12 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the twelfth constructor of a sum type. + +Where 'Control.Lens._12' is the twelfth projection out of a product, '_I12' is the twelfth +injection into a sum. + +The default implementation is the prism to the twelfth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 11)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 Int | C13 deriving (Show, Generic) +>>> instance Injection12 T T Int Int +>>> C12 1 ^? _I12 +Just 1 + +>>> C13 ^? _I12 +Nothing + +>>> _I12 # 1 :: T +C12 1 +-} +class Injection12 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I12 :: Prism s t a b + default _I12 :: (Generic s, Generic t, GInjection 11 (Rep s) (Rep t) a b) => Prism s t a b + _I12 = + injection (Proxy :: Proxy 11) + {-# INLINE _I12 #-} diff --git a/src/Data/Lens/Injection/Injection13.hs b/src/Data/Lens/Injection/Injection13.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection13.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The thirteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field13'. +module Data.Lens.Injection.Injection13 ( + Injection13 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the thirteenth constructor of a sum type. + +Where 'Control.Lens._13' is the thirteenth projection out of a product, '_I13' is the thirteenth +injection into a sum. + +The default implementation is the prism to the thirteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 12)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 Int | C14 deriving (Show, Generic) +>>> instance Injection13 T T Int Int +>>> C13 1 ^? _I13 +Just 1 + +>>> C14 ^? _I13 +Nothing + +>>> _I13 # 1 :: T +C13 1 +-} +class Injection13 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I13 :: Prism s t a b + default _I13 :: (Generic s, Generic t, GInjection 12 (Rep s) (Rep t) a b) => Prism s t a b + _I13 = + injection (Proxy :: Proxy 12) + {-# INLINE _I13 #-} diff --git a/src/Data/Lens/Injection/Injection14.hs b/src/Data/Lens/Injection/Injection14.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection14.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The fourteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field14'. +module Data.Lens.Injection.Injection14 ( + Injection14 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the fourteenth constructor of a sum type. + +Where 'Control.Lens._14' is the fourteenth projection out of a product, '_I14' is the fourteenth +injection into a sum. + +The default implementation is the prism to the fourteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 13)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 Int | C15 deriving (Show, Generic) +>>> instance Injection14 T T Int Int +>>> C14 1 ^? _I14 +Just 1 + +>>> C15 ^? _I14 +Nothing + +>>> _I14 # 1 :: T +C14 1 +-} +class Injection14 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I14 :: Prism s t a b + default _I14 :: (Generic s, Generic t, GInjection 13 (Rep s) (Rep t) a b) => Prism s t a b + _I14 = + injection (Proxy :: Proxy 13) + {-# INLINE _I14 #-} diff --git a/src/Data/Lens/Injection/Injection15.hs b/src/Data/Lens/Injection/Injection15.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection15.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The fifteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field15'. +module Data.Lens.Injection.Injection15 ( + Injection15 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the fifteenth constructor of a sum type. + +Where 'Control.Lens._15' is the fifteenth projection out of a product, '_I15' is the fifteenth +injection into a sum. + +The default implementation is the prism to the fifteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 14)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 | C15 Int | C16 deriving (Show, Generic) +>>> instance Injection15 T T Int Int +>>> C15 1 ^? _I15 +Just 1 + +>>> C16 ^? _I15 +Nothing + +>>> _I15 # 1 :: T +C15 1 +-} +class Injection15 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I15 :: Prism s t a b + default _I15 :: (Generic s, Generic t, GInjection 14 (Rep s) (Rep t) a b) => Prism s t a b + _I15 = + injection (Proxy :: Proxy 14) + {-# INLINE _I15 #-} diff --git a/src/Data/Lens/Injection/Injection16.hs b/src/Data/Lens/Injection/Injection16.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection16.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The sixteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field16'. +module Data.Lens.Injection.Injection16 ( + Injection16 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the sixteenth constructor of a sum type. + +Where 'Control.Lens._16' is the sixteenth projection out of a product, '_I16' is the sixteenth +injection into a sum. + +The default implementation is the prism to the sixteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 15)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 | C15 | C16 Int | C17 deriving (Show, Generic) +>>> instance Injection16 T T Int Int +>>> C16 1 ^? _I16 +Just 1 + +>>> C17 ^? _I16 +Nothing + +>>> _I16 # 1 :: T +C16 1 +-} +class Injection16 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I16 :: Prism s t a b + default _I16 :: (Generic s, Generic t, GInjection 15 (Rep s) (Rep t) a b) => Prism s t a b + _I16 = + injection (Proxy :: Proxy 15) + {-# INLINE _I16 #-} diff --git a/src/Data/Lens/Injection/Injection17.hs b/src/Data/Lens/Injection/Injection17.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection17.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The seventeenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field17'. +module Data.Lens.Injection.Injection17 ( + Injection17 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the seventeenth constructor of a sum type. + +Where 'Control.Lens._17' is the seventeenth projection out of a product, '_I17' is the seventeenth +injection into a sum. + +The default implementation is the prism to the seventeenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 16)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 Int | C18 deriving (Show, Generic) +>>> instance Injection17 T T Int Int +>>> C17 1 ^? _I17 +Just 1 + +>>> C18 ^? _I17 +Nothing + +>>> _I17 # 1 :: T +C17 1 +-} +class Injection17 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I17 :: Prism s t a b + default _I17 :: (Generic s, Generic t, GInjection 16 (Rep s) (Rep t) a b) => Prism s t a b + _I17 = + injection (Proxy :: Proxy 16) + {-# INLINE _I17 #-} diff --git a/src/Data/Lens/Injection/Injection18.hs b/src/Data/Lens/Injection/Injection18.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection18.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The eighteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field18'. +module Data.Lens.Injection.Injection18 ( + Injection18 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the eighteenth constructor of a sum type. + +Where 'Control.Lens._18' is the eighteenth projection out of a product, '_I18' is the eighteenth +injection into a sum. + +The default implementation is the prism to the eighteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 17)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 Int | C19 deriving (Show, Generic) +>>> instance Injection18 T T Int Int +>>> C18 1 ^? _I18 +Just 1 + +>>> C19 ^? _I18 +Nothing + +>>> _I18 # 1 :: T +C18 1 +-} +class Injection18 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I18 :: Prism s t a b + default _I18 :: (Generic s, Generic t, GInjection 17 (Rep s) (Rep t) a b) => Prism s t a b + _I18 = + injection (Proxy :: Proxy 17) + {-# INLINE _I18 #-} diff --git a/src/Data/Lens/Injection/Injection19.hs b/src/Data/Lens/Injection/Injection19.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection19.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The nineteenth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field19'. +module Data.Lens.Injection.Injection19 ( + Injection19 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the nineteenth constructor of a sum type. + +Where 'Control.Lens._19' is the nineteenth projection out of a product, '_I19' is the nineteenth +injection into a sum. + +The default implementation is the prism to the nineteenth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 18)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 | C10 | C11 | C12 | C13 | C14 | C15 | C16 | C17 | C18 | C19 Int | C20 deriving (Show, Generic) +>>> instance Injection19 T T Int Int +>>> C19 1 ^? _I19 +Just 1 + +>>> C20 ^? _I19 +Nothing + +>>> _I19 # 1 :: T +C19 1 +-} +class Injection19 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I19 :: Prism s t a b + default _I19 :: (Generic s, Generic t, GInjection 18 (Rep s) (Rep t) a b) => Prism s t a b + _I19 = + injection (Proxy :: Proxy 18) + {-# INLINE _I19 #-} diff --git a/src/Data/Lens/Injection/Injection2.hs b/src/Data/Lens/Injection/Injection2.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection2.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The second injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field2'. +module Data.Lens.Injection.Injection2 ( + Injection2 (..), +) where + +import Control.Lens (Prism, prism) +import Data.Functor.Sum (Sum (..)) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.List.NonEmpty (NonEmpty (..), toList) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep, (:+:) (..)) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import GHC.Generics(Generic) +>>> import Control.Lens((^?), (#), over) +>>> import Data.Functor.Sum(Sum(..)) +>>> import Data.List.NonEmpty(NonEmpty(..)) +>>> import GHC.Generics((:+:)(..)) +-} + +{- | Access the second constructor of a sum type. + +Where 'Control.Lens._2' is the second projection out of a product, '_I2' is the second +injection into a sum. + +The default implementation is the prism to the second constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 1)@. + +>>> data T = C1 | C2 Int | C3 deriving (Show, Generic) +>>> instance Injection2 T T Int Int +>>> C2 1 ^? _I2 +Just 1 + +>>> C3 ^? _I2 +Nothing + +>>> _I2 # 1 :: T +C2 1 +-} +class Injection2 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I2 :: Prism s t a b + default _I2 :: (Generic s, Generic t, GInjection 1 (Rep s) (Rep t) a b) => Prism s t a b + _I2 = + injection (Proxy :: Proxy 1) + {-# INLINE _I2 #-} + +{- | +>>> (Right "x" :: Either Int String) ^? _I2 +Just "x" + +>>> (Left 1 :: Either Int String) ^? _I2 +Nothing + +>>> _I2 # "x" :: Either Int String +Right "x" + +>>> over _I2 show (Right True :: Either Int Bool) +Right "True" +-} +instance Injection2 (Either c a) (Either c b) a b where + _I2 = + prism Right $ \case + Left c -> Left (Left c) + Right a -> Right a + {-# INLINE _I2 #-} + +{- | +>>> Just 1 ^? _I2 +Just 1 + +>>> (Nothing :: Maybe Int) ^? _I2 +Nothing + +>>> _I2 # 1 :: Maybe Int +Just 1 + +>>> over _I2 show (Just 1) +Just "1" +-} +instance Injection2 (Maybe a) (Maybe b) a b where + _I2 = + prism Just $ \case + Nothing -> Left Nothing + Just a -> Right a + {-# INLINE _I2 #-} + +{- | +>>> True ^? _I2 +Just () + +>>> False ^? _I2 +Nothing + +>>> _I2 # () :: Bool +True +-} +instance Injection2 Bool Bool () () where + _I2 = + prism (const True) $ \case + False -> Left False + True -> Right () + {-# INLINE _I2 #-} + +{- | +>>> EQ ^? _I2 +Just () + +>>> LT ^? _I2 +Nothing + +>>> GT ^? _I2 +Nothing + +>>> _I2 # () :: Ordering +EQ +-} +instance Injection2 Ordering Ordering () () where + _I2 = + prism (const EQ) $ \case + EQ -> Right () + o -> Left o + {-# INLINE _I2 #-} + +{- | A list is the sum of the empty list and a non-empty list. + +>>> [1, 2, 3] ^? _I2 +Just (1 :| [2,3]) + +>>> ([] :: [Int]) ^? _I2 +Nothing + +>>> _I2 # (1 :| [2, 3]) :: [Int] +[1,2,3] + +>>> over _I2 (fmap show) [1, 2, 3] +["1","2","3"] +-} +instance Injection2 [a] [b] (NonEmpty a) (NonEmpty b) where + _I2 = + prism toList $ \case + [] -> Left [] + h : t -> Right (h :| t) + {-# INLINE _I2 #-} + +{- | +>>> (InR [1] :: Sum Maybe [] Int) ^? _I2 +Just [1] + +>>> (InL (Just 1) :: Sum Maybe [] Int) ^? _I2 +Nothing + +>>> _I2 # [1] :: Sum Maybe [] Int +InR [1] +-} +instance Injection2 (Sum f g a) (Sum f g' a) (g a) (g' a) where + _I2 = + prism InR $ \case + InL x -> Left (InL x) + InR y -> Right y + {-# INLINE _I2 #-} + +{- | +>>> (R1 [1] :: (Maybe :+: []) Int) ^? _I2 +Just [1] + +>>> (L1 (Just 1) :: (Maybe :+: []) Int) ^? _I2 +Nothing + +>>> _I2 # [1] :: (Maybe :+: []) Int +R1 [1] +-} +instance Injection2 ((f :+: g) p) ((f :+: g') p) (g p) (g' p) where + _I2 = + prism R1 $ \case + L1 x -> Left (L1 x) + R1 y -> Right y + {-# INLINE _I2 #-} diff --git a/src/Data/Lens/Injection/Injection3.hs b/src/Data/Lens/Injection/Injection3.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection3.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The third injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field3'. +module Data.Lens.Injection.Injection3 ( + Injection3 (..), +) where + +import Control.Lens (Prism, prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import GHC.Generics(Generic) +>>> import Control.Lens((^?), (#)) +-} + +{- | Access the third constructor of a sum type. + +Where 'Control.Lens._3' is the third projection out of a product, '_I3' is the third +injection into a sum. + +The default implementation is the prism to the third constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 2)@. + +>>> data T = C1 | C2 | C3 Int | C4 deriving (Show, Generic) +>>> instance Injection3 T T Int Int +>>> C3 1 ^? _I3 +Just 1 + +>>> C4 ^? _I3 +Nothing + +>>> _I3 # 1 :: T +C3 1 +-} +class Injection3 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I3 :: Prism s t a b + default _I3 :: (Generic s, Generic t, GInjection 2 (Rep s) (Rep t) a b) => Prism s t a b + _I3 = + injection (Proxy :: Proxy 2) + {-# INLINE _I3 #-} + +{- | +>>> GT ^? _I3 +Just () + +>>> LT ^? _I3 +Nothing + +>>> EQ ^? _I3 +Nothing + +>>> _I3 # () :: Ordering +GT +-} +instance Injection3 Ordering Ordering () () where + _I3 = + prism (const GT) $ \case + GT -> Right () + o -> Left o + {-# INLINE _I3 #-} diff --git a/src/Data/Lens/Injection/Injection4.hs b/src/Data/Lens/Injection/Injection4.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection4.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The fourth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field4'. +module Data.Lens.Injection.Injection4 ( + Injection4 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the fourth constructor of a sum type. + +Where 'Control.Lens._4' is the fourth projection out of a product, '_I4' is the fourth +injection into a sum. + +The default implementation is the prism to the fourth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 3)@. + +>>> data T = C1 | C2 | C3 | C4 Int | C5 deriving (Show, Generic) +>>> instance Injection4 T T Int Int +>>> C4 1 ^? _I4 +Just 1 + +>>> C5 ^? _I4 +Nothing + +>>> _I4 # 1 :: T +C4 1 +-} +class Injection4 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I4 :: Prism s t a b + default _I4 :: (Generic s, Generic t, GInjection 3 (Rep s) (Rep t) a b) => Prism s t a b + _I4 = + injection (Proxy :: Proxy 3) + {-# INLINE _I4 #-} diff --git a/src/Data/Lens/Injection/Injection5.hs b/src/Data/Lens/Injection/Injection5.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection5.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The fifth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field5'. +module Data.Lens.Injection.Injection5 ( + Injection5 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the fifth constructor of a sum type. + +Where 'Control.Lens._5' is the fifth projection out of a product, '_I5' is the fifth +injection into a sum. + +The default implementation is the prism to the fifth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 4)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 Int | C6 deriving (Show, Generic) +>>> instance Injection5 T T Int Int +>>> C5 1 ^? _I5 +Just 1 + +>>> C6 ^? _I5 +Nothing + +>>> _I5 # 1 :: T +C5 1 +-} +class Injection5 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I5 :: Prism s t a b + default _I5 :: (Generic s, Generic t, GInjection 4 (Rep s) (Rep t) a b) => Prism s t a b + _I5 = + injection (Proxy :: Proxy 4) + {-# INLINE _I5 #-} diff --git a/src/Data/Lens/Injection/Injection6.hs b/src/Data/Lens/Injection/Injection6.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection6.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The sixth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field6'. +module Data.Lens.Injection.Injection6 ( + Injection6 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the sixth constructor of a sum type. + +Where 'Control.Lens._6' is the sixth projection out of a product, '_I6' is the sixth +injection into a sum. + +The default implementation is the prism to the sixth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 5)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 Int | C7 deriving (Show, Generic) +>>> instance Injection6 T T Int Int +>>> C6 1 ^? _I6 +Just 1 + +>>> C7 ^? _I6 +Nothing + +>>> _I6 # 1 :: T +C6 1 +-} +class Injection6 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I6 :: Prism s t a b + default _I6 :: (Generic s, Generic t, GInjection 5 (Rep s) (Rep t) a b) => Prism s t a b + _I6 = + injection (Proxy :: Proxy 5) + {-# INLINE _I6 #-} diff --git a/src/Data/Lens/Injection/Injection7.hs b/src/Data/Lens/Injection/Injection7.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection7.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The seventh injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field7'. +module Data.Lens.Injection.Injection7 ( + Injection7 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the seventh constructor of a sum type. + +Where 'Control.Lens._7' is the seventh projection out of a product, '_I7' is the seventh +injection into a sum. + +The default implementation is the prism to the seventh constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 6)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 Int | C8 deriving (Show, Generic) +>>> instance Injection7 T T Int Int +>>> C7 1 ^? _I7 +Just 1 + +>>> C8 ^? _I7 +Nothing + +>>> _I7 # 1 :: T +C7 1 +-} +class Injection7 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I7 :: Prism s t a b + default _I7 :: (Generic s, Generic t, GInjection 6 (Rep s) (Rep t) a b) => Prism s t a b + _I7 = + injection (Proxy :: Proxy 6) + {-# INLINE _I7 #-} diff --git a/src/Data/Lens/Injection/Injection8.hs b/src/Data/Lens/Injection/Injection8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection8.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The eighth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field8'. +module Data.Lens.Injection.Injection8 ( + Injection8 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the eighth constructor of a sum type. + +Where 'Control.Lens._8' is the eighth projection out of a product, '_I8' is the eighth +injection into a sum. + +The default implementation is the prism to the eighth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 7)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 Int | C9 deriving (Show, Generic) +>>> instance Injection8 T T Int Int +>>> C8 1 ^? _I8 +Just 1 + +>>> C9 ^? _I8 +Nothing + +>>> _I8 # 1 :: T +C8 1 +-} +class Injection8 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I8 :: Prism s t a b + default _I8 :: (Generic s, Generic t, GInjection 7 (Rep s) (Rep t) a b) => Prism s t a b + _I8 = + injection (Proxy :: Proxy 7) + {-# INLINE _I8 #-} diff --git a/src/Data/Lens/Injection/Injection9.hs b/src/Data/Lens/Injection/Injection9.hs new file mode 100644 --- /dev/null +++ b/src/Data/Lens/Injection/Injection9.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# OPTIONS_GHC -Wall #-} + +-- | The ninth injection of a sum type, as a prism. The sum-type dual of 'Control.Lens.Field9'. +module Data.Lens.Injection.Injection9 ( + Injection9 (..), +) where + +import Control.Lens (Prism) +import Data.Lens.Injection.Generic (GInjection, injection) +import Data.Proxy (Proxy (..)) +import GHC.Generics (Generic, Rep) + +{- $setup +>>> :set -XDeriveGeneric -XMultiParamTypeClasses -XFlexibleInstances +>>> import Control.Lens((^?), (#)) +>>> import GHC.Generics(Generic) +-} + +{- | Access the ninth constructor of a sum type. + +Where 'Control.Lens._9' is the ninth projection out of a product, '_I9' is the ninth +injection into a sum. + +The default implementation is the prism to the ninth constructor of a +'Generic' type, @'injection' (Proxy :: Proxy 8)@. + +>>> data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 | C8 | C9 Int | C10 deriving (Show, Generic) +>>> instance Injection9 T T Int Int +>>> C9 1 ^? _I9 +Just 1 + +>>> C10 ^? _I9 +Nothing + +>>> _I9 # 1 :: T +C9 1 +-} +class Injection9 s t a b | s -> a, t -> b, s b -> t, t a -> s where + _I9 :: Prism s t a b + default _I9 :: (Generic s, Generic t, GInjection 8 (Rep s) (Rep t) a b) => Prism s t a b + _I9 = + injection (Proxy :: Proxy 8) + {-# INLINE _I9 #-} diff --git a/test/Either3TTests.hs b/test/Either3TTests.hs new file mode 100644 --- /dev/null +++ b/test/Either3TTests.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} +{- HLINT ignore "Use <&>" -} +{- HLINT ignore "Monad law, left identity" -} +{- HLINT ignore "Use asks" -} + +-- | Laws for 'Either3T'. +module Either3TTests ( + either3TTests, +) where + +import Control.DeepSeq (rnf) +import Control.Lens (each, over, preview, review, set, toListOf, view, _Wrapped) +import Control.Monad.Cont (Cont, callCC, runCont) +import Control.Monad.Except (catchError, throwError) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.RWS (RWS, runRWS) +import Control.Monad.Reader (Reader, ask, local, reader, runReader) +import Control.Monad.State (State, get, put, runState) +import Control.Monad.Writer (Writer, listen, pass, runWriter, tell, writer) +import Control.Monad.Zip (munzip, mzip) +import Data.Bifunctor (bimap) +import Data.Data (gmapQ, gmapT, showConstr, toConstr) +import Data.Either3 +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Lens.Injection (_I1, _I2, _I3) +import Data.String (fromString) +import GHC.Generics (from, from1, to, to1) +import Gens (genEither3, genFnInt, genInt, genString) +import Hedgehog +import Hedgehog.Function (Fn, apply, fn) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Laws + +-- | Values with list effects. +genList3 :: Gen a -> Gen b -> Gen c -> Gen (Either3TList a b c) +genList3 a b c = + Either3T <$> Gen.list (Range.linear 0 3) (genEither3 a b c) + +genIdentity3 :: Gen a -> Gen b -> Gen c -> Gen (Either3TIdentity a b c) +genIdentity3 a b c = + Either3T . Identity <$> genEither3 a b c + +subjectIdentity :: Subject (Either3TIdentity Int Int) (Either3TIdentity Int Int) (Either3TIdentity Int Int) +subjectIdentity = + Subject "Either3T Identity" (genIdentity3 genInt genInt) id id + +subjectList :: Subject (Either3TList Int Int) (Either3TList Int Int) (Either3TList Int Int) +subjectList = + Subject "Either3T []" (genList3 genInt genInt) id id + +subject2 :: Subject2 (Either3TList Int) (Either3TList Int) (Either3TList Int) +subject2 = + Subject2 "Either3T []" (genList3 genInt) id id + +genL :: Gen (Either3TList Int String Int) +genL = + genList3 genInt genString genInt + +genI :: Gen (Either3TIdentity Int String Int) +genI = + genIdentity3 genInt genString genInt + +genE :: Gen (Either3 Int String Int) +genE = + genEither3 genInt genString genInt + +either3TTests :: Laws +either3TTests = + concat + [ semigroupLaws subjectIdentity + , semigroupLaws subjectList + , functorLaws subjectIdentity + , functorLaws subjectList + , applicativeLaws subjectIdentity + , applicativeLaws subjectList + , monadLaws subjectIdentity + , monadLaws subjectList + , altLaws subjectIdentity + , altLaws subjectList + , extendLaws subjectIdentity + , extendLaws subjectList + , selectiveLaws subjectIdentity + , selectiveLaws subjectList + , foldableLaws subjectList + , traversableLaws subjectList + , bifunctorLaws subject2 + , bifoldableLaws subject2 + , bitraversableLaws subject2 + , swapLaws subject2 + , wrappedLaws + , either3IdentityLaws + , classesAgree + , optics + , either3TOptics + , isoLaws "Either3T [] either3TACB" either3TACB (genList3 genInt Gen.bool genString) (genList3 genInt genString Gen.bool) + , isoLaws "Either3T [] either3TBAC" either3TBAC (genList3 genInt Gen.bool genString) (genList3 Gen.bool genInt genString) + , isoLaws "Either3T [] either3TBCA" either3TBCA (genList3 genInt Gen.bool genString) (genList3 Gen.bool genString genInt) + , isoLaws "Either3T [] either3TCAB" either3TCAB (genList3 genInt Gen.bool genString) (genList3 genString genInt Gen.bool) + , isoLaws "Either3T [] either3TCBA" either3TCBA (genList3 genInt Gen.bool genString) (genList3 genString Gen.bool genInt) + , reorderTLaws + , prismLawsVia "Either3T [] AsEither3T" _Either3T genL id id genL + , prismLawsVia "Either3T Identity Injection1" _I1 genI id id genInt + , prismLawsVia "Either3T Identity Injection2" _I2 genI id id genString + , prismLawsVia "Either3T Identity Injection3" _I3 genI id id genInt + , prismLawsVia "Either3T Identity AsEither3" _Either3 genI id id genE + , monadStateLaws + , monadReaderLaws + , monadFailLaws + , monadIOLaws + , monadWriterLaws + , monadErrorLaws + , monadRWSLaws + , monadContLaws + , monadZipLaws + , genericLaws + , [("Either3T [] NFData", property (forAll genL >>= \x -> rnf x === ()))] + ] + +-- | '_Wrapped' is an isomorphism. +wrappedLaws :: Laws +wrappedLaws = + [ + ( "Either3T [] _Wrapped view . review" + , property $ do + x <- forAll (Gen.list (Range.linear 0 3) genE) + view _Wrapped (review _Wrapped x :: Either3TList Int String Int) === x + ) + , + ( "Either3T [] _Wrapped review . view" + , property $ do + t <- forAll genL + review _Wrapped (view _Wrapped t) === t + ) + ] + +-- | 'either3Identity' is an isomorphism. +either3IdentityLaws :: Laws +either3IdentityLaws = + [ + ( "either3Identity review . view" + , property $ do + x <- forAll genE + review either3Identity (view either3Identity x) === x + ) + , + ( "either3Identity view . review" + , property $ do + t <- forAll genI + view either3Identity (review either3Identity t) === t + ) + , + ( "either3Identity changes type as fmap does" + , property $ do + x <- forAll genE + f <- forAll genFnInt + over either3Identity (fmap (apply f)) x === fmap (apply f) x + ) + , + ( "either3Identity agrees with _Wrapped" + , property $ do + x <- forAll genE + view either3Identity x === review _Wrapped (Identity x) + ) + ] + +-- | 'Eq', 'Ord', 'Show' and the lifted classes agree with those of the wrapped value. +classesAgree :: Laws +classesAgree = + [ ("Either3T [] Eq agrees with the wrapped value", agree2 (\x y -> (x == y) === (view _Wrapped x == view _Wrapped y))) + , ("Either3T [] Ord agrees with the wrapped value", agree2 (\x y -> compare x y === compare (view _Wrapped x) (view _Wrapped y))) + , ("Either3T [] Eq1 agrees with Eq", agree2 (\x y -> liftEq (==) x y === (x == y))) + , ("Either3T [] Eq2 agrees with Eq", agree2 (\x y -> liftEq2 (==) (==) x y === (x == y))) + , ("Either3T [] Ord1 agrees with Ord", agree2 (\x y -> liftCompare compare x y === compare x y)) + , ("Either3T [] Ord2 agrees with Ord", agree2 (\x y -> liftCompare2 compare compare x y === compare x y)) + , + ( "Either3T [] Show shows the wrapped value" + , property $ do + x <- forAll genL + show x === "Either3T " ++ showsPrec 11 (view _Wrapped x) "" + ) + , + ( "Either3T [] Show1 agrees with Show" + , property $ do + x <- forAll genL + d <- forAll (Gen.int (Range.linear 0 11)) + liftShowsPrec showsPrec showList d x "" === showsPrec d x "" + ) + , + ( "Either3T [] Show2 agrees with Show" + , property $ do + x <- forAll genL + d <- forAll (Gen.int (Range.linear 0 11)) + liftShowsPrec2 showsPrec showList showsPrec showList d x "" === showsPrec d x "" + ) + , + ( "Either3T [] each visits every value" + , property $ do + x <- forAll (genList3 genInt genInt genInt) + toListOf each x === concatMap (toListOf each) (view _Wrapped x) + ) + ] + where + agree2 p = + property $ do + x <- forAll genL + same <- forAll Gen.bool + y <- if same then pure x else forAll genL + p x y + +-- | Lens laws for 'either3', and 'reviewEither3' in an effectful @f@. +optics :: Laws +optics = + [ + ( "Either3T Identity HasEither3 view . set" + , property $ do + s <- forAll genI + v <- forAll genE + view either3 (set either3 v s) === v + ) + , + ( "Either3T Identity HasEither3 set . view" + , property $ do + s <- forAll genI + set either3 (view either3 s) s === s + ) + , + ( "Either3T Identity HasEither3 set . set" + , property $ do + s <- forAll genI + v <- forAll genE + v' <- forAll genE + set either3 v' (set either3 v s) === set either3 v' s + ) + , + ( "Either3T [] reviewEither3 is pure" + , property $ do + e <- forAll genE + (review reviewEither3 e :: Either3TList Int String Int) === Either3T [e] + ) + ] + +-- | 'setEither3' and 'matchEither3' on @Either3T Identity@, and the classy optics for 'Either3T'. +either3TOptics :: Laws +either3TOptics = + [ + ( "Either3T Identity setEither3 agrees with set either3" + , property $ do + s <- forAll genI + v <- forAll genE + setEither3 v s === set either3 v s + ) + , + ( "Either3T Identity matchEither3 agrees with preview _Either3" + , property $ do + s <- forAll genI + matchEither3 s === preview _Either3 s + ) + , + ( "Either3T [] HasEither3T view . set" + , property $ do + s <- forAll genL + v <- forAll genL + view either3T (set either3T v s) === v + ) + , + ( "Either3T [] HasEither3T set . view" + , property $ do + s <- forAll genL + set either3T (view either3T s) s === s + ) + , + ( "Either3T [] HasEither3T set . set" + , property $ do + s <- forAll genL + v <- forAll genL + v' <- forAll genL + set either3T v' (set either3T v s) === set either3T v' s + ) + , + ( "Either3T [] matchEither3T agrees with preview _Either3T" + , property $ do + s <- forAll genL + matchEither3T s === preview _Either3T s + ) + ] + +-- | Each reordering of 'Either3T' applies the reordering of 'Either3' under @f@. +reorderTLaws :: Laws +reorderTLaws = + [ agreeUnder "either3TACB" (view either3TACB) (view either3ACB) + , agreeUnder "either3TBAC" (view either3TBAC) (view either3BAC) + , agreeUnder "either3TBCA" (view either3TBCA) (view either3BCA) + , agreeUnder "either3TCAB" (view either3TCAB) (view either3CAB) + , agreeUnder "either3TCBA" (view either3TCBA) (view either3CBA) + ] + where + agreeUnder name t e = + ( fromString ("Either3T [] " ++ name ++ " agrees with the Either3 reordering under f") + , property $ do + x <- forAll (genList3 genInt Gen.bool genString) + t x === over _Wrapped (fmap e) x + ) + +type StateT3 = Either3T (State Int) Int Int + +runS :: StateT3 a -> Int -> (Either3 Int Int a, Int) +runS = + runState . view _Wrapped + +monadStateLaws :: Laws +monadStateLaws = + [ + ( "Either3T State get >>= put" + , property $ do + s <- forAll genInt + runS (get >>= put) s === runS (pure ()) s + ) + , + ( "Either3T State put >> get" + , property $ do + s <- forAll genInt + s0 <- forAll genInt + runS (put s >> get) s0 === runS (put s >> pure s) s0 + ) + , + ( "Either3T State put >> put" + , property $ do + s <- forAll genInt + s' <- forAll genInt + s0 <- forAll genInt + runS (put s >> put s') s0 === runS (put s') s0 + ) + ] + +type ReaderT3 = Either3T (Reader Int) Int Int + +runR :: ReaderT3 a -> Int -> Either3 Int Int a +runR = + runReader . view _Wrapped + +monadReaderLaws :: Laws +monadReaderLaws = + [ + ( "Either3T Reader local f ask" + , property $ do + f <- forAll genFnInt + r <- forAll genInt + runR (local (apply f) ask) r === runR (fmap (apply f) ask) r + ) + , + ( "Either3T Reader local id" + , property $ do + m <- genReader + r <- forAll genInt + runR (local id m) r === runR m r + ) + , + ( "Either3T Reader local composition" + , property $ do + m <- genReader + f <- forAll genFnInt + g <- forAll genFnInt + r <- forAll genInt + runR (local (apply f) (local (apply g) m)) r === runR (local (apply g . apply f) m) r + ) + , + ( "Either3T Reader local does not change the environment for what follows" + , property $ do + m <- genReader + f <- forAll genFnInt + r <- forAll genInt + runR (local (apply f) m >> ask) r === fmap (const r) (runR (local (apply f) m) r) + ) + ] + where + genReader :: PropertyT IO (ReaderT3 Int) + genReader = + do + h <- forAll (fn (genEither3 genInt genInt genInt)) + pure (Either3T (reader (apply (h :: Fn Int (Either3 Int Int Int))))) + +monadFailLaws :: Laws +monadFailLaws = + [ + ( "Either3T Maybe fail s >>= k" + , property $ do + s <- forAll genString + k <- forAll (fn (genEither3 genInt genInt genInt)) + (fail s >>= review reviewEither3 . apply (k :: Fn Int (Either3 Int Int Int)) :: Either3TMaybe Int Int Int) === Either3T Nothing + ) + ] + +monadIOLaws :: Laws +monadIOLaws = + [ + ( "Either3T IO liftIO . pure" + , property $ do + x <- forAll genInt + r <- evalIO (view _Wrapped (liftIO (pure x) :: Either3TIO Int Int Int)) + r === Third3 x + ) + , + ( "Either3T IO liftIO distributes over >>=" + , property $ do + x <- forAll genInt + f <- forAll genFnInt + lhs <- evalIO (view _Wrapped (liftIO (pure x >>= pure . apply f) :: Either3TIO Int Int Int)) + rhs <- evalIO (view _Wrapped (liftIO (pure x) >>= liftIO . pure . apply f :: Either3TIO Int Int Int)) + lhs === rhs + ) + ] + +type WriterT3 = Either3T (Writer [Int]) Int Int + +runW :: WriterT3 a -> (Either3 Int Int a, [Int]) +runW = + runWriter . view _Wrapped + +genWriter :: PropertyT IO (WriterT3 Int) +genWriter = + do + e <- forAll (genEither3 genInt genInt genInt) + w <- forAll genList' + pure (Either3T (writer (e, w))) + +genList' :: Gen [Int] +genList' = + Gen.list (Range.linear 0 3) genInt + +monadWriterLaws :: Laws +monadWriterLaws = + [ + ( "Either3T Writer tell mempty" + , property $ + runW (tell mempty) === runW (pure ()) + ) + , + ( "Either3T Writer tell w1 >> tell w2" + , property $ do + w1 <- forAll genList' + w2 <- forAll genList' + runW (tell w1 >> tell w2) === runW (tell (w1 <> w2)) + ) + , + ( "Either3T Writer writer (a, w)" + , property $ do + a <- forAll genInt + w <- forAll genList' + runW (writer (a, w)) === runW (tell w >> pure a) + ) + , + ( "Either3T Writer listen (pure a)" + , property $ do + a <- forAll genInt + runW (listen (pure a)) === runW (pure (a, mempty)) + ) + , + ( "Either3T Writer listen (tell w)" + , property $ do + w <- forAll genList' + runW (listen (tell w)) === runW (tell w >> pure ((), w)) + ) + , + ( "Either3T Writer fmap fst . listen" + , property $ do + m <- genWriter + runW (fmap fst (listen m)) === runW m + ) + , + ( "Either3T Writer pass (tell w >> pure (a, f))" + , property $ do + w <- forAll genList' + a <- forAll genInt + f <- forAll (fn genList') + runW (pass (tell w >> pure (a, apply f))) === runW (tell (apply f w) >> pure a) + ) + ] + +type ErrorT3 = Either3T (Either Int) Int Int + +monadErrorLaws :: Laws +monadErrorLaws = + [ + ( "Either3T Either throwError e >>= k" + , property $ do + e <- forAll genInt + k <- forAll (fn (genEither3 genInt genInt genInt)) + (throwError e >>= review reviewEither3 . apply (k :: Fn Int (Either3 Int Int Int)) :: ErrorT3 Int) === throwError e + ) + , + ( "Either3T Either catchError (throwError e) h" + , property $ do + e <- forAll genInt + h <- forAll (fn (genEither3 genInt genInt genInt)) + (catchError (throwError e) (review reviewEither3 . apply h) :: ErrorT3 Int) === review reviewEither3 (apply h e) + ) + , + ( "Either3T Either catchError (pure a) h" + , property $ do + a <- forAll genInt + h <- forAll (fn (genEither3 genInt genInt genInt)) + (catchError (pure a) (review reviewEither3 . apply h) :: ErrorT3 Int) === pure a + ) + , + ( "Either3T Either catchError m throwError" + , property $ do + m <- forAll (Either3T <$> Gen.either genInt (genEither3 genInt genInt genInt)) + catchError m throwError === (m :: ErrorT3 Int) + ) + ] + +monadRWSLaws :: Laws +monadRWSLaws = + [ + ( "Either3T RWS reads, writes and updates state" + , property $ do + r <- forAll genInt + s0 <- forAll genInt + let m = ask >>= \x -> tell [x] >> get >>= \s -> put (s + x) :: Either3T (RWS Int [Int] Int) Int Int () + runRWS (view _Wrapped m) r s0 === (Third3 (), s0 + r, [r]) + ) + ] + +type ContT3 = Either3T (Cont (Either3 Int Int Int)) Int Int + +runC :: ContT3 Int -> Either3 Int Int Int +runC m = + runCont (view _Wrapped m) id + +monadContLaws :: Laws +monadContLaws = + [ + ( "Either3T Cont callCC (const m)" + , property $ do + e <- forAll (genEither3 genInt genInt genInt) + runC (callCC (const (review reviewEither3 e))) === e + ) + , + ( "Either3T Cont callCC escapes" + , property $ do + a <- forAll genInt + e <- forAll (genEither3 genInt genInt genInt) + runC (callCC (\k -> k a >> review reviewEither3 e)) === Third3 a + ) + ] + +monadZipLaws :: Laws +monadZipLaws = + [ + ( "Either3T [] mzip naturality" + , property $ do + ma <- forAll (genList3 genInt genInt genInt) + mb <- forAll (genList3 genInt genInt genInt) + f <- forAll genFnInt + g <- forAll genFnInt + fmap (bimap (apply f) (apply g)) (mzip ma mb) === mzip (fmap (apply f) ma) (fmap (apply g) mb) + ) + , + ( "Either3T [] mzip information preservation" + , property $ do + ma <- forAll (genList3 genInt genInt genInt) + f <- forAll genFnInt + let mb = fmap (apply f) ma + munzip (mzip ma mb) === (ma, mb) + ) + ] + +-- | The derived 'Generic', 'Generic1' and 'Data' instances. +genericLaws :: Laws +genericLaws = + [ + ( "Either3T [] Generic to . from" + , property $ do + x <- forAll genL + to (from x) === x + ) + , + ( "Either3T [] Generic1 to1 . from1" + , property $ do + x <- forAll genL + to1 (from1 x) === x + ) + , + ( "Either3T [] Data gmapT id" + , property $ do + x <- forAll genL + gmapT id x === x + ) + , + ( "Either3T [] Data toConstr names the constructor" + , property $ do + x <- forAll genL + showConstr (toConstr x) === "Either3T" + ) + , + ( "Either3T [] Data gmapQ visits the one field" + , property $ do + x <- forAll genL + length (gmapQ (const ()) x) === 1 + ) + ] diff --git a/test/Either3Tests.hs b/test/Either3Tests.hs new file mode 100644 --- /dev/null +++ b/test/Either3Tests.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wall #-} + +-- | Laws for 'Either3'. +module Either3Tests ( + either3Tests, +) where + +import Control.DeepSeq (rnf) +import Control.Lens (FoldableWithIndex (..), FunctorWithIndex (..), TraversableWithIndex (..), each, over, preview, set, toListOf, view) +import Control.Monad.Zip (munzip, mzip) +import Data.Bifunctor (bimap) +import Data.Data (gmapQ, gmapT, showConstr, toConstr) +import Data.Either3 +import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Lens.Injection (_I1, _I2, _I3) +import GHC.Generics (from, from1, to, to1) +import Gens (genEither3, genFnInt, genInt, genString) +import Hedgehog +import Hedgehog.Function (apply, fn) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Laws + +type E = Either3 Int Int + +subject :: Subject E E E +subject = + Subject "Either3" (genEither3 genInt genInt) id id + +subject2 :: Subject2 (Either3 Int) (Either3 Int) (Either3 Int) +subject2 = + Subject2 "Either3" (genEither3 genInt) id id + +genE :: Gen (Either3 Int String Int) +genE = + genEither3 genInt genString genInt + +either3Tests :: Laws +either3Tests = + concat + [ semigroupLaws subject + , functorLaws subject + , applicativeLaws subject + , monadLaws subject + , altLaws subject + , extendLaws subject + , selectiveLaws subject + , foldableLaws subject + , traversableLaws subject + , bifunctorLaws subject2 + , bifoldableLaws subject2 + , bitraversableLaws subject2 + , swapLaws subject2 + , classesAgree + , indexedLaws + , eachLaws + , prismLawsVia "Either3 Injection1" _I1 genE id id genInt + , prismLawsVia "Either3 Injection2" _I2 genE id id genString + , prismLawsVia "Either3 Injection3" _I3 genE id id genInt + , [("Either3 NFData", property (forAll genE >>= \x -> rnf x === ()))] + , genericLaws + , monadZipLaws + , opticsLaws + , isoLaws "Either3 either3ACB" either3ACB (g3 genInt Gen.bool genString) (g3 genInt genString Gen.bool) + , isoLaws "Either3 either3BAC" either3BAC (g3 genInt Gen.bool genString) (g3 Gen.bool genInt genString) + , isoLaws "Either3 either3BCA" either3BCA (g3 genInt Gen.bool genString) (g3 Gen.bool genString genInt) + , isoLaws "Either3 either3CAB" either3CAB (g3 genInt Gen.bool genString) (g3 genString genInt Gen.bool) + , isoLaws "Either3 either3CBA" either3CBA (g3 genInt Gen.bool genString) (g3 genString Gen.bool genInt) + , reorderLaws + , prismLawsVia "Either3 AsEither3" _Either3 genE id id genE + ] + +-- | The lifted classes agree with 'Eq', 'Ord' and 'Show'. +classesAgree :: Laws +classesAgree = + [ ("Either3 Eq1 agrees with Eq", agree2 (\x y -> liftEq (==) x y === (x == y))) + , ("Either3 Eq2 agrees with Eq", agree2 (\x y -> liftEq2 (==) (==) x y === (x == y))) + , ("Either3 Ord1 agrees with Ord", agree2 (\x y -> liftCompare compare x y === compare x y)) + , ("Either3 Ord2 agrees with Ord", agree2 (\x y -> liftCompare2 compare compare x y === compare x y)) + , + ( "Either3 Show1 agrees with Show" + , property $ do + x <- forAll genE + d <- forAll (Gen.int (Range.linear 0 11)) + liftShowsPrec showsPrec showList d x "" === showsPrec d x "" + ) + , + ( "Either3 Show2 agrees with Show" + , property $ do + x <- forAll genE + d <- forAll (Gen.int (Range.linear 0 11)) + liftShowsPrec2 showsPrec showList showsPrec showList d x "" === showsPrec d x "" + ) + ] + where + agree2 p = + property $ do + x <- forAll genE + same <- forAll Gen.bool + y <- if same then pure x else forAll genE + p x y + +indexedLaws :: Laws +indexedLaws = + [ + ( "Either3 imap agrees with fmap" + , property $ do + x <- forAll genE + f <- forAll genFnInt + imap (const (apply f)) x === fmap (apply f) x + ) + , + ( "Either3 ifoldMap agrees with foldMap" + , property $ do + x <- forAll genE + f <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + ifoldMap (const (apply f)) x === foldMap (apply f) x + ) + , + ( "Either3 itraverse agrees with traverse" + , property $ do + x <- forAll genE + f <- forAll (fn (Gen.maybe genInt)) + itraverse (const (apply f)) x === traverse (apply f) x + ) + ] + +eachLaws :: Laws +eachLaws = + [ + ( "Either3 each identity" + , property $ do + x <- forAll genSame + runIdentity (each Identity x) === x + ) + , + ( "Either3 each visits the one value" + , property $ do + x <- forAll genSame + length (toListOf each x) === 1 + ) + , + ( "Either3 each composition" + , property $ do + x <- forAll genSame + f <- forAll genFnInt + g <- forAll genFnInt + over each (apply f . apply g) x === over each (apply f) (over each (apply g) x) + ) + ] + where + genSame = genEither3 genInt genInt genInt + +-- | The derived 'Generic', 'Generic1' and 'Data' instances. +genericLaws :: Laws +genericLaws = + [ + ( "Either3 Generic to . from" + , property $ do + x <- forAll genE + to (from x) === x + ) + , + ( "Either3 Generic1 to1 . from1" + , property $ do + x <- forAll genE + to1 (from1 x) === x + ) + , + ( "Either3 Data gmapT id" + , property $ do + x <- forAll genE + gmapT id x === x + ) + , + ( "Either3 Data toConstr names the constructor" + , property $ do + x <- forAll genE + showConstr (toConstr x) === foldEither3 (const "First3") (const "Second3") (const "Third3") x + ) + , + ( "Either3 Data gmapQ visits the one field" + , property $ do + x <- forAll genE + length (gmapQ (const ()) x) === 1 + ) + ] + +monadZipLaws :: Laws +monadZipLaws = + [ + ( "Either3 mzip naturality" + , property $ do + ma <- forAll (genEither3 genInt genInt genInt) + mb <- forAll (genEither3 genInt genInt genInt) + f <- forAll genFnInt + g <- forAll genFnInt + fmap (bimap (apply f) (apply g)) (mzip ma mb) === mzip (fmap (apply f) ma) (fmap (apply g) mb) + ) + , + ( "Either3 mzip information preservation" + , property $ do + ma <- forAll (genEither3 genInt genInt genInt) + f <- forAll genFnInt + let mb = fmap (apply f) ma + munzip (mzip ma mb) === (ma, mb) + ) + ] + +-- | The classy optics, defined by 'setEither3' and 'matchEither3', obey the lens laws. +opticsLaws :: Laws +opticsLaws = + [ + ( "Either3 HasEither3 view . set" + , property $ do + s <- forAll genE + v <- forAll genE + view either3 (set either3 v s) === v + ) + , + ( "Either3 HasEither3 set . view" + , property $ do + s <- forAll genE + set either3 (view either3 s) s === s + ) + , + ( "Either3 HasEither3 set . set" + , property $ do + s <- forAll genE + v <- forAll genE + v' <- forAll genE + set either3 v' (set either3 v s) === set either3 v' s + ) + , + ( "Either3 setEither3 agrees with set either3" + , property $ do + s <- forAll genE + v <- forAll genE + setEither3 v s === set either3 v s + ) + , + ( "Either3 matchEither3 agrees with preview _Either3" + , property $ do + s <- forAll genE + matchEither3 s === preview _Either3 s + ) + ] + +g3 :: Gen a -> Gen b -> Gen c -> Gen (Either3 a b c) +g3 = + genEither3 + +-- | The reordering isomorphisms compose as permutations do. +reorderLaws :: Laws +reorderLaws = + [ + ( "Either3 either3CAB undoes either3BCA" + , property $ do + x <- forAll (g3 genInt Gen.bool genString) + view either3CAB (view either3BCA x) === x + ) + , + ( "Either3 either3ACB, either3BAC and either3CBA are involutions" + , property $ do + x <- forAll (g3 genInt genInt genInt) + view either3ACB (view either3ACB x) === x + view either3BAC (view either3BAC x) === x + view either3CBA (view either3CBA x) === x + ) + ] diff --git a/test/Gens.hs b/test/Gens.hs new file mode 100644 --- /dev/null +++ b/test/Gens.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -Wall #-} + +-- | Generators shared by the property tests. +module Gens ( + genUnit, + genInt, + genString, + genList, + genMaybeInt, + genEither3, + genFnInt, +) where + +import Data.Either3 (Either3 (..)) +import Hedgehog (Gen) +import Hedgehog.Function (Fn, fn) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +genUnit :: Gen () +genUnit = pure () + +genInt :: Gen Int +genInt = Gen.int (Range.linear (-100) 100) + +genString :: Gen String +genString = Gen.string (Range.linear 0 50) Gen.unicode + +genList :: Gen [Int] +genList = Gen.list (Range.linear 0 10) genInt + +genMaybeInt :: Gen (Maybe Int) +genMaybeInt = Gen.maybe genInt + +genEither3 :: Gen a -> Gen b -> Gen c -> Gen (Either3 a b c) +genEither3 a b c = Gen.choice [fmap First3 a, fmap Second3 b, fmap Third3 c] + +genFnInt :: Gen (Fn Int Int) +genFnInt = fn genInt diff --git a/test/Laws.hs b/test/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Laws.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wall #-} +{- HLINT ignore "Redundant bimap" -} +{- HLINT ignore "Use second" -} +{- HLINT ignore "Use first" -} +{- HLINT ignore "Use bimap" -} +{- HLINT ignore "Monad law, right identity" -} +{- HLINT ignore "Monad law, left identity" -} +{- HLINT ignore "Use <$>" -} +{- HLINT ignore "Functor law" -} + +{- | Type class laws, checked through an observation. + +A 'Subject' generates a showable value, injects it into the type under test, +and observes the result as a comparable value. This lets the same laws check +a type with no 'Eq' or 'Show' instance, by observing it as one that has them. +-} +module Laws ( + Laws, + Subject (..), + Subject2 (..), + semigroupLaws, + functorLaws, + applicativeLaws, + monadLaws, + altLaws, + extendLaws, + selectiveLaws, + foldableLaws, + traversableLaws, + bifunctorLaws, + bifoldableLaws, + bitraversableLaws, + swapLaws, + prismLawsVia, + isoLaws, +) where + +import Control.Lens (APrism', AnIso', cloneIso, clonePrism, preview, review, view) +import Control.Selective (Selective (..)) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor.Swap (Swap (..)) +import Data.Bitraversable (Bitraversable (..)) +import Data.Functor.Alt (Alt (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Extend (Extend (..)) +import Data.Functor.Identity (Identity (..)) +import Data.String (fromString) +import Gens (genFnInt, genInt) +import Hedgehog +import Hedgehog.Function (Fn, apply, fn) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +type Laws = [(PropertyName, Property)] + +-- | Generate a @g x@, inject it into the type under test @t x@, and observe it as an @o x@. +data Subject g t o + = Subject + String + (forall x. Gen x -> Gen (g x)) + (forall x. g x -> t x) + (forall x. t x -> o x) + +-- | As 'Subject', for a type constructor of two arguments. +data Subject2 g p o + = Subject2 + String + (forall x y. Gen x -> Gen y -> Gen (g x y)) + (forall x y. g x y -> p x y) + (forall x y. p x y -> o x y) + +law :: String -> String -> PropertyT IO () -> (PropertyName, Property) +law name l p = + (fromString (name ++ " " ++ l), property p) + +semigroupLaws :: (Semigroup (t Int), Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws +semigroupLaws (Subject name gen inj obs) = + [ law name "semigroup associativity" $ do + x <- inj <$> forAll (gen genInt) + y <- inj <$> forAll (gen genInt) + z <- inj <$> forAll (gen genInt) + obs ((x <> y) <> z) === obs (x <> (y <> z)) + ] + +functorLaws :: (Functor t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws +functorLaws (Subject name gen inj obs) = + [ law name "functor identity" $ do + x <- inj <$> forAll (gen genInt) + obs (fmap id x) === obs x + , law name "functor composition" $ do + x <- inj <$> forAll (gen genInt) + f <- forAll genFnInt + g <- forAll genFnInt + obs (fmap (apply f . apply g) x) === obs (fmap (apply f) (fmap (apply g) x)) + ] + +applicativeLaws :: + (Apply t, Applicative t, Show (g Int), Show (g (Fn Int Int)), Eq (o Int), Show (o Int)) => + Subject g t o -> + Laws +applicativeLaws (Subject name gen inj obs) = + [ law name "applicative identity" $ do + v <- inj <$> forAll (gen genInt) + obs (pure id <*> v) === obs v + , law name "applicative composition" $ do + u <- fmap apply . inj <$> forAll (gen genFnInt) + v <- fmap apply . inj <$> forAll (gen genFnInt) + w <- inj <$> forAll (gen genInt) + obs (pure (.) <*> u <*> v <*> w) === obs (u <*> (v <*> w)) + , law name "applicative homomorphism" $ do + f <- forAll genFnInt + x <- forAll genInt + obs (pure (apply f) <*> pure x) === obs (pure (apply f x)) + , law name "applicative interchange" $ do + u <- fmap apply . inj <$> forAll (gen genFnInt) + y <- forAll genInt + obs (u <*> pure y) === obs (pure ($ y) <*> u) + , law name "apply agrees with applicative" $ do + u <- fmap apply . inj <$> forAll (gen genFnInt) + v <- inj <$> forAll (gen genInt) + obs (u <.> v) === obs (u <*> v) + ] + +monadLaws :: + (Bind t, Monad t, Show (g Int), Eq (o Int), Show (o Int)) => + Subject g t o -> + Laws +monadLaws (Subject name gen inj obs) = + [ law name "monad left identity" $ do + a <- forAll genInt + k <- forAll (fn (gen genInt)) + obs (pure a >>= inj . apply k) === obs (inj (apply k a)) + , law name "monad right identity" $ do + m <- inj <$> forAll (gen genInt) + obs (m >>= pure) === obs m + , law name "monad associativity" $ do + m <- inj <$> forAll (gen genInt) + k <- forAll (fn (gen genInt)) + h <- forAll (fn (gen genInt)) + obs ((m >>= inj . apply k) >>= inj . apply h) === obs (m >>= (\x -> inj (apply k x) >>= inj . apply h)) + , law name "bind agrees with monad" $ do + m <- inj <$> forAll (gen genInt) + k <- forAll (fn (gen genInt)) + obs (m >>- inj . apply k) === obs (m >>= inj . apply k) + ] + +altLaws :: (Alt t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws +altLaws (Subject name gen inj obs) = + [ law name "alt associativity" $ do + x <- inj <$> forAll (gen genInt) + y <- inj <$> forAll (gen genInt) + z <- inj <$> forAll (gen genInt) + obs ((x y) z) === obs (x (y z)) + , law name "alt left distributivity" $ do + x <- inj <$> forAll (gen genInt) + y <- inj <$> forAll (gen genInt) + f <- forAll genFnInt + obs (apply f <$> (x y)) === obs ((apply f <$> x) (apply f <$> y)) + ] + +-- | @duplicated . duplicated = fmap duplicated . duplicated@, observed at every level. +extendLaws :: + (Extend t, Functor o, Show (g Int), Eq (o (o (o Int))), Show (o (o (o Int)))) => + Subject g t o -> + Laws +extendLaws (Subject name gen inj obs) = + [ law name "extend associativity" $ do + x <- inj <$> forAll (gen genInt) + let obs3 = obs . fmap (obs . fmap obs) + obs3 (duplicated (duplicated x)) === obs3 (fmap duplicated (duplicated x)) + ] + +-- | @x \<*? pure id = either id id \<$\> x@ +selectiveLaws :: (Selective t, Show (g (Either Int Int)), Eq (o Int), Show (o Int)) => Subject g t o -> Laws +selectiveLaws (Subject name gen inj obs) = + [ law name "selective identity" $ do + x <- inj <$> forAll (gen (Gen.either genInt genInt)) + obs (select x (pure id)) === obs (either id id <$> x) + ] + +-- | @foldMap f = foldr (\\x acc -> f x <> acc) mempty@ +foldableLaws :: (Foldable t, Show (g Int)) => Subject g t o -> Laws +foldableLaws (Subject name gen inj _) = + [ law name "foldMap agrees with foldr" $ do + x <- inj <$> forAll (gen genInt) + f <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + foldMap (apply f) x === foldr (\a acc -> apply f a <> acc) [] x + ] + +traversableLaws :: (Traversable t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws +traversableLaws (Subject name gen inj obs) = + [ law name "traversable identity" $ do + x <- inj <$> forAll (gen genInt) + obs (runIdentity (traverse Identity x)) === obs x + , law name "traversable composition" $ do + x <- inj <$> forAll (gen genInt) + f <- forAll (fn (Gen.maybe genInt)) + g <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + let lhs = traverse (Compose . fmap (apply g) . apply f) x + rhs = Compose (fmap (traverse (apply g)) (traverse (apply f) x)) + fmap (fmap obs) (getCompose lhs) === fmap (fmap obs) (getCompose rhs) + ] + +bifunctorLaws :: (Bifunctor p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws +bifunctorLaws (Subject2 name gen inj obs) = + [ law name "bifunctor identity" $ do + x <- inj <$> forAll (gen genInt genInt) + obs (bimap id id x) === obs x + , law name "bifunctor composition" $ do + x <- inj <$> forAll (gen genInt genInt) + f <- forAll genFnInt + g <- forAll genFnInt + h <- forAll genFnInt + i <- forAll genFnInt + obs (bimap (apply f . apply g) (apply h . apply i) x) === obs (bimap (apply f) (apply h) (bimap (apply g) (apply i) x)) + , law name "first and second agree with bimap" $ do + x <- inj <$> forAll (gen genInt genInt) + f <- forAll genFnInt + g <- forAll genFnInt + obs (first (apply f) (second (apply g) x)) === obs (bimap (apply f) (apply g) x) + ] + +-- | @bifoldMap f g = bifoldr (\\x acc -> f x <> acc) (\\y acc -> g y <> acc) mempty@ +bifoldableLaws :: (Bifoldable p, Show (g Int Int)) => Subject2 g p o -> Laws +bifoldableLaws (Subject2 name gen inj _) = + [ law name "bifoldMap agrees with bifoldr" $ do + x <- inj <$> forAll (gen genInt genInt) + f <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + g <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + bifoldMap (apply f) (apply g) x === bifoldr (\a acc -> apply f a <> acc) (\b acc -> apply g b <> acc) [] x + ] + +bitraversableLaws :: (Bitraversable p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws +bitraversableLaws (Subject2 name gen inj obs) = + [ law name "bitraversable identity" $ do + x <- inj <$> forAll (gen genInt genInt) + obs (runIdentity (bitraverse Identity Identity x)) === obs x + , law name "bitraversable composition" $ do + x <- inj <$> forAll (gen genInt genInt) + f <- forAll (fn (Gen.maybe genInt)) + g <- forAll (fn (Gen.maybe genInt)) + h <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + i <- forAll (fn (Gen.list (Range.linear 0 3) genInt)) + let lhs = bitraverse (Compose . fmap (apply h) . apply f) (Compose . fmap (apply i) . apply g) x + rhs = Compose (fmap (bitraverse (apply h) (apply i)) (bitraverse (apply f) (apply g) x)) + fmap (fmap obs) (getCompose lhs) === fmap (fmap obs) (getCompose rhs) + ] + +swapLaws :: (Bifunctor p, Swap p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws +swapLaws (Subject2 name gen inj obs) = + [ law name "swap involution" $ do + x <- inj <$> forAll (gen genInt genInt) + obs (swap (swap x)) === obs x + , law name "swap naturality" $ do + x <- inj <$> forAll (gen genInt genInt) + f <- forAll genFnInt + g <- forAll genFnInt + obs (swap (bimap (apply f) (apply g) x)) === obs (bimap (apply g) (apply f) (swap x)) + ] + +{- | Prism laws, generating a showable @g@, injecting it into @s@, and observing @s@ as @o@. + +* @preview l (review l a) == Just a@ +* @preview l s == Just a ==> review l a == s@ +-} +prismLawsVia :: (Show g, Eq o, Show o, Eq a, Show a) => String -> APrism' s a -> Gen g -> (g -> s) -> (s -> o) -> Gen a -> Laws +prismLawsVia name p genG inj obs genA = + [ law name "preview . review" $ do + a <- forAll genA + preview (clonePrism p) (review (clonePrism p) a) === Just a + , law name "review . preview" $ do + s <- inj <$> forAll genG + obs (maybe s (review (clonePrism p)) (preview (clonePrism p) s)) === obs s + ] + +{- | Isomorphism laws. + +* @view l (review l a) == a@ +* @review l (view l s) == s@ +-} +isoLaws :: (Eq s, Show s, Eq a, Show a) => String -> AnIso' s a -> Gen s -> Gen a -> Laws +isoLaws name l genS genA = + [ law name "view . review" $ do + a <- forAll genA + view (cloneIso l) (review (cloneIso l) a) === a + , law name "review . view" $ do + s <- forAll genS + review (cloneIso l) (view (cloneIso l) s) === s + ] diff --git a/test/doctest_tests.hs b/test/doctest_tests.hs new file mode 100644 --- /dev/null +++ b/test/doctest_tests.hs @@ -0,0 +1,43 @@ +import Control.Monad (unless) +import System.Exit (ExitCode (..), exitFailure) +import System.Process (rawSystem) + +main :: IO () +main = do + results <- + mapM + ( \f -> + rawSystem + "cabal" + [ "exec" + , "--" + , "doctest" + , "-isrc" + , f + ] + ) + [ "src/Data/Either3.hs" + , "src/Data/Either3/Either3.hs" + , "src/Data/Either3/Either3T.hs" + , "src/Data/Lens/Injection/Generic.hs" + , "src/Data/Lens/Injection/Injection1.hs" + , "src/Data/Lens/Injection/Injection2.hs" + , "src/Data/Lens/Injection/Injection3.hs" + , "src/Data/Lens/Injection/Injection4.hs" + , "src/Data/Lens/Injection/Injection5.hs" + , "src/Data/Lens/Injection/Injection6.hs" + , "src/Data/Lens/Injection/Injection7.hs" + , "src/Data/Lens/Injection/Injection8.hs" + , "src/Data/Lens/Injection/Injection9.hs" + , "src/Data/Lens/Injection/Injection10.hs" + , "src/Data/Lens/Injection/Injection11.hs" + , "src/Data/Lens/Injection/Injection12.hs" + , "src/Data/Lens/Injection/Injection13.hs" + , "src/Data/Lens/Injection/Injection14.hs" + , "src/Data/Lens/Injection/Injection15.hs" + , "src/Data/Lens/Injection/Injection16.hs" + , "src/Data/Lens/Injection/Injection17.hs" + , "src/Data/Lens/Injection/Injection18.hs" + , "src/Data/Lens/Injection/Injection19.hs" + ] + unless (all (== ExitSuccess) results) exitFailure diff --git a/test/hedgehog_tests.hs b/test/hedgehog_tests.hs new file mode 100644 --- /dev/null +++ b/test/hedgehog_tests.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +import Control.Lens (APrism', clonePrism, over, preview, review) +import Control.Monad (unless) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Sum (Sum (..)) +import Data.Lens.Injection +import Data.List.NonEmpty (NonEmpty) +import Data.Proxy (Proxy (..)) +import Data.String (fromString) +import Either3TTests (either3TTests) +import Either3Tests (either3Tests) +import GHC.Generics (Generic, (:+:) (..)) +import Gens (genInt, genList, genMaybeInt, genString, genUnit) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import System.Exit (exitFailure) +import System.IO (BufferMode (..), hSetBuffering, stderr, stdout) + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + + result <- + and + <$> mapM + checkParallel + [ Group "Injection" injectionTests + , Group "Generic agrees with base instances" agreementTests + , Group "Generic default instances" genericTests + , Group "Either3" either3Tests + , Group "Either3T" either3TTests + ] + + unless result exitFailure + +injectionTests :: [(PropertyName, Property)] +injectionTests = + concat + [ prismLaws "Injection1 Either" _I1 genEither genInt + , prismLaws "Injection1 Maybe" _I1 genMaybeInt genUnit + , prismLaws "Injection1 Bool" _I1 Gen.bool genUnit + , prismLaws "Injection1 Ordering" _I1 genOrdering genUnit + , prismLaws "Injection1 List" _I1 genList genUnit + , prismLaws "Injection1 Identity" _I1 genIdentity genInt + , prismLaws "Injection1 Unit" _I1 genUnit genUnit + , prismLaws "Injection1 Sum" _I1 genSum genMaybeInt + , prismLaws "Injection1 :+:" _I1 genGenericSum genMaybeInt + , prismLaws "Injection2 Either" _I2 genEither genString + , prismLaws "Injection2 Maybe" _I2 genMaybeInt genInt + , prismLaws "Injection2 Bool" _I2 Gen.bool genUnit + , prismLaws "Injection2 Ordering" _I2 genOrdering genUnit + , prismLaws "Injection2 List" _I2 genList genNonEmpty + , prismLaws "Injection2 Sum" _I2 genSum genList + , prismLaws "Injection2 :+:" _I2 genGenericSum genList + , prismLaws "Injection3 Ordering" _I3 genOrdering genUnit + ] + +agreementTests :: [(PropertyName, Property)] +agreementTests = + concat + [ agree "Injection1 Either" _I1 (injection (Proxy @0)) genEither genInt + , agree "Injection2 Either" _I2 (injection (Proxy @1)) genEither genString + , agree "Injection1 Maybe" _I1 (injection (Proxy @0)) genMaybeInt genUnit + , agree "Injection2 Maybe" _I2 (injection (Proxy @1)) genMaybeInt genInt + , agree "Injection1 Bool" _I1 (injection (Proxy @0)) Gen.bool genUnit + , agree "Injection2 Bool" _I2 (injection (Proxy @1)) Gen.bool genUnit + , agree "Injection1 Ordering" _I1 (injection (Proxy @0)) genOrdering genUnit + , agree "Injection2 Ordering" _I2 (injection (Proxy @1)) genOrdering genUnit + , agree "Injection3 Ordering" _I3 (injection (Proxy @2)) genOrdering genUnit + , agree "Injection1 List" _I1 (injection (Proxy @0)) genList genUnit + , agree "Injection2 List" _I2 (injection (Proxy @1)) genList genNonEmpty + ] + +genericTests :: [(PropertyName, Property)] +genericTests = + concat + [ prismLaws "Injection1 Sum19" _I1 genSum19 genInt + , prismLaws "Injection2 Sum19" _I2 genSum19 genUnit + , prismLaws "Injection3 Sum19" _I3 genSum19 ((,) <$> genInt <*> Gen.bool) + , prismLaws "Injection4 Sum19" _I4 genSum19 genString + , prismLaws "Injection5 Sum19" _I5 genSum19 ((,,) <$> genInt <*> genInt <*> genInt) + , prismLaws "Injection6 Sum19" _I6 genSum19 genInt + , prismLaws "Injection7 Sum19" _I7 genSum19 genInt + , prismLaws "Injection8 Sum19" _I8 genSum19 genInt + , prismLaws "Injection9 Sum19" _I9 genSum19 genInt + , prismLaws "Injection10 Sum19" _I10 genSum19 genInt + , prismLaws "Injection11 Sum19" _I11 genSum19 genInt + , prismLaws "Injection12 Sum19" _I12 genSum19 genInt + , prismLaws "Injection13 Sum19" _I13 genSum19 genInt + , prismLaws "Injection14 Sum19" _I14 genSum19 genInt + , prismLaws "Injection15 Sum19" _I15 genSum19 genInt + , prismLaws "Injection16 Sum19" _I16 genSum19 genInt + , prismLaws "Injection17 Sum19" _I17 genSum19 genInt + , prismLaws "Injection18 Sum19" _I18 genSum19 genInt + , prismLaws "Injection19 Sum19" _I19 genSum19 genInt + , prismLaws "Injection1 Three" _I1 genThree genInt + , prismLaws "Injection2 Three" _I2 genThree genString + , prismLaws "Injection3 Three" _I3 genThree Gen.bool + , [("Injection1 Three changes type", prop_three_changes_type)] + ] + +-- Prism laws + +prismLaws :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> Gen s -> Gen a -> [(PropertyName, Property)] +prismLaws name p genS genA = + [ (fromString (name ++ " preview . review"), prop_preview_review p genA) + , (fromString (name ++ " review . preview"), prop_review_preview p genS) + ] + +-- | @preview l (review l b) == Just b@ +prop_preview_review :: (Eq a, Show a) => APrism' s a -> Gen a -> Property +prop_preview_review p genA = + property $ do + a <- forAll genA + preview (clonePrism p) (review (clonePrism p) a) === Just a + +-- | @preview l s == Just a ==> review l a == s@ +prop_review_preview :: (Eq s, Show s) => APrism' s a -> Gen s -> Property +prop_review_preview p genS = + property $ do + s <- forAll genS + maybe s (review (clonePrism p)) (preview (clonePrism p) s) === s + +-- | Two prisms agree on both 'preview' and 'review'. +agree :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> APrism' s a -> Gen s -> Gen a -> [(PropertyName, Property)] +agree name p q genS genA = + [ (fromString (name ++ " preview"), prop_agree_preview p q genS) + , (fromString (name ++ " review"), prop_agree_review p q genA) + ] + +prop_agree_preview :: (Show s, Eq a, Show a) => APrism' s a -> APrism' s a -> Gen s -> Property +prop_agree_preview p q genS = + property $ do + s <- forAll genS + preview (clonePrism p) s === preview (clonePrism q) s + +prop_agree_review :: (Eq s, Show s, Show a) => APrism' s a -> APrism' s a -> Gen a -> Property +prop_agree_review p q genA = + property $ do + a <- forAll genA + review (clonePrism p) a === review (clonePrism q) a + +-- Generic default instances + +-- | One constructor for each class, with no fields, one field, more than one field and strict fields. +data Sum19 + = S1 Int + | S2 + | S3 Int Bool + | S4 String + | S5 !Int !Int !Int + | S6 Int + | S7 Int + | S8 Int + | S9 Int + | S10 Int + | S11 Int + | S12 Int + | S13 Int + | S14 Int + | S15 Int + | S16 Int + | S17 Int + | S18 Int + | S19 Int + deriving (Eq, Show, Generic) + +instance Injection1 Sum19 Sum19 Int Int + +instance Injection2 Sum19 Sum19 () () + +instance Injection3 Sum19 Sum19 (Int, Bool) (Int, Bool) + +instance Injection4 Sum19 Sum19 String String + +instance Injection5 Sum19 Sum19 (Int, Int, Int) (Int, Int, Int) + +instance Injection6 Sum19 Sum19 Int Int + +instance Injection7 Sum19 Sum19 Int Int + +instance Injection8 Sum19 Sum19 Int Int + +instance Injection9 Sum19 Sum19 Int Int + +instance Injection10 Sum19 Sum19 Int Int + +instance Injection11 Sum19 Sum19 Int Int + +instance Injection12 Sum19 Sum19 Int Int + +instance Injection13 Sum19 Sum19 Int Int + +instance Injection14 Sum19 Sum19 Int Int + +instance Injection15 Sum19 Sum19 Int Int + +instance Injection16 Sum19 Sum19 Int Int + +instance Injection17 Sum19 Sum19 Int Int + +instance Injection18 Sum19 Sum19 Int Int + +instance Injection19 Sum19 Sum19 Int Int + +-- | Each instance changes the type of its own constructor. +data Three a b c + = Three1 a + | Three2 b + | Three3 c + deriving (Eq, Show, Generic) + +instance Injection1 (Three a b c) (Three a' b c) a a' + +instance Injection2 (Three a b c) (Three a b' c) b b' + +instance Injection3 (Three a b c) (Three a b c') c c' + +prop_three_changes_type :: Property +prop_three_changes_type = + property $ do + a <- forAll genInt + over _I1 show (Three1 a :: Three Int String Bool) === Three1 (show a) + +-- Generators + +genNonEmpty :: Gen (NonEmpty Int) +genNonEmpty = Gen.nonEmpty (Range.linear 1 10) genInt + +genEither :: Gen (Either Int String) +genEither = Gen.choice [fmap Left genInt, fmap Right genString] + +genOrdering :: Gen Ordering +genOrdering = Gen.enumBounded + +genIdentity :: Gen (Identity Int) +genIdentity = fmap Identity genInt + +genSum :: Gen (Sum Maybe [] Int) +genSum = Gen.choice [fmap InL genMaybeInt, fmap InR genList] + +genGenericSum :: Gen ((Maybe :+: []) Int) +genGenericSum = Gen.choice [fmap L1 genMaybeInt, fmap R1 genList] + +genSum19 :: Gen Sum19 +genSum19 = + Gen.choice + [ S1 <$> genInt + , pure S2 + , S3 <$> genInt <*> Gen.bool + , S4 <$> genString + , S5 <$> genInt <*> genInt <*> genInt + , S6 <$> genInt + , S7 <$> genInt + , S8 <$> genInt + , S9 <$> genInt + , S10 <$> genInt + , S11 <$> genInt + , S12 <$> genInt + , S13 <$> genInt + , S14 <$> genInt + , S15 <$> genInt + , S16 <$> genInt + , S17 <$> genInt + , S18 <$> genInt + , S19 <$> genInt + ] + +genThree :: Gen (Three Int String Bool) +genThree = Gen.choice [fmap Three1 genInt, fmap Three2 genString, fmap Three3 Gen.bool]