fresnel (empty) → 0.0.0.0

raw patch · 51 files changed

+2832/−0 lines, 51 filesdep +QuickCheckdep +ansi-terminaldep +base

Dependencies added: QuickCheck, ansi-terminal, base, containers, fresnel, fused-effects, hashable, profunctors, template-haskell, transformers, unordered-containers

Files

• CHANGELOG.md +3/−0
• LICENSE +30/−0
• fresnel.cabal +117/−0
• src/Fresnel/At.hs +71/−0
• src/Fresnel/Bifunctor/Contravariant.hs +45/−0
• src/Fresnel/Either.hs +15/−0
• src/Fresnel/Fold.hs +157/−0
• src/Fresnel/Functor/Backwards.hs +7/−0
• src/Fresnel/Functor/Traversed.hs +22/−0
• src/Fresnel/Getter.hs +47/−0
• src/Fresnel/Getter/Internal.hs +15/−0
• src/Fresnel/Iso.hs +221/−0
• src/Fresnel/Iso/Internal.hs +20/−0
• src/Fresnel/Ixed.hs +106/−0
• src/Fresnel/Lens.hs +66/−0
• src/Fresnel/Lens/Internal.hs +17/−0
• src/Fresnel/List.hs +22/−0
• src/Fresnel/List/NonEmpty.hs +26/−0
• src/Fresnel/Maybe.hs +15/−0
• src/Fresnel/Monoid/Cons.hs +43/−0
• src/Fresnel/Monoid/Fork.hs +43/−0
• src/Fresnel/Monoid/Snoc.hs +42/−0
• src/Fresnel/Optic.hs +12/−0
• src/Fresnel/Optional.hs +95/−0
• src/Fresnel/Optional/Internal.hs +17/−0
• src/Fresnel/OptionalFold.hs +54/−0
• src/Fresnel/OptionalFold/Internal.hs +15/−0
• src/Fresnel/Prism.hs +99/−0
• src/Fresnel/Prism/Internal.hs +18/−0
• src/Fresnel/Profunctor/Coexp.hs +55/−0
• src/Fresnel/Profunctor/OptionalStar.hs +60/−0
• src/Fresnel/Profunctor/Recall.hs +54/−0
• src/Fresnel/Review.hs +72/−0
• src/Fresnel/Set.hs +15/−0
• src/Fresnel/Setter.hs +97/−0
• src/Fresnel/Traversal.hs +78/−0
• src/Fresnel/Traversal/Internal.hs +15/−0
• src/Fresnel/Tuple.hs +15/−0
• test/Fold/Test.hs +52/−0
• test/Fresnel/Tropical.hs +16/−0
• test/Getter/Test.hs +16/−0
• test/Iso/Test.hs +43/−0
• test/Monoid/Fork/Test.hs +71/−0
• test/Profunctor/Coexp/Test.hs +34/−0
• test/Review/Test.hs +15/−0
• test/Test.hs +35/−0
• test/Test/Group.hs +166/−0
• test/Test/Options.hs +103/−0
• test/Test/Print.hs +104/−0
• test/Test/Run.hs +213/−0
• test/Tropical/Test.hs +43/−0

@@ -0,0 +1,3 @@+# 0.0.0.0++Initial release.

@@ -0,0 +1,30 @@+Copyright (c) 2021, Rob Rix++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Rob Rix nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,117 @@+cabal-version:      2.4+name:               fresnel+version:            0.0.0.0+synopsis:           high-powered optics in a small package+description:        fresnel offers (non-indexed) profunctor optics composed with the lowly . operator.+homepage:           https://github.com/fresnel/fresnel+bug-reports:        https://github.com/fresnel/fresnel/issues+license:            BSD-3-Clause+license-file:       LICENSE+author:             Rob Rix+maintainer:         rob.rix@me.com++copyright:          2021–2022 Rob Rix+category:           Control+extra-source-files: CHANGELOG.md++common common+  default-language: Haskell2010+  ghc-options:+    -Weverything+    -Wno-all-missed-specialisations+    -Wno-implicit-prelude+    -Wno-missed-specialisations+    -Wno-missing-import-lists+    -Wno-missing-local-signatures+    -Wno-missing-safe-haskell-mode+    -Wno-monomorphism-restriction+    -Wno-name-shadowing+    -Wno-safe+    -Wno-unsafe+  if (impl(ghc >= 8.8))+    ghc-options: -Wno-missing-deriving-strategies+  if (impl(ghc >= 8.10))+    ghc-options:+      -Wno-missing-safe-haskell-mode+      -Wno-prepositive-qualified-module++library+  import: common+  exposed-modules:+    Fresnel.At+    Fresnel.Bifunctor.Contravariant+    Fresnel.Either+    Fresnel.Fold+    Fresnel.Functor.Backwards+    Fresnel.Functor.Traversed+    Fresnel.Getter+    Fresnel.Iso+    Fresnel.Ixed+    Fresnel.Lens+    Fresnel.List+    Fresnel.List.NonEmpty+    Fresnel.Maybe+    Fresnel.Monoid.Cons+    Fresnel.Monoid.Fork+    Fresnel.Monoid.Snoc+    Fresnel.Optic+    Fresnel.Optional+    Fresnel.OptionalFold+    Fresnel.Prism+    Fresnel.Profunctor.Coexp+    Fresnel.Profunctor.OptionalStar+    Fresnel.Profunctor.Recall+    Fresnel.Review+    Fresnel.Set+    Fresnel.Setter+    Fresnel.Traversal+    Fresnel.Tuple+  other-modules:+    Fresnel.Getter.Internal+    Fresnel.Iso.Internal+    Fresnel.Lens.Internal+    Fresnel.Optional.Internal+    Fresnel.OptionalFold.Internal+    Fresnel.Prism.Internal+    Fresnel.Traversal.Internal+  build-depends:+    , base >=4.14 && < 5+    , containers   >= 0.5 && < 0.7+    , hashable    ^>= 1.3+    , profunctors ^>= 5.6+    , transformers  >= 0.4 && < 0.6+    , unordered-containers ^>= 0.2+  hs-source-dirs: src++test-suite test+  import: common+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Test.hs+  other-modules:+    Fold.Test+    Fresnel.Tropical+    Getter.Test+    Iso.Test+    Monoid.Fork.Test+    Profunctor.Coexp.Test+    Review.Test+    Test.Group+    Test.Options+    Test.Print+    Test.Run+    Tropical.Test+  build-depends:+    , ansi-terminal ^>= 0.11+    , base+    , containers+    , fresnel+    , fused-effects+    , template-haskell+    , QuickCheck ^>= 2.14+++source-repository head+  type:     git+  location: https://github.com/fresnel/fresnel+  subdir:   fresnel

@@ -0,0 +1,71 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.At+( -- * Updateable collections+  At(..)+, Index+, IxValue+  -- * Construction+, atSet+, atMap+, ixAt+  -- * Elimination+, sans+) where++import           Control.Monad (guard)+import qualified Data.HashMap.Internal.Strict as HashMap+import qualified Data.HashSet as HashSet+import           Data.Hashable+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.Map as Map+import qualified Data.Set as Set+import           Fresnel.Ixed+import           Fresnel.Lens (Lens', lens)+import           Fresnel.Maybe (_Just)+import           Fresnel.Optional (Optional')+import           Fresnel.Setter++-- Updateable collections++class Ixed c => At c where+  at :: Index c -> Lens' c (Maybe (IxValue c))++instance At IntSet.IntSet where+  at = atSet IntSet.member IntSet.insert IntSet.delete++instance At (IntMap.IntMap v) where+  at = atMap IntMap.lookup IntMap.insert IntMap.delete++instance Ord k => At (Set.Set k) where+  at = atSet Set.member Set.insert Set.delete++instance Ord k => At (Map.Map k v) where+  at = atMap Map.lookup Map.insert Map.delete++instance (Eq k, Hashable k) => At (HashSet.HashSet k) where+  at = atSet HashSet.member HashSet.insert HashSet.delete++instance (Eq k, Hashable k) => At (HashMap.HashMap k v) where+  at = atMap HashMap.lookup HashMap.insert HashMap.delete++instance At (Maybe a) where+  at _ = lens id (const id)+++-- Construction++atSet :: (Index c -> c -> Bool) -> (Index c -> c -> c) -> (Index c -> c -> c) -> Index c -> Lens' c (Maybe ())+atSet member insert delete k = lens (guard . member k) (\ s -> maybe (delete k s) (const (insert k s)))++atMap :: (Index c -> c -> Maybe (IxValue c)) -> (Index c -> IxValue c -> c -> c) -> (Index c -> c -> c) -> Index c -> Lens' c (Maybe (IxValue c))+atMap lookup insert delete k = lens (lookup k) (\ m -> maybe (delete k m) (flip (insert k) m))++ixAt :: At a => Index a -> Optional' a (IxValue a)+ixAt i = at i . _Just+++-- Elimination++sans :: At c => Index c -> c -> c+sans k = at k .~ Nothing

