fresnel 0.0.0.3 → 0.1.0.0

raw patch · 28 files changed

+891/−35 lines, 28 filesdep +foldable1-classes-compatdep +semigroupoidsdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: foldable1-classes-compat, semigroupoids

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• fresnel.cabal +26/−4
• src/Fresnel/Fold.hs +165/−14
• src/Fresnel/Fold1.hs +168/−0
• src/Fresnel/Fold1/Internal.hs +18/−0
• src/Fresnel/Functor/Ap1.hs +12/−0
• src/Fresnel/Functor/Backwards.hs +0/−7
• src/Fresnel/Functor/Traversed1.hs +16/−0
• src/Fresnel/Getter/Internal.hs +2/−0
• src/Fresnel/Iso.hs +8/−0
• src/Fresnel/Iso/Internal.hs +2/−0
• src/Fresnel/Lens.hs +30/−0
• src/Fresnel/Lens/Internal.hs +2/−0
• src/Fresnel/Profunctor/Star1.hs +32/−0
• src/Fresnel/Profunctor/Traversing1.hs +59/−0
• src/Fresnel/Semigroup/Cons1.hs +41/−0
• src/Fresnel/Semigroup/Fork1.hs +50/−0
• src/Fresnel/Semigroup/Snoc1.hs +41/−0
• src/Fresnel/Traversal.hs +38/−5
• src/Fresnel/Traversal/Internal.hs +2/−1
• src/Fresnel/Traversal1.hs +88/−0
• src/Fresnel/Traversal1/Internal.hs +20/−0
• test/Fold/Test.hs +39/−0
• test/Getter/Test.hs +1/−1
• test/Iso/Test.hs +2/−2
• test/Review/Test.hs +1/−1
• test/Test.hs +2/−0
• test/Traversal/Test.hs +16/−0

@@ -1,3 +1,13 @@+# 0.1.0.0++- Add non-empty folds and traversals, `Fold1` and `Traversal1` respectively.+- Add a dependency on `semigroupoids` to support the above.+- Add a number of constructors and eliminators, primarily over `Fold` and `Traversal`.+- 🔥 `Fresnel.Functor.Backwards` in favour of `Control.Applicative.Backwards` from the `transformers` package.+- Support ghc 9.8+- Support ghc 9.10++ # 0.0.0.3  Support ghc 9.6 a little harder.

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               fresnel-version:            0.0.0.3+version:            0.1.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@@ -10,7 +10,7 @@ author:             Rob Rix maintainer:         rob.rix@me.com -copyright:          2021–2023 Rob Rix+copyright:          2021–2024 Rob Rix category:           Control extra-doc-files:   CHANGELOG.md@@ -39,6 +39,10 @@   if (impl(ghc >= 9.2))     ghc-options:       -Wno-missing-kind-signatures+  if (impl(ghc >= 9.8))+    ghc-options:+      -Wno-missing-role-annotations+      -Wno-term-variable-capture  library   import: common@@ -46,9 +50,11 @@     Fresnel.At     Fresnel.Bifunctor.Contravariant     Fresnel.Either+    Fresnel.Fold1     Fresnel.Fold-    Fresnel.Functor.Backwards+    Fresnel.Functor.Ap1     Fresnel.Functor.Traversed+    Fresnel.Functor.Traversed1     Fresnel.Getter     Fresnel.Iso     Fresnel.Ixed@@ -66,12 +72,19 @@     Fresnel.Profunctor.Coexp     Fresnel.Profunctor.OptionalStar     Fresnel.Profunctor.Recall+    Fresnel.Profunctor.Star1+    Fresnel.Profunctor.Traversing1     Fresnel.Review+    Fresnel.Semigroup.Cons1+    Fresnel.Semigroup.Fork1+    Fresnel.Semigroup.Snoc1     Fresnel.Set     Fresnel.Setter     Fresnel.Traversal+    Fresnel.Traversal1     Fresnel.Tuple   other-modules:+    Fresnel.Fold1.Internal     Fresnel.Getter.Internal     Fresnel.Iso.Internal     Fresnel.Lens.Internal@@ -79,13 +92,18 @@     Fresnel.OptionalFold.Internal     Fresnel.Prism.Internal     Fresnel.Traversal.Internal+    Fresnel.Traversal1.Internal   build-depends:     , base >=4.14 && < 5     , containers   >= 0.5 && < 0.7     , hashable     >= 1.3 && < 1.5     , profunctors ^>= 5.6+    , semigroupoids ^>= 6     , transformers  >= 0.4 && < 0.7     , unordered-containers ^>= 0.2+  if (impl(ghc < 9.6))+    build-depends:+      , foldable1-classes-compat ^>= 0.1   hs-source-dirs: src  test-suite test@@ -105,6 +123,7 @@     Test.Options     Test.Print     Test.Run+    Traversal.Test     Tropical.Test   build-depends:     , ansi-terminal ^>= 0.11@@ -112,11 +131,14 @@     , containers     , fresnel     , fused-effects ^>= 1.1-    , template-haskell >= 2.16 && < 2.22+    , template-haskell >= 2.16 && < 2.23     , QuickCheck ^>= 2.14   if (impl(ghc >= 9.2))     ghc-options:       -Wno-missing-signatures+  if (impl(ghc >= 9.8))+    ghc-options:+      -Wno-x-partial   source-repository head

