diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,36 @@ +2.0.0 (Changes from 1.2.4) +========================== +This new release continues to explore the design of Van Laarhoven style +optics with new support for adapters, grates, grids[2], and prisms. + +To bring support to these new optics necessarily mean moving a little +further away from syntactic compatibility with Kmett's lens library. +In particular, lens-family's 'under' is unrelated to Kmett's lens +library's 'under' combinator. Nonetheless the 'under' combinator plays +a crucial role in lens-family as a dual to the 'over' combinator and +this naming is hard to resist despite the conflict. + +This new version comes with some minor incompatibilities with the version +1.0 library that may require user updates: + +* 'backwards' has moved into the "Stock" module. +* '_Left' and '_Right' have been renamed as 'lft_' and 'rgt_'. +* '_Just' and '_Nothing' have been renamed as 'some_' and 'none_'. +* 'both' has been renamed 'both_'. +* 'beside' has been renamed 'beside_'. +* 'iso' has been removed, however its functionality can be replicated by + a combination of 'adapter' and 'under'. +* Haskell 98 is no longer supportable. + +[1] +[2]A grid is an optic that is both a grate and a traversal. + +1.2.4 (Changes from 1.2.3) +========================== +* Add 'matching' operator +* Correct lower bound on transformers +* Expand Applicative imports to broaden compatability + 1.2.3 (Changes from 1.2.2) ========================= * Bump dependency on containers diff --git a/lens-family-core.cabal b/lens-family-core.cabal --- a/lens-family-core.cabal +++ b/lens-family-core.cabal @@ -1,41 +1,52 @@ name: lens-family-core category: Data, Lenses -version: 1.2.3 +version: 2.0.0 license: BSD3 cabal-version: >= 1.6 license-file: LICENSE author: Russell O'Connor maintainer: Russell O'Connor stability: experimental -copyright: Copyright (C) 2012,2013,2014,2017 Russell O'Connor -synopsis: Haskell 98 Lens Families +copyright: Copyright (C) 2012,2013,2014,2017,2018,2019 Russell O'Connor +synopsis: Haskell 2022 Lens Families build-type: Simple extra-source-files: CHANGELOG -description: This package provides first class(†) functional references. - In addition to the usual operations of getting, setting and composition, plus integration with the state monad, lens families provide some unique features: +description: This package provides first class(†) functional references in Van Laarhoven style supporting the following optics: . - * Polymorphic updating + * Lenses (view, over) . - * Traversals + * Traversals (toListOf, matching, over) . - * Cast projection functions to read-only lenses + * Setters (over) . - * Cast \"toList\" functions to read-only traversals + * Grates (zipWithOf, under, review) . - * Cast semantic editor combinators to modify-only traversals. + * Resetters (under) . + * Adapters (view, review) + . + * Grids (toListOf, over / under, review) + . + * Prisms (matching, over / under, review) + . + * Getters (view) + . + * Folders (toListOf) + . + * Reviewers (review) + . (†) For optimal first-class support use the @lens-family@ package with rank 2 / rank N polymorphism. - "Lens.Family.Clone" allows for first-class support of lenses and traversals for those who require Haskell 98. + "Lens.Family.Clone" allows for first-class support of lenses and traversals for those who cannot support rank 2 polymorphism. source-repository head type: darcs - location: http://r6.ca/lens-family + location: https://hub.darcs.net/roconnor/lens-family library build-depends: - base >= 4.8 && < 5, + base >= 4.11 && < 5, containers >= 0.5.8 && < 0.7, - transformers >= 0.2.0 && < 0.6 + transformers >= 0.3.0 && < 0.6 exposed-modules: Lens.Family.Unchecked diff --git a/src/Lens/Family.hs b/src/Lens/Family.hs --- a/src/Lens/Family.hs +++ b/src/Lens/Family.hs @@ -1,5 +1,5 @@ -- | This is the main module for end-users of lens-families-core. --- If you are not building your own lenses or traversals, but just using functional references made by others, this is the only module you need. +-- If you are not building your own optics such as lenses, traversals, grates, etc., but just using optics made by others, this is the only module you need. module Lens.Family ( -- * Lenses -- @@ -23,7 +23,7 @@ -- @record & l1 .~ value1 & l2 .~ value2@ -- -- Lenses are implemented in van Laarhoven style. --- Lenses have type @'Functor' f => (b -> f b) -> a -> f a@ and lens families have type @'Functor' f => (b i -> f (b j)) -> a i -> f (a j)@. +-- Lenses have type @'Functor' f => (a -> f a) -> s -> f s@ and lens families have type @'Functor' f => (a i -> f (a j)) -> s i -> f (s j)@. -- -- Keep in mind that lenses and lens families can be used directly for functorial updates. -- For example, @_2 id@ gives you strength. @@ -34,13 +34,13 @@ -- -- > -- | 'sharedUpdate' returns the *identical* object if the update doesn't change anything. -- > -- This is useful for preserving sharing. --- > sharedUpdate :: Eq b => LensLike' Maybe a b -> (b -> b) -> a -> a --- > sharedUpdate l f a = fromMaybe a (l f' a) +-- > sharedUpdate :: Eq a => LensLike' Maybe s a -> (a -> a) -> s -> s +-- > sharedUpdate l f s = fromMaybe s (l f' s) -- > where --- > f' b | fb == b = Nothing --- > | otherwise = Just fb +-- > f' a | b == a = Nothing +-- > | otherwise = Just b -- > where --- > fb = f b +-- > b = f a -- * Traversals -- @@ -55,15 +55,78 @@ -- -- When '.~' is used with a traversal, all referenced fields will be set to the same value, and when '%~' is used with a traversal, all referenced fields will be modified with the same function. -- --- Like lenses, traversals can be composed with '.', and because every lens is automatically a traversal, lenses and traversals can be composed with '.' yielding a traversal. +-- A variant of '^?' call 'matching' returns 'Either' a 'Right' value which is the first value of the traversal, or a 'Left' value which is a "proof" that the traversal has no elements. +-- The "proof" consists of the original input structure, but in the case of polymorphic families, the type parameter is replaced with a fresh type variable, thus proving that the type parameter was unused. -- +-- Like all optics, traversals can be composed with '.', and because every lens is automatically a traversal, lenses and traversals can be composed with '.' yielding a traversal. +-- -- Traversals are implemented in van Laarhoven style. --- Traversals have type @'Applicative' f => (b -> f b) -> a -> f a@ and traversal families have type @'Applicative' f => (b i -> f (b j)) -> a i -> f (a j)@. +-- Traversals have type @'Applicative' f => (a -> f a) -> s -> f s@ and traversal families have type @'Applicative' f => (a i -> f (a j)) -> s i -> f (s j)@. -- --- For stock lenses and traversals, see "Lens.Family.Stock". + +-- * Grates -- --- To build your own lenses and traversals, see "Lens.Family.Unchecked". +-- | 'zipWithOf' can be used with grates to zip two structure together provided a binary operation. -- +-- 'under' can be to modify each value in a structure according to a function. This works analogous to how 'over' works for lenses and traversals. +-- +-- 'review' can be used with grates to construct a constant grate from a single value. This is like a 0-ary @zipWith@ function. +-- +-- 'degrating' can be used to build higher arity @zipWithOf@ functions: +-- +-- > zipWith3Of :: AGrate s t a b -> (a -> a -> a -> b) -> s -> s -> s -> t +-- > zipWith3Of l f s1 s2 s3 = degrating l (\k -> f (k s1) (k s2) (k s3)) +-- +-- Like all optics, grates can be composed with '.', and 'id' is the identity grate. +-- +-- Grates are implemented in van Laarhoven style. +-- +-- Grates have type @'Functor' g => (g a -> a) -> g s -> s@ and grate families have type @'Functor' g => (g (a i) -> a j) -> g (s i) -> s j@. +-- +-- Keep in mind that grates and grate families can be used directly for functorial zipping. For example, +-- +-- > both sum :: Num a => [(a, a)] -> (a, a) +-- +-- will take a list of pairs return the sum of the first components and the sum of the second components. For another example, +-- +-- > cod id :: Functor f => f (r -> a) -> r -> f a +-- +-- will turn a functor full of functions into a function returning a functor full of results. + +-- * Adapters, Grids, and Prisms +-- +-- | The Adapter, Prism, and Grid optics are all 'AdapterLike' optics and typically not used directly, but either converted to a 'LensLike' optic using 'under', or into a 'GrateLike' optic using 'over'. +-- See 'under' and 'over' for details about which conversions are possible. +-- +-- These optics are implemented in van Laarhoven style. +-- +-- * Adapters have type @('Functor' f, 'Functor' g) => (g a -> f a) -> g s -> f s@ and Adapters families have type @('Functor' f, 'Functor' g) => (g (a i) -> f (a j)) -> g (s i) -> f (s j)@. +-- +-- * Grids have type @('Applicative' f, 'Functor' g) => (g a -> f a) -> g s -> f s@ and Grids families have type @('Applicative' f, 'Functor' g) => (g (a i) -> f (a j)) -> g (s i) -> f (s j)@. +-- +-- * Prisms have type @('Applicative' f, 'Traversable' g) => (g a -> f a) -> g s -> f s@ and Prisms families have type @('Applicative' f, 'Traversable' g) => (g (a i) -> f (a j)) -> g (s i) -> f (s j)@. +-- +-- Keep in mind that these optics and their families can sometimes be used directly, without using 'over' and 'under'. Sometimes you can take advantage of the fact that +-- +-- @ +-- LensLike f (g s) t (g a) b +-- == +-- AdapterLike f g s t a b +-- == +-- GrateLike g s (f t) a (f b) +-- @ +-- +-- For example, if you have a grid for your structure to another type that has an @Arbitray@ instance, such as grid from a custom word type to 'Bool', e.g. @myWordBitVector :: (Applicative f, Functor g) => AdapterLike' f g MyWord Bool@, you can use the grid to create an @Arbitrary@ instance for your structure by directly applying 'review': +-- +-- > instance Arbitrary MyWord where +-- > arbitrary = review myWordBitVector arbitrary + +-- * Building and Finding Optics +-- +-- | To build your own optics, see "Lens.Family.Unchecked". +-- +-- For stock optics, see "Lens.Family.Stock". +-- -- References: -- -- * @@ -73,49 +136,68 @@ -- * -- -- * +-- +-- * -- * Documentation to, view, (^.) , folding, views, (^..), (^?) , toListOf, allOf, anyOf, firstOf, lastOf, sumOf, productOf , lengthOf, nullOf - , backwards + , matching , over, (%~), set, (.~) + , review, zipWithOf, degrating + , under, reset , (&) -- * Pseudo-imperatives , (+~), (*~), (-~), (//~), (&&~), (||~), (<>~) -- * Types + , AdapterLike, AdapterLike' , LensLike, LensLike' , FoldLike, FoldLike' + , GrateLike, GrateLike' + , AGrate, AGrate' , ASetter, ASetter' + , AResetter, AResetter' + , PCont + , First, Last , Phantom - , Constant, Identity -- * Re-exports - , Applicative, Foldable, Monoid - , Backwards, All, Any, First, Last, Sum, Product + , Constant, Identity, Prod + , All, Any, Sum, Product ) where -import Control.Applicative (Applicative) -import Control.Applicative.Backwards (Backwards(..)) -import Data.Foldable (Foldable, traverse_) -import Data.Functor.Identity (Identity(..)) +import Data.Foldable (traverse_) import Data.Functor.Constant (Constant(..)) -import Data.Monoid ( Monoid, mappend - , All(..), Any(..) - , First(..), Last(..) +import Data.Functor.Identity (Identity(..)) +import qualified Data.Functor.Product +import Data.Monoid ( All(..), Any(..) , Sum(..), Product(..) ) -import Lens.Family.Phantom (Phantom, coerce) -import Lens.Family.Unchecked ( LensLike, LensLike' ) +import Lens.Family.Phantom +import Lens.Family.Unchecked -type FoldLike r a a' b b' = LensLike (Constant r) a a' b b' -type FoldLike' r a b = LensLike' (Constant r) a b -type ASetter a a' b b' = LensLike Identity a a' b b' -type ASetter' a b = LensLike' Identity a b +type Prod = Data.Functor.Product.Product +newtype PCont i j a = PCont ((a -> j) -> i) -to :: Phantom f => (a -> b) -> LensLike f a a' b b' +instance Functor (PCont i j) where + fmap f (PCont h) = PCont $ \k -> h (k . f) + +runPCont :: PCont i a a -> i +runPCont (PCont h) = h id + +type FoldLike r s t a b = LensLike (Constant r) s t a b +type FoldLike' r s a = LensLike' (Constant r) s a +type AGrate s t a b = GrateLike (PCont b a) s t a b +type AGrate' s a = GrateLike' (PCont a a) s a +type ASetter s t a b = LensLike Identity s t a b +type ASetter' s a = LensLike' Identity s a +type AResetter s t a b = GrateLike Identity s t a b +type AResetter' s a = GrateLike' Identity s a + +to :: Phantom f => (s -> a) -> LensLike f s t a b -- ^ @ --- to :: (a -> b) -> Getter a a' b b' +-- to :: (s -> a) -> Getter s t a b -- @ -- -- 'to' promotes a projection function to a read-only lens called a getter. @@ -125,23 +207,23 @@ -- 5.0 :+ 0.0 to p f = coerce . f . p -view :: FoldLike b a a' b b' -> a -> b +view :: FoldLike a s t a b -> s -> a -- ^ @ --- view :: Getter a a' b b' -> a -> b +-- view :: Getter s t a b -> s -> a -- @ -- -- Demote a lens or getter to a projection function. -- -- @ --- view :: Monoid b => Fold a a' b b' -> a -> b +-- view :: Monoid a => Fold s t a b -> s -> a -- @ -- -- Returns the monoidal summary of a traversal or a fold. view l = (^.l) -folding :: (Foldable g, Phantom f, Applicative f) => (a -> g b) -> LensLike f a a' b b' +folding :: (Foldable g, Phantom f, Applicative f) => (s -> g a) -> LensLike f s t a b -- ^ @ --- folding :: (a -> [b]) -> Fold a a' b b' +-- folding :: (s -> [a]) -> Fold s t a b -- @ -- -- 'folding' promotes a \"toList\" function to a read-only traversal called a fold. @@ -149,51 +231,51 @@ -- To demote a traversal or fold to a \"toList\" function use the section @(^..l)@ or @toListOf l@. folding p f = coerce . traverse_ f . p -views :: FoldLike r a a' b b' -> (b -> r) -> a -> r +views :: FoldLike r s t a b -> (a -> r) -> s -> r -- ^ @ --- views :: Monoid r => Fold a a' b b' -> (b -> r) -> a -> r +-- views :: Monoid r => Fold s t a b -> (a -> r) -> s -> r -- @ -- -- Given a fold or traversal, return the 'foldMap' of all the values using the given function. -- -- @ --- views :: Getter a a' b b' -> (b -> r) -> a -> r +-- views :: Getter s t a b -> (a -> r) -> s -> r -- @ -- -- 'views' is not particularly useful for getters or lenses, but given a getter or lens, it returns the referenced value passed through the given function. -- -- @ --- views l f a = f (view l a) +-- views l f s = f (view l s) -- @ views l f = getConstant . l (Constant . f) -toListOf :: FoldLike [b] a a' b b' -> a -> [b] +toListOf :: FoldLike [a] s t a b -> s -> [a] -- ^ @ --- toListOf :: Fold a a' b b' -> a -> [b] +-- toListOf :: Fold s t a b -> s -> [a] -- @ -- -- Returns a list of all of the referenced values in order. toListOf l = views l (:[]) -allOf :: FoldLike All a a' b b' -> (b -> Bool) -> a -> Bool +allOf :: FoldLike All s t a b -> (a -> Bool) -> s -> Bool -- ^ @ --- allOf :: Fold a a' b b' -> (b -> Bool) -> a -> Bool +-- allOf :: Fold s t a b -> (a -> Bool) -> s -> Bool -- @ -- -- Returns true if all of the referenced values satisfy the given predicate. allOf l p = getAll . views l (All . p) -anyOf :: FoldLike Any a a' b b' -> (b -> Bool) -> a -> Bool +anyOf :: FoldLike Any s t a b -> (a -> Bool) -> s -> Bool -- ^ @ --- anyOf :: Fold a a' b b' -> (b -> Bool) -> a -> Bool +-- anyOf :: Fold s t a b -> (a -> Bool) -> s -> Bool -- @ -- -- Returns true if any of the referenced values satisfy the given predicate. anyOf l p = getAny . views l (Any . p) -firstOf :: FoldLike (First b) a a' b b' -> a -> Maybe b +firstOf :: FoldLike (First a) s t a b -> s -> Maybe a -- ^ @ --- firstOf :: Fold a a' b b' -> a -> Maybe b +-- firstOf :: Fold s t a b -> s -> Maybe a -- @ -- -- Returns 'Just' the first referenced value. @@ -201,42 +283,42 @@ -- See '^?' for an infix version of 'firstOf' firstOf l = getFirst . views l (First . Just) -lastOf :: FoldLike (Last b) a a' b b' -> a -> Maybe b +lastOf :: FoldLike (Last a) s t a b -> s -> Maybe a -- ^ @ --- lastOf :: Fold a a' b b' -> a -> Maybe b +-- lastOf :: Fold s t a b -> s -> Maybe a -- @ -- -- Returns 'Just' the last referenced value. -- Returns 'Nothing' if there are no referenced values. lastOf l = getLast . views l (Last . Just) -sumOf :: Num b => FoldLike (Sum b) a a' b b' -> a -> b +sumOf :: Num a => FoldLike (Sum a) s t a b -> s -> a -- ^ @ --- sumOf :: Num b => Fold a a' b b' -> a -> b +-- sumOf :: Num a => Fold s t a b -> s -> a -- @ -- -- Returns the sum of all the referenced values. sumOf l = getSum . views l Sum -productOf :: Num b => FoldLike (Product b) a a' b b' -> a -> b +productOf :: Num a => FoldLike (Product a) s t a b -> s -> a -- ^ @ --- productOf :: Num b => Fold a a' b b' -> a -> b +-- productOf :: Num a => Fold s t a b -> s -> a -- @ -- -- Returns the product of all the referenced values. productOf l = getProduct . views l Product -lengthOf :: Num r => FoldLike (Sum r) a a' b b' -> a -> r +lengthOf :: Num r => FoldLike (Sum r) s t a b -> s -> r -- ^ @ --- lengthOf :: Num r => Fold a a' b b' -> a -> r +-- lengthOf :: Num r => Fold s t a b -> s -> r -- @ -- -- Counts the number of references in a traversal or fold for the input. lengthOf l = getSum . views l (const (Sum 1)) -nullOf :: FoldLike All a a' b b' -> a -> Bool +nullOf :: FoldLike All s t a b -> s -> Bool -- ^ @ --- nullOf :: Fold a a' b b' -> a -> Bool +-- nullOf :: Fold s t a b -> s -> Bool -- @ -- -- Returns true if the number of references in the input is zero. @@ -244,104 +326,187 @@ infixl 8 ^. -(^.) :: a -> FoldLike b a a' b b' -> b +(^.) :: s -> FoldLike a s t a b -> a -- ^ @ --- (^.) :: a -> Getter a a' b b' -> b +-- (^.) :: s -> Getter s t a b -> a -- @ -- -- Access the value referenced by a getter or lens. -- -- @ --- (^.) :: Monoid b => a -> Fold a a' b b' -> b +-- (^.) :: Monoid a => s -> Fold s t a b -> a -- @ -- --- Access the monoidal summary referenced by a getter or lens. -x^.l = getConstant $ l Constant x +-- Access the monoidal summary referenced by a traversal or a fold. +s^.l = getConstant $ l Constant s infixl 8 ^.. -(^..) :: a -> FoldLike [b] a a' b b' -> [b] +(^..) :: s -> FoldLike [a] s t a b -> [a] -- ^ @ --- (^..) :: a -> Getter a a' b b' -> [b] +-- (^..) :: s -> Fold s t a b -> [a] -- @ -- -- Returns a list of all of the referenced values in order. -x^..l = toListOf l x +s^..l = toListOf l s infixl 8 ^? -(^?) :: a -> FoldLike (First b) a a' b b' -> Maybe b +(^?) :: s -> FoldLike (First a) s t a b -> Maybe a -- ^ @ --- (^?) :: a -> Fold a a' b b' -> Maybe b +-- (^?) :: s -> Fold s t a b -> Maybe a -- @ -- -- Returns 'Just' the first referenced value. -- Returns 'Nothing' if there are no referenced values. -x^?l = firstOf l x +s^?l = firstOf l s -backwards :: LensLike (Backwards f) a a' b b' -> LensLike f a a' b b' +matching :: LensLike (Either a) s t a b -> s -> Either t a -- ^ @ --- backwards :: Traversal a a' b b' -> Traversal a a' b b' --- backwards :: Fold a a' b b' -> Fold a a' b b' +-- matching :: Traversal s t a b -> s -> Either t a -- @ -- --- Given a traversal or fold, reverse the order that elements are traversed. +-- Returns 'Right' of the first referenced value. +-- Returns 'Left' the original value when there are no referenced values. +-- In case there are no referenced values, the result might have a fresh type parameter, thereby proving the original value had no referenced values. +matching l = either Right Left . l Left + +review :: GrateLike (Constant ()) s t a b -> b -> t +-- ^ @ +-- review :: Grate s t a b -> b -> t +-- review :: Reviewer s t a b -> b -> t +-- @ +review l b = l (const b) (Constant ()) + +zipWithOf :: GrateLike (Prod Identity Identity) s t a b -> (a -> a -> b) -> s -> s -> t +-- ^ @ +-- zipWithOf :: Grate s t a b -> (a -> a -> b) -> s -> s -> t +-- @ -- +-- Returns a binary instance of a grate. +-- -- @ --- backwards :: Lens a a' b b' -> Lens a a' b b' --- backwards :: Getter a a' b b' -> Getter a a' b b' --- backwards :: Setter a a' b b' -> Setter a a' b b' +-- zipWithOf l f x y = degrating l (\k -> f (k x) (k y)) -- @ +zipWithOf l f s1 s2 = l (\(Data.Functor.Product.Pair (Identity a1) (Identity a2)) -> f a1 a2) + (Data.Functor.Product.Pair (Identity s1) (Identity s2)) + +degrating :: AGrate s t a b -> ((s -> a) -> b) -> t +-- ^ @ +-- degrating :: Grate s t a b -> ((s -> a) -> b) -> t +-- @ -- --- No effect on lenses, getters or setters. -backwards l f = forwards . l (Backwards . f) +-- Demote a grate to its normal, higher-order function, form. +-- +-- @ +-- degrating . grate = id +-- grate . degrating = id +-- @ +degrating l = l runPCont . PCont --- | Demote a setter to a semantic editor combinator. -over :: ASetter a a' b b' -> (b -> b') -> a -> a' +under :: AResetter s t a b -> (a -> b) -> s -> t +-- ^ @ +-- under :: Resetter s t a b -> (a -> b) -> s -> t +-- @ +-- +-- Demote a resetter to a semantic editor combinator. +-- +-- @ +-- under :: Prism s t a b -> Traversal s t a b +-- under :: Grid s t a b -> Traversal s t a b +-- under :: Adapter s t a b -> Lens s t a b +-- @ +-- +-- Covert an 'AdapterLike' optic into a 'LensLike' optic. +-- +-- Note: this function is unrelated to the lens package's @under@ function. +under l f = l (f . runIdentity) . Identity + +reset :: AResetter s t a b -> b -> s -> t +-- ^ @ +-- reset :: Resetter s t a b -> b -> s -> t +-- @ +-- Set all referenced fields to the given value. +reset l b = under l (const b) + +over :: ASetter s t a b -> (a -> b) -> s -> t +-- ^ @ +-- over :: Setter s t a b -> (a -> b) -> s -> t +-- @ +-- Demote a setter to a semantic editor combinator. +-- +-- @ +-- over :: Prism s t a b -> Reviwer s t a b +-- over :: Grid s t a b -> Grate s t a b +-- over :: Adapter s t a b -> Grate s t a b +-- @ +-- +-- Covert an 'AdapterLike' optic into a 'GrateLike' optic. over l = (l %~) infixr 4 %~ -- | Modify all referenced fields. -(%~) :: ASetter a a' b b' -> (b -> b') -> a -> a' +(%~) :: ASetter s t a b -> (a -> b) -> s -> t l %~ f = runIdentity . l (Identity . f) infixr 4 .~ -- | Set all referenced fields to the given value. -(.~) :: ASetter a a' b b' -> b' -> a -> a' +(.~) :: ASetter s t a b -> b -> s -> t l .~ b = l %~ const b -- | Set all referenced fields to the given value. -set :: ASetter a a' b b' -> b' -> a -> a' +set :: ASetter s t a b -> b -> s -> t set = (.~) infixl 1 & -- | A flipped version of @($)@. -(&) :: a -> (a -> b) -> b +(&) :: s -> (s -> t) -> t (&) = flip ($) infixr 4 +~, -~, *~ -(+~), (-~), (*~) :: Num b => ASetter' a b -> b -> a -> a -f +~ b = f %~ (+ b) -f -~ b = f %~ subtract b -f *~ b = f %~ (* b) +(+~), (-~), (*~) :: Num a => ASetter s t a a -> a -> s -> t +l +~ a = l %~ (+ a) +l -~ a = l %~ subtract a +l *~ a = l %~ (* a) infixr 4 //~ -(//~) :: Fractional b => ASetter' a b -> b -> a -> a -f //~ b = f %~ (/ b) +(//~) :: Fractional a => ASetter s t a a -> a -> s -> t +l //~ a = l %~ (/ a) infixr 4 &&~, ||~ -(&&~), (||~) :: ASetter' a Bool -> Bool -> a -> a -f &&~ b = f %~ (&& b) -f ||~ b = f %~ (|| b) +(&&~), (||~) :: ASetter s t Bool Bool -> Bool -> s -> t +l &&~ a = l %~ (&& a) +l ||~ a = l %~ (|| a) infixr 4 <>~ -- | Monoidally append a value to all referenced fields. -(<>~) :: (Monoid o) => ASetter' a o -> o -> a -> a -f <>~ o = f %~ (`mappend` o) +(<>~) :: (Monoid a) => ASetter s t a a -> a -> s -> t +l <>~ a = l %~ (<> a) + +-- Local copies of First and Last to hide it from Data.Moniod's pending deprication +newtype First a = First { getFirst :: Maybe a } +newtype Last a = Last { getLast :: Maybe a } + +instance Monoid (First a) where + mempty = First Nothing + (First Nothing) `mappend` b = b + a `mappend` _ = a + +instance Monoid (Last a) where + mempty = Last Nothing + a `mappend` (Last Nothing) = a + _ `mappend` b = b + +instance Semigroup (First a) where + (<>) = mappend + +instance Semigroup (Last a) where + (<>) = mappend + diff --git a/src/Lens/Family/Clone.hs b/src/Lens/Family/Clone.hs --- a/src/Lens/Family/Clone.hs +++ b/src/Lens/Family/Clone.hs @@ -1,119 +1,145 @@ --- | This module is provided for Haskell 98 compatibility. +-- | This module is provided for "Haskell 2022" compatibility. -- If you are able to use @Rank2Types@, I advise you to instead use the rank 2 aliases -- +-- * @Adapter@, @Adapter'@ +-- +-- * @Prism@, @Prism'@ +-- -- * @Lens@, @Lens'@ -- -- * @Traversal@, @Traversal'@ -- -- * @Setter@, @Setter'@ -- +-- * @Grate@, @Grate'@ +-- +-- * @Resetter@, @Resetter'@ +-- +-- * @Grid@, @Grid'@ +-- -- * @Fold@, @Fold'@ -- -- * @Getter@, @Getter'@ -- +-- * @Reviewer@, @Reviewer'@ +-- -- from the @lens-family@ package instead. -- -- 'cloneLens' allows one to circumvent the need for rank 2 types by allowing one to take a universal monomorphic lens instance and rederive a polymorphic instance. --- When you require a lens family parameter you use the type @'ALens' a a' b b'@ (or @'ALens'' a b@). +-- When you require a lens family parameter you use the type @'ALens' s t a b@ (or @'ALens'' s a@). -- Then, inside a @where@ clause, you use 'cloneLens' to create a 'Lens' type. -- -- For example. -- --- > example :: ALens a a' b b' -> Example +-- > example :: ALens s t a b -> Example -- > example l = ... x^.cl ... cl .~ y ... -- > where -- > cl x = cloneLens l x -- -- /Note/: It is important to eta-expand the definition of 'cl' to avoid the dreaded monomorphism restriction. -- --- 'cloneTraversal', 'cloneGetter', 'cloneSetter', and 'cloneFold' provides similar functionality for traversals, getters, setters, and folds respectively. +-- 'cloneAdapter', 'cloneGrate', 'cloneTraversal', 'cloneSetter', 'cloneResetter', 'cloneGetter', and 'cloneFold' provides similar functionality for adapters, grates, traversals, setters, resetters, getters, and folds respectively. Unfortunately, it is not yet known how to clone prisms and grids. -- -- /Note/: Cloning is only need if you use a functional reference multiple times with different instances. module Lens.Family.Clone - ( cloneLens, cloneTraversal, cloneSetter, cloneGetter, cloneFold + ( cloneAdapter, cloneLens, cloneGrate, cloneTraversal, cloneSetter, cloneResetter, cloneGetter, cloneFold -- * Types + , AnAdapter, AnAdapter' , ALens, ALens' , ATraversal, ATraversal' , AGetter, AGetter' , AFold, AFold' - , IStore, IKleeneStore + , PStore, PKleeneStore -- * Re-exports - , LensLike, LensLike', FoldLike, FoldLike', ASetter - , Applicative, Phantom, Identical + , LensLike, LensLike', GrateLike, GrateLike', FoldLike, FoldLike', AGrate, ASetter, AResetter + , Phantom, Identical ) where -import Control.Applicative (Applicative, pure, (<*>), (<$>)) -import Lens.Family.Unchecked (Identical, setting) -import Lens.Family ( LensLike, LensLike' - , ASetter, over - , FoldLike, FoldLike', toListOf, folding - , to, view - , Phantom - ) +import Lens.Family.Unchecked +import Lens.Family -data IStore b b' a = IStore (b' -> a) b -instance Functor (IStore b b') where - fmap f (IStore g b) = IStore (f . g) b +data PStore i j a = PStore (j -> a) i +instance Functor (PStore i j) where + fmap f (PStore g i) = PStore (f . g) i --- | ALens a a' b b' is a universal Lens a a' b b' instance -type ALens a a' b b' = LensLike (IStore b b') a a' b b' +-- | AnAdapter s t a b is a universal Adapter s t a b instance +type AnAdapter s t a b = AdapterLike (PStore (s -> a) b) ((->) s) s t a b +-- | AnAdapter' s a is a universal Adapter' s a instance +type AnAdapter' s a = AdapterLike' (PStore (s -> a) a) ((->) s) s a --- | ALens' a b is a universal Lens' a b instance -type ALens' a b = LensLike' (IStore b b) a b +-- | Converts a universal adapter instance back into a polymorphic adapter. +cloneAdapter :: (Functor f, Functor g) => AnAdapter s t a b -> AdapterLike f g s t a b +cloneAdapter univ = adapter yin yang + where + PStore yang yin = univ (PStore id) id +-- | ALens s t a b is a universal Lens s t a b instance +type ALens s t a b = LensLike (PStore a b) s t a b + +-- | ALens' s a is a universal Lens' s a instance +type ALens' s a = LensLike' (PStore a a) s a + -- | Converts a universal lens instance back into a polymorphic lens. -cloneLens :: Functor f => ALens a a' b b' -> LensLike f a a' b b' -cloneLens univ f = experiment f . univ (IStore id) +cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b +cloneLens univ f = experiment f . univ (PStore id) -experiment :: Functor f => (b -> f b') -> IStore b b' a -> f a -experiment f (IStore g b) = g <$> f b +experiment :: Functor f => (a -> f b) -> PStore a b t -> f t +experiment f (PStore g a) = g <$> f a -data IKleeneStore b b' a = Unit a - | Battery (IKleeneStore b b' (b' -> a)) b +data PKleeneStore i j a = Unit a + | Battery (PKleeneStore i j (j -> a)) i -instance Functor (IKleeneStore b b') where +instance Functor (PKleeneStore i j) where fmap f (Unit a) = Unit (f a) - fmap f (Battery g b) = Battery (fmap (f .) g) b + fmap f (Battery g i) = Battery (fmap (f .) g) i -instance Applicative (IKleeneStore b b') where +instance Applicative (PKleeneStore i j) where pure = Unit - Unit f <*> a = fmap f a + Unit f <*> a = f <$> a Battery f b <*> a = Battery (flip <$> f <*> a) b --- | ATraversal a a' b b' is a universal Traversal a a' b b' instance -type ATraversal a a' b b' = LensLike (IKleeneStore b b') a a' b b' +-- | ATraversal s t a b is a universal Traversal s t a b instance +type ATraversal s t a b = LensLike (PKleeneStore a b) s t a b -- | ATraversal' a b is a universal Traversal' a b instance -type ATraversal' a b = LensLike' (IKleeneStore b b) a b +type ATraversal' s a = LensLike' (PKleeneStore a a) s a -- | Converts a universal traversal instance back into a polymorphic traversal. -cloneTraversal :: Applicative f => ATraversal a a' b b' -> LensLike f a a' b b' +cloneTraversal :: Applicative f => ATraversal s t a b -> LensLike f s t a b cloneTraversal univ f = research f . univ (Battery (Unit id)) -research :: Applicative f => (b -> f b') -> IKleeneStore b b' a -> f a +research :: Applicative f => (a -> f b) -> PKleeneStore a b t -> f t research _ (Unit a) = pure a research f (Battery g b) = research f g <*> f b -- | Converts a universal setter instance back into a polymorphic setter. -cloneSetter :: Identical f => ASetter a a' b b' -> LensLike f a a' b b' +cloneSetter :: Identical f => ASetter s t a b -> LensLike f s t a b cloneSetter = setting . over --- | AFold a a' b b' is a universal Fold' a a' b b' instance -type AFold a a' b b' = FoldLike [b] a a' b b' +-- | AFold s t a b is a universal Fold s t a b instance +type AFold s t a b = FoldLike [a] s t a b --- | AFold' a b is a universal Fold' a b instance -type AFold' a b = FoldLike' [b] a b +-- | AFold' s a is a universal Fold' s a instance +type AFold' s a = FoldLike' [a] s a -- | Converts a universal fold instance back into a polymorphic fold. -cloneFold :: (Phantom f, Applicative f) => AFold a a' b b' -> LensLike f a a' b b' +cloneFold :: (Phantom f, Applicative f) => AFold s t a b -> LensLike f s t a b cloneFold univ = folding (toListOf univ) --- | AGetter a a' b b' is a universal Fold a a' b b' instance -type AGetter a a' b b' = FoldLike b a a' b b' +-- | Converts a universal resetter instance back into a polymorphic resetter. +cloneResetter :: Identical f => AResetter s t a b -> GrateLike f s t a b +cloneResetter = resetting . under --- | AGetter' a b is a universal Fold' a b instance -type AGetter' a b = FoldLike' b a b +-- | AGetter s t a b is a universal Getter s t a b instance +type AGetter s t a b = FoldLike a s t a b +-- | AGetter' s a is a universal Getter' s a instance +type AGetter' s a = FoldLike' a s a + -- | Converts a universal getter instance back into a polymorphic getter. -cloneGetter :: Phantom f => AGetter a a' b b' -> LensLike f a a' b b' +cloneGetter :: Phantom f => AGetter s t a b -> LensLike f s t a b cloneGetter univ = to (view univ) + +-- | Converts a universal grate instance back into a polymorphic grater. +cloneGrate :: Functor g => AGrate s t a b -> GrateLike g s t a b +cloneGrate = grate . degrating diff --git a/src/Lens/Family/Identical.hs b/src/Lens/Family/Identical.hs --- a/src/Lens/Family/Identical.hs +++ b/src/Lens/Family/Identical.hs @@ -5,7 +5,7 @@ import Data.Functor.Compose (Compose(..)) -- It would really be much better if comonads was in tranformers -class Applicative f => Identical f where +class (Traversable f, Applicative f) => Identical f where extract :: f a -> a instance Identical Identity where diff --git a/src/Lens/Family/State.hs b/src/Lens/Family/State.hs --- a/src/Lens/Family/State.hs +++ b/src/Lens/Family/State.hs @@ -1,4 +1,4 @@ -module Lens.Family.State +module Lens.Family.State ( module Lens.Family.State.Lazy ) where diff --git a/src/Lens/Family/State/Lazy.hs b/src/Lens/Family/State/Lazy.hs --- a/src/Lens/Family/State/Lazy.hs +++ b/src/Lens/Family/State/Lazy.hs @@ -26,70 +26,64 @@ , FoldLike, Constant , ASetter, ASetter', Identity , StateT, Writer - , Monoid ) where -import Data.Monoid (Monoid, mappend) -import Data.Tuple (swap) import Control.Monad (liftM) import Control.Monad.Trans.Writer.Lazy (Writer, writer, runWriter) import Control.Monad.Trans.State.Lazy (StateT(..), state, get, modify, modify') -import Lens.Family ( LensLike, LensLike' - , FoldLike, Constant - , ASetter, ASetter', Identity - , view, views, (%~) - ) -import Lens.Family.State.Zoom (Zooming(..)) +import Data.Tuple (swap) +import Lens.Family +import Lens.Family.State.Zoom {- all these Monad constraints could be weakened to Functor or Applicative constraints -} -zoom :: Monad m => LensLike' (Zooming m c) a b -> StateT b m c -> StateT a m c +zoom :: Monad m => LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c -- ^ @ --- zoom :: Monad m => Lens' a b -> StateT b m c -> StateT a m c +-- zoom :: Monad m => Lens' s a -> StateT a m c -> StateT s m c -- @ -- -- Lift a stateful operation on a field to a stateful operation on the whole state. -- This is a good way to call a \"subroutine\" that only needs access to part of the state. -- -- @ --- zoom :: (Monoid c, Monad m) => Traversal' a b -> StateT b m c -> StateT a m c +-- zoom :: (Monad m, Monoid c) => Traversal' s a -> StateT a m c -> StateT s m c -- @ -- -- Run the \"subroutine\" on each element of the traversal in turn and 'mconcat' all the results together. -- -- @ --- zoom :: Monad m => Traversal' a b -> StateT b m () -> StateT a m () +-- zoom :: Monad m => Traversal' s a -> StateT a m () -> StateT s m () -- @ -- -- Run the \"subroutine\" on each element the traversal in turn. zoom l m = StateT $ unZooming . l (Zooming . (runStateT m)) -use :: Monad m => FoldLike b a a' b b' -> StateT a m b +use :: Monad m => FoldLike a s t a b -> StateT s m a -- ^ @ --- use :: Monad m => Getter a a' b b' -> StateT a m b +-- use :: Monad m => Getter s t a b -> StateT s m a -- @ -- -- Retrieve a field of the state -- -- @ --- use :: (Monoid b, Monad m) => Fold a a' b b' -> StateT a m b +-- use :: (Monad m, Monoid a) => Fold s t a b -> StateT s m a -- @ -- -- Retrieve a monoidal summary of all the referenced fields from the state use l = view l `liftM` get -uses :: Monad m => FoldLike r a a' b b' -> (b -> r) -> StateT a m r +uses :: Monad m => FoldLike r s t a b -> (a -> r) -> StateT s m r -- ^ @ --- uses :: (Monoid r, Monad m) => Fold a a' b b' -> (b -> r) -> StateT a m r +-- uses :: (Monad m, Monoid r) => Fold s t a b -> (a -> r) -> StateT s m r -- @ -- --- Retrieve all the referenced fields from the state and foldMap the results together with @f :: b -> r@. +-- Retrieve all the referenced fields from the state and foldMap the results together with @f :: a -> r@. -- -- @ --- uses :: Monad m => Getter a a' b b' -> (b -> r) -> StateT a m r +-- uses :: Monad m => Getter s t a b -> (a -> r) -> StateT s m r -- @ -- --- Retrieve a field of the state and pass it through the function @f :: b -> r@. +-- Retrieve a field of the state and pass it through the function @f :: a -> r@. -- -- @uses l f = f \<$> use l@ uses l f = views l f `liftM` get @@ -97,36 +91,36 @@ infix 4 %= -- | Modify a field of the state. -(%=) :: Monad m => ASetter a a b b' -> (b -> b') -> StateT a m () +(%=) :: Monad m => ASetter s s a b -> (a -> b) -> StateT s m () l %= f = modify (l %~ f) infix 4 .= -- | Set a field of the state. -(.=) :: Monad m => ASetter a a b b' -> b' -> StateT a m () +(.=) :: Monad m => ASetter s s a b -> b -> StateT s m () l .= v = l %= const v -- | Set a field of the state. -assign :: Monad m => ASetter a a b b' -> b' -> StateT a m () +assign :: Monad m => ASetter s s a b -> b -> StateT s m () assign = (.=) infixr 2 <~ -- | Set a field of the state using the result of executing a stateful command. -(<~) :: Monad m => ASetter a a b b' -> StateT a m b' -> StateT a m () +(<~) :: Monad m => ASetter s s a b -> StateT s m b -> StateT s m () l <~ v = assign l =<< v infix 4 %%= -(%%=) :: Monad m => LensLike (Writer c) a a b b' -> (b -> (c, b')) -> StateT a m c +(%%=) :: Monad m => LensLike (Writer c) s s a b -> (a -> (c, b)) -> StateT s m c -- ^ @ --- (%%=) :: Monad m => Lens a a b b' -> (b -> (c, b')) -> StateT a m c +-- (%%=) :: Monad m => Lens s s a b -> (a -> (c, b)) -> StateT s m c -- @ -- -- Modify a field of the state while returning another value. -- -- @ --- (%%=) :: (Monad m, Monoid c) => Traversal a a b b' -> (b -> (c, b')) -> StateT a m c +-- (%%=) :: (Monad m, Monoid c) => Traversal s s a b -> (a -> (c, b)) -> StateT s m c -- @ -- -- Modify each field of the state and return the 'mconcat' of the other values. @@ -134,53 +128,53 @@ infixr 4 +=, -=, *= -(+=), (-=), (*=) :: (Monad m, Num b) => ASetter' a b -> b -> StateT a m () -f += b = f %= (+ b) -f -= b = f %= subtract b -f *= b = f %= (* b) +(+=), (-=), (*=) :: (Monad m, Num a) => ASetter' s a -> a -> StateT s m () +l += a = l %= (+ a) +l -= a = l %= subtract a +l *= a = l %= (* a) infixr 4 //= -(//=) :: (Monad m, Fractional b) => ASetter' a b -> b -> StateT a m () -f //= b = f %= (/ b) +(//=) :: (Monad m, Fractional a) => ASetter' s a -> a -> StateT s m () +l //= a = l %= (/ a) infixr 4 &&=, ||= -(&&=), (||=) :: Monad m => ASetter' a Bool -> Bool -> StateT a m () -f &&= b = f %= (&& b) -f ||= b = f %= (|| b) +(&&=), (||=) :: Monad m => ASetter' s Bool -> Bool -> StateT s m () +l &&= a = l %= (&& a) +l ||= a = l %= (|| a) infixr 4 <>= -- | Monoidally append a value to all referenced fields of the state. -(<>=) :: (Monoid o, Monad m) => ASetter' a o -> o -> StateT a m () -f <>= b = f %= (`mappend` b) +(<>=) :: (Monad m, Monoid a) => ASetter' s a -> a -> StateT s m () +l <>= a = l %= (<> a) infix 4 %!= -- | Strictly modify a field of the state. -(%!=) :: Monad m => ASetter a a b b' -> (b -> b') -> StateT a m () +(%!=) :: Monad m => ASetter s s a b -> (a -> b) -> StateT s m () l %!= f = modify' (l %~ f) infixr 4 +!=, -!=, *!= -(+!=), (-!=), (*!=) :: (Monad m, Num b) => ASetter' a b -> b -> StateT a m () -f +!= b = f %!= (+ b) -f -!= b = f %!= subtract b -f *!= b = f %!= (* b) +(+!=), (-!=), (*!=) :: (Monad m, Num a) => ASetter' s a -> a -> StateT s m () +l +!= a = l %!= (+ a) +l -!= a = l %!= subtract a +l *!= a = l %!= (* a) infixr 4 //!= -(//!=) :: (Monad m, Fractional b) => ASetter' a b -> b -> StateT a m () -f //!= b = f %!= (/ b) +(//!=) :: (Monad m, Fractional a) => ASetter' s a -> a -> StateT s m () +l //!= a = l %!= (/ a) infixr 4 &&!=, ||!= -(&&!=), (||!=) :: Monad m => ASetter' a Bool -> Bool -> StateT a m () -f &&!= b = f %!= (&& b) -f ||!= b = f %!= (|| b) +(&&!=), (||!=) :: Monad m => ASetter' s Bool -> Bool -> StateT s m () +l &&!= a = l %!= (&& a) +l ||!= a = l %!= (|| a) infixr 4 <>!= -(<>!=) :: (Monoid o, Monad m) => ASetter' a o -> o -> StateT a m () -f <>!= b = f %!= (`mappend` b) +(<>!=) :: (Monad m, Monoid a) => ASetter' s a -> a -> StateT s m () +l <>!= a = l %!= (<> a) diff --git a/src/Lens/Family/State/Strict.hs b/src/Lens/Family/State/Strict.hs --- a/src/Lens/Family/State/Strict.hs +++ b/src/Lens/Family/State/Strict.hs @@ -26,70 +26,64 @@ , FoldLike, Constant , ASetter, ASetter', Identity , StateT, Writer - , Monoid ) where -import Data.Monoid (Monoid, mappend) -import Data.Tuple (swap) import Control.Monad (liftM) -import Control.Monad.Trans.Writer.Lazy (Writer, writer, runWriter) import Control.Monad.Trans.State.Strict (StateT(..), state, get, modify, modify') -import Lens.Family ( LensLike, LensLike' - , FoldLike, Constant - , ASetter, ASetter', Identity - , view, views, (%~) - ) -import Lens.Family.State.Zoom (Zooming(..)) +import Control.Monad.Trans.Writer.Lazy (Writer, writer, runWriter) +import Data.Tuple (swap) +import Lens.Family +import Lens.Family.State.Zoom {- all these Monad constraints could be weakened to Functor or Applicative constraints -} -zoom :: Monad m => LensLike' (Zooming m c) a b -> StateT b m c -> StateT a m c +zoom :: Monad m => LensLike' (Zooming m c) s a -> StateT a m c -> StateT s m c -- ^ @ --- zoom :: Monad m => Lens' a b -> StateT b m c -> StateT a m c +-- zoom :: Monad m => Lens' s a -> StateT a m c -> StateT s m c -- @ -- -- Lift a stateful operation on a field to a stateful operation on the whole state. -- This is a good way to call a \"subroutine\" that only needs access to part of the state. -- -- @ --- zoom :: (Monoid c, Monad m) => Traversal' a b -> StateT b m c -> StateT a m c +-- zoom :: (Monad m, Monoid c) => Traversal' s a -> StateT a m c -> StateT s m c -- @ -- -- Run the \"subroutine\" on each element of the traversal in turn and 'mconcat' all the results together. -- -- @ --- zoom :: Monad m => Traversal' a b -> StateT b m () -> StateT a m () +-- zoom :: Monad m => Traversal' s a -> StateT a m () -> StateT s m () -- @ -- -- Run the \"subroutine\" on each element the traversal in turn. zoom l m = StateT $ unZooming . l (Zooming . (runStateT m)) -use :: Monad m => FoldLike b a a' b b' -> StateT a m b +use :: Monad m => FoldLike a s t a b -> StateT s m a -- ^ @ --- use :: Monad m => Getter a a' b b' -> StateT a m b +-- use :: Monad m => Getter s t a b -> StateT s m a -- @ -- -- Retrieve a field of the state -- -- @ --- use :: (Monoid b, Monad m) => Fold a a' b b' -> StateT a m b +-- use :: (Monad m, Monoid a) => Fold s t a b -> StateT s m a -- @ -- -- Retrieve a monoidal summary of all the referenced fields from the state use l = view l `liftM` get -uses :: Monad m => FoldLike r a a' b b' -> (b -> r) -> StateT a m r +uses :: Monad m => FoldLike r s t a b -> (a -> r) -> StateT s m r -- ^ @ --- uses :: (Monoid r, Monad m) => Fold a a' b b' -> (b -> r) -> StateT a m r +-- uses :: (Monad m, Monoid r) => Fold s t a b -> (a -> r) -> StateT s m r -- @ -- --- Retrieve all the referenced fields from the state and foldMap the results together with @f :: b -> r@. +-- Retrieve all the referenced fields from the state and foldMap the results together with @f :: a -> r@. -- -- @ --- uses :: Monad m => Getter a a' b b' -> (b -> r) -> StateT a m r +-- uses :: Monad m => Getter s t a b -> (a -> r) -> StateT s m r -- @ -- --- Retrieve a field of the state and pass it through the function @f :: b -> r@. +-- Retrieve a field of the state and pass it through the function @f :: a -> r@. -- -- @uses l f = f \<$> use l@ uses l f = views l f `liftM` get @@ -97,36 +91,36 @@ infix 4 %= -- | Modify a field of the state. -(%=) :: Monad m => ASetter a a b b' -> (b -> b') -> StateT a m () +(%=) :: Monad m => ASetter s s a b -> (a -> b) -> StateT s m () l %= f = modify (l %~ f) infix 4 .= -- | Set a field of the state. -(.=) :: Monad m => ASetter a a b b' -> b' -> StateT a m () +(.=) :: Monad m => ASetter s s a b -> b -> StateT s m () l .= v = l %= const v -- | Set a field of the state. -assign :: Monad m => ASetter a a b b' -> b' -> StateT a m () +assign :: Monad m => ASetter s s a b -> b -> StateT s m () assign = (.=) infixr 2 <~ -- | Set a field of the state using the result of executing a stateful command. -(<~) :: Monad m => ASetter a a b b' -> StateT a m b' -> StateT a m () +(<~) :: Monad m => ASetter s s a b -> StateT s m b -> StateT s m () l <~ v = assign l =<< v infix 4 %%= -(%%=) :: Monad m => LensLike (Writer c) a a b b' -> (b -> (c, b')) -> StateT a m c +(%%=) :: Monad m => LensLike (Writer c) s s a b -> (a -> (c, b)) -> StateT s m c -- ^ @ --- (%%=) :: Monad m => Lens a a b b' -> (b -> (c, b')) -> StateT a m c +-- (%%=) :: Monad m => Lens s s a b -> (a -> (c, b)) -> StateT s m c -- @ -- -- Modify a field of the state while returning another value. -- -- @ --- (%%=) :: (Monad m, Monoid c) => Traversal a a b b' -> (b -> (c, b')) -> StateT a m c +-- (%%=) :: (Monad m, Monoid c) => Traversal s s a b -> (a -> (c, b)) -> StateT s m c -- @ -- -- Modify each field of the state and return the 'mconcat' of the other values. @@ -134,53 +128,53 @@ infixr 4 +=, -=, *= -(+=), (-=), (*=) :: (Monad m, Num b) => ASetter' a b -> b -> StateT a m () -f += b = f %= (+ b) -f -= b = f %= subtract b -f *= b = f %= (* b) +(+=), (-=), (*=) :: (Monad m, Num a) => ASetter' s a -> a -> StateT s m () +l += a = l %= (+ a) +l -= a = l %= subtract a +l *= a = l %= (* a) infixr 4 //= -(//=) :: (Monad m, Fractional b) => ASetter' a b -> b -> StateT a m () -f //= b = f %= (/ b) +(//=) :: (Monad m, Fractional a) => ASetter' s a -> a -> StateT s m () +l //= a = l %= (/ a) infixr 4 &&=, ||= -(&&=), (||=) :: Monad m => ASetter' a Bool -> Bool -> StateT a m () -f &&= b = f %= (&& b) -f ||= b = f %= (|| b) +(&&=), (||=) :: Monad m => ASetter' s Bool -> Bool -> StateT s m () +l &&= a = l %= (&& a) +l ||= a = l %= (|| a) infixr 4 <>= -- | Monoidally append a value to all referenced fields of the state. -(<>=) :: (Monoid o, Monad m) => ASetter' a o -> o -> StateT a m () -f <>= b = f %= (`mappend` b) +(<>=) :: (Monad m, Monoid a) => ASetter' s a -> a -> StateT s m () +l <>= a = l %= (<> a) infix 4 %!= -- | Strictly modify a field of the state. -(%!=) :: Monad m => ASetter a a b b' -> (b -> b') -> StateT a m () +(%!=) :: Monad m => ASetter s s a b -> (a -> b) -> StateT s m () l %!= f = modify' (l %~ f) infixr 4 +!=, -!=, *!= -(+!=), (-!=), (*!=) :: (Monad m, Num b) => ASetter' a b -> b -> StateT a m () -f +!= b = f %!= (+ b) -f -!= b = f %!= subtract b -f *!= b = f %!= (* b) +(+!=), (-!=), (*!=) :: (Monad m, Num a) => ASetter' s a -> a -> StateT s m () +l +!= a = l %!= (+ a) +l -!= a = l %!= subtract a +l *!= a = l %!= (* a) infixr 4 //!= -(//!=) :: (Monad m, Fractional b) => ASetter' a b -> b -> StateT a m () -f //!= b = f %!= (/ b) +(//!=) :: (Monad m, Fractional a) => ASetter' s a -> a -> StateT s m () +l //!= a = l %!= (/ a) infixr 4 &&!=, ||!= -(&&!=), (||!=) :: Monad m => ASetter' a Bool -> Bool -> StateT a m () -f &&!= b = f %!= (&& b) -f ||!= b = f %!= (|| b) +(&&!=), (||!=) :: Monad m => ASetter' s Bool -> Bool -> StateT s m () +l &&!= a = l %!= (&& a) +l ||!= a = l %!= (|| a) infixr 4 <>!= -(<>!=) :: (Monoid o, Monad m) => ASetter' a o -> o -> StateT a m () -f <>!= b = f %!= (`mappend` b) +(<>!=) :: (Monad m, Monoid a) => ASetter' s a -> a -> StateT s m () +l <>!= a = l %!= (<> a) diff --git a/src/Lens/Family/State/Zoom.hs b/src/Lens/Family/State/Zoom.hs --- a/src/Lens/Family/State/Zoom.hs +++ b/src/Lens/Family/State/Zoom.hs @@ -1,8 +1,6 @@ module Lens.Family.State.Zoom where -import Control.Applicative (Applicative, pure, (<*>)) import Control.Monad (liftM) -import Data.Monoid (Monoid, mempty, mappend) newtype Zooming m c a = Zooming { unZooming :: m (c, a) } @@ -14,4 +12,4 @@ Zooming f <*> Zooming x = Zooming $ do (a, f') <- f (b, x') <- x - return (a `mappend` b, f' x') + return (a <> b, f' x') diff --git a/src/Lens/Family/Stock.hs b/src/Lens/Family/Stock.hs --- a/src/Lens/Family/Stock.hs +++ b/src/Lens/Family/Stock.hs @@ -1,83 +1,106 @@ --- | This module contains lenses and traversals for common structures in Haskell. --- It also contains the combinators for lenses and traversals. +-- | This module contains lenses, prisms, grids, grates and traversals for common structures in Haskell. +-- It also contains the combinators for various kinds of optics. +-- +-- A Function name with @'@ is a grate variant of a grid, and a function name with @_@ is a traversal variants of a grid or prism. +-- For example, 'both'' is the grate variant of 'both' while 'both_' is the traversal variant. module Lens.Family.Stock ( --- * Lens Combinators - choosing - , alongside - , beside -- * Stock Lenses - , _1, _2 + _1, _2 , chosen , ix , at, intAt , at', intAt' , contains, intContains --- * Stock Traversals +-- * Stock Prisms + , lft, rgt + , some, none +-- * Stock Grids , both - , _Left, _Right - , _Just, _Nothing + , bend, lend +-- * Stock Grates + , cod + , both' + , bend', lend' +-- * Stock Traversals + , both_ + , bend_, lend_ + , lft_, rgt_ + , some_, none_ , ignored -- * Stock SECs , mapped +-- * Lens Combinators + , alongside + , backwards + , beside, beside', beside_ + , choosing + , from -- * Types , AlongsideLeft, AlongsideRight + , FromF, FromG -- * Re-exports + , AdapterLike, AdapterLike' , LensLike, LensLike' - , Applicative, Identical + , GrateLike, GrateLike' + , Identical, Backwards + , FiniteBits ) where import Control.Arrow (first, second) -import Control.Applicative (Applicative, pure, (<$>), (<*>)) -import Lens.Family (LensLike, LensLike') -import Lens.Family.Unchecked (lens, setting, Identical) -import Lens.Family.Phantom (Phantom, coerce) -import qualified Data.Map as Map +import Control.Applicative.Backwards (Backwards(..)) +import Control.Applicative (liftA2) +import Data.Bits (FiniteBits, (.|.), bit, finiteBitSize, testBit, zeroBits) import qualified Data.IntMap as IntMap -import qualified Data.Map.Strict as Map' import qualified Data.IntMap.Strict as IntMap' -import qualified Data.Set as Set import qualified Data.IntSet as IntSet +import qualified Data.Map as Map +import qualified Data.Map.Strict as Map' +import Data.Proxy (asProxyTypeOf) +import qualified Data.Set as Set +import Lens.Family +import Lens.Family.Phantom +import Lens.Family.Unchecked -choosing :: Functor f => LensLike f a a' c c' -> LensLike f b b' c c' -> LensLike f (Either a b) (Either a' b') c c' +choosing :: Functor f => LensLike f s0 t0 a b -> LensLike f s1 t1 a b -> LensLike f (Either s0 s1) (Either t0 t1) a b -- ^ @ --- choosing :: Lens a a' c c' -> Lens b b' c c' -> Lens (Either a b) (Either a' b') c c' +-- choosing :: Lens s0 t0 a b -> Lens s1 t1 a b -> Lens (Either s0 s1) (Either t0 t1) a b -- @ -- -- @ --- choosing :: Traversal a a' c c' -> Traversal b b' c c' -> Traversal (Either a b) (Either a' b') c c' +-- choosing :: Traversal s0 t0 a b -> Traversal s1 t1 a b -> Traversal (Either s0 s1) (Either t0 t1) a b -- @ -- -- @ --- choosing :: Getter a a' c c' -> Getter b b' c c' -> Getter (Either a b) (Either a' b') c c' +-- choosing :: Getter s0 t0 a b -> Getter s1 t1 a b -> Getter (Either s0 s1) (Either t0 t1) a b -- @ -- -- @ --- choosing :: Fold a a' c c' -> Fold b b' c c' -> Fold (Either a b) (Either a' b') c c' +-- choosing :: Fold s0 t0 a b -> Fold s1 t1 a b -> Fold (Either s0 s1) (Either t0 t1) a b -- @ -- -- @ --- choosing :: Setter a a' c c' -> Setter b b' c c' -> Setter (Either a b) (Either a' b') c c' +-- choosing :: Setter s0 t0 a b -> Setter s1 t1 a b -> Setter (Either s0 s1) (Either t0 t1) a b -- @ -- -- Given two lens\/traversal\/getter\/fold\/setter families with the same substructure, make a new lens\/traversal\/getter\/fold\/setter on 'Either'. -choosing la _ f (Left a) = Left `fmap` la f a -choosing _ lb f (Right b) = Right `fmap` lb f b +choosing la _ f (Left a) = Left <$> la f a +choosing _ lb f (Right b) = Right <$> lb f b -_1 :: Functor f => LensLike f (a, b) (a', b) a a' +_1 :: Functor f => LensLike f (a, r) (b, r) a b -- ^ @ --- _1 :: Lens (a, b) (a', b) a a' +-- _1 :: Lens (a, r) (b, r) a b -- @ -- -- Lens on the first element of a pair. -_1 f (a, b) = (\a' -> (a', b)) `fmap` f a +_1 f (a, r) = (\b -> (b, r)) <$> f a -_2 :: Functor f => LensLike f (a, b) (a, b') b b' +_2 :: Functor f => LensLike f (r, a) (r, b) a b -- ^ @ --- _2 :: Lens (a, b) (a, b') b b' +-- _2 :: Lens (r, a) (r, b) a b -- @ -- -- Lens on the second element of a pair. -_2 f (a, b) = (\b' -> (a, b')) `fmap` f b +_2 f (r, a) = (\b -> (r, b)) <$> f a chosen :: Functor f => LensLike f (Either a a) (Either b b) a b -- ^ @ @@ -93,7 +116,7 @@ -- @ -- -- Lens on a given point of a function. -ix k f g = (\v' x -> if (k == x) then v' else g x) `fmap` f (g k) +ix k f g = (\v' x -> if (k == x) then v' else g x) <$> f (g k) at :: (Ord k, Functor f) => k -> LensLike' f (Map.Map k v) (Maybe v) -- ^ @ @@ -143,82 +166,269 @@ -- Lens on a given point of a 'IntSet.IntSet'. intContains k = lens (IntSet.member k) (\m nv -> if nv then IntSet.insert k m else IntSet.delete k m) -_Left :: Applicative f => LensLike f (Either a b) (Either a' b) a a' +cod :: Functor g => GrateLike g (r -> a) (r -> b) a b -- ^ @ --- _Left :: Traversal (Either a b) (Either a' b) a a' +-- cod :: Grate (r -> a) (r -> b) a b -- @ -- +-- A grate accessing the codomain of a function. +cod f h r = f $ ($ r) <$> h + +lft :: (Applicative f, Traversable g) => AdapterLike f g (Either a r) (Either b r) a b +-- ^ @ +-- lft :: Prism (Either a r) (Either b r) a b +-- @ +-- +-- A prism on the 'Left' element of an 'Either'. +lft f = either (pure . Right) (fmap Left . f) . traverse switch + where + switch = either Right Left + +lft_ :: Applicative f => LensLike f (Either a r) (Either b r) a b +-- ^ @ +-- lft_ :: Traversal (Either a r) (Either b r) a b +-- @ +-- -- Traversal on the 'Left' element of an 'Either'. -_Left f (Left a) = Left <$> f a -_Left _ (Right b) = pure (Right b) +-- +-- @ +-- lft_ = under lft +-- @ +lft_ = under lft -_Right :: Applicative f => LensLike f (Either a b) (Either a b') b b' +rgt :: (Applicative f, Traversable g) => AdapterLike f g (Either r a) (Either r b) a b -- ^ @ --- _Right :: Traversal (Either a b) (Either a b') b b' +-- rgt :: Prism (Either r a) (Either r b) a b -- @ -- +-- A prism on the 'Right' element of an 'Either'. +rgt f = either (pure . Left) (fmap Right . f) . sequenceA + +rgt_ :: Applicative f => LensLike f (Either r a) (Either r b) a b +-- ^ @ +-- rgt_ :: Traversal (Either r a) (Either r b) a b +-- @ +-- -- Traversal on the 'Right' element of an 'Either'. -_Right f (Right b) = Right <$> f b -_Right _ (Left a) = pure (Left a) +-- +-- @ +-- rgt_ = under rgt +-- @ +rgt_ = under rgt -_Just :: Applicative f => LensLike f (Maybe a) (Maybe a') a a' +some :: (Applicative f, Traversable g) => AdapterLike f g (Maybe a) (Maybe b) a b -- ^ @ --- _Just :: Traversal (Maybe a) (Maybe a') a a' +-- some :: Prism (Maybe a) (Maybe b) a b -- @ -- +-- A prism on the 'Just' element of a 'Maybe'. +some f = maybe (pure Nothing) (fmap Just . f) . sequenceA + +some_ :: Applicative f => LensLike f (Maybe a) (Maybe b) a b +-- ^ @ +-- some_ :: Traversal (Maybe a) (Maybe b) a b +-- @ +-- -- Traversal on the 'Just' element of a 'Maybe'. -_Just f (Just a) = Just <$> f a -_Just _ Nothing = pure Nothing +some_ = under some -_Nothing :: Applicative f => LensLike' f (Maybe a) () +none :: (Applicative f, Traversable g) => AdapterLike' f g (Maybe a) () -- ^ @ --- _Nothing :: Traversal' (Maybe a) () +-- none :: Prism' (Maybe a) () -- @ -- +-- A prism on the 'Nothing' element of a 'Maybe'. +none = prism (maybe (Right ()) (Left . Just)) (const Nothing) + +none_ :: Applicative f => LensLike' f (Maybe a) () +-- ^ @ +-- none_ :: Traversal' (Maybe a) () +-- @ +-- -- Traversal on the 'Nothing' element of a 'Maybe'. -_Nothing f Nothing = const Nothing <$> f () -_Nothing _ j = pure j +none_ = under none -both :: Applicative f => LensLike f (a,a) (b,b) a b +both :: (Applicative f, Functor g) => AdapterLike f g (a,a) (b,b) a b -- ^ @ --- both :: Traversal (a,a) (b,b) a b +-- both :: Grid (a,a) (b,b) a b -- @ -- +-- A grid on both elements of a pair @(a,a)@. +both = beside id id + +both' :: Functor g => GrateLike g (a,a) (b,b) a b +-- ^ @ +-- both' :: Grate (a,a) (b,b) a b +-- @ +-- +-- A grate on both elements of a pair @(a,a)@. +-- +-- @ +-- both' = over both +-- @ +both' = beside' id id + +both_ :: Applicative f => LensLike f (a,a) (b,b) a b +-- ^ @ +-- both_ :: Traversal (a,a) (b,b) a b +-- @ +-- -- Traversals on both elements of a pair @(a,a)@. -both f (x,y) = (,) <$> f x <*> f y +-- +-- @ +-- both_ = under both +-- @ +both_ = beside_ id id -beside :: Applicative f => LensLike f a a' c c' -> LensLike f b b' c c' -> LensLike f (a,b) (a',b') c c' +lend :: (FiniteBits b, Applicative f, Functor g) => AdapterLike' f g b Bool -- ^ @ --- beside :: Traversal a a' c c' -> Traversal b' b' c c' -> Traversal (a,b) (a',b') c c' +-- lend :: FiniteBits b => Grid' b Bool -- @ -- +-- A grid from the least significant bit to the most significant bit of a 'FiniteBits' type. +-- +-- Little endian order. +lend f s = foldr (liftA2 (.|.)) (pure zeroBits) [mask i <$> f (flip testBit i <$> s) | i <- [0..finiteBitSize b-1]] + where + mask i True = bit i + mask _ False = zeroBits + b = b `asProxyTypeOf` s + +lend' :: (FiniteBits b, Functor g) => GrateLike' g b Bool +-- ^ @ +-- lend' :: FiniteBits b => Grate' b Bool -- @ --- beside :: Fold a a' c c' -> Fold b' b' c c' -> Fold (a,b) (a',b') c c' +-- +-- A grate from the least significant bit to the most significant bit of a 'FiniteBits' type. +-- +-- Little endian order. +-- -- @ +-- lend' = over lend +-- @ +lend' = over lend + +lend_ :: (FiniteBits b, Applicative f) => LensLike' f b Bool +-- ^ @ +-- lend_ :: FiniteBits b => Traversal' b Bool +-- @ -- +-- A traversal from the least significant bit to the most significant bit of a 'FiniteBits' type. +-- +-- Little endian order. +-- -- @ --- beside :: Setter a a' c c' -> Setter b' b' c c' -> Setter (a,b) (a',b') c c' +-- lend_ = under lend -- @ +lend_ = under lend + +bend :: (FiniteBits b, Applicative f, Functor g) => AdapterLike' f g b Bool +-- ^ @ +-- bend :: FiniteBits b => Grid' b Bool +-- @ -- +-- A grid from the most significant bit to the least significant bit of a 'FiniteBits' type. +-- +-- Big endian order. +bend = backwards lend + +bend' :: (FiniteBits b, Functor g) => GrateLike' g b Bool +-- ^ @ +-- bend' :: FiniteBits b => Grate' b Bool +-- @ +-- +-- A grate from the most significant bit to the least significant bit of a 'FiniteBits' type. +-- +-- Big endian order. +-- +-- @ +-- bend' = over bend +-- @ +bend' = over bend + +bend_ :: (FiniteBits b, Applicative f) => LensLike' f b Bool +-- ^ @ +-- bend_ :: FiniteBits b => Traversal' b Bool +-- @ +-- +-- A traversal from the most significant bit to the least significant bit of a 'FiniteBits' type. +-- +-- Big endian order. +-- +-- @ +-- bend_ = under bend +-- @ +bend_ = under bend + +beside :: (Applicative f, Functor g) => AdapterLike f g s0 t0 a b -> AdapterLike f g s1 t1 a b -> AdapterLike f g (s0, s1) (t0, t1) a b +-- ^ @ +-- beside :: Grid s1 t1 a b -> Grid s2 t2 a b -> Grid (s1, s2) (t1, t2) a b +-- @ +-- +-- Given two grids referencing a type 'c', create a grid on the pair referencing 'c'. +beside la lb f s = (,) <$> la f (fst <$> s) <*> lb f (snd <$> s) + +beside' :: Functor g => GrateLike g s0 t0 a b -> GrateLike g s1 t1 a b -> GrateLike g (s0, s1) (t0, t1) a b +-- ^ @ +-- beside' :: Grate s0 t0 a b -> Grate s1 t1 a b -> Grate (s0, s1) (t0, t1) a b +-- @ +-- +-- @ +-- beside' :: Resetter s0 t0 a b -> Resetter s1 t1 a b -> Resetter (s0, s1) (t0, t1) a b +-- @ +-- +-- Given two grates\/resetters referencing a type 'c', create a grate\/resetter on the pair referencing 'c'. +beside' la lb = over $ beside (setting la) (setting lb) + +beside_ :: Applicative f => LensLike f s0 t0 a b -> LensLike f s1 t1 a b -> LensLike f (s0, s1) (t0, t1) a b +-- ^ @ +-- beside_ :: Traversal s0 t0 a b -> Traversal s1 t1 a b -> Traversal (s0, s1) (t0, t1) a b +-- @ +-- +-- @ +-- beside_ :: Fold s0 t0 a b -> Fold s1 t1 a b -> Fold (s0, s1) (t0, t1) a b +-- @ +-- +-- @ +-- beside_ :: Setter s0 t0 a b -> Setter s1 t1 a b -> Setter (s0, s1) (t0, t1) a b +-- @ +-- -- Given two traversals\/folds\/setters referencing a type 'c', create a traversal\/fold\/setter on the pair referencing 'c'. -beside la lb f (x,y) = (,) <$> la f x <*> lb f y +beside_ la lb = under $ beside (resetting la) (resetting lb) -ignored :: Applicative f => null -> a -> f a +ignored :: Applicative f => null -> s -> f s -- ^ @ --- ignored :: Traversal a a b b' +-- ignored :: Traversal s s a b -- @ -- -- The empty traversal on any type. ignored _ = pure -mapped :: (Identical f, Functor g) => LensLike f (g a) (g a') a a' +mapped :: (Identical f, Functor h) => LensLike f (h a) (h b) a b -- ^ @ --- mapped :: Functor g => Setter (g a) (g a') a a' +-- mapped :: Functor h => Setter (h a) (h b) a b -- @ -- -- An SEC referencing the parameter of a functor. mapped = setting fmap +backwards :: LensLike (Backwards f) s t a b -> LensLike f s t a b +-- ^ @ +-- backwards :: Traversal s t a b -> Traversal s t a b +-- backwards :: Fold s t a b -> Fold s t a b +-- @ +-- +-- Given a traversal or fold, reverse the order that elements are traversed. +-- +-- @ +-- backwards :: Lens s t a b -> Lens s t a b +-- backwards :: Getter s t a b -> Getter s t a b +-- backwards :: Setter s t a b -> Setter s t a b +-- @ +-- +-- No effect on lenses, getters or setters. +backwards l f = forwards . l (Backwards . f) + {- Alongside -} newtype AlongsideLeft f b a = AlongsideLeft (f (a, b)) @@ -237,22 +447,59 @@ instance Phantom f => Phantom (AlongsideRight f a) where coerce (AlongsideRight x) = AlongsideRight (coerce x) -alongside :: Functor f => LensLike (AlongsideLeft f b2') a1 a1' b1 b1' - -> LensLike (AlongsideRight f a1') a2 a2' b2 b2' - -> LensLike f (a1, a2) (a1', a2') (b1, b2) (b1', b2') +alongside :: Functor f => LensLike (AlongsideLeft f b1) s0 t0 a0 b0 + -> LensLike (AlongsideRight f t0) s1 t1 a1 b1 + -> LensLike f (s0, s1) (t0, t1) (a0, a1) (b0, b1) -- ^ @ --- alongside :: Lens a1 a1' b1 b1' -> Lens a2 a2' b2 b2' -> Lens (a1, a2) (a1', a2') (b1, b2) (b1', b2') +-- alongside :: Lens s0 t0 a0 b0 -> Lens s1 t1 a1 b1 -> Lens (s0, s1) (t0, t1) (a0, a1) (b0, b1) -- @ -- -- @ --- alongside :: Getter a1 a1' b1 b1' -> Getter a2 a2' b2 b2' -> Getter (a1, a2) (a1', a2') (b1, b2) (b1', b2') +-- alongside :: Getter s0 t0 a0 b0 -> Getter s1 t1 a1 b1 -> Getter (s0, s1) (t0, t1) (a0, a1) (b0, b1) -- @ -- -- Given two lens\/getter families, make a new lens\/getter on their product. -alongside l1 l2 f (a1, a2) = fa1'a2' +alongside l0 l1 f (s0, s1) = ft0t1 where - AlongsideRight fa1'a2' = l2 f2 a2 - f2 b2 = AlongsideRight fa1'b2' + AlongsideRight ft0t1 = l1 f1 s1 + f1 a1 = AlongsideRight ft0a1 where - AlongsideLeft fa1'b2' = l1 f1 a1 - f1 b1 = AlongsideLeft (f (b1, b2)) + AlongsideLeft ft0a1 = l0 f0 s0 + f0 a0 = AlongsideLeft (f (a0, a1)) + +{- From -} + +newtype FromF i j g x = FromF ((g x -> j) -> i) + +instance Functor g => Functor (FromF i j g) where + fmap f (FromF h) = FromF $ \k -> h (k . fmap f) + +instance Phantom g => Phantom (FromF i j g) where + coerce (FromF h) = FromF $ \k -> h (k . coerce) + +newtype FromG e f x = FromG (e -> f x) + +instance Functor f => Functor (FromG e f) where + fmap f (FromG h) = FromG $ fmap f . h + +instance Phantom g => Phantom (FromG e g) where + coerce (FromG h) = FromG $ coerce . h + +from :: (Functor f, Functor g) + => AdapterLike (FromF (g s -> f t) (f b) g) (FromG (f b) f) b a t s + -> AdapterLike f g s t a b +-- ^ @ +-- from :: Adapter b a t s -> Adapter s t a b +-- @ +-- +-- Reverses the direction of an adapter. +-- +-- @ +-- from :: Getter b a t s -> Reviewer s t a b +-- from :: Reviewer b a t s -> Getter s t a b +-- @ +-- +-- Changes a Getter into a Reviewer and vice versa. +from l = l' + where + FromF l' = l (\(FromG h1) -> FromF $ (.) h1) (FromG id) diff --git a/src/Lens/Family/Unchecked.hs b/src/Lens/Family/Unchecked.hs --- a/src/Lens/Family/Unchecked.hs +++ b/src/Lens/Family/Unchecked.hs @@ -1,71 +1,84 @@ -- | /Caution/: Improper use of this module can lead to unexpected behaviour if the preconditions of the functions are not met. module Lens.Family.Unchecked ( +-- * Adapters +-- | An adapter represents a isomorphism between two types or a parametric isomorphism between two families of types. +-- For example we can build an adapter between the type families @'Either' a a@ and @('Bool', a)@ as follows: +-- +-- > timesTwo :: (Functor f, Functor g) => AdapterLike f g (Either a a) (Either b b) (Bool, a) (Bool b) +-- > timesTwo f x = fmap yang . f . fmap yin +-- > where +-- > yin (True, a) = Left a +-- > yin (False, a) = Right a +-- > yang (Left a) = (True, a) +-- > yang (Right a) = (False, a) +-- +-- /Note/: It is possible to adapters without even depending on @lens-family-core@ by expanding away the type synonym. +-- +-- > timesTwo :: (Functor f, Functor g) => (g (Either a a) -> f (Either b b)) -> g (Bool, a) -> f (Bool, b) +-- +-- The function 'adapter' can also be used to construct adapters from a pair of mutually inverse functions. + -- * Lenses --- | A lens family is created by separating a substructure from the rest of its structure by a functor. +-- | A lens focuses on a field of record type. +-- Lenses can be used to get and/or set the focused field. -- How to create a lens family is best illustrated by the common example of a field of a record: -- --- > data MyRecord a = MyRecord { _myA :: a, _myB :: Int } +-- > data MyRecord a = MyRecord { _myA :: a, _myInt :: Int } -- > --- > -- The use of type variables a and a' allow for polymorphic updates. --- > myA :: Functor f => LensLike f (MyRecord a) (MyRecord a') a a' --- > myA f (MyRecord a b) = (\a' -> MyRecord a' b) `fmap` (f a) +-- > -- The use of type variables a and b allow for polymorphic updates. +-- > myA :: Functor f => LensLike f (MyRecord a) (MyRecord b) a b +-- > myA f (MyRecord a i) = (\b -> MyRecord b i) <$> f a -- > --- > -- The field _myB is monomorphic, so we can use a 'LensLike'' type. +-- > -- The field _myInt is monomorphic, so we can use a 'LensLike'' type. -- > -- However, the structure of the function is exactly the same as for LensLike. --- > myB :: Functor f => LensLike' f (MyRecord a) Int --- > myB f (MyRecord a b) = (\b' -> MyRecord a b') `fmap` (f b) +-- > myInt :: Functor f => LensLike' f (MyRecord a) Int +-- > myInt f (MyRecord a i) = (\i' -> MyRecord a i') <$> f i -- --- By following this template you can safely build your own lenses. --- To use this template, you do not need anything from this module other than the type synonyms 'LensLike' and 'LensLike'', and even they are optional. --- See the @lens-family-th@ package to generate this code using Template Haskell. +-- See the @lens-family-th@ package to generate this sort of code using Template Haskell. -- -- /Note/: It is possible to build lenses without even depending on @lens-family-core@ by expanding away the type synonym. -- --- > -- A lens definition that only requires the Haskell "Prelude". --- > myA :: Functor f => (a -> f a') -> (MyRecord a) -> f (MyRecord a') --- > myA f (MyRecord a b) = (\a' -> MyRecord a' b) `fmap` (f a) +-- > myA :: Functor f => (a -> f b) -> (MyRecord a) -> f (MyRecord b) -- -- You can build lenses for more than just fields of records. --- Any value @l :: Functor f => LensLike f a a' b b'@ is well-defined when it satisfies the two van Laarhoven lens laws: +-- Any value @l :: Functor f => LensLike f s t a b@ is well-defined when it satisfies the two van Laarhoven lens laws: -- -- * @l Identity === Identity@ -- -- * @l (Compose . fmap f . g) === Compose . fmap (l f) . (l g)@ -- --- The functions 'lens' and 'iso' can also be used to construct lenses. +-- The function 'lens' can also be used to construct lenses. -- The resulting lenses will be well-defined so long as their preconditions are satisfied. -- * Traversals --- -- | If you have zero or more fields of the same type of a record, a traversal can be used to refer to all of them in order. -- Multiple references are made by replacing the 'Functor' constraint of lenses with an 'Control.Applicative.Applicative' constraint. -- Consider the following example of a record with two 'Int' fields. -- --- > data MyRecord = MyRecord { _myA :: Int, _myB :: Int } +-- > data MyRecord = MyRecord { _myA :: Int, _myB :: Int, _myC :: Bool } -- > -- > -- myInts is a traversal over both fields of MyRecord. -- > myInts :: Applicative f => LensLike' f MyRecord Int --- > myInts f (MyRecord a b) = MyRecord <$> f a <*> f b +-- > myInts f (MyRecord a b c) = MyRecord <$> f a <*> f b <*> pure c -- --- If the record and the referenced fields are parametric, you can can build traversals with polymorphic updating. +-- If the record and the referenced fields are parametric, you can can build polymrphic traversals. -- Consider the following example of a record with two 'Maybe' fields. -- --- > data MyRecord a = MyRecord { _myA :: Maybe a, _myB :: Maybe a } +-- > data MyRecord a = MyRecord { _myA0 :: Maybe a, _myA1 :: Maybe a, myC :: Bool } -- > --- > -- myInts is a traversal over both fields of MyRecord. --- > myMaybes :: Applicative f => LensLike f (MyRecord a) (MyRecord a') (Maybe a) (Maybe a') --- > myMaybes f (MyRecord a b) = MyRecord <$> f a <*> f b +-- > -- myMaybes is a traversal over both fields of MyRecord. +-- > myMaybes :: Applicative f => LensLike f (MyRecord a) (MyRecord b) (Maybe a) (Maybe b) +-- > myMaybes f (MyRecord a0 a1 c) = MyRecord <$> f a0 <*> f a1 <*> pure c -- --- /Note/: As with lenses, is possible to build traversals without even depending on @lens-family-core@ by expanding away the type synonym. +-- /Note/: It is possible to build traversals without even depending on @lens-family-core@ by expanding away the type synonym. -- --- > -- A traversal definition that only requires the Haskell "Prelude". --- > myMaybes :: Applicative f => (Maybe a -> f (Maybe a')) -> MyRecord a -> f (MyRecord a') --- > myMaybes f (MyRecord a b) = MyRecord <$> f a <*> f b +-- > myMaybes :: Applicative f => (Maybe a -> f (Maybe b)) -> MyRecord a -> f (MyRecord b) +-- > myMaybes f (MyRecord a0 a1 c) = MyRecord <$> f a0 <*> f a1 <*> pure c -- --- Unfortuantely, there are no helper functions for making traversals. --- You must make them by hand. +-- Unfortunately, there are no helper functions for making traversals. +-- In most cases, you must make them by hand. -- --- Any value @t :: Applicative f => LensLike f a a' b b'@ is well-defined when it satisfies the two van Laarhoven traversal laws: +-- Any value @t :: Applicative f => LensLike f s t a b@ is well-defined when it satisfies the two van Laarhoven traversal laws: -- -- * @t Identity === Identity@ -- @@ -73,69 +86,228 @@ -- -- 'Data.Traversable.traverse' is the canonical traversal for various containers. +-- * Prisms +-- | A prism focuses on a single variant of a type. +-- They can be used to 'Lens.Family.matching' / 'Lens.Family.review' the focused variant. +-- Consider the following example. +-- +-- > data MySum a = MyA a | MyB Int +-- > +-- > -- myA is a prism for the MyA variant of MySum +-- > myA :: (Applicative f, Traversable g) => AdapterLike f g (MySum a) (MySum b) a b +-- > myA f = either pure (fmap MyA . f) . traverse h +-- > where +-- > h (MyA a) = Right a +-- > h (MyB n) = Left (MyB n) +-- +-- This prism can be used with 'Lens.Family.matching' via 'Lens.Family.under': +-- +-- @ 'Lens.Family.matching' ('Lens.Family.under' myA) :: MySum a -> Either (MySum b) a @ +-- +-- This prism can be used with 'Lens.Family.review' via 'Lens.Family.over': +-- +-- @ 'Lens.Family.review' ('Lens.Family.over' myA) :: a -> MySum a @ +-- +-- /Note/: It is possible to build prisms without even depending on @lens-family-core@ by expanding away the type synonym. +-- +-- > myA :: (Appicative f, Traversable g) => (g a -> f b) -> g (MySum a) -> f (MySum b) +-- +-- You can build prism for more than just constructors of sum types. +-- Any value @p :: (Applicative f, Traversable g) => AdapterLike f g s t a b@ is well-defined when it satisfies the prism laws: +-- +-- * @matching (under p) (review (over p) b) === Right b@ +-- +-- * @(id ||| review (over p)) (matching (under p) s) === s@ +-- +-- * @left (match (under p)) (matching (under p) s) === left Left (matching (under p) s)@ +-- +-- The function 'prism' can also be used to construct prisms. +-- The resulting prisms will be well-defined so long as their preconditions are satisfied. + +-- * Grates +-- | A grate focuses on the contents of a representable functor. +-- In other words, a grate focuses on the codomain of a function type or something isomorphic to a function type. +-- They are used to lift operations on this codomain to operations on the larger structure via zipping. +-- Consider the following example of a stream of 'Int's. +-- +-- > data IntStream = IntStream { hd :: Int, tl :: IntStream } +-- > +-- > -- myInts is a grate over the Ints of IntStream. +-- > myInts :: Functor g => GrateLike' g IntStream Int +-- > myInts f s = IntStream (f (hd <$> s)) (myInts f (tl <$> s)) +-- +-- If the contents are parametric, you can can build polymorphic grates. +-- Consider the following example of a generic stream. +-- +-- > data Stream a = Stream { hd :: a, tl :: Stream a } +-- > +-- > -- myStream is a grate over the contents of a Stream. +-- > myStream :: Functor g => GrateLike g (Stream a) (Stream b) a b +-- > myStream f s = Stream (f (hd <$> s)) (myStream f (tl <$> s)) +-- +-- /Note/: It is possible to build grates without even depending on @lens-family-core@ by expanding away the type synonym. +-- +-- > myStream :: Functor g => (g (Stream a) -> Stream b) -> g a -> b +-- +-- Any value @t :: Functor g => GrateLike g s t a b@ is a well-defined grate when it satisfies the two van Laarhoven traversal laws: +-- +-- * @t runIdentity === runIdentity@ +-- +-- * @t (f . fmap g . runCompose) === (t f) . fmap (t g) . runCompose@ +-- +-- The function 'grate' can also be used to construct grates from graters. +-- The resulting grates will be well-defined so long as the preconditions are satisfied. + +-- * Grids +-- | A grid is both a traversal and a grate. +-- When you have a type that is isomorphic to a fixed and finite number of copies of another type, a grid can be used to zip or traverse them. +-- Consider the following example of a record with exactly two 'Int' fields. +-- +-- > data MyRecord = MyRecord { _myA :: Int, _myB :: Int } +-- > +-- > -- myInts is a grid over both fields of MyRecord. +-- > myInts :: (Applicative f, Functor g) => AdapterLike' f g MyRecord Int +-- > myInts f r = MyRecord <$> f (_myA <$> r) <*> f (_myB <$> r) +-- +-- If the record and the referenced fields are parametric, you can can build polymorphic grids. +-- Consider the following example of a record with exactly two 'Maybe' fields. +-- +-- > data MyRecord a = MyRecord { _myA0 :: Maybe a, _myA1 :: Maybe a } +-- > +-- > -- myMaybes is a traversal over both fields of MyRecord. +-- > myMaybes :: (Applicative f, Functor g) => AdapterLike f g (MyRecord a) (MyRecord b) (Maybe a) (Maybe b) +-- > myMaybes f r = MyRecord <$> f (_myA0 <$> r) <*> f (_myA1 <$> r) +-- +-- A grid is converted into a grate by using the 'Lens.Family.over' function, and it is converted to a traversal by using the 'Lens.Family.under' function. +-- +-- /Note/: It is possible to build grids without even depending on @lens-family-core@ by expanding away the type synonym. +-- +-- > myMaybes :: (Applicative f, Functor g) => (g (Maybe a) -> f (Maybe b)) -> g (MyRecord a) -> f (MyRecord b) +-- +-- Unfortunately, there are no helper functions for making grids. +-- In most cases, you must make them by hand. + -- * Documentation - lens - , iso + adapter + , lens + , prism + , grate , setting + , resetting -- * Types + , AdapterLike, AdapterLike' , LensLike, LensLike' + , GrateLike, GrateLike' , Identical ) where -import Control.Applicative (pure) -import Lens.Family.Identical (Identical, extract) +import Lens.Family.Identical -type LensLike f a a' b b' = (b -> f b') -> (a -> f a') -type LensLike' f a b = (b -> f b) -> (a -> f a) +type AdapterLike f g s t a b = (g a -> f b) -> (g s -> f t) +type AdapterLike' f g s a = (g a -> f a) -> (g s -> f s) +type LensLike f s t a b = (a -> f b) -> (s -> f t) +type LensLike' f s a = (a -> f a) -> (s -> f s) +type GrateLike g s t a b = (g a -> b) -> (g s -> t) +type GrateLike' g s a = (g a -> a) -> (g s -> s) +adapter :: (Functor f, Functor g) + => (s -> a) -- ^ yin + -> (b -> t) -- ^ yang + -> AdapterLike f g s t a b +-- ^ @ +-- adapter :: (s -> a) -> (b -> t) -> Adapter s t a b +-- @ +-- +-- Build an adapter from an isomorphism family. +-- +-- /Caution/: In order for the generated adapter family to be well-defined, you must ensure that the two isomorphism laws hold: +-- +-- * @yin . yang === id@ +-- +-- * @yang . yin === id@ +adapter yin yang f s = yang <$> f (yin <$> s) + lens :: Functor f - => (a -> b) -- ^ getter - -> (a -> b' -> a') -- ^ setter - -> LensLike f a a' b b' + => (s -> a) -- ^ getter + -> (s -> b -> t) -- ^ setter + -> LensLike f s t a b -- ^ @ --- lens :: (a -> b) -> (a -> b' -> a') -> Lens a a' b b' +-- lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b -- @ -- --- Build a lens from a @getter@ and @setter@ families. +-- Build a lens from a @getter@ and @setter@ family. -- -- /Caution/: In order for the generated lens family to be well-defined, you must ensure that the three lens laws hold: --- --- * @getter (setter a b) === b@ -- --- * @setter a (getter a) === a@ +-- * @getter (setter s a) === a@ -- --- * @setter (setter a b1) b2) === setter a b2@ -lens getter setter f a = fmap (setter a) (f (getter a)) +-- * @setter s (getter s) === s@ +-- +-- * @setter (setter s a1) a2 === setter s a2@ +lens getter setter f s = setter s <$> f (getter s) -iso :: Functor f - => (a -> b) -- ^ yin - -> (b' -> a') -- ^ yang - -> LensLike f a a' b b' +grate :: Functor g + => (((s -> a) -> b) -> t) -- ^ grater + -> GrateLike g s t a b -- ^ @ --- iso :: (a -> b) -> (b' -> a') -> Lens a a' b b' +-- grate :: (((s -> a) -> b) -> t) -> Grate s t a b -- @ -- --- Build a lens from isomorphism families. +-- Build a grate from a @grater@ family. -- --- /Caution/: In order for the generated lens family to be well-defined, you must ensure that the two isomorphism laws hold: +-- /Caution/: In order for the generated grate family to be well-defined, you must ensure that the two grater laws hold: -- --- * @yin . yang === id@ +-- * @grater ($ s) === s@ -- --- * @yang . yin === id@ -iso getter setter = lens getter (const setter) +-- * @grater (\k -> h (k . grater)) === grater (\k -> h ($ k))@ +-- +-- Note: The grater laws are that of an algebra for the parameterised continuation monad, `Lens.Family.PCont`. +grate grater f s = grater $ \h -> f (h <$> s) +prism :: (Applicative f, Traversable g) + => (s -> Either t a) -- ^ matcher + -> (b -> t) -- ^ reviewer + -> AdapterLike f g s t a b +-- ^ @ +-- prism :: (s -> Either t a) -> (b -> t) -> Prism s t a b +-- @ +-- +-- Build a prism from a @matcher@ and @reviewer@ family. +-- +-- /Caution/: In order for the generated prism family to be well-defined, you must ensure that the three prism laws hold: +-- +-- * @matcher (reviewer b) === Right b@ +-- +-- * @(id ||| reviewer) (matcher s) === s@ +-- +-- * @left matcher (matcher s) === left Left (matcher s)@ +prism matcher reviewer f s = either pure (fmap reviewer . f) $ traverse matcher s + -- | 'setting' promotes a \"semantic editor combinator\" to a modify-only lens. -- To demote a lens to a semantic edit combinator, use the section @(l %~)@ or @over l@ from "Lens.Family". -- --- >>> setting map . fstL %~ length $ [("The",0),("quick",1),("brown",1),("fox",2)] +-- >>> [("The",0),("quick",1),("brown",1),("fox",2)] & setting map . fstL %~ length -- [(3,0),(5,1),(5,1),(3,2)] -- --- /Caution/: In order for the generated setter family to be well-defined, you must ensure that the two functors laws hold: --- +-- /Caution/: In order for the generated family to be well-defined, you must ensure that the two functors laws hold: +-- -- * @sec id === id@ -- -- * @sec f . sec g === sec (f . g)@ setting :: Identical f - => ((b -> b') -> a -> a') -- ^ sec (semantic editor combinator) - -> LensLike f a a' b b' -setting s f = pure . s (extract . f) + => ((a -> b) -> s -> t) -- ^ sec (semantic editor combinator) + -> LensLike f s t a b +setting sec f = pure . sec (extract . f) + +-- | 'resetting' promotes a \"semantic editor combinator\" to a form of grate that can only lift unary functions. +-- To demote a grate to a semantic edit combinator, use @under l@ from "Lens.Family". +-- +-- /Caution/: In order for the generated family to be well-defined, you must ensure that the two functors laws hold: +-- +-- * @sec id === id@ +-- +-- * @sec f . sec g === sec (f . g)@ +resetting :: Identical g + => ((a -> b) -> s -> t) -- ^ sec (semantic editor combinator) + -> GrateLike g s t a b +resetting sec f = sec (f . pure) . extract