@@ -0,0 +1,45 @@+module Fresnel.Bifunctor.Contravariant+( -- * Bicontravariant functors+  Bicontravariant(..)+, contrafirst+, contrasecond+  -- * Phantom parameters+, rphantom+, biphantom+) where++import Data.Bifunctor (Bifunctor(..))+import Data.Profunctor (Forget(..), Profunctor(..), Star(..))+import Data.Functor.Contravariant+import Control.Arrow++-- Bicontravariant functors++class Bicontravariant p where+  contrabimap :: (a' -> a) -> (b' -> b) -> p a b -> p a' b'++instance Bicontravariant (Forget r) where+  contrabimap f _ = Forget . lmap f . runForget++instance Contravariant f => Bicontravariant (Star f) where+  contrabimap f g = Star . dimap f (contramap g) . runStar++instance Contravariant m => Bicontravariant (Kleisli m) where+  contrabimap f g = Kleisli . dimap f (contramap g) . runKleisli+++contrafirst :: Bicontravariant p => (a' -> a) -> p a b -> p a' b+contrafirst = (`contrabimap` id)++contrasecond :: Bicontravariant p => (b' -> b) -> p a b -> p a b'+contrasecond = (id `contrabimap`)+++-- Phantom parameters++rphantom :: (Profunctor p, Bicontravariant p) => p a b -> p a c+rphantom = contrasecond (const ()) . rmap (const ())+++biphantom :: (Bifunctor p, Bicontravariant p) => p a b -> p c d+biphantom = contrabimap (const ()) (const ()) . bimap (const ()) (const ())

@@ -0,0 +1,15 @@+module Fresnel.Either+( -- * Prisms+  _Left+, _Right+) where++import Fresnel.Prism++-- Prisms++_Left :: Prism (Either a b) (Either a' b) a a'+_Left = prism Left (either Right (Left . Right))++_Right :: Prism (Either a b) (Either a b') b b'+_Right = prism Right (either (Left . Left) Right)

@@ -0,0 +1,157 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+module Fresnel.Fold+( -- * Folds+  Fold+, IsFold+  -- * Construction+, folded+, unfolded+, folding+, foldring+, ignored+, backwards+  -- * Elimination+, has+, hasn't+, foldMapOf+, foldMapByOf+, foldrOf+, foldlOf'+, foldOf+, sequenceOf_+, traverseOf_+, forOf_+, toListOf+, anyOf+, allOf+, nullOf+, previews+, preview+, (^?)+, Failover(..)+, Union(..)+) where++import Data.Foldable (traverse_)+import Data.Functor.Contravariant+import Data.Monoid+import Data.Profunctor+import Data.Profunctor.Traversing+import Data.Profunctor.Unsafe ((#.), (.#))+import Fresnel.Bifunctor.Contravariant+import Fresnel.Functor.Backwards (Backwards(..))+import Fresnel.Functor.Traversed+import Fresnel.Monoid.Cons as Cons+import Fresnel.Monoid.Fork as Fork+import Fresnel.Monoid.Snoc as Snoc+import Fresnel.Optic+import Fresnel.OptionalFold.Internal (IsOptionalFold)+import Fresnel.Traversal.Internal (IsTraversal)++-- Folds++type Fold s a = forall p . IsFold p => Optic' p s a++class (IsOptionalFold p, IsTraversal p) => IsFold p++instance Monoid r => IsFold (Forget r)+instance (Applicative f, Traversable f, Contravariant f) => IsFold (Star f)+++-- Construction++folded :: Foldable f => Fold (f a) a+folded = rphantom . wander traverse_++unfolded :: (s -> Maybe (a, s)) -> Fold s a+unfolded coalg = rphantom . wander (\ f -> let loop = maybe (pure ()) (\ (a, s) -> f a *> loop s) . coalg in loop)++folding :: Foldable f => (s -> f a) -> Fold s a+folding f = contrabimap f (const ()) . rmap (const ()) . wander traverse_++foldring :: (forall f . Applicative f => (a -> f u -> f u) -> f v -> s -> f w) -> Fold s a+foldring fr = rphantom . wander (\ f -> fr (\ a -> (f a *>)) (pure v)) where+  v = error "foldring: value used"++ignored :: Fold s a+ignored = foldring (\ _ nil _ -> nil)++backwards :: Fold s a -> Fold s a+backwards o = rphantom . wander (\ f -> forwards . traverseOf_ o (Backwards #. f))+++-- Elimination++has :: Fold s a -> (s -> Bool)+has o = anyOf o (const True)++hasn't :: Fold s a -> (s -> Bool)+hasn't = nullOf+++foldMapOf :: Monoid m => Fold s a -> ((a -> m) -> (s -> m))+foldMapOf o = runForget #. o .# Forget++foldMapByOf :: Fold s a -> ((r -> r -> r) -> r -> (a -> r) -> (s -> r))+foldMapByOf o fork nil leaf s = runFork (runForget (o (Forget Fork.singleton)) s) fork leaf nil++foldrOf :: Fold s a -> ((a -> r -> r) -> r -> s -> r)+foldrOf o cons nil s = runCons (runForget (o (Forget Cons.singleton)) s) cons nil++foldlOf' :: Fold s a -> ((r -> a -> r) -> r -> s -> r)+foldlOf' o snoc nil s = runSnoc (runForget (o (Forget Snoc.singleton)) s) snoc nil++foldOf :: Monoid a => Fold s a -> (s -> a)+foldOf o = foldMapOf o id++sequenceOf_ :: Applicative f => Fold s (f a) -> (s -> f ())+sequenceOf_ o = runTraversed . foldMapOf o Traversed++traverseOf_ :: Applicative f => Fold s a -> ((a -> f r) -> (s -> f ()))+traverseOf_ o f = runTraversed . foldMapOf o (Traversed #. f)++forOf_ :: Applicative f => Fold s a -> (s -> (a -> f r) -> f ())+forOf_ o = flip (traverseOf_ o)++toListOf :: Fold s a -> s -> [a]+toListOf o = foldrOf o (:) []++anyOf :: Fold s a -> (a -> Bool) -> (s -> Bool)+anyOf o = foldMapByOf o (||) False++allOf :: Fold s a -> (a -> Bool) -> (s -> Bool)+allOf o = foldMapByOf o (&&) True++nullOf :: Fold s a -> (s -> Bool)+nullOf o = foldrOf o (\ _ _ -> False) True+++previews :: Fold s a -> (a -> r) -> (s -> Maybe r)+previews o f = getFirst #. foldMapOf o (First #. Just . f)++preview :: Fold s a -> s -> Maybe a+preview o = previews o id++(^?) :: s -> Fold s a -> Maybe a+s ^? o = preview o s++infixl 8 ^?+++newtype Failover s a = Failover { getFailover :: Fold s a }++instance Semigroup (Failover s a) where+  Failover a1 <> Failover a2 = Failover (folding (\ s -> Cons (\ cons nil -> maybe (foldrOf a2 cons nil s) (uncurry cons) (foldrOf a1 (\ a -> Just . (,) a . maybe nil (uncurry cons)) Nothing s))))++instance Monoid (Failover s a) where+  mempty = Failover ignored+++newtype Union s a = Union { getUnion :: Fold s a }++instance Semigroup (Union s a) where+  Union a1 <> Union a2 = Union (rphantom . wander (\ f s -> traverseOf_ a1 f s *> traverseOf_ a2 f s) . rphantom)++instance Monoid (Union s a) where+  mempty = Union ignored

@@ -0,0 +1,7 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Fresnel.Functor.Backwards+( Backwards(..)+) where++newtype Backwards f a = Backwards { forwards :: f a }+  deriving (Applicative, Functor)

@@ -0,0 +1,22 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Fresnel.Functor.Traversed+( -- * Traversed functor+  runTraversed+, Traversed(..)+) where++import Data.Functor (void)++-- Traversed functor++runTraversed :: Functor f => Traversed f a -> f ()+runTraversed (Traversed fa) = void fa++newtype Traversed f a = Traversed (f a)+  deriving (Applicative, Functor)++instance Applicative f => Semigroup (Traversed f a) where+  Traversed a1 <> Traversed a2 = Traversed (a1 *> a2)++instance Applicative f => Monoid (Traversed f a) where+  mempty = Traversed (pure (error "Traversed.mempty: value used"))

@@ -0,0 +1,47 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Getter+( -- * Getters+  Getter+, IsGetter+  -- * Construction+, to+, getting+  -- * Elimination+, views+, view+, (^.)+) where++import Data.Profunctor+import Data.Profunctor.Unsafe ((#.), (.#))+import Fresnel.Bifunctor.Contravariant+import Fresnel.Getter.Internal (IsGetter)+import Fresnel.Optic++-- Getters++type Getter s a = forall p . IsGetter p => Optic' p s a+++-- Construction++to :: (s -> a) -> Getter s a+to f = lmap f . rphantom+++getting :: (Profunctor p, Bicontravariant p) => Optic p s t a b -> Optic' p s a+getting l f = rphantom . l $ rphantom f+++-- Elimination++views :: Getter s a -> (a -> r) -> (s -> r)+views b = runForget #. b .# Forget++view :: Getter s a -> (s -> a)+view b = views b id++(^.) :: s -> Getter s a -> a+s ^. o = view o s++infixl 8 ^.

@@ -0,0 +1,15 @@+module Fresnel.Getter.Internal+( IsGetter+) where++import Data.Functor.Contravariant (Contravariant)+import Data.Profunctor (Cochoice, Forget, Star)+import Fresnel.Bifunctor.Contravariant (Bicontravariant)+import Fresnel.Lens.Internal (IsLens)+import Fresnel.Profunctor.OptionalStar (OptionalStar)++class (IsLens p, Bicontravariant p, Cochoice p) => IsGetter p++instance IsGetter (Forget r)+instance (Contravariant f, Traversable f) => IsGetter (Star f)+instance (Contravariant f, Traversable f) => IsGetter (OptionalStar f)

@@ -0,0 +1,221 @@+{-# LANGUAGE RankNTypes #-}+{-|+@'Iso'@s are the root of the optic hierarchy: an @'Iso'@ can be used anywhere any other kind of optic is required. On the other hand, if something requests an @'Iso'@, it can only be given an @'Iso'@, as it doesn't provide enough capabilities to accept anything else.++This implies that they're the weakest optic; they make the fewest assumptions, and thus can provide only the most minimal guarantees. Even so, these guarantees are relativevly strong: notionally, an @'Iso'@ consists of functions @/f/@ and @/g/@ which are mutual inverses:++@+f '.' g = 'id'+@+@+g '.' f = 'id'+@+-}+module Fresnel.Iso+( -- * Isos+  Iso+, Iso'+, IsIso+  -- * Construction+, iso+, from+  -- * Elimination+, withIso+, under+  -- * Functions+, constant+, constantWith+, involuted+, flipped+, curried+, uncurried+  -- * Relations+, non+, non'+  -- * Tuples+, swapped+, mirrored+  -- * Coercion+, coerced+, coercedTo+, coercedFrom+  -- * Functor+, fmapping+  -- * Contravariant+, contramapping+  -- * Bifunctor+, bimapping+, firsting+, seconding+  -- * Profunctor+, dimapping+, lmapping+, rmapping+  -- * (Co-)representable+, protabulated+, cotabulated+) where++import Control.Applicative (Alternative)+import Control.Monad (guard)+import Data.Bifunctor+import Data.Coerce (Coercible, coerce)+import Data.Functor.Contravariant+import Data.Maybe (fromMaybe)+import Data.Profunctor+import Data.Profunctor.Rep hiding (cotabulated)+import Data.Profunctor.Sieve+import Data.Tuple (swap)+import Fresnel.Iso.Internal+import Fresnel.Optic+import Fresnel.Optional (isn't)+import Fresnel.Prism (Prism', only)+import Fresnel.Profunctor.Coexp+import Fresnel.Review (review)++-- Isos++type Iso s t a b = forall p . IsIso p => Optic p s t a b++type Iso' s a = Iso s s a a+++-- Construction++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso f g = f `dimap` g++from :: Iso s t a b -> Iso b a t s+from o = withIso o (flip dimap)+++-- Elimination++withIso :: Iso s t a b -> (((s -> a) -> (b -> t) -> r) -> r)+withIso i = withCoexp (i mempty) . flip+++under :: Iso s t a b -> (t -> s) -> (b -> a)+under i = withIso i (\ f r -> (f .) . (. r))+++-- Functions++constant :: a -> Iso (a -> b) (a' -> b') b b'+constant a = a `constantWith` const++constantWith :: a -> (b' -> a' -> b') -> Iso (a -> b) (a' -> b') b b'+constantWith a = iso ($ a)++involuted :: (a -> a) -> Iso' a a+involuted f = iso f f++flipped :: Iso (a -> b -> c) (a' -> b' -> c') (b -> a -> c) (b' -> a' -> c')+flipped = iso flip flip++curried :: Iso ((a, b) -> c) ((a', b') -> c') (a -> b -> c) (a' -> b' -> c')+curried = iso curry uncurry++uncurried :: Iso (a -> b -> c) (a' -> b' -> c') ((a, b) -> c) ((a', b') -> c')+uncurried = iso uncurry curry+++-- Relations++non :: Eq a => a -> Iso' (Maybe a) a+non a = non' (only a)++non' :: Prism' a () -> Iso' (Maybe a) a+non' o = iso (fromMaybe (review o ())) (select (isn't o))+++-- Tuples++swapped :: Iso (a, b) (a', b') (b, a) (b', a')+swapped = iso swap swap++mirrored :: Iso (Either a b) (Either a' b') (Either b a) (Either b' a')+mirrored = iso mirror mirror+  where+  mirror = either Right Left+++-- Coercion++coerced :: (Coercible s a, Coercible t b) => Iso s t a b+coerced = coerce `iso` coerce++-- | Build a bidi coercion, taking a constructor for the type being built both to improve type inference and as documentation.+--+-- For example, given two newtypes @A@ and @B@ wrapping the same type, this expression:+--+-- @+-- 'coercedTo' B <<< 'coercedFrom' A+-- @+--+-- produces a bijection of type @'Iso'' A B@.+coercedTo :: Coercible t b => (s -> a) -> Iso s t a b+coercedTo f = f `iso` coerce++-- | Build a bidi coercion, taking a constructor for the type being eliminated both to improve type inference and as documentation.+--+-- For example, given two newtypes @A@ and @B@ wrapping the same type, this expression:+--+-- @+-- 'coercedTo' B <<< 'coercedFrom' A+-- @+--+-- produces a bijection of type @'Iso'' A B@.+coercedFrom :: Coercible s a => (b -> t) -> Iso s t a b+coercedFrom g = coerce `iso` g+++-- Functor++fmapping :: (Functor f, Functor g) => Iso s t a b -> Iso (f s) (g t) (f a) (g b)+fmapping o = withIso o $ \ sa bt -> iso (fmap sa) (fmap bt)+++-- Contravariant++contramapping :: (Contravariant f, Contravariant g) => Iso s t a b -> Iso (f a) (g b) (f s) (g t)+contramapping o = withIso o $ \ sa bt -> iso (contramap sa) (contramap bt)+++-- Bifunctor++bimapping :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso s' t' a' b' -> Iso (p s s') (q t t') (p a a') (q b b')+bimapping a b = withIso a $ \ lsa lbt -> withIso b $ \ rsa rbt -> iso (bimap lsa rsa) (bimap lbt rbt)++firsting :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso (p s x) (q t y) (p a x) (q b y)+firsting a = withIso a $ \ sa bt -> iso (first sa) (first bt)++seconding :: (Bifunctor p, Bifunctor q) => Iso s t a b -> Iso (p x s) (q y t) (p x a) (q y b)+seconding b = withIso b $ \ sa bt -> iso (second sa) (second bt)+++-- Profunctor++dimapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso s' t' a' b' -> Iso (p a s') (q b t') (p s a') (q t b')+dimapping a b = withIso a $ \ lsa lbt -> withIso b $ \ rsa rbt -> iso (dimap lsa rsa) (dimap lbt rbt)++lmapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso (p a x) (q b y) (p s x) (q t y)+lmapping a = withIso a $ \ lsa lbt -> iso (lmap lsa) (lmap lbt)++rmapping :: (Profunctor p, Profunctor q) => Iso s t a b -> Iso (p x s) (q y t) (p x a) (q y b)+rmapping b = withIso b $ \ rsa rbt -> iso (rmap rsa) (rmap rbt)+++-- (Co-)representable (profunctorial)++protabulated :: (Representable p, Representable q) => Iso (a -> Rep p b) (a' -> Rep q b') (p a b) (q a' b')+protabulated = tabulate `iso` sieve++cotabulated :: (Corepresentable p, Corepresentable q) => Iso (Corep p a -> b) (Corep q a' -> b') (p a b) (q a' b')+cotabulated = cotabulate `iso` cosieve+++-- Utilities++select :: Alternative f => (a -> Bool) -> (a -> f a)+select p a = a <$ guard (p a)

@@ -0,0 +1,20 @@+module Fresnel.Iso.Internal+( IsIso+) where++import Control.Arrow (Kleisli)+import Data.Profunctor+import Fresnel.Profunctor.Coexp (Coexp)+import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Recall (Recall)++class Profunctor p => IsIso p++instance IsIso (->)+instance Monad m => IsIso (Kleisli m)+instance IsIso (Forget r)+instance IsIso (Recall e)+instance Functor f => IsIso (Star f)+instance Functor f => IsIso (Costar f)+instance Functor f => IsIso (OptionalStar f)+instance IsIso (Coexp s t)

@@ -0,0 +1,106 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+module Fresnel.Ixed+( -- * Indexable collections+  Ixed(..)+  -- * Construction+, ixSet+, ixMap+, ixList+) where++import           Control.Monad (guard)+import qualified Data.HashMap.Internal as HashMap+import qualified Data.HashSet as HashSet+import           Data.Hashable (Hashable)+import qualified Data.IntMap as IntMap+import qualified Data.IntSet as IntSet+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map as Map+import qualified Data.Set as Set+import           Fresnel.List.NonEmpty (head_, tail_)+import           Fresnel.Optional (Optional', optional')++-- Indexable collections++class Ixed c where+  type Index c+  type IxValue c++  ix :: Index c -> Optional' c (IxValue c)++instance Ixed IntSet.IntSet where+  type Index IntSet.IntSet = IntSet.Key+  type IxValue IntSet.IntSet = ()++  ix = ixSet IntSet.member IntSet.insert++instance Ixed (IntMap.IntMap v) where+  type Index (IntMap.IntMap v) = IntMap.Key+  type IxValue (IntMap.IntMap v) = v++  ix = ixMap IntMap.lookup IntMap.insert++instance Ord k => Ixed (Set.Set k) where+  type Index (Set.Set k) = k+  type IxValue (Set.Set k) = ()++  ix = ixSet Set.member Set.insert++instance Ord k => Ixed (Map.Map k v) where+  type Index (Map.Map k v) = k+  type IxValue (Map.Map k v) = v++  ix = ixMap Map.lookup Map.insert++instance (Eq k, Hashable k) => Ixed (HashSet.HashSet k) where+  type Index (HashSet.HashSet k) = k+  type IxValue (HashSet.HashSet k) = ()++  ix = ixSet HashSet.member HashSet.insert++instance (Eq k, Hashable k) => Ixed (HashMap.HashMap k v) where+  type Index (HashMap.HashMap k v) = k+  type IxValue (HashMap.HashMap k v) = v++  ix = ixMap HashMap.lookup HashMap.insert++instance Ixed (Maybe a) where+  type Index (Maybe a) = ()+  type IxValue (Maybe a) = a++  ix _ = optional' id (\ _ a -> Just a)++instance Ixed [v] where+  type Index [v] = Int+  type IxValue [v] = v++  ix k = ixList k++instance Ixed (NonEmpty.NonEmpty v) where+  type Index (NonEmpty.NonEmpty v) = Int+  type IxValue (NonEmpty.NonEmpty v) = v++  ix k+    | k <= 0    = head_+    | otherwise = tail_.ixList (k - 1)+++-- Construction++ixSet :: (Index c -> c -> Bool) -> (Index c -> c -> c) -> Index c -> Optional' c ()+ixSet member insert k = optional' (guard . member k) (const . insert k)++ixMap :: (Index c -> c -> Maybe (IxValue c)) -> (Index c -> IxValue c -> c -> c) -> Index c -> Optional' c (IxValue c)+ixMap lookup insert k = optional' (lookup k) (flip (insert k))++ixList :: Int -> Optional' [a] a+ixList i = optional' (get i) (set i)+  where+  get i as = case as of+    []   -> Nothing+    a:as -> if i <= 0 then Just a else get (i - 1) as+  set i as a' = case as of+    []   -> as+    a:as -> if i <= 0 then a':as else a : set (i - 1) as a'

@@ -0,0 +1,66 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Lens+( -- * Lenses+  Lens+, Lens'+, IsLens+  -- * Construction+, lens+  -- * Elimination+, withLens+  -- * Combinators+, alongside+  -- * Unpacked+, UnpackedLens(..)+, unpackedLens+) where++import Control.Arrow ((&&&), (***))+import Data.Profunctor+import Fresnel.Iso.Internal (IsIso)+import Fresnel.Lens.Internal (IsLens)+import Fresnel.Optic++-- Lenses++type Lens s t a b = forall p . IsLens p => Optic p s t a b++type Lens' s a = Lens s s a a+++-- Construction++lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b+lens get set = dimap (id &&& get) (uncurry set) . second'+++-- Elimination++withLens :: Lens s t a b -> (((s -> a) -> (s -> b -> t) -> r) -> r)+withLens o = withUnpackedLens (o (unpackedLens id (const id)))+++-- Combinators++alongside :: Lens s1 t1 a1 b1 -> Lens s2 t2 a2 b2 -> Lens (s1, s2) (t1, t2) (a1, a2) (b1, b2)+alongside o1 o2 = withLens o1 $ \ get1 set1 -> withLens o2 $ \ get2 set2 ->+  lens (get1 *** get2) (uncurry (***) . (set1 *** set2))+++-- Unpacked++-- | A 'Lens' unpacked into the get & set functions it was constructed from.+newtype UnpackedLens a b s t = UnpackedLens { withUnpackedLens :: forall r . ((s -> a) -> (s -> b -> t) -> r) -> r }++instance Profunctor (UnpackedLens a b) where+  dimap f g (UnpackedLens r) = r $ \ get set -> unpackedLens (get . f) (rmap g . set . f)++instance Strong (UnpackedLens a b) where+  first' (UnpackedLens r) = r $ \ get set -> unpackedLens (get . fst) (\ (a, c) b -> (set a b, c))++instance IsIso (UnpackedLens a b)+instance IsLens (UnpackedLens a b)+++unpackedLens :: (s -> a) -> (s -> b -> t) -> UnpackedLens a b s t+unpackedLens get set = UnpackedLens (\ k -> k get set)

@@ -0,0 +1,17 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Lens.Internal+( IsLens+) where++import Control.Arrow (Kleisli)+import Data.Profunctor (Forget, Star, Strong)+import Fresnel.Iso.Internal (IsIso)+import Fresnel.Profunctor.OptionalStar (OptionalStar)++class (IsIso p, Strong p) => IsLens p++instance IsLens (->)+instance Monad m => IsLens (Kleisli m)+instance IsLens (Forget r)+instance Functor f => IsLens (Star f)+instance Functor f => IsLens (OptionalStar f)

@@ -0,0 +1,22 @@+module Fresnel.List+( -- * Optics+  uncons_+, head_+, tail_+) where++import qualified Data.List as List+import           Fresnel.Optional+import           Fresnel.Prism+import           Fresnel.Tuple++-- Optics++uncons_ :: Prism' [a] (a, [a])+uncons_ = prism' (uncurry (:)) List.uncons++head_ :: Optional' [a] a+head_ = uncons_.fst_++tail_ :: Optional' [a] [a]+tail_ = uncons_.snd_

@@ -0,0 +1,26 @@+module Fresnel.List.NonEmpty+( -- * Optics+  nonEmpty_+, uncons_+, head_+, tail_+) where++import qualified Data.List.NonEmpty as NE+import           Fresnel.Iso (Iso, from, iso)+import           Fresnel.Lens (Lens')+import           Fresnel.Tuple (fst_, snd_)++-- Optics++nonEmpty_ :: Iso [a] [b] (Maybe (NE.NonEmpty a)) (Maybe (NE.NonEmpty b))+nonEmpty_ = iso NE.nonEmpty (foldMap NE.toList)++uncons_ :: Iso (NE.NonEmpty a) (NE.NonEmpty b) (a, Maybe (NE.NonEmpty a)) (b, Maybe (NE.NonEmpty b))+uncons_ = iso NE.uncons (uncurry (NE.:|) . fmap (foldMap NE.toList))++head_ :: Lens' (NE.NonEmpty a) a+head_ = uncons_.fst_++tail_ :: Lens' (NE.NonEmpty a) [a]+tail_ = uncons_.snd_.from nonEmpty_

@@ -0,0 +1,15 @@+module Fresnel.Maybe+( -- * Prisms+  _Just+, _Nothing+) where++import Fresnel.Prism++-- Prisms++_Just :: Prism (Maybe a) (Maybe a') a a'+_Just = prism Just (maybe (Left Nothing) Right)++_Nothing :: Prism' (Maybe a) ()+_Nothing = prism' (const Nothing) (maybe (Just ()) (const Nothing))

@@ -0,0 +1,43 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Monoid.Cons+( -- * Cons lists+  Cons(..)+  -- * Construction+, singleton+, cons+, nil+) where++import Data.Foldable (toList)++-- Cons lists++newtype Cons a = Cons { runCons :: forall r . (a -> r -> r) -> r -> r }++instance Show a => Show (Cons a) where+  showsPrec _ = showList . toList++instance Semigroup (Cons a) where+  Cons a1 <> Cons a2 = Cons (\ cons -> a1 cons . a2 cons)++instance Monoid (Cons a) where+  mempty = nil++instance Foldable Cons where+  foldMap f (Cons r) = r (mappend . f) mempty+  foldr f z (Cons r) = r f z++instance Functor Cons where+  fmap f (Cons r) = r (cons . f) nil+++-- Construction++singleton :: a -> Cons a+singleton a = Cons (\ cons nil -> cons a nil)++cons :: a -> Cons a -> Cons a+cons a (Cons as) = Cons (\ cons -> cons a . as cons)++nil :: Cons a+nil = Cons (\ _ nil -> nil)

@@ -0,0 +1,43 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Monoid.Fork+( -- * Binary trees+  Fork(..)+  -- * Construction+, singleton+) where++import Control.Applicative (Alternative(..))+import Data.Foldable (toList)++-- Binary trees++newtype Fork a = Fork { runFork :: forall r . (r -> r -> r) -> (a -> r) -> r -> r }++instance Show a => Show (Fork a) where+  showsPrec _ = showList . toList++instance Semigroup (Fork a) where+  Fork a1 <> Fork a2 = Fork (\ fork leaf nil -> a1 fork leaf nil `fork` a2 fork leaf nil)++instance Monoid (Fork a) where+  mempty = Fork (\ _ _ nil -> nil)++instance Foldable Fork where+  foldMap f (Fork r) = r (<>) f mempty++instance Functor Fork where+  fmap f (Fork r) = Fork (\ fork leaf -> r fork (leaf . f))++instance Applicative Fork where+  pure a = Fork (\ _ leaf _ -> leaf a)+  Fork f <*> Fork a = Fork (\ fork leaf nil -> f fork (\ f' -> a fork (leaf . f') nil) nil)++instance Alternative Fork where+  empty = mempty+  (<|>) = (<>)+++-- Construction++singleton :: a -> Fork a+singleton a = Fork (\ _ leaf _ -> leaf a)

@@ -0,0 +1,42 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Monoid.Snoc+( -- * Snoc lists+  Snoc(..)+  -- * Construction+, singleton+, snoc+, nil+) where++import Data.Foldable (toList)++-- Snoc lists++newtype Snoc a = Snoc { runSnoc :: forall r . (r -> a -> r) -> r -> r }++instance Show a => Show (Snoc a) where+  showsPrec _ = showList . toList++instance Semigroup (Snoc a) where+  Snoc a1 <> Snoc a2 = Snoc (\ snoc -> a1 snoc . a2 snoc)++instance Monoid (Snoc a) where+  mempty = nil++instance Foldable Snoc where+  foldMap f (Snoc r) = r (const <> const f) mempty++instance Functor Snoc where+  fmap f (Snoc r) = r ((. f) . snoc) nil+++-- Construction++singleton :: a -> Snoc a+singleton a = Snoc (\ snoc nil -> snoc nil a)++snoc :: Snoc a -> a -> Snoc a+snoc (Snoc as) a = Snoc (\ snoc nil -> snoc (as snoc nil) a)++nil :: Snoc a+nil = Snoc (\ _ nil -> nil)

@@ -0,0 +1,12 @@+-- | Type synonyms for defining types of optics.+module Fresnel.Optic+( -- * Optics+  Optic+, Optic'+) where++-- Optics++type Optic p s t a b = p a b -> p s t++type Optic' p s a = Optic p s s a a

@@ -0,0 +1,95 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Fresnel.Optional+( -- * Optionals+  Optional+, Optional'+, IsOptional+  -- * Construction+, optional+, optional'+  -- * Elimination+, matching+, matching'+, withOptional+, traverseOf+, is+, isn't+  -- * Unpacked+, UnpackedOptional(..)+, unpackedOptional+) where++import Data.Bifunctor+import Data.Maybe (isJust, isNothing)+import Data.Profunctor+import Fresnel.Iso.Internal (IsIso)+import Fresnel.Lens.Internal (IsLens)+import Fresnel.Optic+import Fresnel.Optional.Internal (IsOptional)+import Fresnel.Prism.Internal (IsPrism)+import Fresnel.Profunctor.OptionalStar++-- Optional traversals++type Optional s t a b = forall p . IsOptional p => Optic p s t a b++type Optional' s a = Optional s s a a+++-- Construction++optional :: (s -> Either t a) -> (s -> b -> t) -> Optional s t a b+optional prj set = dimap+  (\ s -> (prj s, set s))+  (\ (e, f) -> either id f e)+  . first' . right'++optional' :: (s -> Maybe a) -> (s -> b -> s) -> Optional s s a b+optional' prj = optional (\ s -> maybe (Left s) Right (prj s))+++-- Elimination++matching :: Optional s t a b -> (s -> Either t a)+matching o = withOptional o const++matching' :: Optional s t a b -> (s -> Maybe a)+matching' o = withOptional o (\ prj _ -> either (const Nothing) Just . prj)++withOptional :: Optional s t a b -> (((s -> Either t a) -> (s -> b -> t) -> r) -> r)+withOptional o = withUnpackedOptional (o (unpackedOptional Right (const id)))++traverseOf :: Functor f => Optional s t a b -> (forall r . r -> f r) -> (a -> f b) -> (s -> f t)+traverseOf o point = runOptionalStar . o . optionalStar point++is :: Optional s t a b -> (s -> Bool)+is o = isJust . matching' o++isn't :: Optional s t a b -> (s -> Bool)+isn't o = isNothing . matching' o+++-- Unpacked++newtype UnpackedOptional a b s t = UnpackedOptional { withUnpackedOptional :: forall r . ((s -> Either t a) -> (s -> b -> t) -> r) -> r }++instance Profunctor (UnpackedOptional a b) where+  dimap f g (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (Left . g) Right . prj . f) (rmap g . set . f)++instance Strong (UnpackedOptional a b) where+  first'  (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (\ (a, c) -> first (,c) (prj a)) (\ (a, c) b -> (set a b, c))+  second' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (\ (c, a) -> first (c,) (prj a)) (\ (c, a) b -> (c, set a b))++instance Choice (UnpackedOptional a b) where+  left' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (either (Left . Left) Right . prj) (Left . Right)) (\ e b -> first (`set` b) e)+  right' (UnpackedOptional r) = r $ \ prj set -> unpackedOptional (either (Left . Left) (either (Left . Right) Right . prj)) (\ e b -> fmap (`set` b) e)++instance IsIso (UnpackedOptional a b)+instance IsLens (UnpackedOptional a b)+instance IsPrism (UnpackedOptional a b)+instance IsOptional (UnpackedOptional a b)+++unpackedOptional :: (s -> Either t a) -> (s -> b -> t) -> UnpackedOptional a b s t+unpackedOptional prj set = UnpackedOptional (\ k -> k prj set)

@@ -0,0 +1,17 @@+module Fresnel.Optional.Internal+( IsOptional+) where++import Control.Arrow (Kleisli)+import Data.Profunctor (Forget, Star)+import Fresnel.Lens.Internal (IsLens)+import Fresnel.Prism.Internal (IsPrism)+import Fresnel.Profunctor.OptionalStar (OptionalStar)++class (IsLens p, IsPrism p) => IsOptional p where++instance IsOptional (->)+instance Monad m => IsOptional (Kleisli m)+instance Monoid r => IsOptional (Forget r)+instance Applicative f => IsOptional (Star f)+instance Functor f => IsOptional (OptionalStar f)

@@ -0,0 +1,54 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.OptionalFold+( -- * Optional folds+  OptionalFold+, IsOptionalFold+  -- * Construction+, folding+, filtered+  -- * Elimination+, is+, isn't+, traverseOf_+, Failover(..)+) where++import Control.Applicative ((<|>))+import Data.Functor (void)+import Data.Maybe (isJust, isNothing)+import Data.Profunctor+import Fresnel.Bifunctor.Contravariant+import Fresnel.Fold (preview)+import Fresnel.Optic+import Fresnel.OptionalFold.Internal++-- Optional folds++type OptionalFold s a = forall p . IsOptionalFold p => Optic' p s a+++-- Construction++folding :: (s -> Maybe a) -> OptionalFold s a+folding f = contrabimap ((`maybe` Right) . Left <*> f) Left . right'++filtered :: (a -> Bool) -> OptionalFold a a+filtered p = folding (\ a -> if p a then Just a else Nothing)+++-- Elimination++is :: OptionalFold s a -> (s -> Bool)+is o = isNothing . preview o++isn't :: OptionalFold s a -> (s -> Bool)+isn't o = isJust . preview o++traverseOf_ :: Functor f => OptionalFold s a -> ((forall x . x -> f x) -> (a -> f u) -> (s -> f ()))+traverseOf_ o point f s = maybe (point ()) (void . f) (preview o s)+++newtype Failover s a = Failover { getFailover :: OptionalFold s a }++instance Semigroup (Failover s a) where+  Failover a1 <> Failover a2 = Failover (folding (\ s -> preview a1 s <|> preview a2 s))

@@ -0,0 +1,15 @@+module Fresnel.OptionalFold.Internal+( IsOptionalFold+) where++import Data.Functor.Contravariant+import Data.Profunctor+import Fresnel.Getter.Internal (IsGetter)+import Fresnel.Optional.Internal (IsOptional)+import Fresnel.Profunctor.OptionalStar (OptionalStar)++class (IsOptional p, IsGetter p) => IsOptionalFold p++instance Monoid r => IsOptionalFold (Forget r)+instance (Applicative f, Traversable f, Contravariant f) => IsOptionalFold (Star f)+instance (Traversable f, Contravariant f) => IsOptionalFold (OptionalStar f)

@@ -0,0 +1,99 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Fresnel.Prism+( -- * Prisms+  Prism+, Prism'+, IsPrism+  -- * Construction+, prism+, prism'+  -- * Elimination+, withPrism+, matching+, matching'+, is+, isn't+  -- * Relations+, only+, nearly+  -- * Combinators+, without+, below+, aside+  -- * Unpacked+, UnpackedPrism(..)+, unpackedPrism+) where++import Control.Monad (guard)+import Data.Bifunctor (Bifunctor(..))+import Data.Profunctor+import Fresnel.Iso.Internal (IsIso)+import Fresnel.Optic+import Fresnel.Optional (is, isn't, matching, matching')+import Fresnel.Prism.Internal (IsPrism)++-- Prisms++type Prism s t a b = forall p . IsPrism p => Optic p s t a b++type Prism' s a = Prism s s a a+++-- Construction++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism inj prj = dimap prj (either id inj) . right'++prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b+prism' inj prj = prism inj (\ s -> maybe (Left s) Right (prj s))+++-- Elimination++withPrism :: Prism s t a b -> (((b -> t) -> (s -> Either t a) -> r) -> r)+withPrism o = withUnpackedPrism (o (unpackedPrism id Right))+++-- Relations++only :: Eq a => a -> Prism' a ()+only a = nearly a (a ==)++nearly :: a -> (a -> Bool) -> Prism' a ()+nearly a p = prism' (const a) (guard . p)+++-- Combinators++without :: Prism s1 t1 a1 b1 -> Prism s2 t2 a2 b2 -> Prism (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)+without o1 o2 = withPrism o1 $ \ inj1 prj1 -> withPrism o2 $ \ inj2 prj2 ->+  prism (bimap inj1 inj2) (either (bimap Left Left . prj1) (bimap Right Right . prj2))++below :: Traversable f => Prism' s a -> Prism' (f s) (f a)+below o = withPrism o $ \ inj prj -> prism (fmap inj) $ \ s -> first (const s) (traverse prj s)++aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)+aside o = withPrism o $ \ inj prj -> prism (fmap inj) $ \ (e, s) -> bimap (e,) (e,) (prj s)+++-- Unpacked++newtype UnpackedPrism a b s t = UnpackedPrism { withUnpackedPrism :: forall r . ((b -> t) -> (s -> Either t a) -> r) -> r }++instance Functor (UnpackedPrism a b s) where+  fmap = rmap++instance Profunctor (UnpackedPrism a b) where+  dimap f g (UnpackedPrism r) = r $ \ inj prj -> unpackedPrism (g . inj) (either (Left . g) Right . prj . f)++instance Choice (UnpackedPrism a b) where+  left' (UnpackedPrism r) = r $ \ inj prj -> unpackedPrism (Left . inj) (either (either (Left . Left) Right . prj) (Left . Right))++instance IsIso (UnpackedPrism a b)+instance IsPrism (UnpackedPrism a b)+++unpackedPrism :: (b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t+unpackedPrism inj prj = UnpackedPrism (\ k -> k inj prj)

@@ -0,0 +1,18 @@+module Fresnel.Prism.Internal+( IsPrism+) where++import Control.Arrow (Kleisli)+import Data.Profunctor (Choice, Forget, Star)+import Fresnel.Iso.Internal+import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Recall (Recall)++class (IsIso p, Choice p) => IsPrism p++instance IsPrism (->)+instance Monad m => IsPrism (Kleisli m)+instance Monoid r => IsPrism (Forget r)+instance IsPrism (Recall e)+instance Applicative f => IsPrism (Star f)+instance Functor f => IsPrism (OptionalStar f)

@@ -0,0 +1,55 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+module Fresnel.Profunctor.Coexp+( -- * Coexponential profunctor+  Coexp(..)+  -- * Construction+, coexp+  -- * Elimination+, recall+, forget+) where++import Data.Profunctor+import Data.Profunctor.Unsafe+import Data.Coerce++-- Coexponential++-- | Coexponentials are the dual of functions, consisting of an argument of type @a@ (derived within an environment of type @s@) and a continuation from the return type @b@ (extending to the eventual result type @t@). As such, they naturally have the shape of optics, relating the outer context @s -> t@ to the inner @a -> b@.+newtype Coexp s t b a = Coexp { withCoexp :: forall r . ((s -> a) -> (b -> t) -> r) -> r }++instance Functor (Coexp s t b) where+  fmap = rmap++instance Monoid t => Applicative (Coexp s t b) where+  pure a = coexp (pure a) mempty+  f <*> a = withCoexp f $ \ f kf -> withCoexp a $ \ a ka -> coexp (f <*> a) (mappend <$> kf <*> ka)++instance Profunctor (Coexp s t) where+  dimap f g c = withCoexp c $ \ recall forget -> coexp (g . recall) (forget . f)+  lmap f c = withCoexp c $ \ recall forget -> coexp recall (forget . f)+  rmap g c = withCoexp c $ \ recall forget -> coexp (g . recall) forget+  (#.) = const coerce+  (.#) = fmap coerce . const++instance Semigroup (Coexp a b b a) where+  c1 <> c2 = withCoexp c1 $ \ r1 f1 -> withCoexp c2 $ \ r2 f2 -> coexp (r2 . r1) (f1 . f2)++instance Monoid (Coexp a b b a) where+  mempty = coexp id id+++-- Construction++coexp :: (s -> a) -> (b -> t) -> Coexp s t b a+coexp recall forget = Coexp (\ k -> k recall forget)+++-- Elimination++recall :: Coexp s t b a -> (s -> a)+recall c = withCoexp c const++forget :: Coexp s t b a -> (b -> t)+forget c = withCoexp c (const id)

@@ -0,0 +1,60 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Fresnel.Profunctor.OptionalStar+( -- * Optional star profunctors+  OptionalStar(..)+  -- * Construction+, optionalStar+  -- * Elimination+, runOptionalStar+  -- * Computation+, mapOptionalStar+) where++import Data.Coerce+import Data.Functor.Contravariant+import Data.Profunctor+import Data.Profunctor.Unsafe+import Fresnel.Bifunctor.Contravariant++-- Optional star profunctors++newtype OptionalStar f a b = OptionalStar { withOptionalStar :: forall r . ((forall x . x -> f x) -> (a -> f b) -> r) -> r }++instance Functor f => Profunctor (OptionalStar f) where+  dimap f g = mapOptionalStar (dimap f (fmap g))+  lmap f = mapOptionalStar (lmap f)+  rmap g = mapOptionalStar (rmap (fmap g))+  (.#) = fmap coerce . const++instance Functor f => Choice (OptionalStar f) where+  left'  (OptionalStar r) = OptionalStar (\ k -> r (\ point f -> k point (either (fmap Left . f) (fmap Right . point))))+  right' (OptionalStar r) = OptionalStar (\ k -> r (\ point f -> k point (either (fmap Left . point) (fmap Right . f))))++instance Traversable f => Cochoice (OptionalStar f) where+  unright r = withOptionalStar r $ \ point f -> let go = either (go . Left) id . sequenceA . f in optionalStar point (go . Right)++instance Functor f => Strong (OptionalStar f) where+  first'  = mapOptionalStar (\ f (a, c) -> (,c) <$> f a)+  second' = mapOptionalStar (\ f (c, a) -> (c,) <$> f a)++instance Contravariant f => Bicontravariant (OptionalStar f) where+  contrabimap f g = mapOptionalStar (\ h -> contramap g . h . f)+++-- Construction++optionalStar :: (forall x . x -> f x) -> (a -> f b) -> OptionalStar f a b+optionalStar point f = OptionalStar (\ k -> k point f)+++-- Elimination++runOptionalStar :: OptionalStar f a b -> (a -> f b)+runOptionalStar a = withOptionalStar a (\ _ f -> f)+++-- Computation++mapOptionalStar :: ((a -> f b) -> (c -> f d)) -> (OptionalStar f a b -> OptionalStar f c d)+mapOptionalStar f (OptionalStar r) = OptionalStar (\ k -> r (\ point -> k point . f))

@@ -0,0 +1,54 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Fresnel.Profunctor.Recall+( -- * Recall profunctor+  Recall(..)+) where++import Data.Bifunctor+import Data.Coerce+import Data.Functor.Const+import Data.Profunctor+import Data.Profunctor.Rep as Pro+import Data.Profunctor.Sieve+import Data.Profunctor.Unsafe++-- Recall profunctor++-- | @'Recall' e@ is dual to @'Forget' r@: it ignores the argument parameter, substituting in one of its own.+newtype Recall e a b = Recall { runRecall :: e -> b }+  deriving (Applicative, Functor, Monad, Monoid, Semigroup)++instance Bifunctor (Recall e) where+  bimap _ g = Recall . fmap g . runRecall+  second = fmap++instance Profunctor (Recall e) where+  dimap _ g = Recall . fmap g . runRecall+  lmap = const coerce+  rmap = fmap+  (#.) = const coerce+  (.#) = fmap coerce . const++instance Choice (Recall e) where+  left'  = Recall . fmap Left  . runRecall+  right' = Recall . fmap Right . runRecall++instance Closed (Recall e) where+  closed = Recall . fmap const . runRecall++instance Costrong (Recall e) where+  unfirst  = Recall . fmap fst . runRecall+  unsecond = Recall . fmap snd . runRecall++instance Sieve (Recall e) ((->) e) where+  sieve = const . runRecall++instance Cosieve (Recall e) (Const e) where+  cosieve = lmap getConst . runRecall++instance Pro.Corepresentable (Recall e) where+  type Corep (Recall e) = Const e++  cotabulate = Recall . lmap Const

@@ -0,0 +1,72 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Review+( -- * Reviews+  Review+, IsReview+  -- * Construction+, unto+, reviewing+, un+  -- * Elimination+, reviews+, review+, (#)+, re+  -- * Utilities+, lphantom+) where++import Data.Bifunctor+import Data.Profunctor+import Data.Profunctor.Unsafe ((#.), (.#))+import Data.Void+import Fresnel.Getter (Getter, to, view)+import Fresnel.Optic+import Fresnel.Prism.Internal (IsPrism)+import Fresnel.Profunctor.Recall++-- Reviews++type Review t b = forall p . IsReview p => Optic' p t b++class (IsPrism p, Bifunctor p, Costrong p) => IsReview p++instance IsReview (Recall e)+++-- Construction++unto :: (b -> t) -> Review t b+unto f = lphantom . rmap f+++reviewing :: (Profunctor p, Bifunctor p) => Optic p s t a b -> Optic' p t b+reviewing l f = lphantom . l $ lphantom f+++un :: Getter s a -> Review a s+un o = unto (view o)+++-- Elimination++reviews :: Review t b -> (e -> b) -> (e -> t)+reviews b = runRecall #. b .# Recall++review :: Review t b -> (b -> t)+review b = reviews b id++(#) :: Review t b -> (b -> t)+(#) = review++infixr 8 #+++re :: Review t b -> Getter b t+re o = to (review o)+++-- Utilities++lphantom :: (Bifunctor p, Profunctor p) => p b c -> p a c+lphantom = first absurd . lmap absurd

@@ -0,0 +1,15 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Set+( setmapped+, setOf+) where++import Data.Set as Set+import Fresnel.Fold+import Fresnel.Setter++setmapped :: Ord b => Setter (Set a) (Set b) a b+setmapped = sets Set.map++setOf :: Ord a => Fold s a -> (s -> Set.Set a)+setOf o = Set.fromList . toListOf o

@@ -0,0 +1,97 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Setter+( -- * Setters+  Setter+, Setter'+, IsSetter+  -- * Construction+, sets+, mapped+, contramapped+  -- * Elimination+, over+, (%~)+, set+, (.~)+, (+~)+, (-~)+, (*~)+, (/~)+, (^~)+, (^^~)+, (**~)+) where++import Data.Functor.Contravariant+import Data.Profunctor.Mapping+import Fresnel.Optic+import Fresnel.Traversal.Internal (IsTraversal)++-- Setters++type Setter s t a b = forall p . IsSetter p => Optic p s t a b++type Setter' s a = Setter s s a a++class (IsTraversal p, Mapping p) => IsSetter p++instance IsSetter (->)+++-- Construction++sets :: ((a -> b) -> (s -> t)) -> Setter s t a b+sets f = (f `roam`) -- written thus to placate hlint+++mapped :: Functor f => Setter (f a) (f b) a b+mapped = sets fmap++contramapped :: Contravariant f => Setter (f a) (f b) b a+contramapped = sets contramap+++-- Elimination++over, (%~) :: Setter s t a b -> (a -> b) -> (s -> t)+over o = o++(%~) = over++infixr 4 %~+++set, (.~) :: Setter s t a b -> b -> s -> t+set o = over o . const++(.~) = set++infixr 4 .~+++(+~), (-~), (*~) :: Num a => Setter s t a a -> a -> s -> t+o +~ a = over o (+ a)+o -~ a = over o (subtract a)+o *~ a = over o (* a)++infixr 4 +~, -~, *~++(/~) :: Fractional a => Setter s t a a -> a -> s -> t+o /~ a = over o (/ a)++infixr 4 /~++(^~) :: (Num a, Integral b) => Setter s t a a -> b -> s -> t+o ^~ a = over o (^ a)++infixr 4 ^~++(^^~) :: (Fractional a, Integral b) => Setter s t a a -> b -> s -> t+o ^^~ a = over o (^^ a)++infixr 4 ^^~++(**~) :: Floating a => Setter s t a a -> a -> s -> t+o **~ a = over o (** a)++infixr 4 **~

@@ -0,0 +1,78 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Traversal+( -- * Traversals+  Traversal+, Traversal'+, IsTraversal+  -- * Construction+, traversed+, backwards+  -- * Elimination+, traverseOf+, forOf+, sequenceOf+, transposeOf+, mapAccumLOf+, mapAccumROf+, scanl1Of+, scanr1Of+) where++import Control.Applicative (ZipList(..))+import Control.Monad.Trans.State+import Data.Profunctor+import Data.Profunctor.Traversing (Traversing(..))+import Data.Profunctor.Unsafe ((#.))+import Fresnel.Functor.Backwards+import Fresnel.Optic+import Fresnel.Traversal.Internal (IsTraversal)++-- Traversals++type Traversal s t a b = forall p . IsTraversal p => Optic p s t a b++type Traversal' s a = Traversal s s a a+++-- Construction++traversed :: Traversable t => Traversal (t a) (t b) a b+traversed = wander traverse++backwards :: Traversal s t a b -> Traversal s t a b+backwards o = wander (\ f -> forwards . traverseOf o (Backwards . f))+++-- Elimination++traverseOf :: Applicative f => Traversal s t a b -> ((a -> f b) -> (s -> f t))+traverseOf o = runStar . o . Star++forOf :: Applicative f => Traversal s t a b -> (s -> (a -> f b) -> f t)+forOf o = flip (traverseOf o)++sequenceOf :: Applicative f => Traversal s t (f b) b -> (s -> f t)+sequenceOf o = traverseOf o id++transposeOf :: Traversal s t [a] a -> s -> [t]+transposeOf o = getZipList #. traverseOf o ZipList++mapAccumLOf :: Traversal s t a b -> (accum -> a -> (b, accum)) -> accum -> s -> (t, accum)+mapAccumLOf o f z s =+  let g a = state $ \ accum -> f accum a+  in runState (traverseOf o g s) z++mapAccumROf :: Traversal s t a b -> (accum -> a -> (b, accum)) -> accum -> s -> (t, accum)+mapAccumROf o = mapAccumLOf (backwards o)++scanl1Of :: Traversal s t a a -> (a -> a -> a) -> s -> t+scanl1Of o f =+  let step Nothing  a = (a, Just a)+      step (Just s) a = let r = f s a in (r, Just r)+  in fst . mapAccumLOf o step Nothing++scanr1Of :: Traversal s t a a -> (a -> a -> a) -> s -> t+scanr1Of o f =+  let step Nothing  a = (a, Just a)+      step (Just s) a = let r = f s a in (r, Just r)+  in fst . mapAccumROf o step Nothing

@@ -0,0 +1,15 @@+module Fresnel.Traversal.Internal+( IsTraversal+) where++import Control.Arrow (Kleisli)+import Data.Profunctor (Forget, Star)+import Data.Profunctor.Traversing (Traversing)+import Fresnel.Optional.Internal (IsOptional)++class (IsOptional p, Traversing p) => IsTraversal p++instance IsTraversal (->)+instance Monad m => IsTraversal (Kleisli m)+instance Monoid r => IsTraversal (Forget r)+instance Applicative f => IsTraversal (Star f)

@@ -0,0 +1,15 @@+module Fresnel.Tuple+( -- * Lenses+  fst_+, snd_+) where++import Fresnel.Lens++-- Lenses++fst_ :: Lens (a, b) (a', b) a a'+fst_ = lens fst (\ s a' -> (a', snd s))++snd_ :: Lens (a, b) (a, b') b b'+snd_ = lens snd (\ s b' -> (fst s, b'))

@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Fold.Test+( tests+) where++import Fresnel.Fold+import Fresnel.Ixed+import Test.Group+import Test.QuickCheck++prop_union_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property+prop_union_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getUnion (Union a <> (Union b <> Union c))) as === toListOf (getUnion ((Union a <> Union b) <> Union c)) as++prop_union_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property+prop_union_monoid_identity (ArbFold a) as =+  classifyList as $+  toListOf (getUnion (mempty <> Union a)) as === toListOf a as .&&. toListOf (getUnion (Union a <> mempty)) as === toListOf a as+++prop_failover_semigroup_assoc :: (Eq a, Show a) => ArbFold a -> ArbFold a -> ArbFold a -> [a] -> Property+prop_failover_semigroup_assoc (ArbFold a) (ArbFold b) (ArbFold c) as = classifyList as $ toListOf (getFailover (Failover a <> (Failover b <> Failover c))) as === toListOf (getFailover ((Failover a <> Failover b) <> Failover c)) as++prop_failover_monoid_identity :: (Eq a, Show a) => ArbFold a -> [a] -> Property+prop_failover_monoid_identity (ArbFold a) as = classifyList as $ toListOf (getFailover (mempty <> Failover a)) as === toListOf a as .&&. toListOf (getFailover (Failover a <> mempty)) as === toListOf a as+++classifyList :: Testable prop => [a] -> prop -> Property+classifyList as = classify (null as) "empty" . classify (length as == 1) "singleton"+++newtype ArbFold a = ArbFold (Fold [a] a)++instance Show a => Show (ArbFold a) where+  showsPrec _ (ArbFold fold) = showList (toListOf fold []) -- FIXME: this is a bad instance++instance Arbitrary a => Arbitrary (ArbFold a) where+  arbitrary = oneof+    [ pure (ArbFold folded)+    , pure (ArbFold ignored)+    , ixed <$> arbitrary+    ]+    where+    ixed :: Int -> ArbFold a+    ixed i = ArbFold (ix i)+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,16 @@+module Fresnel.Tropical+( finite+, Tropical(..)+) where++finite :: a -> Tropical a+finite = Tropical . Just++newtype Tropical a = Tropical { getTropical :: Maybe a }+  deriving (Eq, Ord, Show)++instance Ord a => Semigroup (Tropical a) where+  (<>) = max++instance Ord a => Monoid (Tropical a) where+  mempty = Tropical Nothing

@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Getter.Test+( tests+) where++import Fresnel.Getter+import Test.Group+import Test.QuickCheck++prop_view_to_involution f x = view (to (applyFun f)) x === applyFun f x+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,43 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+module Iso.Test+( validIso+, invalidIso+, withRoundtrips+, tests+) where++import Fresnel.Getter+import Fresnel.Iso+import Fresnel.Review+import Test.Group+import Test.QuickCheck++validIso :: (Eq a, Show a, Eq s, Show s) => Iso' s a -> s -> a -> Property+validIso o s a = withRoundtrips o $ \ ss aa -> ss s === s .&&. aa a === a++invalidIso :: (Eq a, Show a, Eq s, Show s) => Iso' s a -> s -> a -> Property+invalidIso o s a = withRoundtrips o $ \ ss aa -> ss s =/= s .||. aa a =/= a++withRoundtrips :: Iso' s a -> (((s -> s) -> (a -> a) -> r) -> r)+withRoundtrips o k = withIso o (\ f g -> k (g . f) (f . g))+++prop_view_elimination f g x = view (iso (applyFun f) (applyFun g)) x === applyFun f x++prop_review_elimination f g x = review (iso (applyFun f) (applyFun g)) x === applyFun g x+++prop_constant_validity c s a = withRoundtrips (constant c) $ \ sasa aa ->+  sasa (const a) s === const a s .&&. aa a === a+++prop_involuted_validity = validIso (involuted not)++prop_involuted_invalidity = invalidIso (involuted (+ (1 :: Integer)))+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,71 @@+{-# LANGUAGE TemplateHaskell #-}+module Monoid.Fork.Test+( tests+) where++import Data.Foldable (toList)+import Data.Ratio+import Fresnel.Monoid.Fork (Fork(runFork), singleton)+import Test.Group+import Test.QuickCheck hiding (total)++prop_semigroup_assoc :: (Eq a, Show a) => ArbFork a -> ArbFork a -> ArbFork a -> Property+prop_semigroup_assoc (ArbFork a) (ArbFork b) (ArbFork c) =+  label (summarize a) . label (summarize b) . label (summarize c) $+  (toList (a <> (b <> c)) === toList ((a <> b) <> c))++prop_monoid_identity :: (Eq a, Show a) => ArbFork a -> Property+prop_monoid_identity (ArbFork a) = label (summarize a) $ toList (mempty <> a) === toList a .&&. toList (a <> mempty) === toList a+++newtype ArbFork a = ArbFork (Fork a)+  deriving (Show)++instance Arbitrary a => Arbitrary (ArbFork a) where+  arbitrary = ArbFork <$> sized go where+    go 0 = pure mempty+    go i = oneof+      [ chooseInt (0, i) >>= \ j -> (<>) <$> go (i - j) <*> go j+      , singleton <$> arbitrary+      , pure mempty+      ]+++summarize :: Fork a -> String+summarize r+  | total' == nils     = "nil"+  | ratio nils > 0.4   = "nil-heavy"+  | total' == leaves   = "leaf"+  | ratio leaves > 0.4 = "leaf-heavy"+  | ratio forks > 0.4  = "fork-heavy"+  | otherwise          = "fork"+  where+  (total', Counts forks leaves nils) = (,) . total <*> id $ runFork r (\ l r -> fork <> l <> r) (const leaf) nil+  ratio a = realToFrac  (a % total') :: Double++data Counts = Counts+  { forks  :: {-# UNPACK #-} !Int+  , leaves :: {-# UNPACK #-} !Int+  , nils   :: {-# UNPACK #-} !Int+  }++instance Semigroup Counts where+  c1 <> c2 = Counts (forks c1 + forks c2) (leaves c1 + leaves c2) (nils c1 + nils c2)++fork :: Counts+fork = Counts 1 0 0++leaf :: Counts+leaf = Counts 0 1 0++nil :: Counts+nil = Counts 0 0 1++total :: Counts -> Int+total (Counts f l n) = f + l + n+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,34 @@+{-# LANGUAGE TemplateHaskell #-}+module Profunctor.Coexp.Test+( tests+) where++import Fresnel.Profunctor.Coexp+import Test.Group+import Test.QuickCheck++prop_semigroup_assoc :: (Eq b, Eq a, Show b, Show a) => ArbCoexp b a a b -> ArbCoexp b a a b -> ArbCoexp b a a b -> b -> a -> Property+prop_semigroup_assoc a b c x y =+  appCoexp (toCoexp a <> (toCoexp b <> toCoexp c)) x y === appCoexp ((toCoexp a <> toCoexp b) <> toCoexp c) x y++prop_monoid_identity :: (Eq b, Show b) => ArbCoexp b a a b -> b -> Property+prop_monoid_identity a x = recall (mempty <> toCoexp a) x === recall (toCoexp a) x .&&. recall (toCoexp a <> mempty) x === recall (toCoexp a) x+++data ArbCoexp e r a b = ArbCoexp (Fun e b) (Fun a r)+  deriving (Show)++instance (Function e, Function a, CoArbitrary e, CoArbitrary a, Arbitrary b, Arbitrary r) => Arbitrary (ArbCoexp e r a b) where+  arbitrary = ArbCoexp <$> arbitrary <*> arbitrary++toCoexp :: ArbCoexp e r a b -> Coexp e r a b+toCoexp (ArbCoexp eb ar) = coexp (applyFun eb) (applyFun ar)++appCoexp :: Coexp e r a b -> e -> a -> (b, r)+appCoexp c e a = withCoexp c $ \ recall forget -> (recall e, forget a)+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell #-}+module Review.Test+( tests+) where+import Fresnel.Review+import Test.Group+import Test.QuickCheck++prop_review_unto_involution f x = review (unto (applyFun f)) x === applyFun f x+++pure []++tests :: Entry+tests = $deriveGroup

@@ -0,0 +1,35 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+module Main+( main+) where++import qualified Fold.Test+import qualified Getter.Test+import qualified Iso.Test+import qualified Monoid.Fork.Test+import qualified Profunctor.Coexp.Test+import qualified Review.Test+import           System.Environment (getArgs)+import           Test.Group+import           Test.Options+import           Test.Run+import qualified Tropical.Test++main :: IO ()+main = getArgs >>= withOptions defaultOpts (runEntries tests)++tests :: [Entry]+tests =+  [ Fold.Test.tests+  , Getter.Test.tests+  , Iso.Test.tests+  , Monoid.Fork.Test.tests+  , Profunctor.Coexp.Test.tests+  , Review.Test.tests+  , Tropical.Test.tests+  ]

@@ -0,0 +1,166 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+module Test.Group+( Entry(..)+, mkGroup+, deriveGroup+, mkProp+, entryName+, Loc(..)+, here+, zero+, Semiring(..)+, Unital(..)+, horizontal+, sumWidths+, vertical+, maxWidths+, Width(..)+, HasWidth(..)+  -- * Statuses+, stat+, Status(..)+  -- * Tallies+, hasFailures+, hasSuccesses+, unit+, Tally(..)+) where++import Data.Char (isSpace)+import Fresnel.Tropical+import GHC.Stack+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax (Module(..), modString)+import Numeric (readDec)+import Test.QuickCheck (Property, allProperties)++data Entry+  = Group String [Entry]+  | Prop String Loc Property++mkGroup :: String -> [(String, Property)] -> Entry+mkGroup name = Group name . map (uncurry mkProp)++deriveGroup :: ExpQ+deriveGroup = [e| mkGroup $(thisModule >>= \ (Module _ name) -> stringE (modString name)) $allProperties |]++mkProp :: String -> Property -> Entry+mkProp s = Prop name Loc{ path, lineNumber }+  where+  (name, path, lineNumber) = case breaks [isSpace, not . isSpace, isSpace, not . isSpace, (== ':'), (/= ':')] s of+    [n, _, _, _, p, _, l] -> (unwords (filter (\ s -> s /= "_" && s /= "prop") (breakAll (== '_') n)), p, fst (head (readDec l)))+    _                     -> ("", "", 0)++entryName :: Entry -> String+entryName = \case+  Group name _  -> name+  Prop name _ _ -> name+++data Loc = Loc { path :: FilePath, lineNumber :: Int }++here :: HasCallStack => Loc+here = Loc{ path = srcLocFile srcLoc, lineNumber = srcLocStartLine srcLoc }+  where+  (_, srcLoc) = head (getCallStack callStack)+++breaks :: [a -> Bool] -> [a] -> [[a]]+breaks ps as = case ps of+  []   -> [as]+  p:ps -> let (h, t) = break p as in h : breaks ps t++breakAll :: (a -> Bool) -> [a] -> [[a]]+breakAll p = go False where+  go b = \case+    [] -> []+    as -> let (h, t) = break (if b then not . p else p) as in h : go (not b) t+++zero :: Monoid s => s+zero = mempty++class Semigroup s => Semiring s where+  (><) :: s -> s -> s+  infixr 7 ><++instance (Semigroup a, Ord a) => Semiring (Tropical a) where+  Tropical a1 >< Tropical a2 = Tropical ((<>) <$> a1 <*> a2)++class (Monoid s, Semiring s) => Unital s where+  one :: s++instance (Monoid a, Ord a) => Unital (Tropical a) where+  one = finite zero+++horizontal :: (Foldable t, Unital r) => (a -> r) -> t a -> r+horizontal f = foldr ((><) . f) one++sumWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width+sumWidths = horizontal maxWidth++vertical :: (Foldable t, Semiring r, Monoid r) => (a -> r) -> t a -> r+vertical f = foldr ((<>) . f) zero++maxWidths :: (Foldable t, HasWidth a) => t a -> Tropical Width+maxWidths = vertical maxWidth++newtype Width = Width { width :: Int }+  deriving (Eq, Ord)++instance Semigroup Width where+  Width a1 <> Width a2 = Width (a1 + a2)++instance Monoid Width where+  mempty = Width 0++instance Semiring Width where+  Width a1 >< Width a2 = Width (a1 * a2)++instance Unital Width where+  one = Width 1+++class HasWidth t where+  maxWidth :: t -> Tropical Width++instance HasWidth Char where+  maxWidth _ = finite one++instance HasWidth Entry where+  maxWidth = \case+    Group groupName entries -> sumWidths groupName <> maxWidths entries+    Prop name _ _           -> sumWidths name+++-- Statuses++stat :: a -> a -> Status -> a+stat pass fail = \case{ Pass -> pass ; Fail -> fail }++data Status = Pass | Fail+  deriving (Eq)+++-- Tallies++hasSuccesses :: Tally -> Bool+hasSuccesses = (/= 0) . successes++hasFailures :: Tally -> Bool+hasFailures = (/= 0) . failures++unit :: Status -> Tally+unit = stat (Tally 1 0) (Tally 0 1)++data Tally = Tally { successes :: Int, failures :: Int }++instance Semigroup Tally where+  Tally s1 f1 <> Tally s2 f2 = Tally (s1 + s2) (f1 + f2)++instance Monoid Tally where+  mempty = Tally 0 0

@@ -0,0 +1,103 @@+{-# LANGUAGE NamedFieldPuns #-}+module Test.Options+( -- * Options+  Options(..)+, defaultOptions+, entries_+, args_+  -- * Args optics+, maxSuccess_+, maxSize_+, maxShrinks_+, replay_+  -- * CLI options+, parseOpts+, defaultOpts+, printErrors+, header+, withOptions+) where++import Control.Monad ((<=<))+import Data.Bool (bool)+import Data.Foldable (traverse_)+import Data.List (intercalate)+import Fresnel.Lens (Lens', lens)+import Fresnel.Setter (set, (%~))+import Numeric (readDec)+import System.Console.GetOpt+import System.Environment (getProgName)+import System.Exit (exitFailure, exitSuccess)+import System.IO (hPutStrLn, stderr)+import Test.QuickCheck (Args(..), stdArgs)+import Test.QuickCheck.Random (QCGen)++-- Options++data Options = Options+  { entries :: [String]+  , args    :: Args+  }++defaultOptions :: Options+defaultOptions = Options{ entries = [], args = stdArgs{ maxSuccess = 250, chatty = False }}++entries_ :: Lens' Options [String]+entries_ = lens entries (\ o entries -> o{ entries })++args_ :: Lens' Options Args+args_ = lens args (\ o args -> o{ args })+++-- Args optics++maxSuccess_ :: Lens' Args Int+maxSuccess_ = lens maxSuccess (\ a maxSuccess -> a{ maxSuccess })++maxSize_ :: Lens' Args Int+maxSize_ = lens maxSize (\ a maxSize -> a{ maxSize })++maxShrinks_ :: Lens' Args Int+maxShrinks_ = lens maxShrinks (\ a maxShrinks -> a{ maxShrinks })++replay_ :: Lens' Args (Maybe (QCGen, Int))+replay_ = lens replay (\ a replay -> a{ replay })+++-- CLI options++parseOpts :: [OptDescr (Options -> Options)] -> [String] -> Either [String] Options+parseOpts opts args+  | null other+  , null errs = Right options+  | otherwise = Left (map ("Unrecognized argument: " ++) other ++ errs)+  where+  options = foldr ($) defaultOptions mods+  (mods, other, errs) = getOpt RequireOrder opts args++defaultOpts :: [OptDescr (Options -> Options)]+defaultOpts =+  [ Option "n" ["successes"] (ReqArg (set (args_.maxSuccess_)    . int)  "N")    "require N successful tests before concluding the property passes"+  , Option "z" ["size"]      (ReqArg (set (args_.maxSize_)       . int)  "N")    "increase the size parameter to a maximum of N for successive tests of a property"+  , Option "s" ["shrinks"]   (ReqArg (set (args_.maxShrinks_)    . int)  "N")    "perform a maximum of N shrinks; setting this to 0 disables shrinking"+  , Option "m" ["match"]     (ReqArg (\ s -> entries_ %~ (s:))           "NAME") "include the named group or property; can be used multiple times to include multiple groups/properties"+  , Option "r" ["replay"]    (ReqArg (set (args_.replay_) . Just . read) "SEED") "the seed and size to repeat"+  ]+  where+  int = fst . head . readDec++printErrors :: [OptDescr a] -> [String] -> IO Bool+printErrors opts errs = do+  name <- getProgName+  False <$ traverse_ (hPutStrLn stderr) (errs ++ [usageInfo (header name opts) opts])++header :: String -> [OptDescr a] -> String+header name opts = "Usage: " ++ name ++ " " ++ unwords (map opt opts) where+  opt (Option short long a _) = bracket (intercalate "|" ([ arg a ['-',c] | c <- short ] ++ map (arg a . ("--"++)) long))+  arg (NoArg _)    = id+  arg (ReqArg _ s) = (++ " " ++ s)+  arg (OptArg _ s) = (++ bracket s)+  bracket s = "[" ++ s ++ "]"++withOptions :: [OptDescr (Options -> Options)] -> (Options -> IO Bool) -> [String] -> IO ()+withOptions opts f = bool exitFailure exitSuccess <=< either (printErrors opts) f . parseOpts opts

@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+module Test.Print+( withSGR+, success+, failure+, failure'+, sparkify+, topIndent+, withHandle+, line+, section+, space+, bullet+, heading1+, headingN+, arrow+, vline+, hline+, gtally+, end+, nl+, putS+, sepBy_+) where++import Control.Effect.Reader+import Control.Effect.State+import Control.Monad (join, when)+import Control.Monad.IO.Class+import Data.Bool (bool)+import Data.List (intersperse)+import Data.Monoid (Ap(..))+import Fresnel.Maybe (_Just)+import Fresnel.Optional (is)+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), hSetSGR)+import System.IO (Handle, hPutStr, hPutStrLn)+import Test.Group++withSGR :: (Has (Reader Handle) sig m, MonadIO m) => [SGR] -> m a -> m a+withSGR sgr m = withHandle $ \ h -> liftIO (hSetSGR h sgr) *> m <* liftIO (hSetSGR h [])++colour :: (Has (Reader Handle) sig m, MonadIO m) => ColorIntensity -> Color -> m a -> m a+colour i c = withSGR [SetColor Foreground i c]++success, failure, failure' :: (Has (Reader Handle) sig m, MonadIO m) => m a -> m a++success = colour Vivid Green+failure = colour Vivid Red+failure' = colour Dull Red+++sparks :: String+sparks = " ▁▂▃▄▅▆▇█"++sparkify :: Real a => [a] -> String+sparkify bins = sparkifyRelativeTo sparks (maximum bins) bins++sparkifyRelativeTo :: Real a => String -> a -> [a] -> String+sparkifyRelativeTo sparks max = fmap spark+  where+  spark n = sparks !! round (realToFrac n / realToFrac max * realToFrac (length sparks - 1) :: Double)+++topIndent :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => String -> m ()+topIndent m = gets hasFailures >>= failure' . putS . bool space m++withHandle :: Has (Reader Handle) sig m => (Handle -> m a) -> m a+withHandle = join . asks+++line :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => m ()+line = topIndent vline *> putS vline++section :: (Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => Maybe Status -> m a -> m a+section s m = do+  fullWidth <- asks ((+ (3 + length "Success")) . width)+  let rule corner = indent *> maybe id (stat success failure) s (putS (corner : h : replicate fullWidth h)) *> nl+  rule '╭' *> m <* rule '╰'+  where+  indent = topIndent vline *> when (is _Just s) (putS vline)+  h = '─'+++space, bullet, heading1, headingN, arrow, vline, hline, gtally, end :: String+space    = "  "+bullet   = "☙ "+heading1 = "╭─"+headingN = "├─"+arrow    = "▶ "+vline    = "│ "+hline    = "──"+gtally   = "┤ "+end      = "╰─┤ "+++nl :: (Has (Reader Handle) sig m, MonadIO m) => m ()+nl = withHandle (liftIO . (`hPutStrLn` ""))++putS :: (Has (Reader Handle) sig m, MonadIO m) => String -> m ()+putS s = withHandle (liftIO . (`hPutStr` s))+++sepBy_ :: Applicative m => m () -> [m ()] -> m ()+sepBy_ sep = getAp . foldMap Ap . intersperse sep

@@ -0,0 +1,213 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TupleSections #-}+module Test.Run+( runEntries+) where++import           Control.Carrier.Reader+import           Control.Carrier.State.Church+import           Control.Exception (SomeException)+import           Control.Monad (guard, when)+import           Control.Monad.IO.Class+import           Data.Bool (bool)+import           Data.Foldable (for_, toList)+import qualified Data.IntMap as IntMap+import           Data.List (elemIndex, intercalate, intersperse, sortBy)+import qualified Data.Map as Map+import           Data.Maybe (fromMaybe)+import           Data.Monoid (Ap(..))+import           Data.Ord (comparing)+import           Fresnel.Tropical+import           GHC.Exception.Type (Exception(displayException))+import           Numeric (showFFloatAlt)+import           System.Console.ANSI+import           System.IO+import           Test.Group as Group+import           Test.Options+import           Test.Print+import           Test.QuickCheck (Args(..), isSuccess, quickCheckWithResult)+import qualified Test.QuickCheck as QC++runEntries :: [Entry] -> Options -> IO Bool+runEntries groups (Options es args) = runReader w . runReader args . runReader stdout . runState (const . pure . not . hasFailures) mempty $ do+  t <- getAp (foldMap Ap (intersperse (mempty <$ blank <* blank) (map runEntry (matching ((==) . entryName) es groups))))+  when (hasSuccesses t || hasFailures t) (blank *> topIndent end *> runTally t)+  where+  blank = topIndent vline <* nl+  w = fromMaybe zero (getTropical (maxWidths groups))+  matching _ [] = id+  matching f fs = filter (\ g -> foldr ((||) . f g) False fs)++runEntry :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => Entry -> m Tally+runEntry = \case+  Group name entries -> runGroup name entries+  Prop name loc prop -> runProp  name loc prop+++runGroup :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> [Entry] -> m Tally+runGroup groupName entries  = do+  topIndent vline+  withSGR [SetConsoleIntensity BoldIntensity] (putS (space ++ groupName) *> nl)+  w <- ask+  t <- local (<> Width 2) (section Nothing (getAp (foldMap Ap (intersperse (mempty <$ line <* nl) (map (local (const (w :: Width)) . runEntry) entries)))))+  when (hasSuccesses t || hasFailures t) $ do+    if hasFailures t then+      failure' (putS (headingN <> gtally))+    else+      topIndent vline *> putS space+    runTally t+  pure t++runProp :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => String -> Loc -> QC.Property -> m Tally+runProp name loc property = runPropWith (ask >>= \ args -> fromQC <$> liftIO (quickCheckWithResult args property)) name loc++runPropWith :: (Has (Reader Args) sig m, Has (Reader Handle) sig m, Has (Reader Width) sig m, Has (State Tally) sig m, MonadIO m) => m Result -> String -> Loc -> m Tally+runPropWith run name Loc{ path, lineNumber } = withHandle $ \ h ->  do+  isTerminal <- liftIO (hIsTerminalDevice h)++  when isTerminal (title Pass False)++  failedPreviously <- gets hasFailures+  Result{ stats, status, failed } <- run+  modify (<> unit status)++  when isTerminal $ do+    liftIO (hClearFromCursorToLineBeginning h)+    liftIO (hSetCursorColumn h 0)++  title status failedPreviously++  putS "   " *> stat (success (putS "Success")) (failure (putS "Failure")) status *> nl++  maxSuccess <- asks maxSuccess+  let details = numTests stats == maxSuccess && not (null (classes stats))+      labels = runLabels status stats+      ln b = line *> stat success failure status (putS vline) *> b *> nl+      output+        | details || status == Fail || not (null labels) = section (Just status)+        | otherwise                                      = id++  unit status <$ output (sepBy_ (ln (pure ())) (concat+    [ [ ln (sepBy_ (putS " ") (runStats maxSuccess stats ++ runClasses stats)) | details ]+    , do+      Failure{ seed, reason, exception, testCase } <- toList failed+      let len = length testCase+      concat+        [ [ do+            ln (putS (path ++ ':' : show lineNumber ++ ':' : ' ' : reason))+            for_ exception (ln . putS . displayException) ]+        , [ for_ (enumerate (init testCase)) (\ (i, s) -> ln (putS (i ++ s))) | len >= 2 ]+        , [ ln (failure (putS (last testCase))) | len >= 1 ]+        , [ ln (putS ("--replay '" ++ seed ++ "'")) ] ]+    , labels+    , runTables stats ]))+  where+  title s failedPreviously = do+    topIndent (stat vline (bool heading1 headingN failedPreviously) s)+    stat (putS vline) (failure' (putS (hline ++ arrow))) s+    w <- asks width+    withSGR (SetConsoleIntensity BoldIntensity:stat [] [ SetColor Foreground Vivid Red ] s) (putS (bullet ++ name ++ replicate (w - length name) ' '))+    withHandle (liftIO . hFlush)++data Result = Result+  { stats  :: Stats+  , status :: Status+  , failed :: Maybe Failure+  }++data Failure = Failure+  { seed      :: String+  , reason    :: String+  , exception :: Maybe SomeException+  , testCase  :: [String]+  }++data Stats = Stats+  { numTests     :: Int+  , numDiscarded :: Int+  , numShrinks   :: Int+  , labels       :: Map.Map [String] Int+  , classes      :: Map.Map String Int+  , tables       :: Map.Map String (Map.Map String Int)+  }++defaultStats :: Stats+defaultStats = Stats+  { numTests     = 0+  , numDiscarded = 0+  , numShrinks   = 0+  , labels       = Map.empty+  , classes      = Map.empty+  , tables       = Map.empty+  }++fromQC :: QC.Result -> Result+fromQC r = Result (resultStats r) (bool Fail Pass (isSuccess r)) $ case r of+  QC.Failure{ usedSeed, usedSize, reason, theException, failingTestCase } -> Just Failure{ seed = show (usedSeed, usedSize), reason, exception = theException, testCase = failingTestCase }+  _                                                                       -> Nothing++resultStats :: QC.Result -> Stats+resultStats = \case+  QC.Success{ numTests, numDiscarded, labels, classes, tables }                   -> defaultStats{ numTests, numDiscarded, labels, classes, tables }+  QC.GaveUp{ numTests, numDiscarded, labels, classes, tables }                    -> defaultStats{ numTests, numDiscarded, labels, classes, tables }+  QC.Failure{ numTests, numDiscarded, numShrinks, failingLabels, failingClasses } -> defaultStats{ numTests, numDiscarded, numShrinks, labels = Map.fromList (map ((, numTests) . pure) failingLabels), classes = Map.fromList (map (,numTests) (toList failingClasses)) }+  QC.NoExpectedFailure{ numTests, numDiscarded, labels, classes, tables }         -> defaultStats{ numTests, numDiscarded, labels, classes, tables }++runStats :: (Has (Reader Handle) sig m, MonadIO m) => Int -> Stats -> [m ()]+runStats maxSuccess Stats{ numTests, numDiscarded, numShrinks } = [ sepBy_ (putS ", ") entries *> putS "." | not (null entries) ]+  where+  entries = concat+    [ [ putS (show numTests     ++ " test"   ++ singular numTests)   | numTests     > 0, numTests /= maxSuccess ]+    , [ putS (show numDiscarded ++ " discarded")                     | numDiscarded > 0 ]+    , [ putS (show numShrinks   ++ " shrink" ++ singular numShrinks) | numShrinks   > 0 ]+    ]+++runLabels :: (Has (Reader Handle) sig m, Has (State Tally) sig m, MonadIO m) => Status -> Stats -> [m ()]+runLabels s Stats{ numTests, labels }+  | null labels = []+  | otherwise   = IntMap.elems numberedLabels >>= \ m ->+    let sorted = sortBy (flip (comparing snd) <> flip (comparing fst)) (Map.toList m)+        scaled = map (fmap (\ v -> realToFrac v / n * 100)) sorted+        sparked = sparkify (Map.elems m)+        ln l = line *> stat success failure s (putS vline) *> putS l *> nl+    in+    [ for_ (enumerate scaled) $ \ (i, (key, v)) -> ln (i ++ (' ' <$ guard (v < 10)) ++ showFFloatAlt (Just 1) v "" ++ "% " ++ key)+    , do+      ln [ c | e <- sparked, c <- [e, e, e] ]+      ln [ c | k <- Map.keys m, i <- maybe [] (pure . succ) (elemIndex k (map fst sorted)), c <- ' ':show i ++ " " ] ]+  where+  numberedLabels = IntMap.fromListWith (Map.unionWith (+))+    [ (i, Map.singleton l n)+    | (labels, n) <- Map.toList labels+    , (i, l) <- zip [(0 :: Int)..] labels ]+  n = realToFrac numTests :: Double++enumerate :: [a] -> [(String, a)]+enumerate as = foldr (\ (i, a) as -> (show (i :: Int) ++ ". " ++ replicate (maxDigits - digits i) ' ', a):as) [] (zip [1 :: Int ..] as) where+  digits i = ceiling (logBase 10 (realToFrac (i + 1) :: Double))+  maxDigits = digits (length as)++runClasses :: (Has (Reader Handle) sig m, MonadIO m) => Stats -> [m ()]+runClasses Stats{ numTests = n, classes } = [ putS (intercalate ", " (map (uncurry (class_ n)) (Map.toList classes)) ++ ".") | not (null classes) ] where+  class_ n label n' = if n == n' then label else showFFloatAlt (Just 1) (fromIntegral n' / fromIntegral n * 100 :: Double) ('%':' ':label)++runTables :: Stats -> [m ()]+runTables _ = []+++plural :: Int -> a -> a -> a+plural 1 s _ = s+plural _ _ p = p++singular :: Int -> String+singular 1 = "s"+singular _ = ""++runTally :: (Has (Reader Handle) sig m, MonadIO m) => Tally -> m ()+runTally t = sepBy_ (putS ", " ) (map success (tally "✓" "success" "successes" (successes t)) ++ map failure (tally "✗" "failure" "failures"  (failures t))) *> putS "." *> nl+  where+  tally prefix s p n = [ sepBy_ (putS " ") [ putS prefix, putS (show n), putS (plural n s p) ] | n /= 0 ]

@@ -0,0 +1,43 @@+{-# LANGUAGE TemplateHaskell #-}+module Tropical.Test+( tests+) where++import Data.Monoid (Sum)+import Fresnel.Tropical+import Test.Group+import Test.QuickCheck hiding ((><))++prop_semigroup_assoc (ArbTropical a) (ArbTropical b) (ArbTropical c) = label (summarize a) . label (summarize b) . label (summarize c) $ a <> (b <> c) === (a <> b) <> c++prop_monoid_identity (ArbTropical a) = label (summarize a) $ (mempty <> a) === a .&&. (a <> mempty) === a++prop_semiring_assoc (ArbTropical a) (ArbTropical b) (ArbTropical c) = label (summarize a) . label (summarize b) . label (summarize c) $ a >< (b >< c) === (a >< b) >< c++prop_unital_identity (ArbTropical a) = label (summarize a) $ (one >< a) === a .&&. (a >< one) === a+++summarize :: Tropical (Sum Int) -> String+summarize (Tropical a) = case a of+  Nothing          -> "zero"+  Just a+    | signum a > 0 -> "pos"+    | signum a < 0 -> "neg"+    | otherwise    -> "one"+++newtype ArbTropical = ArbTropical (Tropical (Sum Int))+  deriving (Eq, Ord, Show)++instance Arbitrary ArbTropical where+  arbitrary = oneof $ map (fmap (ArbTropical . Tropical))+    [ pure Nothing+    , Just <$> arbitrary+    , pure (Just 0)+    ]+++pure []++tests :: Entry+tests = $deriveGroup