optics 0.3 → 0.4
raw patch · 13 files changed
+610/−258 lines, 13 filesdep ~arraydep ~basedep ~containers
Dependency ranges changed: array, base, containers, optics-core, optics-extra, optics-th
Files
- CHANGELOG.md +47/−0
- benchmarks/folds.hs +3/−3
- benchmarks/traversals.hs +33/−11
- optics.cabal +11/−9
- src/Optics.hs +55/−13
- tests/Optics/Tests.hs +4/−2
- tests/Optics/Tests/Core.hs +7/−8
- tests/Optics/Tests/Eta.hs +2/−2
- tests/Optics/Tests/Labels.hs +0/−194
- tests/Optics/Tests/Labels/Generic.hs +168/−0
- tests/Optics/Tests/Labels/TH.hs +194/−0
- tests/Optics/Tests/Misc.hs +40/−2
- tests/Optics/Tests/Utils.hs +46/−14
CHANGELOG.md view
@@ -1,3 +1,50 @@+# optics-0.4 (2021-02-22)+* See [migration-guide-0.4.md](https://github.com/well-typed/optics/blob/master/migration-guide-0.4.md) for more details+* Add support for GHC-9.0+* Drop support for GHC-8.0+* The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type+ classes have been migrated to a new package,+ [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable)+ ([#370](https://github.com/well-typed/optics/pull/370))+* Add `adjoin`, `iadjoin` and `both` to `Optics.[Ix]Traversal`+ ([#332](https://github.com/well-typed/optics/pull/332),+ [#372](https://github.com/well-typed/optics/pull/372))+* Add `ifst` and `isnd` to `Optics.IxLens`+ ([#389](https://github.com/well-typed/optics/pull/389))+* Generalize types of `generic`+ ([#376](https://github.com/well-typed/optics/pull/376))+* Make `chosen` an indexed lens to see which value is traversed+ ([#335](https://github.com/well-typed/optics/pull/335))+* Remove `GeneralLabelOptic` extensibility mechanism+ ([#361](https://github.com/well-typed/optics/pull/361))+* Add `gfield`, `gafield`, `gconstructor`, `gposition` and `gplate` for+ generics-based data access+ ([#358](https://github.com/well-typed/optics/pull/358),+ [#361](https://github.com/well-typed/optics/pull/361))+* Add support for generics-based field lenses and constructor prisms (`gfield`+ and `gconstructor`) to `LabelOptic` so they can be used via `OverloadedLabels`+ ([#361](https://github.com/well-typed/optics/pull/361))+* Remove unnecessary INLINE pragmas to reduce compile times+ ([#394](https://github.com/well-typed/optics/pull/394))+* Simplify the type of `(%)` using new `JoinKinds` and `AppendIndices` classes+ in place of the `Join` and `Append` type families+ ([#397](https://github.com/well-typed/optics/pull/397),+ [#399](https://github.com/well-typed/optics/pull/399))+* Print missing language extensions during TH generation of labels if there are+ any ([#352](https://github.com/well-typed/optics/pull/352))+* Add support for getters of rank1 polymorphic fields to optics generated with+ the `makeFieldLabels` family of functions+ ([#365](https://github.com/well-typed/optics/pull/365))+* Extend support of type-changing optics generated with the `makeFieldLabels`+ family to type parameters that are phantom and applied to non-injective type+ families+ ([#365](https://github.com/well-typed/optics/pull/365))+* Fix TH generation of optics for poly-kinded data families+ ([#378](https://github.com/well-typed/optics/pull/378))+* Fix `declareFieldLabels` when a field type refers to a type defined in the+ same quote+ ([#380](https://github.com/well-typed/optics/pull/380))+ # optics-0.3 (2020-04-15) * GHC-8.10 support * Add `filteredBy` and `unsafeFilteredBy`
benchmarks/folds.hs view
@@ -125,7 +125,7 @@ ] , bgroup "intmap" [ bgroup "toList"- [ bench "native" $ nf F.toList im+ [ bench "native" $ nf IM.elems im , bench "each" $ nf (toListOf each) im , bench "each/lens" $ nf (L.toListOf L.each) im , bench "itraversed" $ nf (toListOf itraversed) im@@ -146,7 +146,7 @@ ] , bgroup "map" [ bgroup "toList"- [ bench "native" $ nf F.toList m+ [ bench "native" $ nf M.elems m , bench "each" $ nf (toListOf each) m , bench "each/lens" $ nf (L.toListOf L.each) m , bench "itraversed" $ nf (toListOf itraversed) m@@ -167,7 +167,7 @@ ] , bgroup "hash map" [ bgroup "toList"- [ bench "native" $ nf HM.keys h+ [ bench "native" $ nf HM.elems h , bench "each" $ nf (toListOf each) h , bench "each/lens" $ nf (L.toListOf L.each) h , bench "itraversed" $ nf (toListOf itraversed) h
benchmarks/traversals.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP #-} module Main where import Criterion.Main import Criterion.Types import Data.Char import qualified Control.Lens as L+import qualified Control.Lens.Unsound as L import qualified Control.Monad.Trans.State as S import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8@@ -21,15 +21,6 @@ import Data.ByteString.Optics import Optics -seqTraverseWithIndex- :: Applicative f => (Int -> a -> f b) -> S.Seq a -> f (S.Seq b)-seqTraverseWithIndex f =-#if MIN_VERSION_containers(0,5,8)- S.traverseWithIndex f-#else- sequenceA . S.mapWithIndex f-#endif- main :: IO () main = defaultMainWith config [ bgroup "vector"@@ -118,7 +109,7 @@ nf (\x -> S.execState (L.traverseOf L.itraversed (S.modify' . (+)) x) 0) s ] , bgroup "itraverse"- [ bench "native" $ nf (\x -> S.execState (seqTraverseWithIndex (\i a -> S.modify' $ (i + a +)) x) 0) s+ [ bench "native" $ nf (\x -> S.execState (S.traverseWithIndex (\i a -> S.modify' $ (i + a +)) x) 0) s , bench "itraverse " $ nf (\x -> S.execState (itraverse (\i a -> S.modify' $ (i + a +)) x) 0) s , bench "itraverse/lens" $ nf (\x -> S.execState (L.itraverse (\i a -> S.modify' $ (i + a +)) x) 0) s , bench "each" $ nf (\x -> S.execState (itraverseOf each (\i a -> S.modify' $ (i + a +)) x) 0) s@@ -456,16 +447,47 @@ , bench "indices/lens" $ nf (L.iover (L.itraversed . L.indices even) (+)) h ] ]+ , bgroup "misc"+ [ bgroup "adjoin"+ [ bench "hand-written" $ nf (over adjoinHandWritten (+1)) tuple+ , bench "adjoin" $ nf (over adjoinOptics (+1)) tuple+ , bench "adjoin/lens" $ nf (L.over adjoinLens (+1)) tuple+ ]+ ] ] where config = defaultConfig { timeLimit = 1 }+ l = [0..10000] :: [Int]+ {-# NOINLINE l #-} xl = [0..100000] :: [Int]+ {-# NOINLINE xl #-} b = BS.pack $ map fromIntegral xl+ {-# NOINLINE b #-} bl = BSL.pack $ map fromIntegral [0..1000000::Int]+ {-# NOINLINE bl #-} h = HM.fromList $ zip l l+ {-# NOINLINE h #-} m = M.fromList $ zip l l+ {-# NOINLINE m #-} im = IM.fromList $ zip l l+ {-# NOINLINE im #-} s = S.fromList l+ {-# NOINLINE s #-} u = U.fromList xl+ {-# NOINLINE u #-} v = V.fromList l+ {-# NOINLINE v #-}+ tuple :: (Maybe Int, Either Int Int, Int)+ tuple = (Just 67, Right 567, 23)+ {-# NOINLINE tuple #-}++adjoinHandWritten :: Traversal' (Maybe a, Either a a, a) a+adjoinHandWritten = traversalVL $ \f (a, b, c) ->+ (,,) <$> traverseOf _Just f a <*> traverseOf chosen f b <*> f c++adjoinOptics :: Traversal' (Maybe a, Either a a, a) a+adjoinOptics = _1 % _Just `adjoin` _2 % chosen `adjoin` _3++adjoinLens :: L.Traversal' (Maybe a, Either a a, a) a+adjoinLens = (L._1 . L._Just) `L.adjoin` (L._2 . L.chosen) `L.adjoin` L._3
optics.cabal view
@@ -1,12 +1,12 @@ name: optics-version: 0.3+version: 0.4 license: BSD3 license-file: LICENSE build-type: Simple maintainer: optics@well-typed.com author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus cabal-version: 1.24-tested-with: ghc ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.3 || ==8.10.1, GHCJS ==8.4+tested-with: ghc ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.3, GHCJS ==8.4 synopsis: Optics as an abstract interface category: Data, Optics, Lenses description:@@ -38,13 +38,13 @@ hs-source-dirs: src ghc-options: -Wall - build-depends: base >= 4.9 && <5- , array >= 0.5.1.1 && <0.6- , containers >= 0.5.7.1 && <0.7+ build-depends: base >= 4.10 && <5+ , array >= 0.5.2.0 && <0.6+ , containers >= 0.5.10.2 && <0.7 , mtl >= 2.2.2 && <2.3- , optics-core >= 0.3 && <0.3.1- , optics-extra >= 0.3 && <0.3.1- , optics-th >= 0.3 && <0.3.1+ , optics-core >= 0.4 && <0.4.1+ , optics-extra >= 0.4 && <0.4.1+ , optics-th >= 0.4 && <0.4.1 , transformers >= 0.5 && <0.6 -- main module to land with repl@@ -81,6 +81,7 @@ , Optics.Cons , Optics.Each , Optics.Empty+ , Optics.Generic , Optics.Indexed , Optics.Label , Optics.Mapping@@ -151,7 +152,8 @@ other-modules: Optics.Tests.Computation Optics.Tests.Core Optics.Tests.Eta- Optics.Tests.Labels+ Optics.Tests.Labels.Generic+ Optics.Tests.Labels.TH Optics.Tests.Misc Optics.Tests.Properties Optics.Tests.Utils
src/Optics.hs view
@@ -86,6 +86,9 @@ -- , module Optics.Empty + -- ** Generic data access+ , module Optics.Generic+ -- ** Re -- | Some optics can be reversed with 're'. This is mainly useful to invert@@ -163,6 +166,9 @@ -- $indexed , module Optics.Indexed + -- * Monoid structures #monoids#+ -- $monoids+ -- * Generation of optics -- ** ...with Template Haskell , module Optics.TH@@ -208,6 +214,7 @@ import Optics.Cons import Optics.Each import Optics.Empty+import Optics.Generic import Optics.Indexed import Optics.Mapping import Optics.Operators@@ -525,18 +532,14 @@ -- computes the least upper bound given two optic kind tags. For example the -- 'Join' of a 'Lens' and a 'Prism' is an 'AffineTraversal'. ----- >>> :kind! Join A_Lens A_Prism--- Join A_Lens A_Prism :: OpticKind--- = An_AffineTraversal+-- >>> let res :: JoinKinds A_Lens A_Prism k => Proxy k; res = Proxy+-- >>> :t res+-- res :: Proxy An_AffineTraversal -- -- The join does not exist for some pairs of optic kinds, which means that they -- cannot be composed. For example there is no optic kind above both 'Setter' -- and 'Fold': ----- >>> :kind! Join A_Setter A_Fold--- Join A_Setter A_Fold :: OpticKind--- = (TypeError ...)--- -- >>> :t mapped % folded -- ... -- ...A_Setter cannot be composed with A_Fold@@ -721,21 +724,34 @@ -- * 'singular' ('isingular' for indexed optics) doesn't produce a partial lens -- that might fail with a runtime error, but an affine traversal. ----- * '<>' cannot be used to combine 'Fold's, so 'summing' should be used--- instead.+-- * '<>' cannot be used to combine 'Fold's, so 'summing' should be used instead+-- (see the "Monoid structures" section below in "Optics#monoids"). -- $otherresources ----- * <https://skillsmatter.com/skillscasts/10692-through-a-glass-abstractly-lenses-and-the-power-of-abstraction Through a Glass, Abstractly: Lenses and the Power of Abstraction> a talk on the principles behind this library with <https://github.com/well-typed/optics/raw/master/Talk.pdf accompanying slides> by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given)+-- === Talks ----- * <https://skillsmatter.com/skillscasts/12360-profunctors-and-data-accessors Profunctors and Data Accessors> a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak+-- * (2020-10) <https://skillsmatter.com/skillscasts/14906-user-friendly-optics User Friendly Optics> - a talk about the @optics@ library in comparison to the @lens@ library by Andrzej Rybczak ----- * <https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf Profunctor Optics: Modular Data Accessors> a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu+-- * (2020-06) <https://www.youtube.com/watch?v=geV8F59q48E Basic optics: lenses, prisms, and traversals> - an introductory talk about this library by Alejandro Serrano ----- * <https://oleg.fi/gists/posts/2017-04-18-glassery.html Glassery> and <https://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html Indexed Profunctor optics>, blog posts by Oleg Grenrus+-- * (2018-10) <https://skillsmatter.com/skillscasts/12360-profunctors-and-data-accessors Profunctors and Data Accessors> - a talk on basics of profunctors and how they relate to data accessors such as lenses, prisms and traversals by Andrzej Rybczak --+-- * (2017-10) <https://skillsmatter.com/skillscasts/10692-through-a-glass-abstractly-lenses-and-the-power-of-abstraction Through a Glass, Abstractly: Lenses and the Power of Abstraction> - a talk on the principles behind this library with <https://github.com/well-typed/optics/raw/master/Talk.pdf accompanying slides> by Adam Gundry (but note that the design details of @optics@ have changed substantially since this talk was given)+--+-- === Articles+--+-- * (2020-01) <https://oleg.fi/gists/posts/2020-01-25-case-study-migration-from-lens-to-optics.html Case study: migrating from lens to optics> - a blog post by Oleg Grenrus, potentially useful if you wish to migrate an existing codebase to @optics@ from @lens@+--+-- * (2017-04) <https://oleg.fi/gists/posts/2017-04-18-glassery.html Glassery> and <https://oleg.fi/gists/posts/2017-04-26-indexed-poptics.html Indexed Profunctor optics> - blog posts by Oleg Grenrus on the internal representations used by this library+--+-- * (2017-03) <https://www.cs.ox.ac.uk/people/jeremy.gibbons/publications/poptics.pdf Profunctor Optics: Modular Data Accessors> - a paper by Matthew Pickering, Jeremy Gibbons and Nicolas Wu+--+-- === Libraries+-- -- * The <https://hackage.haskell.org/package/lens lens> package by Edward Kmett and contributors+-- -- $basicusage@@ -866,6 +882,30 @@ -- -- <<diagrams/indexedoptics.png Indexed Optics>> ++-- $monoids+--+-- There are two ways to combine (possibly indexed) folds, traversals and+-- related optics with the same outer and inner types:+--+-- * Visit all the targets of the first optic, then all the targets of the+-- second optic. This makes sense for folds ('summing' or 'isumming') and+-- traversals ('adjoin' or 'iadjoin'), provided in the latter case that the+-- targets are disjoint.+--+-- * Visit the targets of the first optic if there are any, or if not, visit the+-- targets of the second optic. This makes sense for folds ('failing' or+-- 'ifailing') and affine folds ('afailing' or 'iafailing').+--+-- These operations form monoid structures on the appropriate optic kinds, with+-- the identity element 'ignored', which visits no targets.+--+-- There is no 'Semigroup' or 'Monoid' instance for 'Optic', because there is+-- not a unique choice of monoid to use, and the ('<>') operator could not be+-- used to combine optics of different kinds. When porting code from @lens@ that+-- uses ('<>') to combine folds, use 'summing' instead.++ -- $cheatsheet -- -- The following table summarizes the key optic kinds and their combinators.@@ -955,9 +995,11 @@ -- +--------------+-----------------+-------------------------------------------+------------------------------+-------------------------------+-------------------------------------------+ -- $setup+-- >>> :set -XFlexibleContexts -- >>> import Control.Monad.Reader -- >>> import Control.Monad.State -- >>> import Data.Functor.Identity+-- >>> import Data.Proxy -- >>> import qualified Data.IntSet as IntSet -- >>> import qualified Data.Map as Map -- >>> import Optics.State.Operators
tests/Optics/Tests.hs view
@@ -8,7 +8,8 @@ import Optics.Tests.Computation import Optics.Tests.Core import Optics.Tests.Eta-import Optics.Tests.Labels+import Optics.Tests.Labels.Generic+import Optics.Tests.Labels.TH import Optics.Tests.Misc import Optics.Tests.Properties @@ -45,7 +46,8 @@ [ testGroup "Inspection" [ coreTests , etaTests- , labelsTests+ , genericLabelsTests+ , thLabelsTests , miscTests ] , computationTests
tests/Optics/Tests/Core.hs view
@@ -26,7 +26,7 @@ , testCase "optimized rhs03" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs03) , testCase "traverseOf_ (folded % folded) = traverseOf_ (ifolded % ifolded)" $- assertSuccess $(inspectTest $ 'lhs04 === 'rhs04)+ assertSuccess $(inspectTest $ 'lhs04 ==- 'rhs04) , testCase "optimized lhs04" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs04) , testCase "optimized rhs04" $@@ -60,14 +60,15 @@ , testCase "optimized rhs08a" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs08a) , testCase "iover (imapped <% imapped) = iover (imapped % mapped)" $- -- Code is the same on GHC 8.0.2 modulo names of parameters.- ghc80failure $(inspectTest $ 'lhs09 === 'rhs09)+ -- GHC 9.0.1 splits the rhs into two bindings+ ghc90failure $(inspectTest $ 'lhs09 === 'rhs09) , testCase "optimized lhs09" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs09) , testCase "optimized rhs09" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs09) , testCase "itraverseOf_ itraversed = itraverseOf_ ifolded" $- assertSuccess $(inspectTest $ 'lhs10 === 'rhs10)+ -- GHC 8.2 gives a different order of let bindings+ ghc82failure $(inspectTest $ 'lhs10 === 'rhs10) , testCase "optimized lhs10a" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs10a) , testCase "optimized rhs10a" $@@ -91,7 +92,7 @@ , testCase "optimized rhs13" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs13) , testCase "traverseOf_ itraversed = traverseOf_ folded" $- assertSuccess $(inspectTest $ 'lhs14 === 'rhs14)+ assertSuccess $(inspectTest $ 'lhs14 ==- 'rhs14) , testCase "optimized lhs14a" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs14a) , testCase "optimized rhs14a" $@@ -103,9 +104,7 @@ , testCase "optimized rhs15" $ assertSuccess $(inspectTest $ hasNoProfunctors 'rhs15) , testCase "iset (itraversed..) = iset (imapped..)" $- -- GHC >= 8.2 && =< 8.6 has additional let in generated core, but the- -- difference is trivial.- ghc82to86failure $(inspectTest $ 'lhs16 === 'rhs16)+ assertSuccess $(inspectTest $ 'lhs16 === 'rhs16) , testCase "optimized lhs16" $ assertSuccess $(inspectTest $ hasNoProfunctors 'lhs16) , testCase "optimized rhs16" $
tests/Optics/Tests/Eta.hs view
@@ -32,8 +32,8 @@ , testCase "optimized eta5lhs" $ assertSuccess $(inspectTest $ hasNoProfunctors 'eta5lhs) , testCase "itraverseOf_ ifolded = \\f -> itraverseOf_ ifolded f" $- -- See the definition of itraverseOf_ for details.- ghc82failure $(inspectTest $ 'eta6lhs === 'eta6rhs)+ -- The lhs has more lets which the rhs inlines.+ ghc82and90failure $(inspectTest $ 'eta6lhs === 'eta6rhs) , testCase "optimized eta6lhs" $ assertSuccess $(inspectTest $ hasNoProfunctors 'eta6lhs) , testCase "over mapped = \\f -> over mapped f" $
− tests/Optics/Tests/Labels.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedLabels #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}-module Optics.Tests.Labels where--import Data.Ord-import Data.Word-import Control.Monad.Reader-import Control.Monad.State-import Test.Tasty-import Test.Tasty.HUnit-import Test.Inspection-import qualified System.Random as R--import Optics-import Optics.Tests.Utils--data Mammal- = Dog { mammalName :: String, mammalAge :: Int }- | Cat { mammalName :: String, mammalAge :: Int, mammalLazy :: Bool }- deriving Show--data Fish = GoldFish { fishName :: String } | Herring { fishName :: String }- deriving Show--data Human a = Human- { humanName :: String- , humanAge :: Int- , humanFish :: Fish- , humanPets :: [a]- }- deriving Show--makeFieldLabels ''Mammal-makePrismLabels ''Mammal-makeFieldLabels ''Fish-makePrismLabels ''Fish-makeFieldLabels ''Human--------------------------------------------labelsTests :: TestTree-labelsTests = testGroup "Labels"- [- testCase "view #name s = humanName s" $- assertSuccess $(inspectTest $ 'label1lhs ==- 'label1rhs)- , testCase "set #pets s b = s { humanPets = b }" $- assertSuccess $(inspectTest $ 'label2lhs ==- 'label2rhs)- , testCase "view (#fish % #name) s = fishName (humanFish s)" $- assertSuccess $(inspectTest $ 'label3lhs ==- 'label3rhs)- , testCase "set (#fish % #name) b s = s { humanFish = ... }" $- assertSuccess $(inspectTest $ 'label4lhs ==- 'label4rhs)- , testCase "multiple set with labels = multiple set with record syntax" $- assertSuccess $(inspectTest $ 'label5lhs ==- 'label5rhs)- ]--label1lhs, label1rhs :: Human a -> String-label1lhs s = view #name s-label1rhs s = humanName s--label2lhs, label2rhs :: Human a -> [b] -> Human b-label2lhs s b = set #pets b s-label2rhs s b = s { humanPets = b }--label3lhs, label3rhs :: Human a -> String-label3lhs s = view (#fish % #name) s-label3rhs s = fishName (humanFish s)--label4lhs, label4rhs :: Human a -> String -> Human a-label4lhs s b = set (#fish % #name) b s-label4rhs s b = s { humanFish = (humanFish s) { fishName = b } }--label5lhs, label5rhs :: Human a -> String -> Int -> String -> [b] -> Human b-label5lhs s name_ age_ fishName_ pets_ = s- & #name .~ name_- & #age .~ age_- & #fish % #name .~ fishName_- & #pets .~ pets_-label5rhs s name_ age_ fishName_ pets_ = s- { humanName = name_- , humanAge = age_- , humanFish = (humanFish s) { fishName = fishName_ }- , humanPets = pets_- }--------------------------------------------- Basic data manipulation--human :: Human Mammal-human = Human- { humanName = "Andrzej"- , humanAge = 30- , humanFish = GoldFish "Goldie"- , humanPets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False]- }--petNames :: [String]-petNames = toListOf (#pets % folded % #name) human--otherHuman :: Human a-otherHuman = human & set #name "Peter"- & set #pets []- & set #age 41--humanWithFish :: Human Fish-humanWithFish = set #pets [GoldFish "Goldie", GoldFish "Slick", Herring "See"] human--howManyGoldFish :: Int-howManyGoldFish = lengthOf (#pets % folded % #_GoldFish) humanWithFish--hasLazyPets :: Bool-hasLazyPets = orOf (#pets % folded % #lazy) human--yearLater :: Human Mammal-yearLater = human & #age %~ (+1)- & #pets % mapped % #age %~ (+1)--oldestPet :: Maybe Mammal-oldestPet = maximumByOf (#pets % folded) (comparing $ view #age) human--luckyDog :: Human Mammal-luckyDog = human & set (#pets % mapped % #_Dog % _1) "Lucky"--------------------------------------------- Generalization of Has* classes--type HasConfig k s = (LabelOptic' "config" k s Config, Is k A_Getter)--data Config = Config-instance- (k ~ An_Iso, a ~ Config, b ~ Config- ) => LabelOptic "config" k Config Config a b where- labelOptic = equality--data Env = Env { envConfig :: Config, envRng :: R.StdGen }-makeFieldLabels ''Env--data Nested = Nested { nestedName :: String, nestedEnv :: Env }-makeFieldLabels ''Nested--instance- (k ~ A_Lens, a ~ Config, b ~ Config- ) => LabelOptic "config" k Nested Nested a b where- labelOptic = #env % #config--doStuff :: (MonadReader r m, HasConfig k r) => m ()-doStuff = do- _ <- asks (view #config)- -- ...- pure ()--env :: Env-env = Env Config (R.mkStdGen 0)---- | Do stuff with 'Config' directly.-doStuffWithConfig :: Monad m => m ()-doStuffWithConfig = runReaderT doStuff Config---- | Do stuff with larger environment containing 'Config'.-doStuffWithEnv :: Monad m => m ()-doStuffWithEnv = runReaderT doStuff env---- | Do stuff with even larger environment.-doStuffWithNested :: Monad m => m ()-doStuffWithNested = runReaderT doStuff (Nested "weird" env)--------------------------------------------- Composition--randomValue- :: (MonadState s m, LabelOptic' "rng" A_Lens s R.StdGen, R.Random r)- => m r-randomValue = do- (r, g) <- gets $ view (#rng % to R.random)- modify' $ set #rng g- pure r--randomWords :: IO [Word8]-randomWords = do- rng <- R.mkStdGen <$> R.randomIO- (`evalStateT` Env Config rng) $ do- n <- fix $ \loop -> do- n <- (`mod` 16) <$> randomValue- if n < 5- then loop- else pure n- replicateM n randomValue
+ tests/Optics/Tests/Labels/Generic.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Labels.Generic where++import Data.Ord+import GHC.Generics (Generic)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection++import Optics+import Optics.Tests.Utils++data Mammal+ = Dog { name :: String, age :: Int }+ | Cat { name :: String, age :: Int, lazy :: Bool }+ deriving (Show, Generic)++data Fish+ = GoldFish { name :: String }+ | Herring { name :: String }+ deriving (Show, Generic)++data Human a = Human+ { name :: String+ , age :: Int+ , fish :: Fish+ , pets :: [a]+ }+ deriving (Show, Generic)++----------------------------------------++genericLabelsTests :: TestTree+genericLabelsTests = testGroup "Labels via Generic"+ [+ testCase "view #name s = name s" $+ assertSuccess $(inspectTest $ 'label1lhs ==- 'label1rhs)+ , testCase "set #pets s b = s { pets = b }" $+ assertSuccess $(inspectTest $ 'label2lhs ==- 'label2rhs)+ , testCase "view (#fish % #name) s = name (fish s)" $+ assertSuccess $(inspectTest $ 'label3lhs ==- 'label3rhs)+ , testCase "set (#fish % #name) b s = s { fish = ... }" $+ assertSuccess $(inspectTest $ 'label4lhs ==- 'label4rhs)+ , testCase "set (#pets % traversed % #name) b s = s { pets = ... }" $+ -- GHC 8.2 is the same modulo a case expression structure+ ghc82failure $(inspectTest $ 'label5lhs ==- 'label5rhs)+ , testCase "multiple set with labels = multiple set with record syntax" $+ assertSuccess $(inspectTest $ 'label6lhs ==- 'label6rhs)+ , testCase "optimized petNames (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'petNames)+ , testCase "optimized otherHuman (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'otherHuman)+ , testCase "optimized humanWithFish (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'humanWithFish)+ , testCase "optimized howManyGoldFish (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'howManyGoldFish)+ , testCase "optimized hasLazyPets (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'hasLazyPets)+ , testCase "optimized yearLater (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'yearLater)+ , testCase "optimized oldestPet (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'oldestPet)+ , testCase "optimized luckyDog (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'luckyDog)+ ]++label1lhs, label1rhs :: forall a. Human a -> String+label1lhs s = view #name s+label1rhs s = name (s :: Human a)++label2lhs, label2rhs :: Human a -> [b] -> Human b+label2lhs s b = set #pets b s+label2rhs s b = s { pets = b }++label3lhs, label3rhs :: Human a -> String+label3lhs s = view (#fish % #name) s+label3rhs s = name (fish s :: Fish)++label4lhs, label4rhs :: Human a -> String -> Human a+label4lhs s b = set (#fish % #name) b s+label4rhs s b = s { fish = (fish s) { name = b } }++label5lhs, label5rhs :: Human Mammal -> Bool -> Human Mammal+label5lhs s b = set (#pets % traversed % gafield @"lazy") b s+label5rhs s b = s { pets = (`map` pets s) $ \case+ Dog name age -> Dog{..}+ Cat name age _ -> Cat { lazy = b, .. }+ }++label6lhs, label6rhs :: Human a -> String -> Int -> String -> [b] -> Human b+label6lhs = label6setter+label6rhs s name_ age_ fishName_ pets_ = s+ { name = name_+ , age = age_+ , fish = case fish s of+ GoldFish{} -> GoldFish fishName_+ herring -> herring+ , pets = pets_+ }++-- | Check that the setter compiles in full generality.+label6setter+ :: ( Is k1 A_Setter+ , Is k2 A_Setter+ , Is k3 A_Setter+ , Is k4 A_Setter+ , JoinKinds k5 l k4+ , LabelOptic "_GoldFish" l u v a1 b1+ , LabelOptic "age" k2 s1 s2 a2 b2+ , LabelOptic "fish" k5 s2 s3 u v+ , LabelOptic "name" k3 s4 s1 a3 b3+ , LabelOptic "pets" k1 s3 b4 a4 b5+ ) => s4 -> b3 -> b2 -> b1 -> b5 -> b4+label6setter s name_ age_ fishName_ pets_ = s+ & #name .~ name_+ & #age .~ age_+ & #fish % #_GoldFish .~ fishName_+ & #pets .~ pets_++----------------------------------------+-- Basic data manipulation++human :: Human Mammal+human = Human+ { name = "Andrzej"+ , age = 30+ , fish = GoldFish "Goldie"+ , pets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False]+ }++petNames :: [String]+petNames = toListOf (#pets % folded % #name) human++otherHuman :: Human a+otherHuman = human & set #name "Peter"+ & set #pets []+ & set #age 41++humanWithFish :: Human Fish+humanWithFish = set #pets [GoldFish "Goldie", GoldFish "Slick", Herring "See"] human++howManyGoldFish :: Int+howManyGoldFish = lengthOf (#pets % folded % #_GoldFish) humanWithFish++hasLazyPets :: Bool+hasLazyPets = orOf (#pets % folded % gafield @"lazy") human++yearLater :: Human Mammal+yearLater = human & #age %~ (+1)+ & #pets % mapped % #age %~ (+1)++oldestPet :: Maybe Mammal+oldestPet = maximumByOf (#pets % folded) (comparing $ view #age) human++luckyDog :: Human Mammal+luckyDog = human & set (#pets % mapped % #_Dog % _1) "Lucky"
+ tests/Optics/Tests/Labels/TH.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-}+module Optics.Tests.Labels.TH where++import Data.Ord+import Data.Word+import Control.Monad.Reader+import Control.Monad.State+import Test.Tasty+import Test.Tasty.HUnit+import Test.Inspection+import qualified System.Random as R++import Optics+import Optics.Tests.Utils++data Mammal+ = Dog { mammalName :: String, mammalAge :: Int }+ | Cat { mammalName :: String, mammalAge :: Int, mammalLazy :: Bool }+ deriving Show++data Fish = GoldFish { fishName :: String } | Herring { fishName :: String }+ deriving Show++data Human a = Human+ { humanName :: String+ , humanAge :: Int+ , humanFish :: Fish+ , humanPets :: [a]+ }+ deriving Show++makeFieldLabels ''Mammal+makePrismLabels ''Mammal+makeFieldLabels ''Fish+makePrismLabels ''Fish+makeFieldLabels ''Human++----------------------------------------++thLabelsTests :: TestTree+thLabelsTests = testGroup "Labels via Template Haskell"+ [+ testCase "view #name s = humanName s" $+ assertSuccess $(inspectTest $ 'label1lhs ==- 'label1rhs)+ , testCase "set #pets s b = s { humanPets = b }" $+ assertSuccess $(inspectTest $ 'label2lhs ==- 'label2rhs)+ , testCase "view (#fish % #name) s = fishName (humanFish s)" $+ assertSuccess $(inspectTest $ 'label3lhs ==- 'label3rhs)+ , testCase "set (#fish % #name) b s = s { humanFish = ... }" $+ assertSuccess $(inspectTest $ 'label4lhs ==- 'label4rhs)+ , testCase "multiple set with labels = multiple set with record syntax" $+ assertSuccess $(inspectTest $ 'label5lhs ==- 'label5rhs)+ ]++label1lhs, label1rhs :: Human a -> String+label1lhs s = view #name s+label1rhs s = humanName s++label2lhs, label2rhs :: Human a -> [b] -> Human b+label2lhs s b = set #pets b s+label2rhs s b = s { humanPets = b }++label3lhs, label3rhs :: Human a -> String+label3lhs s = view (#fish % #name) s+label3rhs s = fishName (humanFish s)++label4lhs, label4rhs :: Human a -> String -> Human a+label4lhs s b = set (#fish % #name) b s+label4rhs s b = s { humanFish = (humanFish s) { fishName = b } }++label5lhs, label5rhs :: Human a -> String -> Int -> String -> [b] -> Human b+label5lhs s name_ age_ fishName_ pets_ = s+ & #name .~ name_+ & #age .~ age_+ & #fish % #name .~ fishName_+ & #pets .~ pets_+label5rhs s name_ age_ fishName_ pets_ = s+ { humanName = name_+ , humanAge = age_+ , humanFish = (humanFish s) { fishName = fishName_ }+ , humanPets = pets_+ }++----------------------------------------+-- Basic data manipulation++human :: Human Mammal+human = Human+ { humanName = "Andrzej"+ , humanAge = 30+ , humanFish = GoldFish "Goldie"+ , humanPets = [Dog "Rocky" 3, Cat "Pickle" 4 True, Cat "Max" 1 False]+ }++petNames :: [String]+petNames = toListOf (#pets % folded % #name) human++otherHuman :: Human a+otherHuman = human & set #name "Peter"+ & set #pets []+ & set #age 41++humanWithFish :: Human Fish+humanWithFish = set #pets [GoldFish "Goldie", GoldFish "Slick", Herring "See"] human++howManyGoldFish :: Int+howManyGoldFish = lengthOf (#pets % folded % #_GoldFish) humanWithFish++hasLazyPets :: Bool+hasLazyPets = orOf (#pets % folded % #lazy) human++yearLater :: Human Mammal+yearLater = human & #age %~ (+1)+ & #pets % mapped % #age %~ (+1)++oldestPet :: Maybe Mammal+oldestPet = maximumByOf (#pets % folded) (comparing $ view #age) human++luckyDog :: Human Mammal+luckyDog = human & set (#pets % mapped % #_Dog % _1) "Lucky"++----------------------------------------+-- Generalization of Has* classes++type HasConfig k s = (LabelOptic' "config" k s Config, Is k A_Getter)++data Config = Config+instance+ (k ~ An_Iso, a ~ Config, b ~ Config+ ) => LabelOptic "config" k Config Config a b where+ labelOptic = equality++data Env = Env { envConfig :: Config, envRng :: R.StdGen }+makeFieldLabels ''Env++data Nested = Nested { nestedName :: String, nestedEnv :: Env }+makeFieldLabels ''Nested++instance+ (k ~ A_Lens, a ~ Config, b ~ Config+ ) => LabelOptic "config" k Nested Nested a b where+ labelOptic = #env % #config++doStuff :: (MonadReader r m, HasConfig k r) => m ()+doStuff = do+ _ <- asks (view #config)+ -- ...+ pure ()++env :: Env+env = Env Config (R.mkStdGen 0)++-- | Do stuff with 'Config' directly.+doStuffWithConfig :: Monad m => m ()+doStuffWithConfig = runReaderT doStuff Config++-- | Do stuff with larger environment containing 'Config'.+doStuffWithEnv :: Monad m => m ()+doStuffWithEnv = runReaderT doStuff env++-- | Do stuff with even larger environment.+doStuffWithNested :: Monad m => m ()+doStuffWithNested = runReaderT doStuff (Nested "weird" env)++----------------------------------------+-- Composition++randomValue+ :: (MonadState s m, LabelOptic' "rng" A_Lens s R.StdGen, R.Random r)+ => m r+randomValue = do+ (r, g) <- gets $ view (#rng % to R.random)+ modify' $ set #rng g+ pure r++randomWords :: IO [Word8]+randomWords = do+ rng <- R.mkStdGen <$> R.randomIO+ (`evalStateT` Env Config rng) $ do+ n <- fix $ \loop -> do+ n <- (`mod` 16) <$> randomValue+ if n < 5+ then loop+ else pure n+ replicateM n randomValue
tests/Optics/Tests/Misc.hs view
@@ -22,13 +22,25 @@ , testCase "optimized itoList" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkitoListOf) , testCase "optimized partsOf" $- ghc80failure $(inspectTest $ hasNoProfunctors 'checkPartsOf)+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkPartsOf) , testCase "optimized singular" $- ghc80failure $(inspectTest $ hasNoProfunctors 'checkSingular)+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkSingular) , testCase "optimized filteredBy" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkFilteredBy) , testCase "optimized unsafeFilteredBy" $ assertSuccess $(inspectTest $ hasNoProfunctors 'checkUnsafeFilteredBy)+ -- GHC <= 8.4 doesn't optimize away profunctor classes+ , testCase "optimized adjoin" $+ ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkAdjoin)+ -- GHC <= 8.4 doesn't optimize away profunctor classes+ , testCase "optimized iadjoin" $+ ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkIxAdjoin)+ , testCase "optimized gplate (profunctors)" $+ assertSuccess $(inspectTest $ hasNoProfunctors 'checkGplate)+ , testCase "optimized gplate (generics)" $+ assertSuccess $(inspectTest $ hasNoGenericRep 'checkGplate)+ , testCase "optimized icomposeN/appendIndices" $+ assertSuccess $ $(inspectTest $ hasNoIndexClasses 'checkNoIndexFunctions) ] simpleMapIx@@ -71,3 +83,29 @@ -> Either a1 (a, Maybe i) -> f (Either a1 (a, Maybe i)) checkUnsafeFilteredBy = iatraverseOf (unsafeFilteredBy (_Right % _2 % _Just)) pure++checkAdjoin :: (a -> a) -> (Maybe a, Either a a, [a]) -> (Maybe a, Either a a, [a])+checkAdjoin = over (_1 % _Just `adjoin` _2 % chosen `adjoin` _3 % traversed)++checkIxAdjoin :: (Int -> a -> a) -> ((Int, a), [a], (Int, Maybe a)) -> ((Int, a), [a], (Int, Maybe a))+checkIxAdjoin = iover (_1 % itraversed `iadjoin` _2 % itraversed `iadjoin` _3 % itraversed % _Just)++checkGplate+ :: (Char, ([Either Char ()], Char, Maybe Char), [Char], Either Char Int)+ -> [Char]+checkGplate = toListOf gplate++checkNoIndexFunctions+ :: ( TraversableWithIndex i1 f1, TraversableWithIndex i2 f2+ , TraversableWithIndex i3 f3, TraversableWithIndex i4 f4+ , TraversableWithIndex i5 f5, TraversableWithIndex i6 f6+ , TraversableWithIndex i7 f7, TraversableWithIndex i8 f8+ ) => Optic A_Traversal+ (WithIx (i1, i2, i3, i4, i5, i6, i7, i8))+ (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 a))))))))+ (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 b))))))))+ a+ b+checkNoIndexFunctions+ = icomposeN (,,,,,,,) $ (((itraversed % itraversed) % itraversed) % itraversed)+ % (itraversed % (itraversed % (itraversed % itraversed)))
tests/Optics/Tests/Utils.hs view
@@ -5,7 +5,9 @@ import Language.Haskell.TH (Name) import Test.Tasty.HUnit import Test.Inspection+import qualified GHC.Generics as G +import Optics.Internal.Optic import qualified Data.Profunctor.Indexed as P hasNoProfunctors :: Name -> Obligation@@ -33,8 +35,31 @@ , 'P.iwander , 'P.roam , 'P.iroam+ , 'appendIndices+ , 'composeN ] +hasNoIndexClasses :: Name -> Obligation+hasNoIndexClasses name = mkObligation name $ NoUseOf+ [ 'appendIndices+ , 'composeN+ ]++-- | 'hasNoGenerics' from 'Test.Inspection' checks for lack of data types, but+-- they show up in coercions even though the representation was optimized away;+-- check for functions and data constructors instead.+hasNoGenericRep :: Name -> Obligation+hasNoGenericRep name = mkObligation name $ NoUseOf+ [ 'G.from+ , 'G.to+ , '(G.:*:)+ , 'G.K1+ , 'G.L1+ , 'G.M1+ , 'G.R1+ , 'G.U1+ ]+ assertSuccess :: Result -> IO () assertSuccess (Success _) = return () assertSuccess (Failure err) = assertFailure err@@ -43,20 +68,6 @@ assertFailure' (Success err) = assertFailure err assertFailure' (Failure _) = return () -ghc80failure :: Result -> IO ()-#if __GLASGOW_HASKELL__ == 800-ghc80failure = assertFailure'-#else-ghc80failure = assertSuccess-#endif--ghc80success :: Result -> IO ()-#if __GLASGOW_HASKELL__ == 800-ghc80success = assertSuccess-#else-ghc80success = assertFailure'-#endif- ghc82to86failure :: Result -> IO () #if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 806 ghc82to86failure = assertFailure'@@ -76,4 +87,25 @@ ghcGE86failure = assertFailure' #else ghcGE86failure = assertSuccess+#endif++ghcLE84failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ <= 804+ghcLE84failure = assertFailure'+#else+ghcLE84failure = assertSuccess+#endif++ghc82and90failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ == 802 || __GLASGOW_HASKELL__ == 900+ghc82and90failure = assertFailure'+#else+ghc82and90failure = assertSuccess+#endif++ghc90failure :: Result -> IO ()+#if __GLASGOW_HASKELL__ == 900+ghc90failure = assertFailure'+#else+ghc90failure = assertSuccess #endif