@@ -1,4 +1,3 @@-{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} module Fresnel.Fold ( -- * Folds@@ -9,8 +8,16 @@ , unfolded , folding , foldring+, foldMapping+, foldMap1ing , ignored , backwards+, iterated+, filtered+, repeated+, replicated+, cycled+, takingWhile   -- * Elimination , has , hasn't@@ -19,13 +26,36 @@ , foldrOf , foldlOf' , foldOf+, foldByOf , sequenceOf_ , traverseOf_ , forOf_ , toListOf , anyOf , allOf+, noneOf+, andOf+, orOf+, productOf+, sumOf+, altOf+, asumOf+, concatOf+, concatMapOf+, elemOf+, notElemOf+, lengthOf , nullOf+, notNullOf+, firstOf+, lastOf+, minimumOf+, minimumByOf+, maximumOf+, maximumByOf+, findOf+, findMOf+, lookupOf , previews , preview , (^?)@@ -33,27 +63,29 @@ , Union(..) ) where +import Control.Applicative (Alternative(..))+import Control.Applicative.Backwards import Data.Foldable (traverse_)+import Data.Functor (void) 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.Fold1.Internal (IsFold1) 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)+import Fresnel.Traversal (IsTraversal, ignored, traversal)  -- Folds  type Fold s a = forall p . IsFold p => Optic' p s a -class (IsOptionalFold p, IsTraversal p) => IsFold p+class (IsOptionalFold p, IsFold1 p, IsTraversal p) => IsFold p  instance Monoid r => IsFold (Forget r) instance (Applicative f, Traversable f, Contravariant f) => IsFold (Star f)@@ -62,29 +94,66 @@ -- Construction  folded :: Foldable f => Fold (f a) a-folded = rphantom . wander traverse_+folded = rphantom . traversal 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)+unfolded coalg = rphantom . traversal (\ 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_+folding f = contrabimap f (const ()) . traversal 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+foldring fr = rphantom . traversal (\ f -> fr (\ a -> (f a *>)) (pure v)) where   v = error "foldring: value used" -ignored :: Fold s a-ignored = foldring (\ _ nil _ -> nil)+-- | Make a 'Fold' by lifting a 'foldMap'-like function.+--+-- @+-- 'foldMapping' 'foldMap' = 'folded'+-- @+foldMapping :: (forall m . Monoid m => (a -> m) -> (s -> m)) -> Fold s a+foldMapping fm = rphantom . traversal (\ f -> getAp . fm (Ap . void . f)) +-- | Make a 'Fold' by lifting a 'foldMap1'-like function.+foldMap1ing :: (forall m . Semigroup m => (a -> m) -> (s -> m)) -> Fold s a+foldMap1ing fm = rphantom . traversal (\ f -> getAp . fm (Ap . void . f))+ backwards :: Fold s a -> Fold s a-backwards o = rphantom . wander (\ f -> forwards . traverseOf_ o (Backwards #. f))+backwards o = rphantom . traversal (\ f -> forwards . traverseOf_ o (Backwards #. f)) +iterated :: (a -> a) -> Fold a a+iterated f = rphantom . traversal (\ g -> let loop a = g a *> loop (f a) in loop) +filtered :: (a -> Bool) -> Fold a a+filtered p = folding (\ a -> if p a then Just a else Nothing)++-- | An infinite fold repeatedly producing its input.+--+-- @+-- 'toListOf' 'repeated' a = 'repeat' a+-- @+repeated :: Fold a a+repeated = rphantom . traversal (\ f a -> let loop = f a *> loop in loop)++-- | A fold producing its input a finite number of times.+--+-- @+-- 'toListOf' ('replicated' n) a = 'replicate' n a+-- @+replicated :: Int -> Fold a a+replicated n0 = rphantom . traversal (\ f -> let loop n a = if n <= 0 then pure () else f a *> loop (n - 1) a in loop n0)++cycled :: Fold s a -> Fold s a+cycled f = foldring (\ cons _ s -> let loop = foldrOf f cons loop s in loop)++takingWhile :: (a -> Bool) -> Fold s a -> Fold s a+takingWhile p f = foldring (\ cons nil -> foldrOf f (\ a as -> if p a then cons a as else nil) nil)++ -- Elimination  has :: Fold s a -> (s -> Bool)-has o = anyOf o (const True)+has = notNullOf  hasn't :: Fold s a -> (s -> Bool) hasn't = nullOf@@ -105,6 +174,9 @@ foldOf :: Monoid a => Fold s a -> (s -> a) foldOf o = foldMapOf o id +foldByOf :: Fold s a -> ((a -> a -> a) -> a -> (s -> a))+foldByOf o fork nil s = runFork (runForget (o (Forget Fork.singleton)) s) fork id nil+ sequenceOf_ :: Applicative f => Fold s (f a) -> (s -> f ()) sequenceOf_ o = runTraversed . foldMapOf o Traversed @@ -123,10 +195,89 @@ allOf :: Fold s a -> (a -> Bool) -> (s -> Bool) allOf o = foldMapByOf o (&&) True +noneOf :: Fold s a -> (a -> Bool) -> (s -> Bool)+noneOf o p = anyOf o (not . p)++andOf :: Fold s Bool -> (s -> Bool)+andOf o = getAll #. foldMapOf o All++orOf :: Fold s Bool -> (s -> Bool)+orOf o = getAny #. foldMapOf o Any++productOf :: Num a => Fold s a -> (s -> a)+productOf o = getProduct #. foldMapOf o Product++sumOf :: Num a => Fold s a -> (s -> a)+sumOf o = getSum #. foldMapOf o Sum++altOf :: Alternative f => Fold s a -> (s -> f a)+altOf o = getAlt #. foldMapOf o (Alt #. pure)++asumOf :: Alternative f => Fold s (f a) -> (s -> f a)+asumOf o = getAlt #. foldMapOf o Alt++concatOf :: Fold s [a] -> (s -> [a])+concatOf = foldOf++concatMapOf :: Fold s a -> ((a -> [r]) -> (s -> [r]))+concatMapOf = foldMapOf++elemOf :: Eq a => Fold s a -> a -> s -> Bool+elemOf o = anyOf o . (==)++notElemOf :: Eq a => Fold s a -> a -> s -> Bool+notElemOf o = noneOf o . (==)++lengthOf :: Fold s a -> (s -> Int)+lengthOf o = foldrOf o (const (+ 1)) 0+ nullOf :: Fold s a -> (s -> Bool) nullOf o = foldrOf o (\ _ _ -> False) True +notNullOf :: Fold s a -> (s -> Bool)+notNullOf o = foldrOf o (\ _ _ -> True) False +firstOf :: Fold s a -> (s -> Maybe a)+firstOf o = foldrOf o (\ a _ -> Just a) Nothing++lastOf :: Fold s a -> (s -> Maybe a)+lastOf o = getLast #. foldMapOf o (Last #. Just)++minimumOf :: Ord a => Fold s a -> (s -> Maybe a)+minimumOf o = minimumByOf o compare++minimumByOf :: Fold s a -> (a -> a -> Ordering) -> (s -> Maybe a)+minimumByOf o cmp = foldlOf' o (\ a b -> Just (case a of+  Nothing -> b+  Just a+    | GT <- cmp a b -> b+    | otherwise     -> a)) Nothing++maximumOf :: Ord a => Fold s a -> (s -> Maybe a)+maximumOf o = maximumByOf o compare++maximumByOf :: Fold s a -> (a -> a -> Ordering) -> (s -> Maybe a)+maximumByOf o cmp = foldlOf' o (\ a b -> Just (case a of+  Nothing -> b+  Just a+    | LT <- cmp a b -> b+    | otherwise     -> a)) Nothing++findOf :: Fold s a -> (a -> Bool) -> (s -> Maybe a)+findOf o p = foldrOf o (\ a as -> if p a then Just a else as) Nothing++findMOf :: Monad m => Fold s a -> (a -> m Bool) -> (s -> m (Maybe a))+findMOf o p = foldrOf o (\ a as -> do+  c <- p a+  if c then+    return (Just a)+  else+    as) (return Nothing)++lookupOf :: Eq k => Fold s (k, v) -> (k -> s -> Maybe v)+lookupOf o k = fmap snd . findOf o ((== k) . fst)++ previews :: Fold s a -> (a -> r) -> (s -> Maybe r) previews o f = getFirst #. foldMapOf o (First #. Just . f) @@ -151,7 +302,7 @@ 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)+  Union a1 <> Union a2 = Union (rphantom . traversal (\ f s -> traverseOf_ a1 f s *> traverseOf_ a2 f s) . rphantom)  instance Monoid (Union s a) where   mempty = Union ignored

@@ -0,0 +1,168 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Fold1+( -- * Relevant folds+  Fold1+, IsFold1+  -- * Construction+, folded1+, unfolded1+, fold1ing+, foldMap1ing+, backwards+, iterated+, repeated+  -- * Elimination+, foldMap1Of+, foldMap1ByOf+, foldrMap1Of+, foldlMap1Of+, fold1Of+, fold1ByOf+, sequence1Of_+, traverse1Of_+, for1Of_+, toList1Of+, concatOf+, concatMapOf+, firstOf+, lastOf+, minimumOf+, minimumByOf+, maximumOf+, maximumByOf+  -- * Union semigroup+, Union(..)+) where++import Control.Applicative.Backwards+import Data.Functor (void)+import Data.Functor.Apply+import Data.List.NonEmpty (NonEmpty)+import Data.Profunctor+import Data.Profunctor.Unsafe ((#.), (.#))+import Data.Semigroup (First(..), Last(..))+import Data.Semigroup.Foldable+import Fresnel.Bifunctor.Contravariant+import Fresnel.Fold1.Internal (IsFold1)+import Fresnel.Functor.Ap1+import Fresnel.Functor.Traversed1+import Fresnel.Optic (Optic')+import Fresnel.Semigroup.Cons1 as Cons1+import Fresnel.Semigroup.Fork1 as Fork1+import Fresnel.Semigroup.Snoc1 as Snoc1+import Fresnel.Traversal1 hiding (backwards)++-- Relevant folds++type Fold1 s a = forall p . IsFold1 p => Optic' p s a+++-- Construction++folded1 :: Foldable1 t => Fold1 (t a) a+folded1 = foldMap1ing foldMap1++unfolded1 :: (s -> (a, Maybe s)) -> Fold1 s a+unfolded1 coalg = rphantom . traversal1 loop+  where+  loop f s = let (a, s') = coalg s in maybe (f a) ((f a .>) . loop f) s'++fold1ing :: Foldable1 t => (s -> t a) -> Fold1 s a+fold1ing f = contrabimap f (const ()) . traversal1 traverse1_++-- | Make a 'Fold1' by lifting a 'foldMap1'-like function.+--+-- @+-- 'foldMap1ing' 'foldMap1' = 'folded1'+-- 'foldMap1Of' . 'foldMap1ing' = 'id'+-- @+foldMap1ing :: (forall m . Semigroup m => (a -> m) -> (s -> m)) -> Fold1 s a+foldMap1ing fm = rphantom . traversal1 (\ f -> getAp1 #. fm (Ap1 #. void . f))++-- | Reverse the order in which a (finite) 'Fold1' is traversed.+--+-- @+-- 'backwards' . 'backwards' = 'id'+-- @+backwards :: Fold1 s a -> Fold1 s a+backwards o = rphantom . traversal1 (\ f -> forwards . traverse1Of_ o (Backwards #. f))++iterated :: (a -> a) -> Fold1 a a+iterated f = rphantom . traversal1 (\ g -> let loop a = g a .> loop (f a) in loop)++-- | An infinite fold repeatedly producing its input.+--+-- @+-- 'Fresnel.Fold.toListOf' 'repeated' a = 'repeat' a+-- @+repeated :: Fold1 a a+repeated = rphantom . traversal1 (\ f a -> let loop = f a .> loop in loop)+++-- Elimination++foldMap1Of :: Semigroup m => Fold1 s a -> ((a -> m) -> (s -> m))+foldMap1Of o = runForget #. o .# Forget++foldMap1ByOf :: Fold1 s a -> ((r -> r -> r) -> (a -> r) -> (s -> r))+foldMap1ByOf o fork leaf s = runFork1 (runForget (o (Forget Fork1.singleton)) s) fork leaf++foldrMap1Of :: Fold1 s a -> ((a -> r) -> (a -> r -> r) -> (s -> r))+foldrMap1Of o last cons s = runCons1 (runForget (o (Forget Cons1.singleton)) s) last cons++foldlMap1Of :: Fold1 s a -> ((a -> r) -> (r -> a -> r) -> (s -> r))+foldlMap1Of o first snoc s = runSnoc1 (runForget (o (Forget Snoc1.singleton)) s) first snoc++fold1Of :: Semigroup a => Fold1 s a -> (s -> a)+fold1Of o = foldMap1Of o id++fold1ByOf :: Fold1 s a -> ((a -> a -> a) -> (s -> a))+fold1ByOf o fork s = runFork1 (runForget (o (Forget Fork1.singleton)) s) fork id++sequence1Of_ :: Apply f => Fold1 s (f a) -> (s -> f ())+sequence1Of_ o = runTraversed1 . foldMap1Of o Traversed1++traverse1Of_ :: Apply f => Fold1 s a -> ((a -> f r) -> (s -> f ()))+traverse1Of_ o f = runTraversed1 . foldMap1Of o (Traversed1 #. f)++for1Of_ :: Apply f => Fold1 s a -> (s -> (a -> f r) -> f ())+for1Of_ o = flip (traverse1Of_ o)++toList1Of :: Fold1 s a -> (s -> NonEmpty a)+toList1Of o = foldMap1Of o pure++concatOf :: Fold1 s (NonEmpty a) -> (s -> NonEmpty a)+concatOf = fold1Of++concatMapOf :: Fold1 s a -> ((a -> NonEmpty r) -> (s -> NonEmpty r))+concatMapOf = foldMap1Of++firstOf :: Fold1 s a -> (s -> a)+firstOf o = getFirst #. foldMap1Of o First++lastOf :: Fold1 s a -> (s -> a)+lastOf o = getLast #. foldMap1Of o Last++minimumOf :: Ord a => Fold1 s a -> (s -> a)+minimumOf o = minimumByOf o compare++minimumByOf :: Fold1 s a -> (a -> a -> Ordering) -> (s -> a)+minimumByOf o cmp = foldlMap1Of o id (\ a b -> case cmp a b of+  GT -> b+  _  -> a)++maximumOf :: Ord a => Fold1 s a -> (s -> a)+maximumOf o = maximumByOf o compare++maximumByOf :: Fold1 s a -> (a -> a -> Ordering) -> (s -> a)+maximumByOf o cmp = foldlMap1Of o id (\ a b -> case cmp a b of+  LT -> b+  _  -> a)+++-- Union semigroup++newtype Union s a = Union { getUnion1 :: Fold1 s a }++instance Semigroup (Union s a) where+    Union a1 <> Union a2 = Union (rphantom . traversal1 (\ f s -> traverse1Of_ a1 f s .> traverse1Of_ a2 f s) . rphantom)

@@ -0,0 +1,18 @@+module Fresnel.Fold1.Internal+( IsFold1+) where++import Data.Functor.Apply+import Data.Functor.Contravariant+import Data.Profunctor (Forget, Star)+import Fresnel.Getter.Internal (IsGetter)+import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Star1 (Star1)+import Fresnel.Traversal1.Internal (IsTraversal1)++class (IsGetter p, IsTraversal1 p) => IsFold1 p++instance Semigroup r => IsFold1 (Forget r)+instance (Contravariant f, Applicative f, Traversable f) => IsFold1 (Star f)+instance (Contravariant f, Apply f, Traversable f) => IsFold1 (Star1 f)+instance (Contravariant f, Apply f, Traversable f) => IsFold1 (OptionalStar f)

@@ -0,0 +1,12 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Fresnel.Functor.Ap1+( Ap1(..)+) where++import Data.Functor.Apply++newtype Ap1 f a = Ap1 { getAp1 :: f a }+  deriving (Applicative, Apply, Functor, Monad)++instance (Apply f, Semigroup a) => Semigroup (Ap1 f a) where+  Ap1 a <> Ap1 b = Ap1 (liftF2 (<>) a b)

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

@@ -0,0 +1,16 @@+module Fresnel.Functor.Traversed1+( -- * Traversed1 functor+  runTraversed1+, Traversed1(..)+) where++import Data.Functor (void)+import Data.Functor.Apply++runTraversed1 :: Functor f => Traversed1 f a -> f ()+runTraversed1 (Traversed1 fa) = void fa++newtype Traversed1 f a = Traversed1 (f a)++instance Apply f => Semigroup (Traversed1 f a) where+  Traversed1 a1 <> Traversed1 a2 = Traversed1 (a1 .> a2)

@@ -7,9 +7,11 @@ import Fresnel.Bifunctor.Contravariant (Bicontravariant) import Fresnel.Lens.Internal (IsLens) import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Star1 (Star1)  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 (Star1 f) instance (Contravariant f, Traversable f) => IsGetter (OptionalStar f)

@@ -29,6 +29,8 @@ , flipped , curried , uncurried+, au+, auf   -- * Relations , non , non'@@ -118,6 +120,12 @@  uncurried :: Iso (a -> b -> c) (a' -> b' -> c') ((a, b) -> c) ((a', b') -> c') uncurried = iso uncurry curry++au :: Functor f => Iso s t a b -> (((b -> t) -> f s) -> f a)+au o f = withIso o (\ sa bt -> sa <$> f bt)++auf :: (Functor f, Functor g) => Iso s t a b -> ((f t -> g s) -> (f b -> g a))+auf o f fb = withIso o (\ sa bt -> sa <$> f (bt <$> fb))   -- Relations

@@ -7,6 +7,7 @@ import Fresnel.Profunctor.Coexp (Coexp) import Fresnel.Profunctor.OptionalStar (OptionalStar) import Fresnel.Profunctor.Recall (Recall)+import Fresnel.Profunctor.Star1 (Star1)  class Profunctor p => IsIso p @@ -17,4 +18,5 @@ instance Functor f => IsIso (Star f) instance Functor f => IsIso (Costar f) instance Functor f => IsIso (OptionalStar f)+instance Functor f => IsIso (Star1 f) instance IsIso (Coexp s t)

@@ -9,17 +9,28 @@   -- * Elimination , withLens   -- * Combinators+, choosing+, chosen , alongside+, inside+, devoid+, united   -- * Unpacked , UnpackedLens(..) , unpackedLens ) where  import Control.Arrow ((&&&), (***))+import Data.Bifunctor (Bifunctor(..)) import Data.Profunctor+import Data.Profunctor.Rep (Corepresentable(..))+import Data.Profunctor.Sieve (Cosieve(..))+import Data.Void (Void, absurd)+import Fresnel.Getter (getting, view) import Fresnel.Iso.Internal (IsIso) import Fresnel.Lens.Internal (IsLens) import Fresnel.Optic+import Fresnel.Setter (set)  -- Lenses @@ -42,9 +53,28 @@  -- Combinators +choosing :: Lens s1 t1 a b -> Lens s2 t2 a b -> Lens (Either s1 s2) (Either t1 t2) a b+choosing l r = lens+  (either (view (getting l)) (view (getting r)))+  (\ e b -> bimap (set l b) (set r b) e)++chosen :: Lens (Either a a) (Either b b) a b+chosen = choosing id id+ 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))++inside :: Corepresentable p => Lens s t a b -> Lens (p e s) (p e t) (p e a) (p e b)+inside o = lens+  (\ s -> cotabulate (view (getting o) . cosieve s))+  (\ s b -> cotabulate (\ e -> set o (cosieve b e) (cosieve s e)))++devoid :: Lens Void Void a b+devoid = lens absurd const++united :: Lens' a ()+united = lens (const ()) const   -- Unpacked

@@ -7,6 +7,7 @@ import Data.Profunctor (Forget, Star, Strong) import Fresnel.Iso.Internal (IsIso) import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Star1 (Star1)  class (IsIso p, Strong p) => IsLens p @@ -14,4 +15,5 @@ instance Monad m => IsLens (Kleisli m) instance IsLens (Forget r) instance Functor f => IsLens (Star f)+instance Functor f => IsLens (Star1 f) instance Functor f => IsLens (OptionalStar f)

@@ -0,0 +1,32 @@+{-# LANGUAGE TupleSections #-}+module Fresnel.Profunctor.Star1+( -- * Star1 profunctor+  Star1(..)+) where++import Data.Functor.Apply+import Data.Functor.Contravariant (Contravariant(..))+import Data.Profunctor+import Fresnel.Bifunctor.Contravariant (Bicontravariant(..))+import Fresnel.Profunctor.Traversing1++-- | Just like 'Data.Profunctor.Star', but with some instances defined in terms of 'Data.Functor.Apply' instead of 'Applicative'. Used by 'Fresnel.Traversal1.Traversal1' & 'Fresnel.Fold1.Fold1'.+newtype Star1 f a b = Star1 { runStar1 :: a -> f b }++instance Functor f => Profunctor (Star1 f) where+  dimap f g (Star1 h) = Star1 (fmap g . h . f)++instance Functor f => Strong (Star1 f) where+  first'  (Star1 h) = Star1 (\ (a, c) -> (,c) <$> h a)+  second' (Star1 h) = Star1 (\ (c, a) -> (c,) <$> h a)++instance Traversable f => Cochoice (Star1 f) where+  unright (Star1 h) = Star1 (go . Right)+    where+    go = either (go . Left) id . sequence . h++instance Apply f => Traversing1 (Star1 f) where+  wander1 f (Star1 h) = Star1 (f h)++instance Contravariant f => Bicontravariant (Star1 f) where+  contrabimap f g (Star1 h) = Star1 (contramap g . h . f)

@@ -0,0 +1,59 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Profunctor.Traversing1+( Traversing1(..)+  -- ** Profunctor from Traversing1+, dimapTraversing1+, lmapTraversing1+, rmapTraversing1+  -- ** Strong from Traversing1+, firstTraversing1+, secondTraversing1+) where++import Control.Arrow (Kleisli(..))+import Data.Functor.Apply+import Data.Functor.Const+import Data.Functor.Identity+import Data.Profunctor (Forget(..), Star(..), Strong)+import Data.Profunctor.Unsafe ((#.))+import Fresnel.Profunctor.OptionalStar (OptionalStar(..))++class Strong p => Traversing1 p where+  wander1 :: (forall f . Apply f => (a -> f b) -> (s -> f t)) -> (p a b -> p s t)++instance Traversing1 (->) where+  wander1 f g = runIdentity . f (Identity . g)++instance Monad m => Traversing1 (Kleisli m) where+  wander1 f (Kleisli k) = Kleisli (unwrapApplicative . f (WrapApplicative . k))++instance Semigroup r => Traversing1 (Forget r) where+  wander1 f (Forget k) = Forget (getConst #. f (Const #. k))++instance Applicative f => Traversing1 (Star f) where+  wander1 f (Star k) = Star (unwrapApplicative . f (WrapApplicative . k))++instance Apply f => Traversing1 (OptionalStar f) where+  wander1 f (OptionalStar k) = OptionalStar (\ k' -> k (\ p -> k' p . f))+++-- Profunctor from Traversing1++dimapTraversing1 :: Traversing1 p => (a' -> a) -> (b -> b') -> (p a b -> p a' b')+dimapTraversing1 f g = wander1 (\ k -> fmap g . k . f)++lmapTraversing1 :: Traversing1 p => (a' -> a) -> (p a b -> p a' b)+lmapTraversing1 f = wander1 (. f)++rmapTraversing1 :: Traversing1 p => (b -> b') -> (p a b -> p a b')+rmapTraversing1 f = wander1 (fmap f .)+++-- Strong from Traversing1+++firstTraversing1 :: Traversing1 p => p a b -> p (a, c) (b, c)+firstTraversing1 = wander1 (\ k (a, c) -> flip (,) c <$> k a)++secondTraversing1 :: Traversing1 p => p a b -> p (c, a) (c, b)+secondTraversing1 = wander1 (\ k (c, a) -> (,) c <$> k a)

@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Semigroup.Cons1+( -- * Non-empty cons lists+  Cons1(..)+  -- * Construction+, singleton+, cons+) where++import Data.Foldable (toList)+import Data.Foldable1++-- Non-empty cons lists++newtype Cons1 a = Cons1 { runCons1 :: forall r . (a -> r) -> (a -> r -> r) -> r }++instance Show a => Show (Cons1 a) where+  showsPrec _ = showList . toList++instance Semigroup (Cons1 a) where+  Cons1 a1 <> Cons1 a2 = Cons1 (\ f g -> a1 (\ a -> g a (a2 f g)) g)++instance Foldable Cons1 where+  foldMap f (Cons1 r) = r f ((<>) . f)+  foldr f z (Cons1 r) = r (`f` z) f++instance Foldable1 Cons1 where+  foldMap1 f (Cons1 r) = r f ((<>) . f)+  foldrMap1 f g (Cons1 r) = r f g++instance Functor Cons1 where+  fmap h (Cons1 r) = Cons1 (\ f g -> r (f . h) (g . h))+++-- Construction++singleton :: a -> Cons1 a+singleton a = Cons1 (\ f _ -> f a)++cons :: a -> Cons1 a -> Cons1 a+cons a (Cons1 r) = Cons1 (\ f g -> g a (r f g))

@@ -0,0 +1,50 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Semigroup.Fork1+( -- * Non-empty binary trees+  Fork1(..)+  -- * Construction+, singleton+) where++import Data.Foldable (toList)+import Data.Foldable1+import Data.Functor.Alt++-- Non-empty binary trees++newtype Fork1 a = Fork1 { runFork1 :: forall r . (r -> r -> r) -> (a -> r) -> r }++instance Show a => Show (Fork1 a) where+  showsPrec _ = showList . toList++instance Semigroup (Fork1 a) where+  Fork1 a1 <> Fork1 a2 = Fork1 (\ (<>) singleton -> a1 (<>) singleton <> a2 (<>) singleton)++instance Foldable Fork1 where+  foldMap = foldMap1++instance Foldable1 Fork1 where+  foldMap1 f (Fork1 r) = r (<>) f++instance Functor Fork1 where+  fmap f (Fork1 r) = Fork1 (\ (<>) singleton -> r (<>) (singleton . f))++instance Traversable Fork1 where+  traverse f (Fork1 r) = r ((<*>) . fmap (<>)) (fmap singleton . f)++instance Apply Fork1 where+  liftF2 f (Fork1 a) (Fork1 b) = Fork1 (\ (<>) singleton -> a (<>) (\ a' -> b (<>) (singleton . f a')))++instance Applicative Fork1 where+  pure = singleton++  (<*>) = (<.>)++instance Alt Fork1 where+  (<!>) = (<>)+++-- Construction++singleton :: a -> Fork1 a+singleton a = Fork1 (\ _ singleton -> singleton a)

@@ -0,0 +1,41 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Semigroup.Snoc1+( -- * Non-empty snoc lists+  Snoc1(..)+  -- * Construction+, singleton+, snoc+) where++import Data.Foldable (toList)+import Data.Foldable1++-- Non-empty snoc lists++newtype Snoc1 a = Snoc1 { runSnoc1 :: forall r . (a -> r) -> (r -> a -> r) -> r }++instance Show a => Show (Snoc1 a) where+  showsPrec _ = showList . toList++instance Semigroup (Snoc1 a) where+  Snoc1 a1 <> Snoc1 a2 = Snoc1 (\ f g -> a2 (\ a -> g (a1 f g) a) g)++instance Foldable Snoc1 where+  foldMap f (Snoc1 r) = r f ((. f) . (<>))+  foldl f z (Snoc1 r) = r (z `f`) f++instance Foldable1 Snoc1 where+  foldMap1 f (Snoc1 r) = r f ((. f) . (<>))+  foldlMap1 f g (Snoc1 r) = r f g++instance Functor Snoc1 where+  fmap h (Snoc1 r) = Snoc1 (\ f g -> r (f . h) ((. h) . g))+++-- Construction++singleton :: a -> Snoc1 a+singleton a = Snoc1 (\ f _ -> f a)++snoc :: Snoc1 a -> a -> Snoc1 a+snoc (Snoc1 r) a = Snoc1 (\ f g -> g (r f g) a)

@@ -5,8 +5,12 @@ , Traversal' , IsTraversal   -- * Construction+, traversal , traversed , backwards+, both+, beside+, ignored   -- * Elimination , traverseOf , forOf@@ -19,11 +23,12 @@ ) where  import Control.Applicative (ZipList(..))+import Control.Applicative.Backwards import Control.Monad.Trans.State+import Data.Bitraversable (Bitraversable(..)) import Data.Profunctor import Data.Profunctor.Traversing (Traversing(..))-import Data.Profunctor.Unsafe ((#.))-import Fresnel.Functor.Backwards+import Data.Profunctor.Unsafe ((#.), (.#)) import Fresnel.Optic import Fresnel.Traversal.Internal (IsTraversal) @@ -36,17 +41,45 @@  -- Construction +traversal :: (forall f . Applicative f => (a -> f b) -> (s -> f t)) -> Traversal s t a b+traversal f = wander f+ traversed :: Traversable t => Traversal (t a) (t b) a b-traversed = wander traverse+traversed = traversal traverse +-- | Reverse the order in which a (finite) 'Traversal' is traversed.+--+-- @+-- 'backwards' . 'backwards' = 'id'+-- @ backwards :: Traversal s t a b -> Traversal s t a b-backwards o = wander (\ f -> forwards . traverseOf o (Backwards . f))+backwards o = traversal (\ f -> forwards #. traverseOf o (Backwards #. f)) +both :: Bitraversable r => Traversal (r a a) (r b b) a b+both = traversal (\ f -> bitraverse f f) +beside :: Bitraversable r => Traversal s1 t1 a b -> Traversal s2 t2 a b -> Traversal (r s1 s2) (r t1 t2) a b+beside l r = traversal (\ f -> bitraverse (traverseOf l f) (traverseOf r f))++-- | The trivially empty @'Traversal'@.+--+-- @+-- 'traverseOf' 'ignored' f = pure+-- @+ignored :: Traversal s s a b+ignored = traversal (const pure)++ -- Elimination +-- | Map over the targets of an 'Fresnel.Iso.Iso', 'Fresnel.Lens.Lens', 'Fresnel.Optional.Optional', or 'Traversal', collecting the results.+--+-- @+-- 'traverseOf' . 'traversal' = 'id'+-- 'traverseOf' 'traversed' = 'traverse'+-- @ traverseOf :: Applicative f => Traversal s t a b -> ((a -> f b) -> (s -> f t))-traverseOf o = runStar . o . Star+traverseOf o = runStar #. o .# Star  forOf :: Applicative f => Traversal s t a b -> (s -> (a -> f b) -> f t) forOf o = flip (traverseOf o)

@@ -6,8 +6,9 @@ import Data.Profunctor (Forget, Star) import Data.Profunctor.Traversing (Traversing) import Fresnel.Optional.Internal (IsOptional)+import Fresnel.Traversal1.Internal (IsTraversal1) -class (IsOptional p, Traversing p) => IsTraversal p+class (IsOptional p, IsTraversal1 p, Traversing p) => IsTraversal p  instance IsTraversal (->) instance Monad m => IsTraversal (Kleisli m)

@@ -0,0 +1,88 @@+{-# LANGUAGE RankNTypes #-}+module Fresnel.Traversal1+( -- * Relevant traversals+  Traversal1+, Traversal1'+, IsTraversal1+  -- * Construction+, traversal1+, traversed1+, backwards+, both+, beside+  -- * Elimination+, traverse1Of+, for1Of+, sequence1Of+, transposeOf+) where++import Control.Applicative.Backwards+import Data.Functor.Apply+import Data.List.NonEmpty (NonEmpty(..), zipWith)+import Data.Profunctor.Unsafe ((#.), (.#))+import Data.Semigroup.Bitraversable+import Data.Semigroup.Traversable+import Fresnel.Optic+import Fresnel.Profunctor.Star1 (Star1(..))+import Fresnel.Profunctor.Traversing1+import Fresnel.Traversal1.Internal+import Prelude hiding (zipWith)++-- Relevant traversals++type Traversal1 s t a b = forall p . IsTraversal1 p => Optic p s t a b++type Traversal1' s a = Traversal1 s s a a+++-- Construction++traversal1 :: (forall f . Apply f => (a -> f b) -> (s -> f t)) -> Traversal1 s t a b+traversal1 f = wander1 f++traversed1 :: Traversable1 t => Traversal1 (t a) (t b) a b+traversed1 = traversal1 traverse1++-- | Reverse the order in which a (finite) 'Traversal1' is traversed.+--+-- @+-- 'backwards' . 'backwards' = 'id'+-- @+backwards :: Traversal1 s t a b -> Traversal1 s t a b+backwards o = traversal1 (\ f -> forwards #. traverse1Of o (Backwards #. f))++both :: Bitraversable1 r => Traversal1 (r a a) (r b b) a b+both = traversal1 (\ f -> bitraverse1 f f)++beside :: Bitraversable1 r => Traversal1 s1 t1 a b -> Traversal1 s2 t2 a b -> Traversal1 (r s1 s2) (r t1 t2) a b+beside l r = traversal1 (\ f -> bitraverse1 (traverse1Of l f) (traverse1Of r f))+++-- Elimination++-- | Map over the targets of an 'Fresnel.Iso.Iso', 'Fresnel.Lens.Lens', 'Fresnel.Optional.Optional', or 'Traversal', collecting the results.+--+-- @+-- 'traverse1Of' . 'traversal1' = 'id'+-- 'traverse1Of' 'traversed1' = 'traverse1'+-- @+traverse1Of :: Apply f => Traversal1 s t a b -> ((a -> f b) -> (s -> f t))+traverse1Of o = runStar1 #. o .# Star1++for1Of :: Apply f => Traversal1 s t a b -> (s -> (a -> f b) -> f t)+for1Of o = flip (traverse1Of o)++sequence1Of :: Apply f => Traversal1 s t (f b) b -> (s -> f t)+sequence1Of o = traverse1Of o id++transposeOf :: Traversal1 s t (NonEmpty a) a -> s -> NonEmpty t+transposeOf o = getZipList #. traverse1Of o ZipList++newtype ZipList a = ZipList { getZipList :: NonEmpty a }++instance Functor ZipList where+  fmap f (ZipList as) = ZipList (fmap f as)++instance Apply ZipList where+  liftF2 f (ZipList as) (ZipList bs) = ZipList (zipWith f as bs)

@@ -0,0 +1,20 @@+module Fresnel.Traversal1.Internal+( IsTraversal1+) where++import Control.Arrow (Kleisli)+import Data.Functor.Apply+import Data.Profunctor (Forget, Star)+import Fresnel.Lens.Internal (IsLens)+import Fresnel.Profunctor.OptionalStar (OptionalStar)+import Fresnel.Profunctor.Star1 (Star1)+import Fresnel.Profunctor.Traversing1 (Traversing1)++class (IsLens p, Traversing1 p) => IsTraversal1 p++instance IsTraversal1 (->)+instance Monad m => IsTraversal1 (Kleisli m)+instance Semigroup r => IsTraversal1 (Forget r)+instance Applicative f => IsTraversal1 (Star f)+instance Apply f => IsTraversal1 (Star1 f)+instance Apply f => IsTraversal1 (OptionalStar f)

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} module Fold.Test@@ -26,10 +27,35 @@ 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  +prop_iterated (Fn f) a (MostlyPositive n) = classifyInt n $ take n (toListOf (iterated f) a) === take n (iterate f a)+++prop_filtered (Fn p) as+  = classify (not (any p as)) "reject all"+  . classify (all p as) "accept all"+  . classifyList as+  $ toListOf (folded.filtered p) as === filter p as+++prop_repeated (MostlyPositive n) a = classifyInt n $ take n (toListOf repeated a) === take n (repeat a)+++prop_replicated (MostlyPositive n) a = classifyInt n $ toListOf (replicated n) a === replicate n a+++prop_cycled (NonEmpty as) (NonNegative n) = classifyList as $ take n (toListOf (cycled folded) as) === take n (cycle as)+++prop_takingWhile (Fn p) as = classifyList as $ toListOf (takingWhile p folded) as === takeWhile p as++ classifyList :: Testable prop => [a] -> prop -> Property classifyList as = classify (null as) "empty" . classify (length as == 1) "singleton" +classifyInt :: Testable prop => Int -> prop -> Property+classifyInt n = classify (n == 0) "zero" . classify (n < 0) "negative" + newtype ArbFold a = ArbFold (Fold [a] a)  instance Show a => Show (ArbFold a) where@@ -44,6 +70,19 @@     where     ixed :: Int -> ArbFold a     ixed i = ArbFold (ix i)+++newtype MostlyPositive a = MostlyPositive { getMostlyPositive :: a }+  deriving (Eq, Num, Ord, Show)++instance (Arbitrary a, Num a, Ord a) => Arbitrary (MostlyPositive a) where+  arbitrary = MostlyPositive <$> frequency+    [ (90, getPositive <$> arbitrary)+    , (5, pure 0)+    , (5, getNegative <$> arbitrary)+    ]++  shrink (MostlyPositive a) = [MostlyPositive a' | a' <- shrink a, signum a' == signum a]   pure []

@@ -7,7 +7,7 @@ import Test.Group import Test.QuickCheck -prop_view_to_involution f x = view (to (applyFun f)) x === applyFun f x+prop_view_to_involution (Fn f) x = view (to f) x === f x   pure []

@@ -23,9 +23,9 @@ 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_view_elimination (Fn f) (Fn g) x = view (iso f g) x === f x -prop_review_elimination f g x = review (iso (applyFun f) (applyFun g)) x === applyFun g x+prop_review_elimination (Fn f) (Fn g) x = review (iso f g) x === g x   prop_constant_validity c s a = withRoundtrips (constant c) $ \ sasa aa ->

@@ -6,7 +6,7 @@ import Test.Group import Test.QuickCheck -prop_review_unto_involution f x = review (unto (applyFun f)) x === applyFun f x+prop_review_unto_involution (Fn f) x = review (unto f) x === f x   pure []

@@ -18,6 +18,7 @@ import           Test.Group import           Test.Options import           Test.Run+import qualified Traversal.Test import qualified Tropical.Test  main :: IO ()@@ -31,5 +32,6 @@   , Monoid.Fork.Test.tests   , Profunctor.Coexp.Test.tests   , Review.Test.tests+  , Traversal.Test.tests   , Tropical.Test.tests   ]

@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell #-}+module Traversal.Test+( tests+) where++import Fresnel.Traversal+import Test.Group+import Test.QuickCheck++prop_ignored (Fn f) a = traverseOf ignored f a === [a]+++pure []++tests :: Entry+tests = $deriveGroup