├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── Makefile ├── README.md ├── Talk.pdf ├── cabal.codegen.project ├── cabal.haddockbundle.project ├── cabal.haskell-ci ├── cabal.project ├── cabal.project.local.head.hackage ├── codegen ├── Subtypes.hs └── optics-codegen.cabal ├── doctest.sh ├── haddockbundle.sh ├── haddockbundle ├── optics-haddockbundle.cabal └── src │ └── optics-haddockbundle.hs ├── indexed-profunctors ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── indexed-profunctors.cabal └── src │ └── Data │ └── Profunctor │ └── Indexed.hs ├── metametapost ├── .gitignore ├── LICENSE ├── Makefile ├── metametapost.cabal └── src │ ├── Cli.hs │ ├── MMP │ └── Optics │ │ ├── Common.hs │ │ ├── Hierarchy.hs │ │ ├── Indexed.hs │ │ └── Re.hs │ └── MetaMetaPost.hs ├── migration-guide-0.4.md ├── optics-core ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── diagrams │ ├── AffineFold.png │ ├── AffineTraversal.png │ ├── Fold.png │ ├── Getter.png │ ├── Iso.png │ ├── Lens.png │ ├── Prism.png │ ├── ReversedLens.png │ ├── ReversedPrism.png │ ├── Review.png │ ├── Setter.png │ ├── Traversal.png │ └── reoptics.png ├── indexedoptics.png ├── optics-core.cabal ├── optics.png ├── reoptics.png └── src │ ├── Data │ ├── Either │ │ └── Optics.hs │ ├── IntMap │ │ └── Optics.hs │ ├── IntSet │ │ └── Optics.hs │ ├── List │ │ └── Optics.hs │ ├── Map │ │ └── Optics.hs │ ├── Maybe │ │ └── Optics.hs │ ├── Sequence │ │ └── Optics.hs │ ├── Set │ │ └── Optics.hs │ ├── Tree │ │ └── Optics.hs │ ├── Tuple │ │ └── Optics.hs │ └── Typeable │ │ └── Optics.hs │ ├── GHC │ └── Generics │ │ └── Optics.hs │ ├── Numeric │ └── Optics.hs │ └── Optics │ ├── AffineFold.hs │ ├── AffineTraversal.hs │ ├── Arrow.hs │ ├── At │ └── Core.hs │ ├── Coerce.hs │ ├── Cons │ └── Core.hs │ ├── Core.hs │ ├── Core │ └── Extras.hs │ ├── Each │ └── Core.hs │ ├── Empty │ └── Core.hs │ ├── Fold.hs │ ├── Generic.hs │ ├── Getter.hs │ ├── Indexed │ └── Core.hs │ ├── Internal │ ├── Bi.hs │ ├── Fold.hs │ ├── Generic.hs │ ├── Generic │ │ └── TypeLevel.hs │ ├── Indexed.hs │ ├── Indexed │ │ └── Classes.hs │ ├── IxFold.hs │ ├── IxSetter.hs │ ├── IxTraversal.hs │ ├── Magic.hs │ ├── Optic.hs │ ├── Optic │ │ ├── Subtyping.hs │ │ ├── TypeLevel.hs │ │ └── Types.hs │ ├── Setter.hs │ ├── Traversal.hs │ └── Utils.hs │ ├── Iso.hs │ ├── IxAffineFold.hs │ ├── IxAffineTraversal.hs │ ├── IxFold.hs │ ├── IxGetter.hs │ ├── IxLens.hs │ ├── IxSetter.hs │ ├── IxTraversal.hs │ ├── Label.hs │ ├── Lens.hs │ ├── Mapping.hs │ ├── Operators.hs │ ├── Operators │ └── Unsafe.hs │ ├── Optic.hs │ ├── Prism.hs │ ├── Re.hs │ ├── ReadOnly.hs │ ├── ReversedLens.hs │ ├── ReversedPrism.hs │ ├── Review.hs │ ├── Setter.hs │ └── Traversal.hs ├── optics-extra ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── optics-extra.cabal └── src │ ├── Data │ ├── ByteString │ │ ├── Lazy │ │ │ └── Optics.hs │ │ ├── Optics.hs │ │ └── Strict │ │ │ └── Optics.hs │ ├── HashMap │ │ └── Optics.hs │ ├── HashSet │ │ └── Optics.hs │ ├── Text │ │ ├── Lazy │ │ │ └── Optics.hs │ │ ├── Optics.hs │ │ └── Strict │ │ │ └── Optics.hs │ └── Vector │ │ ├── Generic │ │ └── Optics.hs │ │ └── Optics.hs │ └── Optics │ ├── At.hs │ ├── Cons.hs │ ├── Each.hs │ ├── Empty.hs │ ├── Extra.hs │ ├── Extra │ └── Internal │ │ ├── ByteString.hs │ │ ├── Vector.hs │ │ └── Zoom.hs │ ├── Indexed.hs │ ├── Passthrough.hs │ ├── State.hs │ ├── State │ └── Operators.hs │ ├── View.hs │ └── Zoom.hs ├── optics-sop ├── LICENSE ├── Setup.hs ├── optics-sop.cabal └── src │ ├── Generics │ └── SOP │ │ └── Optics.hs │ └── Optics │ ├── SOP.hs │ └── SOP │ └── ToTuple.hs ├── optics-th ├── CHANGELOG.md ├── LICENSE ├── optics-th.cabal ├── src │ ├── Language │ │ └── Haskell │ │ │ └── TH │ │ │ └── Optics │ │ │ └── Internal.hs │ └── Optics │ │ ├── TH.hs │ │ └── TH │ │ └── Internal │ │ ├── Product.hs │ │ ├── Sum.hs │ │ └── Utils.hs └── tests │ └── Optics │ └── TH │ ├── Tests.hs │ └── Tests │ ├── DuplicateRecordFields.hs │ └── T799.hs ├── optics-vl ├── CHANGELOG.md ├── LICENSE ├── Setup.hs ├── optics-vl.cabal └── src │ └── Optics │ └── VL.hs ├── optics ├── CHANGELOG.md ├── LICENSE ├── benchmarks │ ├── folds.hs │ └── traversals.hs ├── diagrams │ ├── indexedoptics.png │ ├── optics.png │ └── reoptics.png ├── optics.cabal ├── src │ └── Optics.hs └── tests │ └── Optics │ ├── Tests.hs │ └── Tests │ ├── Computation.hs │ ├── Core.hs │ ├── Eta.hs │ ├── Labels │ ├── Generic.hs │ └── TH.hs │ ├── Misc.hs │ ├── Properties.hs │ └── Utils.hs └── template-haskell-optics ├── CHANGELOG.md ├── LICENSE ├── src └── Language │ └── Haskell │ └── TH │ └── Optics.hs └── template-haskell-optics.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.swp 3 | dist-* 4 | dist 5 | .ghc.environment.* 6 | cabal.project.local 7 | cabal.*.project.local 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # We use make for small scripts 2 | 3 | .PHONY : all build test haddock validate doctest diagrams 4 | 5 | all : build 6 | 7 | build : 8 | cabal new-build all 9 | 10 | test : build 11 | cabal new-run optics-tests 12 | 13 | haddock : 14 | cabal new-haddock all 15 | 16 | # Build with all supported GHCs, run tests. 17 | validate : build doctest 18 | cabal new-build all --builddir=dist-validate-8.0.2 -w ghc-8.0.2 --write-ghc-environment-files=never 19 | cabal new-build all --builddir=dist-validate-8.2.2 -w ghc-8.2.2 --write-ghc-environment-files=never 20 | cabal new-build all --builddir=dist-validate-8.4.4 -w ghc-8.4.4 --write-ghc-environment-files=never 21 | cabal new-build all --builddir=dist-validate-8.6.3 -w ghc-8.6.3 --write-ghc-environment-files=never 22 | 23 | cabal new-run optics-tests --builddir=dist-validate-8.0.2 -w ghc-8.0.2 --write-ghc-environment-files=never 24 | cabal new-run optics-tests --builddir=dist-validate-8.2.2 -w ghc-8.2.2 --write-ghc-environment-files=never 25 | cabal new-run optics-tests --builddir=dist-validate-8.4.4 -w ghc-8.4.4 --write-ghc-environment-files=never 26 | cabal new-run optics-tests --builddir=dist-validate-8.6.3 -w ghc-8.6.3 --write-ghc-environment-files=never 27 | 28 | ghcid-optics-core : 29 | ghcid -c 'cabal new-repl optics-core' 30 | 31 | codegen-subtypes : 32 | cabal new-run --builddir=dist-codegen --project-file=cabal.codegen.project optics-codegen-subtypes -- subtypes 33 | 34 | codegen-join : 35 | cabal new-run --builddir=dist-codegen --project-file=cabal.codegen.project optics-codegen-subtypes -- join 36 | 37 | DIAGRAMS=optics reoptics indexedoptics 38 | 39 | diagrams : $(DIAGRAMS:%=optics/diagrams/%.png) optics-core/diagrams/reoptics.png 40 | 41 | OPTIC_KINDS=AffineFold AffineTraversal Fold Getter Iso Lens Prism ReversedLens ReversedPrism Review Setter Traversal 42 | 43 | per-kind-diagrams : $(OPTIC_KINDS:%=optics-core/diagrams/%.png) 44 | 45 | metametapost/%.mp : metametapost/src/MetaMetaPost.hs metametapost/src/Cli.hs 46 | cabal new-build metametapost-optics 47 | $$(cabal new-exec which metametapost-optics) $* > $@ 48 | 49 | metametapost/%.png : metametapost/%.mp 50 | make -C metametapost $*.png 51 | 52 | # This rule was: 53 | # cp $< $@ 54 | optics/diagrams/%.png : metametapost/%.png 55 | optipng -o7 -zm1-9 $< -dir optics/diagrams/ 56 | 57 | optics-core/diagrams/%.png : metametapost/%.png 58 | optipng -o7 -zm1-9 $< -dir optics-core/diagrams/ 59 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # optics 2 | 3 | [![Build Status](https://github.com/well-typed/optics/workflows/Haskell-CI/badge.svg?branch=master)](https://github.com/well-typed/optics/actions?query=branch%3Amaster) 4 | [![Hackage](https://img.shields.io/hackage/v/optics.svg)](https://hackage.haskell.org/package/optics) 5 | [![Dependencies](https://img.shields.io/hackage-deps/v/optics.svg)](https://packdeps.haskellers.com/feed?needle=optics@well-typed.com) 6 | [![Stackage LTS](https://www.stackage.org/package/optics/badge/lts)](https://www.stackage.org/lts/package/optics) 7 | [![Stackage Nightly](https://www.stackage.org/package/optics/badge/nightly)](https://www.stackage.org/nightly/package/optics) 8 | 9 | The [`optics`](https://hackage.haskell.org/package/optics) family of Haskell 10 | packages make it possible to define and use Lenses, Traversals, Prisms and other 11 | *optics*, using an abstract interface. They are roughly comparable in 12 | functionality with the [`lens`](https://hackage.haskell.org/package/lens) 13 | package, but explore a different part of the design space. For a detailed 14 | introduction, see the [Haddocks for the main `Optics` 15 | module](https://hackage.haskell.org/package/optics/docs/Optics.html). 16 | 17 | 18 | ## Authors and contributors 19 | 20 | The authors of the `optics` family of packages are: 21 | 22 | * Adam Gundry 23 | * Andres Löh 24 | * Andrzej Rybczak 25 | * Oleg Grenrus 26 | 27 | Our thanks go to those who have (involuntarily) contributed code and ideas to 28 | `optics`. In particular, we have liberally reused parts of the `lens` package by 29 | Edward Kmett and contributors. 30 | 31 | 32 | ## Package structure 33 | 34 | ### Officially supported packages 35 | 36 | * [`optics`](https://hackage.haskell.org/package/optics) is a 37 | "batteries-included" package with many dependencies. It incorporates: 38 | 39 | * [`optics-core`](https://hackage.haskell.org/package/optics-core): core 40 | definitions with a minimal dependency footprint. 41 | 42 | * [`optics-extra`](https://hackage.haskell.org/package/optics-extra): extra 43 | definitions and instances that extend `optics-core`, incurring dependencies 44 | on various boot library packages. 45 | 46 | * [`optics-th`](https://hackage.haskell.org/package/optics-th): machinery to 47 | construct optics using `TemplateHaskell`. 48 | 49 | * [`indexed-profunctors`](https://hackage.haskell.org/package/indexed-profunctors): 50 | internal definitions of indexed profunctor representation. 51 | 52 | * [`optics-vl`](https://hackage.haskell.org/package/optics-vl): utilities for 53 | compatibility with van Laarhoven isomorphisms and prisms, as defined in the 54 | `lens` library. This package is not included in `optics` as it imposes a 55 | dependency on `profunctors`. Note that `optics-core` already supports 56 | conversion for van Laarhoven lenses and various other optics. 57 | 58 | * [`template-haskell-optics`](http://hackage.haskell.org/package/template-haskell-optics): 59 | optics for working with types in the `template-haskell` package (see 60 | `optics-th` for *using* `TemplateHaskell` to construct optics). 61 | 62 | ### Work in progress packages 63 | 64 | These packages have not (yet) been officially released. If you find them 65 | useful, we would welcome offers to maintain these packages. 66 | 67 | * `optics-sop`: generic construction of optics using the `generics-sop` 68 | package, and optics for `generics-sop` types. 69 | 70 | ### Internal packages 71 | 72 | These packages are for internal use only, and are not intended to be released: 73 | 74 | * `metametapost`: generates diagrams used in the documentation, and an example 75 | of using `optics`. 76 | 77 | * `optics-codegen`: code generator for the `Is` class and `Join` type family 78 | used internally by `optics`. 79 | -------------------------------------------------------------------------------- /Talk.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/Talk.pdf -------------------------------------------------------------------------------- /cabal.codegen.project: -------------------------------------------------------------------------------- 1 | packages: codegen/*.cabal 2 | -------------------------------------------------------------------------------- /cabal.haddockbundle.project: -------------------------------------------------------------------------------- 1 | packages: haddockbundle/*.cabal 2 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: focal 2 | branches: master 3 | doctest: <9.3 4 | tests: True 5 | benchmarks: <9.5 6 | jobs-selection: any 7 | 8 | -- turn head hackage off 9 | head-hackage: <0 10 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | optics/*.cabal 3 | optics-core/*.cabal 4 | optics-extra/*.cabal 5 | optics-sop/*.cabal 6 | optics-th/*.cabal 7 | optics-vl/*.cabal 8 | indexed-profunctors/*.cabal 9 | template-haskell-optics/*.cabal 10 | 11 | -- An example, using optics to generate optics diagrams 12 | packages: 13 | metametapost/*.cabal 14 | 15 | tests: true 16 | -------------------------------------------------------------------------------- /cabal.project.local.head.hackage: -------------------------------------------------------------------------------- 1 | -- To develop with head.hackage 2 | -- 3 | -- cp cabal.project.local.head.hackage cabal.project.local 4 | -- 5 | -- To update head.hackage index: 6 | -- 7 | -- rm ~/.cabal/packages/head.hackage 8 | -- cabal v2-update head.hackage 9 | -- 10 | repository head.hackage 11 | url: https://ghc.gitlab.haskell.org/head.hackage/ 12 | secure: True 13 | root-keys: 7541f32a4ccca4f97aea3b22f5e593ba2c0267546016b992dfadcd2fe944e55d 14 | 26021a13b401500c8eb2761ca95c61f2d625bfef951b939a8124ed12ecf07329 15 | f76d08be13e9a61a377a85e2fb63f4c5435d40f8feb3e12eb05905edb8cdea89 16 | key-threshold: 3 17 | 18 | allow-newer: *:base 19 | allow-newer: *:template-haskell 20 | allow-newer: *:time 21 | allow-newer: *:Cabal 22 | allow-newer: *:ghc 23 | allow-newer: *:ghc-prim 24 | 25 | with-compiler: ghc-8.10.1 26 | -------------------------------------------------------------------------------- /codegen/optics-codegen.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-codegen 3 | version: 0 4 | 5 | executable optics-codegen-subtypes 6 | main-is: Subtypes.hs 7 | build-depends: 8 | base, containers, vector, topograph ^>= 1 9 | -------------------------------------------------------------------------------- /doctest.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | # 3 | # For this to work you need to: 4 | # 5 | # - Put "write-ghc-environment-files: always" in your cabal.project.local. 6 | # 7 | # - Compile doctest with the same GHC version the project currently uses. 8 | # 9 | 10 | set -eu 11 | 12 | run_doctest() { 13 | pushd "${1}" 14 | doctest \ 15 | "${2}" \ 16 | -XHaskell2010 \ 17 | -XBangPatterns \ 18 | -XConstraintKinds \ 19 | -XDefaultSignatures \ 20 | -XDeriveFoldable \ 21 | -XDeriveFunctor \ 22 | -XDeriveGeneric \ 23 | -XDeriveTraversable \ 24 | -XEmptyCase \ 25 | -XFlexibleContexts \ 26 | -XFlexibleInstances \ 27 | -XFunctionalDependencies \ 28 | -XGADTs \ 29 | -XGeneralizedNewtypeDeriving \ 30 | -XInstanceSigs \ 31 | -XKindSignatures \ 32 | -XLambdaCase \ 33 | -XOverloadedLabels \ 34 | -XPatternSynonyms \ 35 | -XRankNTypes \ 36 | -XScopedTypeVariables \ 37 | -XTupleSections \ 38 | -XTypeApplications \ 39 | -XTypeFamilies \ 40 | -XTypeOperators \ 41 | -XViewPatterns 42 | popd 43 | } 44 | 45 | if [ $# -eq 0 ]; then 46 | dirs="optics-core optics-extra optics-th optics" 47 | else 48 | dirs="$@" 49 | fi 50 | 51 | for dir in $dirs; do 52 | run_doctest "$dir" src 53 | done 54 | -------------------------------------------------------------------------------- /haddockbundle.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # First we build haddocks for each package 4 | # We build them separately, as apparently cabal haddock doesn't link 5 | # to other /local/ packages. 6 | # 7 | # Therefore you need first to upload packages to Hackage before docs 8 | # can be built. 9 | # 10 | # NOTE: actually this doesn't work either, but it was a good try. 11 | 12 | # Same GHC as hackage doc builder (apparently) uses 13 | GHC=ghc-8.10.7 14 | 15 | TOPDIR=$(pwd) 16 | PACKAGES="optics optics-core optics-th optics-extra" 17 | 18 | for PKG in $PACKAGES; do 19 | echo "$PKG" 20 | cd "$PKG" || exit 21 | 22 | pwd 23 | 24 | # We create a cabal.project, so the root project is not used. 25 | # Apparently cabal haddock --ignore-project doesn't ignore project after all. 26 | echo 'packages: .' > cabal.project 27 | 28 | cabal haddock --enable-documentation --haddock-for-hackage --with-compiler "$GHC" 29 | cp dist-newstyle/*-docs.tar.gz "$TOPDIR/dist-newstyle/" 30 | 31 | rm -f cabal.project 32 | 33 | cd "$TOPDIR" || exit 34 | done 35 | 36 | 37 | # Create haddock bundle 38 | cabal run --project-file=cabal.haddockbundle.project optics-haddockbundle 39 | -------------------------------------------------------------------------------- /haddockbundle/optics-haddockbundle.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-haddockbundle 3 | version: 0 4 | 5 | executable optics-haddockbundle 6 | default-language: Haskell2010 7 | ghc-options: -Wall 8 | main-is: optics-haddockbundle.hs 9 | hs-source-dirs: src 10 | build-depends: 11 | , aeson ^>=2.0.3.0 12 | , base 13 | , bytestring 14 | , Cabal ^>=3.6.3.0 15 | , cabal-install-parsers ^>=0.4.5 16 | , containers 17 | , filepath 18 | , lens 19 | , tar 20 | , text 21 | , transformers 22 | , vector 23 | , zlib 24 | -------------------------------------------------------------------------------- /indexed-profunctors/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # indexed-profunctors-0.1.1.1 (2023-06-22) 2 | * Add INLINE pragmas to small functions that really should inline 3 | 4 | # indexed-profunctors-0.1.1 (2021-04-09) 5 | * Remove unnecessary INLINE pragmas 6 | 7 | # indexed-profunctors-0.1 (2019-10-11) 8 | * Initial release 9 | -------------------------------------------------------------------------------- /indexed-profunctors/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /indexed-profunctors/indexed-profunctors.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: indexed-profunctors 3 | version: 0.1.1.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | maintainer: optics@well-typed.com 8 | author: Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, 12 | GHCJS ==8.4 13 | synopsis: Utilities for indexed profunctors 14 | category: Data, Optics, Lenses, Profunctors 15 | description: 16 | This package contains basic definitions related to indexed profunctors. These 17 | are primarily intended as internal utilities to support the @optics@ and 18 | @generic-lens@ package families. 19 | 20 | extra-doc-files: 21 | CHANGELOG.md 22 | 23 | bug-reports: https://github.com/well-typed/optics/issues 24 | source-repository head 25 | type: git 26 | location: https://github.com/well-typed/optics.git 27 | subdir: indexed-profunctors 28 | 29 | common language 30 | ghc-options: -Wall -Wcompat 31 | 32 | default-language: Haskell2010 33 | 34 | default-extensions: BangPatterns 35 | ConstraintKinds 36 | DefaultSignatures 37 | DeriveFoldable 38 | DeriveFunctor 39 | DeriveGeneric 40 | DeriveTraversable 41 | EmptyCase 42 | FlexibleContexts 43 | FlexibleInstances 44 | FunctionalDependencies 45 | GADTs 46 | GeneralizedNewtypeDeriving 47 | InstanceSigs 48 | KindSignatures 49 | LambdaCase 50 | OverloadedLabels 51 | PatternSynonyms 52 | RankNTypes 53 | ScopedTypeVariables 54 | TupleSections 55 | TypeApplications 56 | TypeFamilies 57 | TypeOperators 58 | ViewPatterns 59 | 60 | library 61 | import: language 62 | hs-source-dirs: src 63 | 64 | build-depends: base >= 4.10 && <5 65 | 66 | exposed-modules: Data.Profunctor.Indexed 67 | -------------------------------------------------------------------------------- /metametapost/.gitignore: -------------------------------------------------------------------------------- 1 | optics.mp 2 | optics.log 3 | optics.mps 4 | optics.mpx 5 | optics.png 6 | optics.svg 7 | 8 | reoptics.mp 9 | reoptics.log 10 | reoptics.mps 11 | reoptics.mpx 12 | reoptics.png 13 | reoptics.svg 14 | 15 | indexedoptics.mp 16 | indexedoptics.log 17 | indexedoptics.mps 18 | indexedoptics.mpx 19 | indexedoptics.png 20 | indexedoptics.svg 21 | 22 | mpxerr.tex 23 | -------------------------------------------------------------------------------- /metametapost/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andres Loeh nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /metametapost/Makefile: -------------------------------------------------------------------------------- 1 | SVGIMAGES=optics reoptics indexedoptics 2 | 3 | all : $(PNGIMAGES:%=%.png) $(SVGIMAGES:%=%.svg) $(SVGIMAGES:%=%.png) $(SVGIMAGES:%=%.mps) 4 | 5 | %.png : %.dot 6 | dot -Tpng $< -o $@ 7 | 8 | MPOST=mpost 9 | SVGPARAMS=-s defaultscale:=8 -s outputformat='"svg"' -s outputtemplate='"%j.svg"' 10 | MPSPARAMS=-s outputformat='"mps"' -s outputtemplate='"%j.mps"' 11 | 12 | %.mp : %.hs 13 | runhaskell $< > $@ 14 | 15 | %.mps : %.mp 16 | $(MPOST) $(MPSPARAMS) $< 17 | 18 | %.svg : %.mp 19 | $(MPOST) $(SVGPARAMS) $< 20 | 21 | %.png : %.svg 22 | inkscape --export-png=$@ --export-dpi=108 --export-background-opacity=0 --without-gui $< 23 | -------------------------------------------------------------------------------- /metametapost/metametapost.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: metametapost 3 | version: 0.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 8 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 9 | || ==9.10.1, 10 | GHCJS ==8.4 11 | maintainer: oleg@well-typed.com 12 | synopsis: Generate optics documentation diagrams 13 | category: Optics, Examples 14 | description: 15 | This is a an example using @optics@, with a practical 16 | benefit of generating diagrams used in the documentation. 17 | 18 | common language 19 | ghc-options: -Wall -Wcompat 20 | 21 | default-language: Haskell2010 22 | 23 | default-extensions: BangPatterns 24 | ConstraintKinds 25 | DefaultSignatures 26 | DeriveFoldable 27 | DeriveFunctor 28 | DeriveGeneric 29 | DeriveTraversable 30 | EmptyCase 31 | FlexibleContexts 32 | FlexibleInstances 33 | FunctionalDependencies 34 | GADTs 35 | GeneralizedNewtypeDeriving 36 | InstanceSigs 37 | KindSignatures 38 | LambdaCase 39 | OverloadedLabels 40 | PatternSynonyms 41 | RankNTypes 42 | ScopedTypeVariables 43 | TupleSections 44 | TypeApplications 45 | TypeFamilies 46 | TypeOperators 47 | ViewPatterns 48 | 49 | executable metametapost-optics 50 | import: language 51 | hs-source-dirs: src 52 | 53 | build-depends: base >=4.10 && <5 54 | , containers 55 | , generics-sop 56 | , mtl 57 | , optics 58 | , optics-sop 59 | 60 | main-is: Cli.hs 61 | 62 | other-modules: MetaMetaPost 63 | MMP.Optics.Common 64 | MMP.Optics.Hierarchy 65 | MMP.Optics.Indexed 66 | MMP.Optics.Re 67 | -------------------------------------------------------------------------------- /metametapost/src/Cli.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Data.List (find) 4 | import System.Environment (getArgs) 5 | 6 | import MetaMetaPost (printDiagram) 7 | 8 | import MMP.Optics.Common 9 | import MMP.Optics.Hierarchy 10 | import MMP.Optics.Indexed 11 | import MMP.Optics.Re 12 | 13 | ------------------------------------------------------------------------------- 14 | -- Main 15 | ------------------------------------------------------------------------------- 16 | 17 | main :: IO () 18 | main = do 19 | args <- getArgs 20 | case args of 21 | ("hierarchy" : _) -> printDiagram hierarchy 22 | ("reoptics" : _) -> printDiagram reOptics 23 | ("indexedoptics" : _) -> printDiagram indexedOptics 24 | (s : _) | Just k <- find ((s ==) . okName) [minBound..maxBound] -> printDiagram (hierarchyFocus k) 25 | _ -> printDiagram hierarchy 26 | -------------------------------------------------------------------------------- /metametapost/src/MMP/Optics/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module MMP.Optics.Common where 3 | 4 | import Generics.SOP 5 | import qualified GHC.Generics as GHC 6 | import Optics 7 | 8 | import MetaMetaPost 9 | 10 | ------------------------------------------------------------------------------- 11 | -- representable with Rep f = OpticKind 12 | ------------------------------------------------------------------------------- 13 | 14 | data OK 15 | = Tag_Iso 16 | | Tag_Lens 17 | | Tag_Prism 18 | | Tag_AffineTraversal 19 | | Tag_Traversal 20 | | Tag_Setter 21 | | Tag_ReversedPrism 22 | | Tag_Getter 23 | | Tag_AffineFold 24 | | Tag_Fold 25 | | Tag_ReversedLens 26 | | Tag_Review 27 | 28 | -- indexed 29 | | Tag_IxGetter 30 | | Tag_IxLens 31 | | Tag_IxTraversal 32 | | Tag_IxSetter 33 | | Tag_IxFold 34 | | Tag_IxAffineTraversal 35 | | Tag_IxAffineFold 36 | deriving (Eq, Ord, Read, Show, Enum, Bounded, GHC.Generic) 37 | 38 | instance Generic OK 39 | 40 | -- | There should be enough @a@ 41 | data PerOK a = PerOK a a a a a a a a a a a a a a a a a a a 42 | deriving (Functor, Foldable, Traversable, GHC.Generic) 43 | 44 | instance Generic (PerOK a) 45 | instance Representable OK PerOK 46 | 47 | instance FunctorWithIndex OK PerOK 48 | instance FoldableWithIndex OK PerOK 49 | instance TraversableWithIndex OK PerOK where itraverse = gitraverse 50 | 51 | ------------------------------------------------------------------------------- 52 | -- Diagrams 53 | ------------------------------------------------------------------------------- 54 | 55 | dimX :: Expr s 'Numeric 56 | dimX = L (-90) 57 | 58 | dimY :: Expr s 'Numeric 59 | dimY = L 50 60 | 61 | okName :: OK -> String 62 | okName Tag_Iso = "Iso" 63 | okName Tag_Lens = "Lens" 64 | okName Tag_Prism = "Prism" 65 | okName Tag_AffineTraversal = "AffineTraversal" 66 | okName Tag_Traversal = "Traversal" 67 | okName Tag_IxTraversal = "IxTraversal" 68 | okName Tag_Setter = "Setter" 69 | okName Tag_IxSetter = "IxSetter" 70 | okName Tag_ReversedPrism = "ReversedPrism" 71 | okName Tag_Getter = "Getter" 72 | okName Tag_IxGetter = "IxGetter" 73 | okName Tag_AffineFold = "AffineFold" 74 | okName Tag_Fold = "Fold" 75 | okName Tag_IxFold = "IxFold" 76 | okName Tag_ReversedLens = "ReversedLens" 77 | okName Tag_Review = "Review" 78 | okName Tag_IxLens = "IxLens" 79 | okName Tag_IxAffineFold = "IxAffineFold" 80 | okName Tag_IxAffineTraversal = "IxAffineTraversal" 81 | 82 | -- | We need an offset to avoid empty space 83 | -- For some reason metapost doesn't cut it itself :( 84 | positions :: PerOK (Expr s 'Product) 85 | positions = tabulate $ \case 86 | Tag_Iso -> pair 2 1 87 | Tag_Lens -> pair 1 2 88 | Tag_IxLens -> pair 0 3 89 | Tag_Prism -> pair 3 2 90 | Tag_AffineTraversal -> pair 2 3 91 | Tag_IxAffineTraversal -> pair 1 4 92 | Tag_Traversal -> pair 3 4 93 | Tag_IxTraversal -> pair 2 5 94 | Tag_Setter -> pair 4 5 95 | Tag_IxSetter -> pair 3 6 96 | Tag_ReversedPrism -> pair 0 2 97 | Tag_Getter -> pair 1 3 98 | Tag_IxGetter -> pair 0 4 99 | Tag_AffineFold -> pair 2 4 100 | Tag_IxAffineFold -> pair 1 5 101 | Tag_Fold -> pair 3 5 102 | Tag_IxFold -> pair 2 6 103 | Tag_ReversedLens -> pair 4 2 104 | Tag_Review -> pair 3 3 105 | where 106 | pair x y = Pair (L x .* dimX) (L y .* dimY) 107 | -------------------------------------------------------------------------------- /metametapost/src/MMP/Optics/Hierarchy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | module MMP.Optics.Hierarchy where 3 | 4 | import Control.Monad 5 | import qualified Data.Graph as G 6 | import Optics 7 | 8 | import MMP.Optics.Common 9 | import MetaMetaPost 10 | 11 | hierarchy :: Stmts s () 12 | hierarchy = hierarchyColoured (\_ -> black) (\ _ _ -> black) 13 | 14 | hierarchyColoured :: (OK -> Expr s 'Color) -- ^ Colour for optic kind label 15 | -> (OK -> OK -> Expr s 'Color) -- ^ Colour for arrow from first optic kind to second 16 | -> Stmts s () 17 | hierarchyColoured text_colour arrow_colour = do 18 | clippath <- vardef3 "clippath" SPath SPicture SPicture $ \p a b -> do 19 | t1 <- bindSnd_ $ bbox_ a `IntersectionTimes` p 20 | t2 <- bindSnd_ $ bbox_ b `IntersectionTimes` reverse_ p 21 | return $ subpath_ (t1, length_ p .- t2) p 22 | 23 | z <- traverse bind_ positions 24 | q <- itraverse (\k -> bind_ . TheLabel ("\\mathit{" ++ okName k ++ "}")) z 25 | 26 | ifor_ q $ \k pic -> unless (isIndexed k) $ drawC_ (text_colour k) pic 27 | 28 | -- arrows 29 | let arrow a b = drawarrowC_ (arrow_colour a b) $ clippath 30 | (P $ (z ^. rix a) ... pathEnd (z ^. rix b)) 31 | (q ^. rix a) 32 | (q ^. rix b) 33 | 34 | mapM_ (uncurry arrow) edges 35 | 36 | edges :: [(OK, OK)] 37 | edges = [ (Tag_Iso, Tag_Lens) 38 | , (Tag_Iso, Tag_Prism) 39 | , (Tag_Iso, Tag_ReversedLens) 40 | , (Tag_Iso, Tag_ReversedPrism) 41 | 42 | , (Tag_ReversedLens, Tag_Review) 43 | , (Tag_Prism, Tag_Review) 44 | , (Tag_Prism, Tag_AffineTraversal) 45 | 46 | , (Tag_Lens, Tag_AffineTraversal) 47 | , (Tag_AffineTraversal, Tag_Traversal) 48 | , (Tag_Traversal, Tag_Setter) 49 | 50 | , (Tag_ReversedPrism, Tag_Getter) 51 | , (Tag_Getter, Tag_AffineFold) 52 | , (Tag_AffineFold, Tag_Fold) 53 | 54 | , (Tag_Lens, Tag_Getter) 55 | , (Tag_AffineTraversal, Tag_AffineFold) 56 | , (Tag_Traversal, Tag_Fold) 57 | ] 58 | 59 | isIndexed :: OK -> Bool 60 | isIndexed Tag_IxAffineFold = True 61 | isIndexed Tag_IxAffineTraversal = True 62 | isIndexed Tag_IxFold = True 63 | isIndexed Tag_IxSetter = True 64 | isIndexed Tag_IxTraversal = True 65 | isIndexed Tag_IxLens = True 66 | isIndexed Tag_IxGetter = True 67 | isIndexed _ = False 68 | 69 | graph :: G.Graph 70 | graph = G.buildG (fromEnum (minBound :: OK), fromEnum (maxBound :: OK)) 71 | (map (\ (x, y) -> (fromEnum x, fromEnum y)) edges) 72 | 73 | hierarchyFocus :: OK -> Stmts s () 74 | hierarchyFocus focus = hierarchyColoured (text_colour . fromEnum) 75 | (\ a b -> arrow_colour (fromEnum a) (fromEnum b)) 76 | where 77 | f = fromEnum focus 78 | 79 | text_colour k 80 | | k == f = red 81 | | G.path graph f k = black 82 | | G.path graph k f = black 83 | | otherwise = grey 84 | 85 | arrow_colour j k 86 | | G.path graph f j, G.path graph f k = black 87 | | G.path graph j f, G.path graph k f = black 88 | | otherwise = grey 89 | 90 | red, grey, black :: Expr s 'Color 91 | red = RGB (L 0.75) (L 0) (L 0) 92 | grey = RGB (L 0.75) (L 0.75) (L 0.75) 93 | black = RGB (L 0) (L 0) (L 0) 94 | -------------------------------------------------------------------------------- /metametapost/src/MMP/Optics/Re.hs: -------------------------------------------------------------------------------- 1 | module MMP.Optics.Re where 2 | 3 | import Control.Monad 4 | import Optics 5 | 6 | import MetaMetaPost 7 | import MMP.Optics.Common 8 | 9 | reOptics :: Stmts s () 10 | reOptics = do 11 | clippath <- vardef3 "clippath" SPath SPicture SPicture $ \p a b -> do 12 | t1 <- bindSnd_ $ bbox_ a `IntersectionTimes` p 13 | t2 <- bindSnd_ $ bbox_ b `IntersectionTimes` reverse_ p 14 | return $ subpath_ (t1, length_ p .- t2) p 15 | 16 | clippath' <- vardef3 "clippath" SPath SPath SPath $ \p a b -> do 17 | t1 <- bindSnd_ $ bbox_ a `IntersectionTimes` p 18 | t2 <- bindSnd_ $ bbox_ b `IntersectionTimes` reverse_ p 19 | return $ subpath_ (t1, length_ p .- t2) p 20 | 21 | clippathend <- vardef2 "clippathend" SPath SPicture $ \p a -> do 22 | t2 <- bindSnd_ $ bbox_ a `IntersectionTimes` reverse_ p 23 | return $ subpath_ (L 0, length_ p .- t2) p 24 | 25 | z <- traverse bind_ positions 26 | q <- itraverse (\k -> bind_ . TheLabel ("\\mathit{" ++ okName k ++ "}")) z 27 | 28 | ifor_ q $ \k pic -> when (isRe k) $ draw_ pic 29 | 30 | -- arrows 31 | let path a b = P $ z ^. rix a .... z ^. rix b 32 | let arrow a b = drawarrow_ $ clippath (path a b) (q ^. rix a) (q ^. rix b) 33 | 34 | arrow Tag_Iso Tag_Lens 35 | arrow Tag_Iso Tag_Prism 36 | arrow Tag_Iso Tag_ReversedLens 37 | arrow Tag_Iso Tag_ReversedPrism 38 | 39 | arrow Tag_ReversedLens Tag_Review 40 | arrow Tag_Prism Tag_Review 41 | 42 | arrow Tag_Lens Tag_Getter 43 | arrow Tag_ReversedPrism Tag_Getter 44 | 45 | -- Getter <-> Review 46 | red <- bind_ $ RGB (L 0.5) (L 0) (L 0) 47 | 48 | getterReview <- bind_ $ P $ (z ^. rix Tag_Getter, L 160) .... (z ^. rix Tag_Review) 49 | getterReview1 <- bind_ $ subpath_ (L 0.5 .* length_ getterReview, length_ getterReview) getterReview 50 | getterReview2 <- bind_ $ reverse_ $ subpath_ (L 0, L 0.5 .* length_ getterReview) getterReview 51 | 52 | drawarrowC_ red $ clippathend 53 | getterReview1 54 | (q ^. rix Tag_Review) 55 | drawarrowC_ red $ clippathend 56 | getterReview2 57 | (q ^. rix Tag_Getter) 58 | 59 | -- Lens <-> ReversedLens & Prism <-> ReversedPrism 60 | prismReview <- bind_ $ path Tag_Prism Tag_Review 61 | lensGetter <- bind_ $ path Tag_Lens Tag_Getter 62 | 63 | prismReversedPrism <- bind_ $ P $ 64 | (z ^. rix Tag_ReversedPrism, L 168) .... (z ^. rix Tag_Prism) 65 | lensReversedLens <- bind_ $ P $ 66 | (z ^. rix Tag_Lens, L 168) .... (z ^. rix Tag_ReversedLens) 67 | 68 | it1 <- bindSnd_ $ lensGetter `IntersectionTimes` prismReversedPrism 69 | ip1 <- bind_ $ lensGetter `IntersectionPoint` prismReversedPrism 70 | ic1 <- bind_ $ Circle (L 2) ip1 71 | 72 | it2 <- bindSnd_ $ prismReversedPrism `IntersectionTimes` lensReversedLens 73 | ip2 <- bind_ $ prismReversedPrism `IntersectionPoint` lensReversedLens 74 | ic2 <- bind_ $ Circle (L 8) ip2 75 | 76 | it3 <- bindSnd_ $ prismReview `IntersectionTimes` lensReversedLens 77 | ip3 <- bind_ $ prismReview `IntersectionPoint` lensReversedLens 78 | ic3 <- bind_ $ Circle (L 2) ip3 79 | 80 | -- Prism <-> ReversedPrism 81 | drawarrowC_ red $ clippath' 82 | (subpath_ (L 0, it1) prismReversedPrism) 83 | ic1 84 | (bbox_ $ q ^. rix Tag_ReversedPrism) 85 | drawarrowC_ red $ reverse_ $ clippath' 86 | (subpath_ (it1, length_ prismReversedPrism) prismReversedPrism) 87 | (bbox_ $ q ^. rix Tag_Prism) 88 | ic1 89 | 90 | -- Lens <-> ReversedLens pieces 91 | drawarrowC_ red $ clippath' 92 | (subpath_ (it3, length_ lensReversedLens) lensReversedLens) 93 | ic3 94 | (bbox_ $ q ^. rix Tag_ReversedLens) 95 | 96 | drawC_ red $ clippath' 97 | (subpath_ (it3, it2) lensReversedLens) 98 | ic3 99 | ic2 100 | 101 | drawarrowC_ red $ reverse_ $ clippath' 102 | (subpath_ (L 0, it2) lensReversedLens) 103 | (bbox_ $ q ^. rix Tag_Lens) 104 | ic2 105 | 106 | -- Iso 107 | -- TODO: add crossings... 108 | drawarrowC_ red $ P $ 109 | (z ^. rix Tag_Iso .+ Pair 5 5, L 80) ... 110 | (z ^. rix Tag_Iso .+ Pair 20 0, L 270) .... 111 | (z ^. rix Tag_Iso .+ Pair 5 (-5), L 100) 112 | 113 | where 114 | isRe Tag_Iso = True 115 | isRe Tag_Lens = True 116 | isRe Tag_Prism = True 117 | isRe Tag_ReversedLens = True 118 | isRe Tag_ReversedPrism = True 119 | isRe Tag_Getter = True 120 | isRe Tag_Review = True 121 | isRe _ = False 122 | -------------------------------------------------------------------------------- /migration-guide-0.4.md: -------------------------------------------------------------------------------- 1 | # Migration guide to optics-0.4 2 | 3 | ## FunctorWithIndex instances 4 | 5 | In `optics-0.4` the `FunctorWithIndex`, `FoldableWithIndex` and 6 | `TraversableWithIndex` type classes have been migrated to a new package, 7 | [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable). 8 | 9 | Beware: the `lens` package (versions `<5`) defines similar classes, 10 | and will also migrate to use `indexed-traversable` classes. Therefore, you 11 | might get duplicate instance errors if your package defines both. 12 | 13 | If you define your own `FunctorWithIndex` etc. instances, 14 | we recommend that you depend directly on the `indexed-traversable` package. 15 | If you want to continue support `optics-0.3` users, you may write 16 | 17 | ```haskell 18 | -- from indexed-traversable 19 | import Data.Functor.WithIndex 20 | 21 | -- from optics-core 22 | import qualified Optics.Core as O 23 | 24 | -- your (indexed) container 25 | data MySeq a = ... 26 | 27 | -- indexed-traversable instance 28 | instance FunctorWithIndex Int MySeq where imap = ... 29 | instance FoldableWithIndex Int MySeq where ifoldMap = ... 30 | instance TraversableWithIndex Int MySeq where itraverse = ... 31 | 32 | -- optics-core <0.4 instance, note the ! 33 | #if !MIN_VERSION_optics_core(0,4,0) 34 | instance O.FunctorWithIndex Int MySeq where imap = imap 35 | instance O.FoldableWithIndex Int MySeq where ifoldMap = ifoldMap 36 | instance O.TraversableWithIndex Int MySeq where itraverse = itraverse 37 | #endif 38 | ``` 39 | 40 | In other words, always provide `indexed-traversable` instances. 41 | If your package depends on `optics(-core)` and allows `optics-0.3`, 42 | you should additionally provide instances for `optics-0.3` type classes 43 | that can reuse the `indexed-traversable` instances. 44 | -------------------------------------------------------------------------------- /optics-core/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # optics-core-0.4.1.1 (2023-06-22) 2 | * Add INLINE pragmas to small functions that really should inline 3 | 4 | # optics-core-0.4.1 (2022-03-22) 5 | * Add support for GHC-9.2 6 | * Add `is` ([#410](https://github.com/well-typed/optics/pull/410)) 7 | * Improve error messages related to the `JoinKinds` class 8 | ([#439](https://github.com/well-typed/optics/pull/439)) 9 | * Port `universeOf`, `cosmosOf`, `paraOf`, `rewriteOf`, `transformOf`, 10 | `rewriteMOf` and `transformMOf` from `Control.Lens.Plated` 11 | ([#379](https://github.com/well-typed/optics/pull/379)) 12 | * Add `(%?)` composition operator 13 | ([#434](https://github.com/well-typed/optics/pull/434)) 14 | 15 | # optics-core-0.4 (2021-02-22) 16 | * See [migration-guide-0.4.md](https://github.com/well-typed/optics/blob/master/migration-guide-0.4.md) for more details 17 | * Add support for GHC-9.0 18 | * Drop support for GHC-8.0 19 | * The `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` type 20 | classes have been migrated to a new package, 21 | [`indexed-traversable`](https://hackage.haskell.org/package/indexed-traversable) 22 | ([#370](https://github.com/well-typed/optics/pull/370)) 23 | * Add `adjoin`, `iadjoin` and `both` to `Optics.[Ix]Traversal` 24 | ([#332](https://github.com/well-typed/optics/pull/332), 25 | [#372](https://github.com/well-typed/optics/pull/372)) 26 | * Add `ifst` and `isnd` to `Optics.IxLens` 27 | ([#389](https://github.com/well-typed/optics/pull/389)) 28 | * Generalize types of `generic` 29 | ([#376](https://github.com/well-typed/optics/pull/376)) 30 | * Make `chosen` an indexed lens to see which value is traversed 31 | ([#335](https://github.com/well-typed/optics/pull/335)) 32 | * Remove `GeneralLabelOptic` extensibility mechanism 33 | ([#361](https://github.com/well-typed/optics/pull/361)) 34 | * Add `gfield`, `gafield`, `gconstructor`, `gposition` and `gplate` for 35 | generics-based data access 36 | ([#358](https://github.com/well-typed/optics/pull/358), 37 | [#361](https://github.com/well-typed/optics/pull/361)) 38 | * Add support for generics-based field lenses and constructor prisms (`gfield` 39 | and `gconstructor`) to `LabelOptic` so they can be used via `OverloadedLabels` 40 | ([#361](https://github.com/well-typed/optics/pull/361)) 41 | * Remove unnecessary INLINE pragmas to reduce compile times 42 | ([#394](https://github.com/well-typed/optics/pull/394)) 43 | * Simplify the type of `(%)` using new `JoinKinds` and `AppendIndices` classes 44 | in place of the `Join` and `Append` type families 45 | ([#397](https://github.com/well-typed/optics/pull/397), 46 | [#399](https://github.com/well-typed/optics/pull/399)) 47 | 48 | # optics-core-0.3.0.1 (2020-08-05) 49 | * Add INLINE pragmas to `atraverseOf_`, `iaTraverseOf_` and `ignored` 50 | * Improve error message in catch-all `GeneralLabelOptic` instance 51 | * Make GHC optimize away profunctor type classes when profiling is enabled 52 | * Improve documentation of `Optics.Label`: 53 | - Add guide on how to effectively use labels as optics 54 | - Restructure existing sections 55 | 56 | # optics-core-0.3 (2020-04-15) 57 | * GHC-8.10 support 58 | * Add `filteredBy` and `unsafeFilteredBy` 59 | * Add `FunctorWithIndex`, `FoldableWithIndex` and `TraversableWithIndex` 60 | instances for `Const` and `Constant` 61 | * Add `afoldVL` and `iafoldVL` constructors 62 | * Rename `toAtraversalVL` to `atraverseOf`, and `toIxAtraversalVL` to `iatraverseOf` 63 | * Generalise `element` and `elementOf` to construct `IxAffineTraversal`s 64 | instead of `IxTraversal`s 65 | * Change `mapping` to work on optic kinds other than `Iso`: it now supports 66 | `Lens` and `Prism` degenerating to `Getter` and `Review` respectively 67 | * Generalise `ignored` to be an `IxAffineTraversal` instead of an `IxTraversal` 68 | * Add `singular` and `isingular` 69 | * Add `(^?!)` operator 70 | * Expose `Curry` and `CurryCompose` 71 | * Show expected elimination forms on optic kind mismatch 72 | * Use stricter `uncurry'` for better performance 73 | * Add hidden `LabelOptic` instance to postpone instance resolution 74 | * Add `GeneralLabelOptic` for pluggable generic optics as labels 75 | * Document monoidal structures of `Fold`s 76 | * Remove proxy argument from `implies` 77 | * Add `itoList` 78 | 79 | # optics-core-0.2 (2019-10-18) 80 | * Add `non`, `non'` and `anon` to `Optics.Iso` 81 | * `ix` can produce optic kinds other than `AffineTraversal` 82 | * Generalise type of `generic1` 83 | * Move some internal definitions out to new `indexed-profunctors` package 84 | * Introduce `OpticKind` and `IxList` type synonyms for better type inference 85 | * Make `itraverse` for `Seq` faster for `containers >= 0.6.0` 86 | * Assorted documentation improvements 87 | 88 | # optics-core-0.1 (2019-09-02) 89 | * Initial release 90 | -------------------------------------------------------------------------------- /optics-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /optics-core/diagrams/AffineFold.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/AffineFold.png -------------------------------------------------------------------------------- /optics-core/diagrams/AffineTraversal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/AffineTraversal.png -------------------------------------------------------------------------------- /optics-core/diagrams/Fold.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Fold.png -------------------------------------------------------------------------------- /optics-core/diagrams/Getter.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Getter.png -------------------------------------------------------------------------------- /optics-core/diagrams/Iso.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Iso.png -------------------------------------------------------------------------------- /optics-core/diagrams/Lens.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Lens.png -------------------------------------------------------------------------------- /optics-core/diagrams/Prism.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Prism.png -------------------------------------------------------------------------------- /optics-core/diagrams/ReversedLens.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/ReversedLens.png -------------------------------------------------------------------------------- /optics-core/diagrams/ReversedPrism.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/ReversedPrism.png -------------------------------------------------------------------------------- /optics-core/diagrams/Review.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Review.png -------------------------------------------------------------------------------- /optics-core/diagrams/Setter.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Setter.png -------------------------------------------------------------------------------- /optics-core/diagrams/Traversal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/Traversal.png -------------------------------------------------------------------------------- /optics-core/diagrams/reoptics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/diagrams/reoptics.png -------------------------------------------------------------------------------- /optics-core/indexedoptics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/indexedoptics.png -------------------------------------------------------------------------------- /optics-core/optics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/optics.png -------------------------------------------------------------------------------- /optics-core/reoptics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics-core/reoptics.png -------------------------------------------------------------------------------- /optics-core/src/Data/Either/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | Module: Data.Either.Optics 2 | -- Description: 'Prism's for the 'Either' datatype. 3 | -- 4 | -- This module defines 'Prism's for the constructors of the 'Either' datatype. 5 | module Data.Either.Optics 6 | ( _Left 7 | , _Right 8 | ) 9 | where 10 | 11 | import Optics.Prism 12 | 13 | -- | A 'Prism' that matches on the 'Left' constructor of 'Either'. 14 | _Left :: Prism (Either a b) (Either c b) a c 15 | _Left = 16 | prism 17 | Left 18 | (\ x -> 19 | case x of 20 | Left y -> Right y 21 | Right y -> Left (Right y) 22 | ) 23 | {-# INLINE _Left #-} 24 | 25 | -- | A 'Prism' that matches on the 'Right' constructor of 'Either'. 26 | _Right :: Prism (Either a b) (Either a c) b c 27 | _Right = 28 | prism 29 | Right 30 | (\ x -> 31 | case x of 32 | Left y -> Left (Left y) 33 | Right y -> Right y 34 | ) 35 | {-# INLINE _Right #-} 36 | -------------------------------------------------------------------------------- /optics-core/src/Data/IntSet/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.IntSet.Optics 3 | -- Description: Optics for working with 'IntSet's. 4 | -- 5 | -- This module defines optics for constructing and manipulating finite 'IntSet's. 6 | -- 7 | module Data.IntSet.Optics 8 | ( members 9 | , setmapped 10 | , setOf 11 | ) where 12 | 13 | import Data.IntSet (IntSet) 14 | import qualified Data.IntSet as IntSet 15 | 16 | import Optics.Fold 17 | import Optics.Optic 18 | import Optics.Setter 19 | 20 | -- | IntSet isn't Foldable, but this 'Fold' can be used to access the members of 21 | -- an 'IntSet'. 22 | -- 23 | -- >>> sumOf members $ setOf folded [1,2,3,4] 24 | -- 10 25 | members :: Fold IntSet Int 26 | members = folding IntSet.toAscList 27 | {-# INLINE members #-} 28 | 29 | -- | This 'Setter' can be used to change the type of a 'IntSet' by mapping the 30 | -- elements to new values. 31 | -- 32 | -- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for an 'IntSet', 33 | -- but you can manipulate it by reading using 'Optics.Fold.folded' and 34 | -- reindexing it via 'setmapped'. 35 | -- 36 | -- >>> over setmapped (+1) (IntSet.fromList [1,2,3,4]) 37 | -- fromList [2,3,4,5] 38 | setmapped :: Setter' IntSet Int 39 | setmapped = sets IntSet.map 40 | {-# INLINE setmapped #-} 41 | 42 | -- | Construct an 'IntSet' from a fold. 43 | -- 44 | -- >>> setOf folded [1,2,3,4] 45 | -- fromList [1,2,3,4] 46 | -- 47 | -- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)] 48 | -- fromList [1,2,3] 49 | setOf :: Is k A_Fold => Optic' k is s Int -> s -> IntSet 50 | setOf l = foldMapOf l IntSet.singleton 51 | {-# INLINE setOf #-} 52 | 53 | -- $setup 54 | -- >>> import Optics.Core 55 | -------------------------------------------------------------------------------- /optics-core/src/Data/List/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.List.Optics 3 | -- Description: Traversals for manipulating parts of a list. 4 | -- 5 | -- Additional optics for manipulating lists are present more generically in this 6 | -- package. 7 | -- 8 | -- The 'Optics.At.Core.Ixed' class allows traversing the element at a specific 9 | -- list index. 10 | -- 11 | -- >>> [0..10] ^? ix 4 12 | -- Just 4 13 | -- 14 | -- >>> [0..5] & ix 4 .~ 2 15 | -- [0,1,2,3,2,5] 16 | -- 17 | -- >>> [0..10] ^? ix 14 18 | -- Nothing 19 | -- 20 | -- >>> [0..5] & ix 14 .~ 2 21 | -- [0,1,2,3,4,5] 22 | -- 23 | -- The 'Optics.Cons.Core.Cons' and 'Optics.Empty.Core.AsEmpty' classes provide 24 | -- 'Optics.Prism.Prism's for list constructors. 25 | -- 26 | -- >>> [1..10] ^? _Cons 27 | -- Just (1,[2,3,4,5,6,7,8,9,10]) 28 | -- 29 | -- >>> [] ^? _Cons 30 | -- Nothing 31 | -- 32 | -- >>> [] ^? _Empty 33 | -- Just () 34 | -- 35 | -- >>> _Cons # (1, _Empty # ()) :: [Int] 36 | -- [1] 37 | -- 38 | -- Additionally, 'Optics.Cons.Core.Snoc' provides a 'Optics.Prism.Prism' for 39 | -- accessing the end of a list. Note that this 'Optics.Prism.Prism' always will 40 | -- need to traverse the whole list. 41 | -- 42 | -- >>> [1..5] ^? _Snoc 43 | -- Just ([1,2,3,4],5) 44 | -- 45 | -- >>> _Snoc # ([1,2],5) 46 | -- [1,2,5] 47 | -- 48 | -- Finally, it's possible to traverse, fold over, and map over index-value pairs 49 | -- thanks to instances of 'Optics.Indexed.Core.TraversableWithIndex', 50 | -- 'Optics.Indexed.Core.FoldableWithIndex', and 51 | -- 'Optics.Indexed.Core.FunctorWithIndex'. 52 | -- 53 | -- >>> imap (,) "Hello" 54 | -- [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] 55 | -- 56 | -- >>> ifoldMap replicate "Hello" 57 | -- "ellllloooo" 58 | -- 59 | -- >>> itraverse_ (curry print) "Hello" 60 | -- (0,'H') 61 | -- (1,'e') 62 | -- (2,'l') 63 | -- (3,'l') 64 | -- (4,'o') 65 | -- 66 | ---------------------------------------------------------------------------- 67 | module Data.List.Optics 68 | ( prefixed 69 | , suffixed 70 | ) where 71 | 72 | import Control.Monad (guard) 73 | import qualified Data.List as L 74 | 75 | import Optics.Prism 76 | 77 | -- | A 'Prism' stripping a prefix from a list when used as a 78 | -- 'Optics.Traversal.Traversal', or prepending that prefix when run backwards: 79 | -- 80 | -- >>> "preview" ^? prefixed "pre" 81 | -- Just "view" 82 | -- 83 | -- >>> "review" ^? prefixed "pre" 84 | -- Nothing 85 | -- 86 | -- >>> prefixed "pre" # "amble" 87 | -- "preamble" 88 | prefixed :: Eq a => [a] -> Prism' [a] [a] 89 | prefixed ps = prism' (ps ++) (L.stripPrefix ps) 90 | {-# INLINE prefixed #-} 91 | 92 | -- | A 'Prism' stripping a suffix from a list when used as a 93 | -- 'Optics.Traversal.Traversal', or appending that suffix when run backwards: 94 | -- 95 | -- >>> "review" ^? suffixed "view" 96 | -- Just "re" 97 | -- 98 | -- >>> "review" ^? suffixed "tire" 99 | -- Nothing 100 | -- 101 | -- >>> suffixed ".o" # "hello" 102 | -- "hello.o" 103 | suffixed :: Eq a => [a] -> Prism' [a] [a] 104 | suffixed qs = prism' (++ qs) (stripSuffix qs) 105 | {-# INLINE suffixed #-} 106 | 107 | ---------------------------------------- 108 | -- Internal 109 | 110 | stripSuffix :: Eq a => [a] -> [a] -> Maybe [a] 111 | stripSuffix qs xs0 = go xs0 zs 112 | where 113 | zs = drp qs xs0 114 | drp (_:ps) (_:xs) = drp ps xs 115 | drp [] xs = xs 116 | drp _ [] = [] 117 | go (_:xs) (_:ys) = go xs ys 118 | go xs [] = zipWith const xs0 zs <$ guard (xs == qs) 119 | go [] _ = Nothing -- impossible 120 | {-# INLINE stripSuffix #-} 121 | 122 | -- $setup 123 | -- >>> import Optics.Core 124 | -------------------------------------------------------------------------------- /optics-core/src/Data/Maybe/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Maybe.Optics 3 | -- Description: 'Prism's for the 'Maybe' datatype. 4 | -- 5 | -- This module defines 'Prism's for the constructors of the 'Maybe' datatype. 6 | module Data.Maybe.Optics 7 | ( _Nothing 8 | , _Just 9 | , (%?) 10 | ) 11 | where 12 | 13 | import Optics.Internal.Optic 14 | import Optics.Prism 15 | 16 | -- | A 'Prism' that matches on the 'Nothing' constructor of 'Maybe'. 17 | _Nothing :: Prism' (Maybe a) () 18 | _Nothing = 19 | prism 20 | (\ () -> Nothing) 21 | (\ x -> 22 | case x of 23 | Nothing -> Right () 24 | Just y -> Left (Just y) 25 | ) 26 | {-# INLINE _Nothing #-} 27 | 28 | -- | A 'Prism' that matches on the 'Just' constructor of 'Maybe'. 29 | _Just :: Prism (Maybe a) (Maybe b) a b 30 | _Just = 31 | prism 32 | Just 33 | (\ x -> 34 | case x of 35 | Nothing -> Left Nothing 36 | Just y -> Right y 37 | ) 38 | {-# INLINE _Just #-} 39 | 40 | -- | Shortcut for @'%' '_Just' '%'@. 41 | -- 42 | -- Useful for composing lenses of 'Maybe' type. 43 | -- 44 | -- @since 0.4.1 45 | infixl 9 %? 46 | (%?) 47 | :: (AppendIndices is js ks, JoinKinds k A_Prism k', JoinKinds k' l m) 48 | => Optic k is s t (Maybe u) (Maybe v) 49 | -> Optic l js u v a b 50 | -> Optic m ks s t a b 51 | o1 %? o2 = o1 % _Just % o2 52 | {-# INLINE (%?) #-} 53 | -------------------------------------------------------------------------------- /optics-core/src/Data/Sequence/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Sequence.Optics 3 | -- Description: Optics for working with 'Seq's. 4 | -- 5 | -- This module defines optics for constructing and manipulating finite 'Seq's. 6 | -- 7 | module Data.Sequence.Optics 8 | ( viewL, viewR 9 | , sliced, slicedTo, slicedFrom 10 | , seqOf 11 | ) where 12 | 13 | import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) 14 | import qualified Data.Sequence as Seq 15 | 16 | import Optics.Internal.Indexed 17 | import Optics.Fold 18 | import Optics.Iso 19 | import Optics.IxTraversal 20 | import Optics.Optic 21 | import Optics.Traversal 22 | 23 | -- * Sequence isomorphisms 24 | 25 | -- | A 'Seq' is isomorphic to a 'ViewL' 26 | -- 27 | -- @'viewl' m ≡ m 'Optics.Operators.^.' 'viewL'@ 28 | -- 29 | -- >>> Seq.fromList [1,2,3] ^. viewL 30 | -- 1 :< fromList [2,3] 31 | -- 32 | -- >>> Seq.empty ^. viewL 33 | -- EmptyL 34 | -- 35 | -- >>> EmptyL ^. re viewL 36 | -- fromList [] 37 | -- 38 | -- >>> review viewL $ 1 Seq.:< Seq.fromList [2,3] 39 | -- fromList [1,2,3] 40 | viewL :: Iso (Seq a) (Seq b) (ViewL a) (ViewL b) 41 | viewL = iso Seq.viewl $ \xs -> case xs of 42 | EmptyL -> mempty 43 | a Seq.:< as -> a Seq.<| as 44 | {-# INLINE viewL #-} 45 | 46 | -- | A 'Seq' is isomorphic to a 'ViewR' 47 | -- 48 | -- @'viewr' m ≡ m 'Optics.Operators.^.' 'viewR'@ 49 | -- 50 | -- >>> Seq.fromList [1,2,3] ^. viewR 51 | -- fromList [1,2] :> 3 52 | -- 53 | -- >>> Seq.empty ^. viewR 54 | -- EmptyR 55 | -- 56 | -- >>> EmptyR ^. re viewR 57 | -- fromList [] 58 | -- 59 | -- >>> review viewR $ Seq.fromList [1,2] Seq.:> 3 60 | -- fromList [1,2,3] 61 | viewR :: Iso (Seq a) (Seq b) (ViewR a) (ViewR b) 62 | viewR = iso Seq.viewr $ \xs -> case xs of 63 | EmptyR -> mempty 64 | as Seq.:> a -> as Seq.|> a 65 | {-# INLINE viewR #-} 66 | 67 | -- | Traverse the first @n@ elements of a 'Seq' 68 | -- 69 | -- >>> Seq.fromList [1,2,3,4,5] ^.. slicedTo 2 70 | -- [1,2] 71 | -- 72 | -- >>> Seq.fromList [1,2,3,4,5] & slicedTo 2 %~ (*10) 73 | -- fromList [10,20,3,4,5] 74 | -- 75 | -- >>> Seq.fromList [1,2,4,5,6] & slicedTo 10 .~ 0 76 | -- fromList [0,0,0,0,0] 77 | slicedTo :: Int -> IxTraversal' Int (Seq a) a 78 | slicedTo n = conjoined noix ix 79 | where 80 | noix = traversalVL $ \f m -> case Seq.splitAt n m of 81 | (l, r) -> (>< r) <$> traverse f l 82 | 83 | ix = itraversalVL $ \f m -> case Seq.splitAt n m of 84 | (l, r) -> (>< r) <$> itraverse f l 85 | {-# INLINE slicedTo #-} 86 | 87 | -- | Traverse all but the first @n@ elements of a 'Seq' 88 | -- 89 | -- >>> Seq.fromList [1,2,3,4,5] ^.. slicedFrom 2 90 | -- [3,4,5] 91 | -- 92 | -- >>> Seq.fromList [1,2,3,4,5] & slicedFrom 2 %~ (*10) 93 | -- fromList [1,2,30,40,50] 94 | -- 95 | -- >>> Seq.fromList [1,2,3,4,5] & slicedFrom 10 .~ 0 96 | -- fromList [1,2,3,4,5] 97 | slicedFrom :: Int -> IxTraversal' Int (Seq a) a 98 | slicedFrom n = conjoined noix ix 99 | where 100 | noix = traversalVL $ \f m -> case Seq.splitAt n m of 101 | (l, r) -> (l ><) <$> traverse f r 102 | 103 | ix = itraversalVL $ \f m -> case Seq.splitAt n m of 104 | (l, r) -> (l ><) <$> itraverse (f . (+n)) r 105 | {-# INLINE slicedFrom #-} 106 | 107 | -- | Traverse all the elements numbered from @i@ to @j@ of a 'Seq' 108 | -- 109 | -- >>> Seq.fromList [1,2,3,4,5] & sliced 1 3 %~ (*10) 110 | -- fromList [1,20,30,4,5] 111 | -- 112 | -- >>> Seq.fromList [1,2,3,4,5] ^.. sliced 1 3 113 | -- [2,3] 114 | -- 115 | -- >>> Seq.fromList [1,2,3,4,5] & sliced 1 3 .~ 0 116 | -- fromList [1,0,0,4,5] 117 | sliced :: Int -> Int -> IxTraversal' Int (Seq a) a 118 | sliced i j = conjoined noix ix 119 | where 120 | noix = traversalVL $ \f s -> case Seq.splitAt i s of 121 | (l, mr) -> case Seq.splitAt (j-i) mr of 122 | (m, r) -> traverse f m <&> \n -> l >< n >< r 123 | 124 | ix = itraversalVL $ \f s -> case Seq.splitAt i s of 125 | (l, mr) -> case Seq.splitAt (j-i) mr of 126 | (m, r) -> itraverse (f . (+i)) m <&> \n -> l >< n >< r 127 | {-# INLINE sliced #-} 128 | 129 | -- | Construct a 'Seq' from a fold. 130 | -- 131 | -- >>> seqOf folded ["hello","world"] 132 | -- fromList ["hello","world"] 133 | -- 134 | -- >>> seqOf (folded % _2) [("hello",1),("world",2),("!!!",3)] 135 | -- fromList [1,2,3] 136 | seqOf :: Is k A_Fold => Optic' k is s a -> s -> Seq a 137 | seqOf l = foldMapOf l Seq.singleton 138 | {-# INLINE seqOf #-} 139 | 140 | -- $setup 141 | -- >>> import Optics.Core 142 | -------------------------------------------------------------------------------- /optics-core/src/Data/Set/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Set.Optics 3 | -- Description: Optics for working with 'Set's. 4 | -- 5 | -- This module defines optics for constructing and manipulating finite 'Set's. 6 | -- 7 | module Data.Set.Optics 8 | ( setmapped 9 | , setOf 10 | ) where 11 | 12 | import Data.Set (Set) 13 | import qualified Data.Set as Set 14 | 15 | import Optics.Fold 16 | import Optics.Optic 17 | import Optics.Setter 18 | 19 | -- | This 'Setter' can be used to change the type of a 'Set' by mapping the 20 | -- elements to new values. 21 | -- 22 | -- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for a 'Set', but 23 | -- you can manipulate it by reading using 'Optics.Fold.folded' and reindexing it 24 | -- via 'setmapped'. 25 | -- 26 | -- >>> over setmapped (+1) (Set.fromList [1,2,3,4]) 27 | -- fromList [2,3,4,5] 28 | setmapped :: Ord b => Setter (Set a) (Set b) a b 29 | setmapped = sets Set.map 30 | {-# INLINE setmapped #-} 31 | 32 | -- | Construct a set from a fold. 33 | -- 34 | -- >>> setOf folded ["hello","world"] 35 | -- fromList ["hello","world"] 36 | -- 37 | -- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)] 38 | -- fromList [1,2,3] 39 | setOf :: (Is k A_Fold, Ord a) => Optic' k is s a -> s -> Set a 40 | setOf l = foldMapOf l Set.singleton 41 | {-# INLINE setOf #-} 42 | 43 | -- $setup 44 | -- >>> import Optics.Core 45 | -------------------------------------------------------------------------------- /optics-core/src/Data/Tree/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Tree.Optics 3 | -- Description: Optics for working with 'Tree's. 4 | -- 5 | -- This module defines optics for manipulating 'Tree's. 6 | -- 7 | module Data.Tree.Optics 8 | ( root 9 | , branches 10 | ) where 11 | 12 | import Data.Tree (Tree (..)) 13 | 14 | import Optics.Lens 15 | 16 | -- | A 'Lens' that focuses on the root of a 'Tree'. 17 | -- 18 | -- >>> view root $ Node 42 [] 19 | -- 42 20 | root :: Lens' (Tree a) a 21 | root = lensVL $ \f (Node a as) -> (`Node` as) <$> f a 22 | {-# INLINE root #-} 23 | 24 | -- | A 'Lens' returning the direct descendants of the root of a 'Tree' 25 | -- 26 | -- @'Optics.Getter.view' 'branches' ≡ 'subForest'@ 27 | branches :: Lens' (Tree a) [Tree a] 28 | branches = lensVL $ \f (Node a as) -> Node a <$> f as 29 | {-# INLINE branches #-} 30 | 31 | -- $setup 32 | -- >>> import Optics.Core 33 | -------------------------------------------------------------------------------- /optics-core/src/Data/Typeable/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Typeable.Optics 3 | -- Description: Optics for working with 'Typeable'. 4 | -- 5 | module Data.Typeable.Optics 6 | ( _cast 7 | , _gcast 8 | ) where 9 | 10 | import Data.Typeable 11 | import Data.Maybe 12 | 13 | import Optics.AffineTraversal 14 | 15 | -- | An 'AffineTraversal'' for working with a 'cast' of a 'Typeable' value. 16 | _cast :: (Typeable s, Typeable a) => AffineTraversal' s a 17 | _cast = atraversalVL $ \point f s -> case cast s of 18 | Just a -> fromMaybe (error "_cast: recast failed") . cast <$> f a 19 | Nothing -> point s 20 | {-# INLINE _cast #-} 21 | 22 | -- | An 'AffineTraversal'' for working with a 'gcast' of a 'Typeable' value. 23 | _gcast :: (Typeable s, Typeable a) => AffineTraversal' (c s) (c a) 24 | _gcast = atraversalVL $ \point f s -> case gcast s of 25 | Just a -> fromMaybe (error "_gcast: recast failed") . gcast <$> f a 26 | Nothing -> point s 27 | {-# INLINE _gcast #-} 28 | -------------------------------------------------------------------------------- /optics-core/src/GHC/Generics/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: GHC.Generics.Optics 3 | -- Description: Optics for types defined in "GHC.Generics". 4 | -- 5 | -- /Note:/ "GHC.Generics" exports a number of names that collide with "Optics" 6 | -- (at least 'GHC.Generics.to'). 7 | -- 8 | -- You can use hiding of imports to mitigate this to an extent. The following 9 | -- imports represent a fair compromise for user code: 10 | -- 11 | -- @ 12 | -- import "Optics" 13 | -- import "GHC.Generics" hiding (to) 14 | -- import "GHC.Generics.Optics" 15 | -- @ 16 | -- 17 | -- You can use 'generic' to replace 'GHC.Generics.from' and 'GHC.Generics.to' 18 | -- from "GHC.Generics". 19 | -- 20 | module GHC.Generics.Optics 21 | ( generic 22 | , generic1 23 | , _V1 24 | , _U1 25 | , _Par1 26 | , _Rec1 27 | , _K1 28 | , _M1 29 | , _L1 30 | , _R1 31 | ) where 32 | 33 | import Optics.Internal.Generic 34 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Arrow.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Arrow 3 | -- Description: Turn optics into arrow transformers. 4 | module Optics.Arrow 5 | ( ArrowOptic(..) 6 | , assignA 7 | ) where 8 | 9 | import Control.Arrow 10 | import Data.Coerce 11 | import qualified Control.Category as C 12 | 13 | import Data.Profunctor.Indexed 14 | 15 | import Optics.AffineTraversal 16 | import Optics.Prism 17 | import Optics.Setter 18 | import Optics.Internal.Optic 19 | import Optics.Internal.Utils 20 | 21 | newtype WrappedArrow p i a b = WrapArrow { unwrapArrow :: p a b } 22 | 23 | instance C.Category p => C.Category (WrappedArrow p i) where 24 | WrapArrow f . WrapArrow g = WrapArrow (f C.. g) 25 | id = WrapArrow C.id 26 | {-# INLINE (.) #-} 27 | {-# INLINE id #-} 28 | 29 | instance Arrow p => Arrow (WrappedArrow p i) where 30 | arr = WrapArrow #. arr 31 | first = WrapArrow #. first .# unwrapArrow 32 | second = WrapArrow #. second .# unwrapArrow 33 | WrapArrow a *** WrapArrow b = WrapArrow (a *** b) 34 | WrapArrow a &&& WrapArrow b = WrapArrow (a &&& b) 35 | {-# INLINE arr #-} 36 | {-# INLINE first #-} 37 | {-# INLINE second #-} 38 | {-# INLINE (***) #-} 39 | {-# INLINE (&&&) #-} 40 | 41 | instance Arrow p => Profunctor (WrappedArrow p) where 42 | dimap f g k = arr f >>> k >>> arr g 43 | lmap f k = arr f >>> k 44 | rmap g k = k >>> arr g 45 | {-# INLINE dimap #-} 46 | {-# INLINE lmap #-} 47 | {-# INLINE rmap #-} 48 | 49 | lcoerce' = lmap coerce 50 | rcoerce' = rmap coerce 51 | {-# INLINE lcoerce' #-} 52 | {-# INLINE rcoerce' #-} 53 | 54 | instance Arrow p => Strong (WrappedArrow p) where 55 | first' (WrapArrow k) = WrapArrow (first k) 56 | second' (WrapArrow k) = WrapArrow (second k) 57 | {-# INLINE first' #-} 58 | {-# INLINE second' #-} 59 | 60 | instance ArrowChoice p => Choice (WrappedArrow p) where 61 | left' (WrapArrow k) = WrapArrow (left k) 62 | right' (WrapArrow k) = WrapArrow (right k) 63 | {-# INLINE left' #-} 64 | {-# INLINE right' #-} 65 | 66 | instance ArrowChoice p => Visiting (WrappedArrow p) 67 | 68 | class Arrow arr => ArrowOptic k arr where 69 | -- | Turn an optic into an arrow transformer. 70 | overA :: Optic k is s t a b -> arr a b -> arr s t 71 | 72 | instance Arrow arr => ArrowOptic An_Iso arr where 73 | overA = overA__ 74 | {-# INLINE overA #-} 75 | 76 | instance Arrow arr => ArrowOptic A_Lens arr where 77 | overA = overA__ 78 | {-# INLINE overA #-} 79 | 80 | instance ArrowChoice arr => ArrowOptic A_Prism arr where 81 | overA = overA__ 82 | {-# INLINE overA #-} 83 | 84 | instance ArrowChoice arr => ArrowOptic An_AffineTraversal arr where 85 | overA = overA__ 86 | {-# INLINE overA #-} 87 | 88 | -- | Run an arrow command and use the output to set all the targets of an optic 89 | -- to the result. 90 | -- 91 | -- @ 92 | -- runKleisli action ((), (), ()) where 93 | -- action = assignA _1 (Kleisli (const getVal1)) 94 | -- \>>> assignA _2 (Kleisli (const getVal2)) 95 | -- \>>> assignA _3 (Kleisli (const getVal3)) 96 | -- getVal1 :: Either String Int 97 | -- getVal1 = ... 98 | -- getVal2 :: Either String Bool 99 | -- getVal2 = ... 100 | -- getVal3 :: Either String Char 101 | -- getVal3 = ... 102 | -- @ 103 | -- 104 | -- has the type @'Either' 'String' ('Int', 'Bool', 'Char')@ 105 | assignA 106 | :: (Is k A_Setter, Arrow arr) 107 | => Optic k is s t a b 108 | -> arr s b -> arr s t 109 | assignA o p = arr (flip $ set o) &&& p >>> arr (uncurry' id) 110 | {-# INLINE assignA #-} 111 | 112 | ---------------------------------------- 113 | 114 | -- | Internal implementation of overA. 115 | overA__ 116 | :: (p ~ WrappedArrow arr, Profunctor p, Constraints k p) 117 | => Optic k is s t a b 118 | -> arr a b -> arr s t 119 | overA__ o = unwrapArrow #. getOptic o .# WrapArrow 120 | {-# INLINE overA__ #-} 121 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Coerce.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Coerce 3 | -- Description: Operators to 'coerce' the type parameters of 'Optic'. 4 | -- 5 | -- This module defines operations to 'coerce' the type parameters of optics to 6 | -- a representationally equal type. For example, if we have 7 | -- 8 | -- > newtype MkInt = MkInt Int 9 | -- 10 | -- and 11 | -- 12 | -- > l :: Lens' S Int 13 | -- 14 | -- then 15 | -- 16 | -- > coerceA @Int @MkInt l :: Lens' S MkInt 17 | -- 18 | module Optics.Coerce 19 | ( coerceS 20 | , coerceT 21 | , coerceA 22 | , coerceB 23 | ) where 24 | 25 | import Data.Coerce 26 | 27 | import Data.Profunctor.Indexed 28 | 29 | import Optics.Internal.Optic 30 | 31 | -- | Lift 'coerce' to the @s@ parameter of an optic. 32 | coerceS 33 | :: Coercible s s' 34 | => Optic k is s t a b 35 | -> Optic k is s' t a b 36 | coerceS = \(Optic o) -> Optic (lcoerce . o) 37 | {-# INLINE coerceS #-} 38 | 39 | -- | Lift 'coerce' to the @t@ parameter of an optic. 40 | coerceT 41 | :: Coercible t t' 42 | => Optic k is s t a b 43 | -> Optic k is s t' a b 44 | coerceT = \(Optic o) -> Optic (rcoerce . o) 45 | {-# INLINE coerceT #-} 46 | 47 | -- | Lift 'coerce' to the @a@ parameter of an optic. 48 | coerceA 49 | :: Coercible a a' 50 | => Optic k is s t a b 51 | -> Optic k is s t a' b 52 | coerceA = \(Optic o) -> Optic (o . lcoerce) 53 | {-# INLINE coerceA #-} 54 | 55 | -- | Lift 'coerce' to the @b@ parameter of an optic. 56 | coerceB 57 | :: Coercible b b' 58 | => Optic k is s t a b 59 | -> Optic k is s t a b' 60 | coerceB = \(Optic o) -> Optic (o . rcoerce) 61 | {-# INLINE coerceB #-} 62 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Core.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- 3 | -- Module: Optics.Core 4 | -- Description: The core optics functionality re-exported. 5 | -- 6 | -- See the @Optics@ module in the main @optics@ package for overview 7 | -- documentation. 8 | -- 9 | module Optics.Core 10 | ( 11 | -- * Basic definitions 12 | module Optics.Optic 13 | 14 | -- * Kinds of optic 15 | , module O 16 | 17 | -- * Indexed optics 18 | , module I 19 | 20 | -- * Overloaded labels 21 | , module Optics.Label 22 | 23 | -- * Combinators 24 | , module P 25 | 26 | -- * Optics for basic data types 27 | , module D 28 | ) 29 | where 30 | 31 | import Optics.AffineFold as O 32 | import Optics.AffineTraversal as O 33 | import Optics.Fold as O 34 | import Optics.Getter as O 35 | import Optics.Iso as O 36 | import Optics.IxAffineFold as O 37 | import Optics.IxAffineTraversal as O 38 | import Optics.IxFold as O 39 | import Optics.IxGetter as O 40 | import Optics.IxLens as O 41 | import Optics.IxSetter as O 42 | import Optics.IxTraversal as O 43 | import Optics.Lens as O 44 | import Optics.ReversedLens as O 45 | import Optics.Prism as O 46 | import Optics.ReversedPrism as O 47 | import Optics.Review as O 48 | import Optics.Setter as O 49 | import Optics.Traversal as O 50 | 51 | import Optics.Indexed.Core as I 52 | 53 | import Optics.Arrow as P 54 | import Optics.At.Core as P 55 | import Optics.Coerce as P 56 | import Optics.Cons.Core as P 57 | import Optics.Each.Core as P 58 | import Optics.Empty.Core as P 59 | import Optics.Generic as P 60 | import Optics.Mapping as P 61 | import Optics.Operators as P 62 | import Optics.Re as P 63 | import Optics.ReadOnly as P 64 | 65 | import Optics.Label 66 | import Optics.Optic 67 | 68 | import Data.Either.Optics as D 69 | import Data.Maybe.Optics as D 70 | import Data.Tuple.Optics as D 71 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Core/Extras.hs: -------------------------------------------------------------------------------- 1 | module Optics.Core.Extras 2 | ( 3 | is 4 | ) 5 | where 6 | 7 | import Data.Maybe 8 | 9 | import Optics.Optic 10 | import Optics.AffineFold 11 | 12 | -- | Check to see if this 'AffineFold' matches. 13 | -- 14 | -- >>> is _Just Nothing 15 | -- False 16 | -- 17 | -- @since 0.4.1 18 | is :: Is k An_AffineFold => Optic' k is s a -> s -> Bool 19 | is k s = isJust (preview k s) 20 | {-# INLINE is #-} 21 | 22 | -- $setup 23 | -- >>> import Optics.Core 24 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Empty/Core.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Empty.Core 3 | -- Description: A 'Prism' for a type that may be '_Empty'. 4 | -- 5 | -- This module defines the 'AsEmpty' class, which provides a 'Prism' for a type 6 | -- that may be '_Empty'. 7 | -- 8 | -- Note that orphan instances for this class are defined in the @Optics.Empty@ 9 | -- module from @optics-extra@, so if you are not simply depending on @optics@ 10 | -- you may wish to import that module instead. 11 | -- 12 | -- >>> isn't _Empty [1,2,3] 13 | -- True 14 | -- 15 | -- >>> case Nothing of { Empty -> True; _ -> False } 16 | -- True 17 | -- 18 | {-# LANGUAGE CPP #-} 19 | module Optics.Empty.Core 20 | ( AsEmpty(..) 21 | , pattern Empty 22 | ) where 23 | 24 | import Control.Applicative (ZipList(..)) 25 | import Data.Maybe (isNothing) 26 | import Data.Monoid (Any (..), All (..), Product (..), Sum (..), Last (..), First (..), Dual (..)) 27 | 28 | import Data.Set (Set) 29 | import qualified Data.Set as Set 30 | import Data.IntMap (IntMap) 31 | import qualified Data.IntMap as IntMap 32 | import Data.IntSet (IntSet) 33 | import qualified Data.IntSet as IntSet 34 | import Data.Map (Map) 35 | import qualified Data.Map as Map 36 | import qualified Data.Sequence as Seq 37 | 38 | import Data.Profunctor.Indexed 39 | 40 | import Data.Maybe.Optics 41 | import Optics.AffineTraversal 42 | import Optics.Fold 43 | import Optics.Iso 44 | import Optics.Optic 45 | import Optics.Prism 46 | import Optics.Review 47 | 48 | #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) 49 | import GHC.Event (Event) 50 | #endif 51 | 52 | -- | Class for types that may be '_Empty'. 53 | -- 54 | class AsEmpty a where 55 | -- | 56 | -- 57 | -- >>> isn't _Empty [1,2,3] 58 | -- True 59 | _Empty :: Prism' a () 60 | default _Empty :: (Monoid a, Eq a) => Prism' a () 61 | _Empty = only mempty 62 | {-# INLINE _Empty #-} 63 | 64 | -- | Pattern synonym for matching on any type with an 'AsEmpty' instance. 65 | -- 66 | -- >>> case Nothing of { Empty -> True; _ -> False } 67 | -- True 68 | -- 69 | pattern Empty :: forall a. AsEmpty a => a 70 | pattern Empty <- (has _Empty -> True) where 71 | Empty = review _Empty () 72 | 73 | {- Default Monoid instances -} 74 | instance AsEmpty Ordering 75 | instance AsEmpty () 76 | instance AsEmpty Any 77 | instance AsEmpty All 78 | #if !defined(mingw32_HOST_OS) && !defined(ghcjs_HOST_OS) 79 | instance AsEmpty Event 80 | #endif 81 | instance (Eq a, Num a) => AsEmpty (Product a) 82 | instance (Eq a, Num a) => AsEmpty (Sum a) 83 | 84 | instance AsEmpty (Maybe a) where 85 | _Empty = _Nothing 86 | {-# INLINE _Empty #-} 87 | 88 | instance AsEmpty (Last a) where 89 | _Empty = nearly (Last Nothing) (isNothing .# getLast) 90 | {-# INLINE _Empty #-} 91 | 92 | instance AsEmpty (First a) where 93 | _Empty = nearly (First Nothing) (isNothing .# getFirst) 94 | {-# INLINE _Empty #-} 95 | 96 | instance AsEmpty a => AsEmpty (Dual a) where 97 | _Empty = iso getDual Dual % _Empty 98 | {-# INLINE _Empty #-} 99 | 100 | instance (AsEmpty a, AsEmpty b) => AsEmpty (a, b) where 101 | _Empty = prism' 102 | (\() -> (review _Empty (), review _Empty ())) 103 | (\(s, s') -> case matching _Empty s of 104 | Right () -> case matching _Empty s' of 105 | Right () -> Just () 106 | Left _ -> Nothing 107 | Left _ -> Nothing) 108 | {-# INLINE _Empty #-} 109 | 110 | instance (AsEmpty a, AsEmpty b, AsEmpty c) => AsEmpty (a, b, c) where 111 | _Empty = prism' 112 | (\() -> (review _Empty (), review _Empty (), review _Empty ())) 113 | (\(s, s', s'') -> case matching _Empty s of 114 | Right () -> case matching _Empty s' of 115 | Right () -> case matching _Empty s'' of 116 | Right () -> Just () 117 | Left _ -> Nothing 118 | Left _ -> Nothing 119 | Left _ -> Nothing) 120 | {-# INLINE _Empty #-} 121 | 122 | instance AsEmpty [a] where 123 | _Empty = nearly [] Prelude.null 124 | {-# INLINE _Empty #-} 125 | 126 | instance AsEmpty (ZipList a) where 127 | _Empty = nearly (ZipList []) (Prelude.null . getZipList) 128 | {-# INLINE _Empty #-} 129 | 130 | instance AsEmpty (Map k a) where 131 | _Empty = nearly Map.empty Map.null 132 | {-# INLINE _Empty #-} 133 | 134 | instance AsEmpty (IntMap a) where 135 | _Empty = nearly IntMap.empty IntMap.null 136 | {-# INLINE _Empty #-} 137 | 138 | instance AsEmpty (Set a) where 139 | _Empty = nearly Set.empty Set.null 140 | {-# INLINE _Empty #-} 141 | 142 | instance AsEmpty IntSet where 143 | _Empty = nearly IntSet.empty IntSet.null 144 | {-# INLINE _Empty #-} 145 | 146 | instance AsEmpty (Seq.Seq a) where 147 | _Empty = nearly Seq.empty Seq.null 148 | {-# INLINE _Empty #-} 149 | 150 | -- $setup 151 | -- >>> import Optics.Core 152 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Getter.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Getter 3 | -- Description: A function considered as an 'Optic'. 4 | -- 5 | -- A 'Getter' is simply a function considered as an 'Optic'. 6 | -- 7 | -- Given a function @f :: S -> A@, we can convert it into a 8 | -- @'Getter' S A@ using 'to', and convert back to a function using 'view'. 9 | -- 10 | -- This is typically useful not when you have functions/'Getter's 11 | -- alone, but when you are composing multiple 'Optic's to produce a 12 | -- 'Getter'. 13 | -- 14 | module Optics.Getter 15 | ( 16 | -- * Formation 17 | Getter 18 | 19 | -- * Introduction 20 | , to 21 | 22 | -- * Elimination 23 | , view 24 | , views 25 | 26 | -- * Computation 27 | -- | 28 | -- 29 | -- @ 30 | -- 'view' ('to' f) ≡ f 31 | -- @ 32 | 33 | -- * Well-formedness 34 | -- | A 'Getter' is not subject to any laws. 35 | 36 | -- * Subtyping 37 | , A_Getter 38 | -- | <> 39 | ) 40 | where 41 | 42 | import Data.Profunctor.Indexed 43 | 44 | import Optics.Internal.Bi 45 | import Optics.Internal.Optic 46 | 47 | -- | Type synonym for a getter. 48 | type Getter s a = Optic' A_Getter NoIx s a 49 | 50 | -- | View the value pointed to by a getter. 51 | -- 52 | -- If you want to 'view' a type-modifying optic that is insufficiently 53 | -- polymorphic to be type-preserving, use 'Optics.ReadOnly.getting'. 54 | -- 55 | view :: Is k A_Getter => Optic' k is s a -> s -> a 56 | view o = views o id 57 | {-# INLINE view #-} 58 | 59 | -- | View the function of the value pointed to by a getter. 60 | views :: Is k A_Getter => Optic' k is s a -> (a -> r) -> s -> r 61 | views o = \f -> runForget $ getOptic (castOptic @A_Getter o) (Forget f) 62 | {-# INLINE views #-} 63 | 64 | -- | Build a getter from a function. 65 | to :: (s -> a) -> Getter s a 66 | to f = Optic (lmap f . rphantom) 67 | {-# INLINE to #-} 68 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Bi.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Classes for co- and contravariant bifunctors. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.Bi where 8 | 9 | import Data.Coerce 10 | import Data.Void 11 | 12 | import Data.Profunctor.Indexed 13 | 14 | -- | Class for (covariant) bifunctors. 15 | class Bifunctor p where 16 | bimap :: (a -> b) -> (c -> d) -> p i a c -> p i b d 17 | first :: (a -> b) -> p i a c -> p i b c 18 | second :: (c -> d) -> p i a c -> p i a d 19 | 20 | instance Bifunctor Tagged where 21 | bimap _f g = Tagged #. g .# unTagged 22 | first _f = coerce 23 | second g = Tagged #. g .# unTagged 24 | 25 | -- | Class for contravariant bifunctors. 26 | class Bicontravariant p where 27 | contrabimap :: (b -> a) -> (d -> c) -> p i a c -> p i b d 28 | contrafirst :: (b -> a) -> p i a c -> p i b c 29 | contrasecond :: (c -> b) -> p i a b -> p i a c 30 | 31 | instance Bicontravariant (Forget r) where 32 | contrabimap f _g (Forget k) = Forget (k . f) 33 | contrafirst f (Forget k) = Forget (k . f) 34 | contrasecond _g (Forget k) = Forget k 35 | 36 | instance Bicontravariant (ForgetM r) where 37 | contrabimap f _g (ForgetM k) = ForgetM (k . f) 38 | contrafirst f (ForgetM k) = ForgetM (k . f) 39 | contrasecond _g (ForgetM k) = ForgetM k 40 | 41 | instance Bicontravariant (IxForget r) where 42 | contrabimap f _g (IxForget k) = IxForget (\i -> k i . f) 43 | contrafirst f (IxForget k) = IxForget (\i -> k i . f) 44 | contrasecond _g (IxForget k) = IxForget k 45 | 46 | instance Bicontravariant (IxForgetM r) where 47 | contrabimap f _g (IxForgetM k) = IxForgetM (\i -> k i . f) 48 | contrafirst f (IxForgetM k) = IxForgetM (\i -> k i . f) 49 | contrasecond _g (IxForgetM k) = IxForgetM k 50 | 51 | ---------------------------------------- 52 | 53 | -- | If @p@ is a 'Profunctor' and a 'Bifunctor' then its left parameter must be 54 | -- phantom. 55 | lphantom :: (Profunctor p, Bifunctor p) => p i a c -> p i b c 56 | lphantom = first absurd . lmap absurd 57 | 58 | -- | If @p@ is a 'Profunctor' and 'Bicontravariant' then its right parameter 59 | -- must be phantom. 60 | rphantom :: (Profunctor p, Bicontravariant p) => p i c a -> p i c b 61 | rphantom = rmap absurd . contrasecond absurd 62 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Fold.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of folds. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.Fold where 8 | 9 | import Data.Functor 10 | import Data.Foldable 11 | import Data.Maybe 12 | import qualified Data.Semigroup as SG 13 | 14 | import Data.Profunctor.Indexed 15 | 16 | import Optics.Internal.Bi 17 | import Optics.Internal.Optic 18 | 19 | -- | Internal implementation of 'Optics.Fold.foldVL'. 20 | foldVL__ 21 | :: (Bicontravariant p, Traversing p) 22 | => (forall f. Applicative f => (a -> f u) -> s -> f v) 23 | -> Optic__ p i i s t a b 24 | foldVL__ f = rphantom . wander f . rphantom 25 | {-# INLINE foldVL__ #-} 26 | 27 | -- | Internal implementation of 'Optics.Fold.folded'. 28 | folded__ 29 | :: (Bicontravariant p, Traversing p, Foldable f) 30 | => Optic__ p i i (f a) (f b) a b 31 | folded__ = foldVL__ traverse_ 32 | {-# INLINE folded__ #-} 33 | 34 | -- | Internal implementation of 'Optics.Fold.foldring'. 35 | foldring__ 36 | :: (Bicontravariant p, Traversing p) 37 | => (forall f. Applicative f => (a -> f u -> f u) -> f v -> s -> f w) 38 | -> Optic__ p i i s t a b 39 | foldring__ fr = foldVL__ $ \f -> void . fr (\a -> (f a *>)) (pure v) 40 | where 41 | v = error "foldring__: value used" 42 | {-# INLINE foldring__ #-} 43 | 44 | ------------------------------------------------------------------------------ 45 | -- Leftmost and Rightmost 46 | ------------------------------------------------------------------------------ 47 | 48 | -- | Used for 'Optics.Fold.headOf' and 'Optics.IxFold.iheadOf'. 49 | data Leftmost a = LPure | LLeaf a | LStep (Leftmost a) 50 | 51 | instance SG.Semigroup (Leftmost a) where 52 | x <> y = LStep $ case x of 53 | LPure -> y 54 | LLeaf _ -> x 55 | LStep x' -> case y of 56 | -- The last two cases make headOf produce a Just as soon as any element is 57 | -- encountered, and possibly serve as a micro-optimisation; this behaviour 58 | -- can be disabled by replacing them with _ -> mappend x y'. Note that 59 | -- this means that firstOf (backwards folded) [1..] is Just _|_. 60 | LPure -> x' 61 | LLeaf a -> LLeaf $ fromMaybe a (getLeftmost x') 62 | LStep y' -> x' SG.<> y' 63 | 64 | instance Monoid (Leftmost a) where 65 | mempty = LPure 66 | mappend = (SG.<>) 67 | 68 | -- | Extract the 'Leftmost' element. This will fairly eagerly determine that it 69 | -- can return 'Just' the moment it sees any element at all. 70 | getLeftmost :: Leftmost a -> Maybe a 71 | getLeftmost LPure = Nothing 72 | getLeftmost (LLeaf a) = Just a 73 | getLeftmost (LStep x) = go x 74 | where 75 | -- Make getLeftmost non-recursive so it might be inlined for LPure/LLeaf. 76 | go LPure = Nothing 77 | go (LLeaf a) = Just a 78 | go (LStep a) = go a 79 | 80 | -- | Used for 'Optics.Fold.lastOf' and 'Optics.IxFold.ilastOf'. 81 | data Rightmost a = RPure | RLeaf a | RStep (Rightmost a) 82 | 83 | instance SG.Semigroup (Rightmost a) where 84 | x <> y = RStep $ case y of 85 | RPure -> x 86 | RLeaf _ -> y 87 | RStep y' -> case x of 88 | -- The last two cases make lastOf produce a Just as soon as any element is 89 | -- encountered, and possibly serve as a micro-optimisation; this behaviour 90 | -- can be disabled by replacing them with _ -> mappend x y'. Note that 91 | -- this means that lastOf folded [1..] is Just _|_. 92 | RPure -> y' 93 | RLeaf a -> RLeaf $ fromMaybe a (getRightmost y') 94 | RStep x' -> mappend x' y' 95 | 96 | instance Monoid (Rightmost a) where 97 | mempty = RPure 98 | mappend = (SG.<>) 99 | 100 | -- | Extract the 'Rightmost' element. This will fairly eagerly determine that it 101 | -- can return 'Just' the moment it sees any element at all. 102 | getRightmost :: Rightmost a -> Maybe a 103 | getRightmost RPure = Nothing 104 | getRightmost (RLeaf a) = Just a 105 | getRightmost (RStep x) = go x 106 | where 107 | -- Make getRightmost non-recursive so it might be inlined for RPure/RLeaf. 108 | go RPure = Nothing 109 | go (RLeaf a) = Just a 110 | go (RStep a) = go a 111 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeInType #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | 6 | -- | Internal implementation details of indexed optics. 7 | -- 8 | -- This module is intended for internal use only, and may change without warning 9 | -- in subsequent releases. 10 | module Optics.Internal.Indexed where 11 | 12 | import Data.Kind (Type) 13 | import GHC.TypeLits 14 | 15 | import Data.Profunctor.Indexed 16 | import Optics.Internal.Optic 17 | 18 | -- | Show useful error message when a function expects optics without indices. 19 | class is ~ NoIx => AcceptsEmptyIndices (f :: Symbol) (is :: IxList) 20 | 21 | instance 22 | ( TypeError 23 | ('Text "‘" ':<>: 'Text f ':<>: 'Text "’ accepts only optics with no indices") 24 | , (x ': xs) ~ NoIx 25 | ) => AcceptsEmptyIndices f (x ': xs) 26 | 27 | instance AcceptsEmptyIndices f '[] 28 | 29 | -- | Check whether a list of indices is not empty and generate sensible error 30 | -- message if it's not. 31 | class NonEmptyIndices (is :: IxList) 32 | 33 | instance 34 | ( TypeError 35 | ('Text "Indexed optic is expected") 36 | ) => NonEmptyIndices '[] 37 | 38 | instance NonEmptyIndices (x ': xs) 39 | 40 | -- | Generate sensible error messages in case a user tries to pass either an 41 | -- unindexed optic or indexed optic with unflattened indices where indexed optic 42 | -- with a single index is expected. 43 | class is ~ '[i] => HasSingleIndex (is :: IxList) (i :: Type) 44 | 45 | instance HasSingleIndex '[i] i 46 | 47 | instance 48 | ( TypeError 49 | ('Text "Indexed optic is expected") 50 | , '[] ~ '[i] 51 | ) => HasSingleIndex '[] i 52 | 53 | instance 54 | ( TypeError 55 | ('Text "Use (<%>) or icompose to combine indices of type " 56 | ':<>: ShowTypes is) 57 | , is ~ '[i1, i2] 58 | , is ~ '[i] 59 | ) => HasSingleIndex '[i1, i2] i 60 | 61 | instance 62 | ( TypeError 63 | ('Text "Use icompose3 to combine indices of type " 64 | ':<>: ShowTypes is) 65 | , is ~ '[i1, i2, i3] 66 | , is ~ '[i] 67 | ) => HasSingleIndex [i1, i2, i3] i 68 | 69 | instance 70 | ( TypeError 71 | ('Text "Use icompose4 to combine indices of type " 72 | ':<>: ShowTypes is) 73 | , is ~ '[i1, i2, i3, i4] 74 | , is ~ '[i] 75 | ) => HasSingleIndex '[i1, i2, i3, i4] i 76 | 77 | instance 78 | ( TypeError 79 | ('Text "Use icompose5 to flatten indices of type " 80 | ':<>: ShowTypes is) 81 | , is ~ '[i1, i2, i3, i4, i5] 82 | , is ~ '[i] 83 | ) => HasSingleIndex '[i1, i2, i3, i4, i5] i 84 | 85 | instance 86 | ( TypeError 87 | ('Text "Use icomposeN to flatten indices of type " 88 | ':<>: ShowTypes is) 89 | , is ~ (i1 ': i2 ': i3 ': i4 ': i5 ': i6 : is') 90 | , is ~ '[i] 91 | ) => HasSingleIndex (i1 ': i2 ': i3 ': i4 ': i5 ': i6 ': is') i 92 | 93 | ---------------------------------------- 94 | -- Helpers for HasSingleIndex 95 | 96 | type family ShowTypes (types :: [Type]) :: ErrorMessage where 97 | ShowTypes '[i] = QuoteType i 98 | ShowTypes '[i, j] = QuoteType i ':<>: 'Text " and " ':<>: QuoteType j 99 | ShowTypes (i ': is) = QuoteType i ':<>: 'Text ", " ':<>: ShowTypes is 100 | 101 | ---------------------------------------- 102 | 103 | data IntT f a = IntT {-# UNPACK #-} !Int (f a) 104 | 105 | unIntT :: IntT f a -> f a 106 | unIntT (IntT _ fa) = fa 107 | 108 | newtype Indexing f a = Indexing { runIndexing :: Int -> IntT f a } 109 | 110 | instance Functor f => Functor (Indexing f) where 111 | fmap f (Indexing m) = Indexing $ \i -> case m i of 112 | IntT j x -> IntT j (fmap f x) 113 | 114 | instance Applicative f => Applicative (Indexing f) where 115 | pure x = Indexing $ \i -> IntT i (pure x) 116 | Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of 117 | IntT j ff -> case ma j of 118 | IntT k fa -> IntT k (ff <*> fa) 119 | 120 | -- | Index a traversal by position of visited elements. 121 | indexing 122 | :: ((a -> Indexing f b) -> s -> Indexing f t) 123 | -> ((Int -> a -> f b) -> s -> f t) 124 | indexing l iafb s = 125 | unIntT $ runIndexing (l (\a -> Indexing (\i -> IntT (i + 1) (iafb i a))) s) 0 126 | 127 | ---------------------------------------- 128 | 129 | -- | Construct a conjoined indexed optic that provides a separate code path when 130 | -- used without indices. Useful for defining indexed optics that are as 131 | -- efficient as their unindexed equivalents when used without indices. 132 | -- 133 | -- /Note:/ @'conjoined' f g@ is well-defined if and only if @f ≡ 134 | -- 'Optics.Indexed.Core.noIx' g@. 135 | conjoined 136 | :: is `HasSingleIndex` i 137 | => Optic k NoIx s t a b 138 | -> Optic k is s t a b 139 | -> Optic k is s t a b 140 | conjoined (Optic f) (Optic g) = Optic (conjoined__ f g) 141 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Indexed/Classes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE UndecidableInstances #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | -- | Internal implementation details of indexed optics. 6 | -- 7 | -- This module is intended for internal use only, and may change without warning 8 | -- in subsequent releases. 9 | module Optics.Internal.Indexed.Classes ( 10 | module Data.Functor.WithIndex, 11 | module Data.Foldable.WithIndex, 12 | module Data.Traversable.WithIndex, 13 | ) where 14 | 15 | import Data.Functor.WithIndex 16 | import Data.Foldable.WithIndex 17 | import Data.Traversable.WithIndex 18 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/IxFold.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of indexed folds. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.IxFold where 8 | 9 | import Data.Functor 10 | import Data.Foldable 11 | 12 | import Data.Profunctor.Indexed 13 | 14 | import Optics.Internal.Bi 15 | import Optics.Internal.Indexed.Classes 16 | import Optics.Internal.Optic 17 | import Optics.Internal.Fold 18 | 19 | -- | Internal implementation of 'Optics.IxFold.ifoldVL'. 20 | ifoldVL__ 21 | :: (Bicontravariant p, Traversing p) 22 | => (forall f. Applicative f => (i -> a -> f u) -> s -> f v) 23 | -> Optic__ p j (i -> j) s t a b 24 | ifoldVL__ f = rphantom . iwander f . rphantom 25 | {-# INLINE ifoldVL__ #-} 26 | 27 | -- | Internal implementation of 'Optics.IxFold.ifolded'. 28 | ifolded__ 29 | :: (Bicontravariant p, Traversing p, FoldableWithIndex i f) 30 | => Optic__ p j (i -> j) (f a) t a b 31 | ifolded__ = conjoined__ (foldVL__ traverse_) (ifoldVL__ itraverse_) 32 | {-# INLINE ifolded__ #-} 33 | 34 | -- | Internal implementation of 'Optics.IxFold.ifoldring'. 35 | ifoldring__ 36 | :: (Bicontravariant p, Traversing p) 37 | => (forall f. Applicative f => (i -> a -> f u -> f u) -> f v -> s -> f w) 38 | -> Optic__ p j (i -> j) s t a b 39 | ifoldring__ fr = ifoldVL__ $ \f -> void . fr (\i a -> (f i a *>)) (pure v) 40 | where 41 | v = error "ifoldring__: value used" 42 | {-# INLINE ifoldring__ #-} 43 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/IxSetter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of indexed setters. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.IxSetter where 8 | 9 | import Data.Profunctor.Indexed 10 | 11 | import Optics.Internal.Indexed.Classes 12 | import Optics.Internal.Optic 13 | 14 | -- | Internal implementation of 'Optics.IxSetter.imapped'. 15 | imapped__ 16 | :: (Mapping p, FunctorWithIndex i f) 17 | => Optic__ p j (i -> j) (f a) (f b) a b 18 | imapped__ = conjoined__ (roam fmap) (iroam imap) 19 | {-# INLINE imapped__ #-} 20 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/IxTraversal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of indexed traversals. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.IxTraversal where 8 | 9 | import Data.Profunctor.Indexed 10 | 11 | import Optics.Internal.Fold 12 | import Optics.Internal.Indexed.Classes 13 | import Optics.Internal.IxFold 14 | import Optics.Internal.IxSetter 15 | import Optics.Internal.Optic 16 | import Optics.Internal.Setter 17 | 18 | -- | Internal implementation of 'Optics.IxTraversal.itraversed'. 19 | itraversed__ 20 | :: (Traversing p, TraversableWithIndex i f) 21 | => Optic__ p j (i -> j) (f a) (f b) a b 22 | itraversed__ = conjoined__ (wander traverse) (iwander itraverse) 23 | {-# INLINE [0] itraversed__ #-} 24 | 25 | -- Because itraversed__ inlines late, GHC needs rewrite rules for all cases in 26 | -- order to generate optimal code for each of them. The ones that rewrite 27 | -- traversal into a traversal correspond to an early inline. 28 | 29 | {-# RULES 30 | 31 | "itraversed__ -> wander traverse" 32 | forall (o :: Star g j a b). itraversed__ o = wander traverse (reStar o) 33 | :: TraversableWithIndex i f => Star g (i -> j) (f a) (f b) 34 | 35 | "itraversed__ -> folded__" 36 | forall (o :: Forget r j a b). itraversed__ o = folded__ (reForget o) 37 | :: FoldableWithIndex i f => Forget r (i -> j) (f a) (f b) 38 | 39 | "itraversed__ -> mapped__" 40 | forall (o :: FunArrow j a b). itraversed__ o = mapped__ (reFunArrow o) 41 | :: FunctorWithIndex i f => FunArrow (i -> j) (f a) (f b) 42 | 43 | "itraversed__ -> itraverse" 44 | forall (o :: IxStar g j a b). itraversed__ o = iwander itraverse o 45 | :: TraversableWithIndex i f => IxStar g (i -> j) (f a) (f b) 46 | 47 | "itraversed__ -> ifolded__" 48 | forall (o :: IxForget r j a b). itraversed__ o = ifolded__ o 49 | :: FoldableWithIndex i f => IxForget r (i -> j) (f a) (f b) 50 | 51 | "itraversed__ -> imapped__" 52 | forall (o :: IxFunArrow j a b). itraversed__ o = imapped__ o 53 | :: FunctorWithIndex i f => IxFunArrow (i -> j) (f a) (f b) 54 | 55 | #-} 56 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Magic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_HADDOCK not-home #-} 5 | 6 | -- | This module is intended for internal use only, and may change without 7 | -- warning in subsequent releases. 8 | module Optics.Internal.Magic where 9 | 10 | -- | How about a magic trick? I'm gonna make the coverage condition disappear. 11 | class Dysfunctional field k s t a b | field s -> k t a b 12 | , field t -> k s a b 13 | 14 | -- | Show something useful when type inference goes into a loop and stops with 15 | -- "reduction stack overflow" message (sometimes happens when trying to infer 16 | -- types of local bindings when monomorphism restriction is enabled). 17 | instance 18 | ( TypeInferenceLoop 19 | "Type inference for the local binding failed. Write the type" 20 | "signature yourself or disable monomorphism restriction with" 21 | "NoMonomorphismRestriction LANGUAGE pragma so GHC infers it." 22 | field k s t a b 23 | ) => Dysfunctional field k s t a b 24 | 25 | class TypeInferenceLoop msg1 msg2 msg3 field k s t a b | field s -> k t a b 26 | , field t -> k s a b 27 | 28 | -- | Including the instance head in the context lifts the coverage condition for 29 | -- all type variables in the instance. A dirty trick until we have 30 | -- https://github.com/ghc-proposals/ghc-proposals/pull/374 and can do it 31 | -- properly. 32 | instance 33 | ( TypeInferenceLoop msg1 msg2 msg3 field k s t a b 34 | ) => TypeInferenceLoop msg1 msg2 msg3 field k s t a b 35 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Optic/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeInType #-} 3 | {-# OPTIONS_HADDOCK not-home #-} 4 | 5 | -- | This module is intended for internal use only, and may change without 6 | -- warning in subsequent releases. 7 | module Optics.Internal.Optic.Types where 8 | 9 | import Data.Kind (Constraint, Type) 10 | 11 | import Data.Profunctor.Indexed 12 | 13 | import Optics.Internal.Bi 14 | 15 | -- | Kind for types used as optic tags, such as 'A_Lens'. 16 | -- 17 | -- @since 0.2 18 | type OpticKind = Type 19 | 20 | -- | Tag for an iso. 21 | data An_Iso :: OpticKind 22 | -- | Tag for a lens. 23 | data A_Lens :: OpticKind 24 | -- | Tag for a prism. 25 | data A_Prism :: OpticKind 26 | -- | Tag for an affine traversal. 27 | data An_AffineTraversal :: OpticKind 28 | -- | Tag for a traversal. 29 | data A_Traversal :: OpticKind 30 | -- | Tag for a setter. 31 | data A_Setter :: OpticKind 32 | -- | Tag for a reversed prism. 33 | data A_ReversedPrism :: OpticKind 34 | -- | Tag for a getter. 35 | data A_Getter :: OpticKind 36 | -- | Tag for an affine fold. 37 | data An_AffineFold :: OpticKind 38 | -- | Tag for a fold. 39 | data A_Fold :: OpticKind 40 | -- | Tag for a reversed lens. 41 | data A_ReversedLens :: OpticKind 42 | -- | Tag for a review. 43 | data A_Review :: OpticKind 44 | 45 | -- | Mapping tag types @k@ to constraints on @p@. 46 | -- 47 | -- Using this type family we define the constraints that the various flavours of 48 | -- optics have to fulfill. 49 | -- 50 | type family Constraints (k :: OpticKind) (p :: Type -> Type -> Type -> Type) :: Constraint where 51 | Constraints An_Iso p = Profunctor p 52 | Constraints A_Lens p = Strong p 53 | Constraints A_ReversedLens p = Costrong p 54 | Constraints A_Prism p = Choice p 55 | Constraints A_ReversedPrism p = Cochoice p 56 | Constraints An_AffineTraversal p = Visiting p 57 | Constraints A_Traversal p = Traversing p 58 | Constraints A_Setter p = Mapping p 59 | Constraints A_Getter p = (Bicontravariant p, Cochoice p, Strong p) 60 | Constraints An_AffineFold p = (Bicontravariant p, Cochoice p, Visiting p) 61 | Constraints A_Fold p = (Bicontravariant p, Cochoice p, Traversing p) 62 | Constraints A_Review p = (Bifunctor p, Choice p, Costrong p) 63 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Setter.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of setters. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.Setter where 8 | 9 | import Data.Profunctor.Indexed 10 | 11 | import Optics.Internal.Optic 12 | 13 | -- | Internal implementation of 'Optics.Setter.mapped'. 14 | mapped__ 15 | :: (Mapping p, Functor f) 16 | => Optic__ p i i (f a) (f b) a b 17 | mapped__ = roam fmap 18 | {-# INLINE mapped__ #-} 19 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Traversal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | Internal implementation details of traversals. 4 | -- 5 | -- This module is intended for internal use only, and may change without warning 6 | -- in subsequent releases. 7 | module Optics.Internal.Traversal where 8 | 9 | import Data.Profunctor.Indexed 10 | 11 | import Optics.Internal.Optic 12 | import Optics.Internal.Fold 13 | import Optics.Internal.Setter 14 | 15 | -- | Internal implementation of 'Optics.Traversal.traversed'. 16 | traversed__ 17 | :: (Traversing p, Traversable f) 18 | => Optic__ p i i (f a) (f b) a b 19 | traversed__ = wander traverse 20 | {-# INLINE [0] traversed__ #-} 21 | 22 | -- Because traversed__ inlines late, GHC needs rewrite rules for all cases in 23 | -- order to generate optimal code for each of them. The one that rewrites 24 | -- traversal into a traversal correspond to an early inline. 25 | 26 | {-# RULES 27 | 28 | "traversed__ -> wander traverse" 29 | forall (o :: Star g i a b). traversed__ o = wander traverse o 30 | :: Traversable f => Star g i (f a) (f b) 31 | 32 | "traversed__ -> folded__" 33 | forall (o :: Forget r i a b). traversed__ o = folded__ o 34 | :: Foldable f => Forget r i (f a) (f b) 35 | 36 | "traversed__ -> mapped__" 37 | forall (o :: FunArrow i a b). traversed__ o = mapped__ o 38 | :: Functor f => FunArrow i (f a) (f b) 39 | 40 | #-} 41 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Internal/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_HADDOCK not-home #-} 2 | 3 | -- | This module is intended for internal use only, and may change without warning 4 | -- in subsequent releases. 5 | module Optics.Internal.Utils 6 | ( Identity'(..) 7 | , wrapIdentity' 8 | , unwrapIdentity' 9 | 10 | , Traversed(..) 11 | , runTraversed 12 | 13 | , OrT(..) 14 | , wrapOrT 15 | 16 | , (#.) 17 | , (.#) 18 | , uncurry' 19 | ) where 20 | 21 | import qualified Data.Semigroup as SG 22 | 23 | import Data.Profunctor.Indexed 24 | 25 | -- Needed for strict application of (indexed) setters. 26 | -- 27 | -- Credit for this goes to Eric Mertens, see 28 | -- . 29 | data Identity' a = Identity' {-# UNPACK #-} !() a 30 | deriving Functor 31 | 32 | instance Applicative Identity' where 33 | pure a = Identity' () a 34 | Identity' () f <*> Identity' () x = Identity' () (f x) 35 | 36 | instance Mapping (Star Identity') where 37 | roam f (Star k) = Star $ wrapIdentity' . f (unwrapIdentity' . k) 38 | iroam f (Star k) = Star $ wrapIdentity' . f (\_ -> unwrapIdentity' . k) 39 | 40 | instance Mapping (IxStar Identity') where 41 | roam f (IxStar k) = 42 | IxStar $ \i -> wrapIdentity' . f (unwrapIdentity' . k i) 43 | iroam f (IxStar k) = 44 | IxStar $ \ij -> wrapIdentity' . f (\i -> unwrapIdentity' . k (ij i)) 45 | 46 | -- | Mark a value for evaluation to whnf. 47 | -- 48 | -- This allows us to, when applying a setter to a structure, evaluate only the 49 | -- parts that we modify. If an optic focuses on multiple targets, Applicative 50 | -- instance of Identity' makes sure that we force evaluation of all of them, but 51 | -- we leave anything else alone. 52 | -- 53 | wrapIdentity' :: a -> Identity' a 54 | wrapIdentity' a = Identity' (a `seq` ()) a 55 | 56 | unwrapIdentity' :: Identity' a -> a 57 | unwrapIdentity' (Identity' () a) = a 58 | 59 | ---------------------------------------- 60 | 61 | -- | Helper for 'Optics.Fold.traverseOf_' and the like for better 62 | -- efficiency than the foldr-based version. 63 | -- 64 | -- Note that the argument @a@ of the result should not be used. 65 | newtype Traversed f a = Traversed (f a) 66 | 67 | runTraversed :: Functor f => Traversed f a -> f () 68 | runTraversed (Traversed fa) = () <$ fa 69 | 70 | instance Applicative f => SG.Semigroup (Traversed f a) where 71 | Traversed ma <> Traversed mb = Traversed (ma *> mb) 72 | 73 | instance Applicative f => Monoid (Traversed f a) where 74 | mempty = Traversed (pure (error "Traversed: value used")) 75 | mappend = (SG.<>) 76 | 77 | ---------------------------------------- 78 | 79 | -- | Helper for 'Optics.Fold.failing' family to visit the first fold only once. 80 | data OrT f a = OrT !Bool (f a) 81 | deriving Functor 82 | 83 | instance Applicative f => Applicative (OrT f) where 84 | pure = OrT False . pure 85 | OrT a f <*> OrT b x = OrT (a || b) (f <*> x) 86 | 87 | -- | Wrap the applicative action in 'OrT' so that we know later that it was 88 | -- executed. 89 | wrapOrT :: f a -> OrT f a 90 | wrapOrT = OrT True 91 | 92 | -- | 'uncurry' with no lazy pattern matching for more efficient code. 93 | -- 94 | -- @since 0.3 95 | uncurry' :: (a -> b -> c) -> (a, b) -> c 96 | uncurry' f (a, b) = f a b 97 | -------------------------------------------------------------------------------- /optics-core/src/Optics/IxGetter.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.IxGetter 3 | -- Description: An indexed version of a 'Optics.Getter.Getter'. 4 | -- 5 | -- An 'IxGetter' is an indexed version of a 'Optics.Getter.Getter'. See the 6 | -- "Indexed optics" section of the overview documentation in the @Optics@ module 7 | -- of the main @optics@ package for more details on indexed optics. 8 | -- 9 | module Optics.IxGetter 10 | ( 11 | -- * Formation 12 | IxGetter 13 | 14 | -- * Introduction 15 | , ito 16 | , selfIndex 17 | 18 | -- * Elimination 19 | , iview 20 | , iviews 21 | 22 | -- * Subtyping 23 | , A_Getter 24 | ) where 25 | 26 | import Data.Profunctor.Indexed 27 | 28 | import Optics.Internal.Bi 29 | import Optics.Internal.Indexed 30 | import Optics.Internal.Optic 31 | import Optics.Internal.Utils 32 | 33 | -- | Type synonym for an indexed getter. 34 | type IxGetter i s a = Optic' A_Getter (WithIx i) s a 35 | 36 | -- | Build an indexed getter from a function. 37 | -- 38 | -- >>> iview (ito id) ('i', 'x') 39 | -- ('i','x') 40 | ito :: (s -> (i, a)) -> IxGetter i s a 41 | ito f = Optic (lmap f . ilinear uncurry' . rphantom) 42 | {-# INLINE ito #-} 43 | 44 | -- | Use a value itself as its own index. This is essentially an indexed version 45 | -- of 'Optics.Iso.equality'. 46 | selfIndex :: IxGetter a a a 47 | selfIndex = ito (\a -> (a, a)) 48 | {-# INLINE selfIndex #-} 49 | 50 | -- | View the value pointed to by an indexed getter. 51 | iview 52 | :: (Is k A_Getter, is `HasSingleIndex` i) 53 | => Optic' k is s a -> s -> (i, a) 54 | iview o = iviews o (,) 55 | {-# INLINE iview #-} 56 | 57 | -- | View the function of the value pointed to by an indexed getter. 58 | iviews 59 | :: (Is k A_Getter, is `HasSingleIndex` i) 60 | => Optic' k is s a -> (i -> a -> r) -> s -> r 61 | iviews o = \f -> 62 | runIxForget (getOptic (castOptic @A_Getter o) (IxForget f)) id 63 | {-# INLINE iviews #-} 64 | -------------------------------------------------------------------------------- /optics-core/src/Optics/IxLens.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.IxLens 3 | -- Description: An indexed version of a 'Optics.Lens.Lens'. 4 | -- 5 | -- An 'IxLens' is an indexed version of a 'Optics.Lens.Lens'. See the "Indexed 6 | -- optics" section of the overview documentation in the @Optics@ module of the 7 | -- main @optics@ package for more details on indexed optics. 8 | -- 9 | module Optics.IxLens 10 | ( 11 | -- * Formation 12 | IxLens 13 | , IxLens' 14 | 15 | -- * Introduction 16 | , ilens 17 | 18 | -- * Elimination 19 | -- | An 'IxLens' is in particular an 'Optics.IxGetter.IxGetter' and an 20 | -- 'Optics.IxSetter.IxSetter', therefore you can specialise types to obtain: 21 | -- 22 | -- @ 23 | -- 'Optics.IxGetter.iview' :: 'IxLens' i s t a b -> s -> (i, a) 24 | -- @ 25 | -- 26 | -- @ 27 | -- 'Optics.IxSetter.iover' :: 'IxLens' i s t a b -> (i -> a -> b) -> s -> t 28 | -- 'Optics.IxSetter.iset' :: 'IxLens' i s t a b -> (i -> b) -> s -> t 29 | -- @ 30 | 31 | -- * Additional introduction forms 32 | , chosen 33 | , devoid 34 | , ifst 35 | , isnd 36 | 37 | -- * Subtyping 38 | , A_Lens 39 | 40 | -- * van Laarhoven encoding 41 | , IxLensVL 42 | , IxLensVL' 43 | , ilensVL 44 | , toIxLensVL 45 | , withIxLensVL 46 | ) where 47 | 48 | import Data.Void 49 | 50 | import Data.Profunctor.Indexed 51 | 52 | import Optics.Internal.Indexed 53 | import Optics.Internal.Optic 54 | import Optics.Internal.Utils 55 | 56 | -- | Type synonym for a type-modifying indexed lens. 57 | type IxLens i s t a b = Optic A_Lens (WithIx i) s t a b 58 | 59 | -- | Type synonym for a type-preserving indexed lens. 60 | type IxLens' i s a = Optic' A_Lens (WithIx i) s a 61 | 62 | -- | Type synonym for a type-modifying van Laarhoven indexed lens. 63 | type IxLensVL i s t a b = 64 | forall f. Functor f => (i -> a -> f b) -> s -> f t 65 | 66 | -- | Type synonym for a type-preserving van Laarhoven indexed lens. 67 | type IxLensVL' i s a = IxLensVL i s s a a 68 | 69 | -- | Build an indexed lens from a getter and a setter. 70 | -- 71 | -- If you want to build an 'IxLens' from the van Laarhoven representation, use 72 | -- 'ilensVL'. 73 | ilens :: (s -> (i, a)) -> (s -> b -> t) -> IxLens i s t a b 74 | ilens get set = ilensVL $ \f s -> set s <$> uncurry' f (get s) 75 | {-# INLINE ilens #-} 76 | 77 | -- | Build an indexed lens from the van Laarhoven representation. 78 | ilensVL :: IxLensVL i s t a b -> IxLens i s t a b 79 | ilensVL f = Optic (ilinear f) 80 | {-# INLINE ilensVL #-} 81 | 82 | -- | Convert an indexed lens to its van Laarhoven representation. 83 | toIxLensVL 84 | :: (Is k A_Lens, is `HasSingleIndex` i) 85 | => Optic k is s t a b 86 | -> IxLensVL i s t a b 87 | toIxLensVL o = \f -> 88 | runIxStar (getOptic (castOptic @A_Lens o) (IxStar f)) id 89 | {-# INLINE toIxLensVL #-} 90 | 91 | -- | Work with an indexed lens in the van Laarhoven representation. 92 | withIxLensVL 93 | :: (Is k A_Lens, is `HasSingleIndex` i) 94 | => Optic k is s t a b 95 | -> (IxLensVL i s t a b -> r) 96 | -> r 97 | withIxLensVL o k = k (toIxLensVL o) 98 | {-# INLINE withIxLensVL #-} 99 | 100 | ---------------------------------------- 101 | -- Lenses 102 | 103 | -- | Focus on both sides of an 'Either'. 104 | chosen :: IxLens (Either () ()) (Either a a) (Either b b) a b 105 | chosen = ilensVL $ \f -> \case 106 | Left a -> Left <$> f (Left ()) a 107 | Right a -> Right <$> f (Right ()) a 108 | {-# INLINE chosen #-} 109 | 110 | -- | There is an indexed field for every type in the 'Void'. 111 | -- 112 | -- >>> set (mapped % devoid) 1 [] 113 | -- [] 114 | -- 115 | -- >>> over (_Just % devoid) abs Nothing 116 | -- Nothing 117 | -- 118 | devoid :: IxLens' i Void a 119 | devoid = ilens absurd const 120 | {-# INLINE devoid #-} 121 | 122 | -- | Indexed '_1' with other half of a pair as an index. 123 | -- 124 | -- See 'isnd' for examples. 125 | -- 126 | -- @since 0.4 127 | -- 128 | ifst :: IxLens i (a, i) (b, i) a b 129 | ifst = ilens (\(a, i) -> (i, a)) (\(_,i) b -> (b, i)) 130 | 131 | -- | Indexed '_2' with other half of a pair as an index. 132 | -- Specialized version of 'itraversed' to pairs, which can be 'IxLens'. 133 | -- 134 | -- >>> iview isnd ('a', True) 135 | -- ('a',True) 136 | -- 137 | -- That is not possible with 'itraversed', because it is an 'IxTraversal'. 138 | -- 139 | -- >>> :t itraversed :: IxTraversal i (i, a) (i, b) a b 140 | -- itraversed :: IxTraversal i (i, a) (i, b) a b 141 | -- :: IxTraversal i (i, a) (i, b) a b 142 | -- 143 | -- @since 0.4 144 | -- 145 | isnd :: IxLens i (i, a) (i, b) a b 146 | isnd = ilens id (\(i,_) b -> (i, b)) 147 | 148 | -- $setup 149 | -- >>> import Optics.Core 150 | -------------------------------------------------------------------------------- /optics-core/src/Optics/IxSetter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | -- | 3 | -- Module: Optics.IxSetter 4 | -- Description: An indexed version of a 'Optics.Setter.Setter'. 5 | -- 6 | -- An 'IxSetter' is an indexed version of a 'Optics.Setter.Setter'. See the 7 | -- "Indexed optics" section of the overview documentation in the @Optics@ module 8 | -- of the main @optics@ package for more details on indexed optics. 9 | -- 10 | module Optics.IxSetter 11 | ( 12 | -- * Formation 13 | IxSetter 14 | , IxSetter' 15 | 16 | -- * Introduction 17 | , isets 18 | 19 | -- * Elimination 20 | , iover 21 | 22 | -- * Computation 23 | -- | 24 | -- 25 | -- @ 26 | -- 'iover' ('isets' f) ≡ f 27 | -- @ 28 | 29 | -- * Well-formedness 30 | -- | 31 | -- 32 | -- * __PutPut__: Setting twice is the same as setting once: 33 | -- 34 | -- @ 35 | -- 'Optics.Setter.iset' l v' ('Optics.Setter.iset' l v s) ≡ 'Optics.Setter.iset' l v' s 36 | -- @ 37 | -- 38 | -- * __Functoriality__: 'IxSetter's must preserve identities and composition: 39 | -- 40 | -- @ 41 | -- 'iover' s ('const' 'id') ≡ 'id' 42 | -- 'iover' s f '.' 'iover' s g ≡ 'iover' s (\i -> f i '.' g i) 43 | -- @ 44 | 45 | -- * Additional introduction forms 46 | , imapped 47 | 48 | -- * Additional elimination forms 49 | , iset 50 | , iset' 51 | , iover' 52 | 53 | -- * Subtyping 54 | , A_Setter 55 | 56 | -- * Re-exports 57 | , FunctorWithIndex(..) 58 | ) where 59 | 60 | import Data.Profunctor.Indexed 61 | 62 | import Optics.Internal.Indexed 63 | import Optics.Internal.Indexed.Classes 64 | import Optics.Internal.IxSetter 65 | import Optics.Internal.Optic 66 | import Optics.Internal.Utils 67 | 68 | -- | Type synonym for a type-modifying indexed setter. 69 | type IxSetter i s t a b = Optic A_Setter (WithIx i) s t a b 70 | 71 | -- | Type synonym for a type-preserving indexed setter. 72 | type IxSetter' i s a = Optic' A_Setter (WithIx i) s a 73 | 74 | -- | Apply an indexed setter as a modifier. 75 | iover 76 | :: (Is k A_Setter, is `HasSingleIndex` i) 77 | => Optic k is s t a b 78 | -> (i -> a -> b) -> s -> t 79 | iover o = \f -> runIxFunArrow (getOptic (castOptic @A_Setter o) (IxFunArrow f)) id 80 | {-# INLINE iover #-} 81 | 82 | -- | Apply an indexed setter as a modifier, strictly. 83 | iover' 84 | :: (Is k A_Setter, is `HasSingleIndex` i) 85 | => Optic k is s t a b 86 | -> (i -> a -> b) -> s -> t 87 | iover' o = \f -> 88 | let star = getOptic (castOptic @A_Setter o) $ IxStar (\i -> wrapIdentity' . f i) 89 | in unwrapIdentity' . runIxStar star id 90 | 91 | {-# INLINE iover' #-} 92 | 93 | -- | Apply an indexed setter. 94 | -- 95 | -- @ 96 | -- 'iset' o f ≡ 'iover' o (\i _ -> f i) 97 | -- @ 98 | -- 99 | iset 100 | :: (Is k A_Setter, is `HasSingleIndex` i) 101 | => Optic k is s t a b 102 | -> (i -> b) -> s -> t 103 | iset o = \f -> iover o (\i _ -> f i) 104 | {-# INLINE iset #-} 105 | 106 | -- | Apply an indexed setter, strictly. 107 | iset' 108 | :: (Is k A_Setter, is `HasSingleIndex` i) 109 | => Optic k is s t a b 110 | -> (i -> b) -> s -> t 111 | iset' o = \f -> iover' o (\i _ -> f i) 112 | {-# INLINE iset' #-} 113 | 114 | -- | Build an indexed setter from a function to modify the element(s). 115 | isets 116 | :: ((i -> a -> b) -> s -> t) 117 | -> IxSetter i s t a b 118 | isets f = Optic (iroam f) 119 | {-# INLINE isets #-} 120 | 121 | -- | Indexed setter via the 'FunctorWithIndex' class. 122 | -- 123 | -- @ 124 | -- 'iover' 'imapped' ≡ 'imap' 125 | -- @ 126 | imapped :: FunctorWithIndex i f => IxSetter i (f a) (f b) a b 127 | imapped = Optic imapped__ 128 | {-# INLINE imapped #-} 129 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Mapping.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Mapping 3 | -- Description: Lifting optics using 'Functor's 'map'. 4 | -- 5 | -- This module defines 'mapping', which turns an @'Optic'' k 'NoIx' s a@ into an 6 | -- @'Optic'' ('MappedOptic' k) 'NoIx' (f s) (f a)@, in other words optic operating on values 7 | -- in a 'Functor'. 8 | -- 9 | {-# LANGUAGE DataKinds #-} 10 | module Optics.Mapping 11 | ( MappingOptic (..) 12 | ) where 13 | 14 | import Optics.Getter 15 | import Optics.Internal.Indexed 16 | import Optics.Internal.Optic 17 | import Optics.Iso 18 | import Optics.Review 19 | 20 | -- $setup 21 | -- >>> import Optics.Core 22 | -- >>> import Optics.Operators 23 | 24 | -- | Class for optics supporting 'mapping' through a 'Functor'. 25 | -- 26 | -- @since 0.3 27 | class MappingOptic k f g s t a b where 28 | -- | Type family that maps an optic to the optic kind produced by 29 | -- 'mapping' using it. 30 | type MappedOptic k 31 | 32 | -- | The 'Optics.Mapping.mapping' can be used to lift optic through a 'Functor'. 33 | -- 34 | -- @ 35 | -- 'mapping' :: 'Iso' s t a b -> 'Iso' (f s) (g t) (f a) (g b) 36 | -- 'mapping' :: 'Optics.Lens.Lens' s a -> 'Getter' (f s) (f a) 37 | -- 'mapping' :: 'Getter' s a -> 'Getter' (f s) (f a) 38 | -- 'mapping' :: 'Optics.Prism.Prism' t b -> 'Review' (g t) (g b) 39 | -- 'mapping' :: 'Review' t b -> 'Review' (g t) (g b) 40 | -- @ 41 | mapping 42 | :: "mapping" `AcceptsEmptyIndices` is 43 | => Optic k is s t a b 44 | -> Optic (MappedOptic k) is (f s) (g t) (f a) (g b) 45 | 46 | instance (Functor f, Functor g) => MappingOptic An_Iso f g s t a b where 47 | type MappedOptic An_Iso = An_Iso 48 | mapping k = withIso k $ \sa bt -> iso (fmap sa) (fmap bt) 49 | {-# INLINE mapping #-} 50 | 51 | -- Getter-y optics 52 | 53 | -- | 54 | -- >>> [('a', True), ('b', False)] ^. _1 %& mapping 55 | -- "ab" 56 | -- 57 | -- >>> let v = [[ (('a', True), "foo"), (('b', False), "bar")], [ (('c', True), "xyz") ] ] 58 | -- >>> v ^. _1 % _2 %& mapping %& mapping 59 | -- [[True,False],[True]] 60 | -- 61 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_Getter f g s t a b where 62 | type MappedOptic A_Getter = A_Getter 63 | mapping o = to (fmap (view o)) 64 | {-# INLINE mapping #-} 65 | 66 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_ReversedPrism f g s t a b where 67 | type MappedOptic A_ReversedPrism = A_Getter 68 | mapping o = to (fmap (view o)) 69 | {-# INLINE mapping #-} 70 | 71 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_Lens f g s t a b where 72 | type MappedOptic A_Lens = A_Getter 73 | mapping o = to (fmap (view o)) 74 | {-# INLINE mapping #-} 75 | 76 | -- Review-y optics 77 | 78 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_Review f g s t a b where 79 | type MappedOptic A_Review = A_Review 80 | mapping o = unto (fmap (review o)) 81 | {-# INLINE mapping #-} 82 | 83 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_Prism f g s t a b where 84 | type MappedOptic A_Prism = A_Review 85 | mapping o = unto (fmap (review o)) 86 | {-# INLINE mapping #-} 87 | 88 | instance (Functor f, f ~ g, s ~ t, a ~ b) => MappingOptic A_ReversedLens f g s t a b where 89 | type MappedOptic A_ReversedLens = A_Review 90 | mapping o = unto (fmap (review o)) 91 | {-# INLINE mapping #-} 92 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Operators.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Operators 3 | -- Description: Definitions of infix operators for optics. 4 | -- 5 | -- Defines some infix operators for optics operations. This is a deliberately 6 | -- small collection. 7 | -- 8 | -- If you like operators, you may also wish to import @Optics.State.Operators@ 9 | -- from the @optics-extra@ package. 10 | -- 11 | module Optics.Operators 12 | ( (^.) 13 | , (^..) 14 | , (^?) 15 | , (#) 16 | , (%~) 17 | , (%!~) 18 | , (.~) 19 | , (!~) 20 | , (?~) 21 | , (?!~) 22 | ) 23 | where 24 | 25 | import Optics.AffineFold 26 | import Optics.Fold 27 | import Optics.Getter 28 | import Optics.Optic 29 | import Optics.Review 30 | import Optics.Setter 31 | 32 | -- | Flipped infix version of 'view'. 33 | (^.) :: Is k A_Getter => s -> Optic' k is s a -> a 34 | (^.) = flip view 35 | {-# INLINE (^.) #-} 36 | 37 | infixl 8 ^. 38 | 39 | -- | Flipped infix version of 'preview'. 40 | (^?) :: Is k An_AffineFold => s -> Optic' k is s a -> Maybe a 41 | (^?) = flip preview 42 | {-# INLINE (^?) #-} 43 | 44 | infixl 8 ^? 45 | 46 | -- | Flipped infix version of 'toListOf'. 47 | (^..) :: Is k A_Fold => s -> Optic' k is s a -> [a] 48 | (^..) = flip toListOf 49 | {-# INLINE (^..) #-} 50 | 51 | infixl 8 ^.. 52 | 53 | -- | Infix version of 'review'. 54 | (#) :: Is k A_Review => Optic' k is t b -> b -> t 55 | (#) = review 56 | {-# INLINE (#) #-} 57 | 58 | infixr 8 # 59 | 60 | -- | Infix version of 'over'. 61 | (%~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t 62 | (%~) = over 63 | {-# INLINE (%~) #-} 64 | 65 | infixr 4 %~ 66 | 67 | -- | Infix version of 'over''. 68 | (%!~) :: Is k A_Setter => Optic k is s t a b -> (a -> b) -> s -> t 69 | (%!~) = over' 70 | {-# INLINE (%!~) #-} 71 | 72 | infixr 4 %!~ 73 | 74 | -- | Infix version of 'set'. 75 | (.~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t 76 | (.~) = set 77 | {-# INLINE (.~) #-} 78 | 79 | infixr 4 .~ 80 | 81 | -- | Infix version of 'set''. 82 | (!~) :: Is k A_Setter => Optic k is s t a b -> b -> s -> t 83 | (!~) = set' 84 | {-# INLINE (!~) #-} 85 | 86 | infixr 4 !~ 87 | 88 | -- | Set the target of a 'Setter' to 'Just' a value. 89 | -- 90 | -- @ 91 | -- o '?~' b ≡ 'set' o ('Just' b) 92 | -- @ 93 | -- 94 | -- >>> Nothing & equality ?~ 'x' 95 | -- Just 'x' 96 | -- 97 | -- >>> Map.empty & at 3 ?~ 'x' 98 | -- fromList [(3,'x')] 99 | (?~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t 100 | (?~) = \o -> set o . Just 101 | {-# INLINE (?~) #-} 102 | 103 | infixr 4 ?~ 104 | 105 | -- | Strict version of ('?~'). 106 | (?!~) :: Is k A_Setter => Optic k is s t a (Maybe b) -> b -> s -> t 107 | (?!~) = \o !b -> set' o (Just b) 108 | {-# INLINE (?!~) #-} 109 | 110 | infixr 4 ?!~ 111 | 112 | -- $setup 113 | -- >>> import qualified Data.Map as Map 114 | -- >>> import Optics.Core 115 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Operators/Unsafe.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Operators.Unsafe 3 | -- Description: Definitions of unsafe infix operators for optics. 4 | -- 5 | module Optics.Operators.Unsafe 6 | ( (^?!) 7 | ) 8 | where 9 | 10 | import Data.Maybe (fromMaybe) 11 | import GHC.Stack (HasCallStack) 12 | 13 | import Optics.AffineFold 14 | import Optics.Optic 15 | import Optics.Operators 16 | 17 | -- | Perform an *UNSAFE* 'head' of an affine fold assuming that it is there. 18 | -- 19 | -- >>> Left 4 ^?! _Left 20 | -- 4 21 | -- 22 | -- >>> "world" ^?! ix 3 23 | -- 'l' 24 | -- 25 | -- >>> [] ^?! _head 26 | -- *** Exception: (^?!): empty affine fold 27 | -- ... 28 | -- 29 | -- @since 0.3 30 | (^?!) :: (HasCallStack, Is k An_AffineFold) => s -> Optic' k is s a -> a 31 | s ^?! o = fromMaybe (error "(^?!): empty affine fold") (s ^? o) 32 | {-# INLINE (^?!) #-} 33 | 34 | infixl 8 ^?! 35 | 36 | -- $setup 37 | -- >>> import Optics.Core 38 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Optic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Module: Optics.Optic 4 | -- Description: Common abstraction for all kinds of optics. 5 | -- 6 | -- This module provides core definitions: 7 | -- 8 | -- * an opaque 'Optic' type, which is parameterised over a type representing an 9 | -- optic kind (instantiated with tag types such as 'A_Lens'); 10 | -- 11 | -- * the optic composition operator ('%'); 12 | -- 13 | -- * the subtyping relation 'Is' with an accompanying 'castOptic' function to 14 | -- convert an optic kind; 15 | -- 16 | -- * the 'JoinKinds' class used to find the optic kind resulting from a 17 | -- composition. 18 | -- 19 | -- Each optic kind is identified by a "tag type" (such as 'A_Lens'), which is an 20 | -- empty data type. The type of the actual optics (such as 'Optics.Lens.Lens') 21 | -- is obtained by applying 'Optic' to the tag type. 22 | -- 23 | -- See the @Optics@ module in the main @optics@ package for overview 24 | -- documentation. 25 | -- 26 | module Optics.Optic 27 | ( OpticKind 28 | , Optic 29 | , Optic' 30 | 31 | -- * Subtyping 32 | , castOptic 33 | , Is 34 | , JoinKinds 35 | 36 | -- * Composition 37 | -- | The usual operator for composing optics is ('%'), which allows different 38 | -- optic kinds to be composed, automatically calculating the resulting optic 39 | -- kind using 'JoinKinds'. 40 | -- 41 | -- The ('.') function composition operator cannot be used to compose optics, 42 | -- because /optics are not functions/. The ('Control.Category..') operator 43 | -- from "Control.Category" cannot be used either, because it would not support 44 | -- type-changing optics or composing optics of different kinds. 45 | , (%) 46 | , (%%) 47 | , (%&) 48 | 49 | -- * Monoid structures 50 | -- | 'Optics.Fold.Fold'-like optics admit various monoid structures (e.g. see 51 | -- "Optics.Fold#monoids"). There is no 'Semigroup' or 'Monoid' instance for 52 | -- 'Optic', however, because there is not a unique choice of monoid to use, 53 | -- and the ('<>') operator could not be used to combine optics of different 54 | -- kinds. 55 | 56 | -- * Indexed optics 57 | -- | See the "Indexed optics" section of the overview documentation in the 58 | -- @Optics@ module of the main @optics@ package for more details on indexed 59 | -- optics. 60 | , IxList 61 | , NoIx 62 | , WithIx 63 | , AppendIndices 64 | , NonEmptyIndices 65 | , HasSingleIndex 66 | , AcceptsEmptyIndices 67 | , Curry 68 | , CurryCompose(..) 69 | 70 | -- * Base re-exports 71 | , (&) 72 | , (<&>) 73 | ) 74 | where 75 | 76 | import Data.Function 77 | 78 | import Optics.Internal.Indexed 79 | import Optics.Internal.Optic 80 | 81 | #if MIN_VERSION_base(4,11,0) 82 | import Data.Functor ((<&>)) 83 | #else 84 | -- | Infix flipped 'fmap'. 85 | -- 86 | -- @ 87 | -- ('<&>') = 'flip' 'fmap' 88 | -- @ 89 | (<&>) :: Functor f => f a -> (a -> b) -> f b 90 | as <&> f = f <$> as 91 | {-# INLINE (<&>) #-} 92 | infixl 1 <&> 93 | #endif 94 | -------------------------------------------------------------------------------- /optics-core/src/Optics/ReadOnly.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeInType #-} 3 | -- | 4 | -- Module: Optics.ReadOnly 5 | -- Description: Converting read-write optics into their read-only counterparts. 6 | -- 7 | -- This module defines 'getting', which turns a read-write optic into its 8 | -- read-only counterpart. 9 | -- 10 | module Optics.ReadOnly 11 | ( ToReadOnly(..) 12 | ) where 13 | 14 | import Data.Profunctor.Indexed 15 | 16 | import Optics.Internal.Bi 17 | import Optics.Internal.Optic 18 | 19 | -- | Class for read-write optics that have their read-only counterparts. 20 | class ToReadOnly k s t a b where 21 | type ReadOnlyOptic k :: OpticKind 22 | -- | Turn read-write optic into its read-only counterpart (or leave read-only 23 | -- optics as-is). 24 | -- 25 | -- This is useful when you have an @optic :: 'Optic' k is s t a b@ of read-write 26 | -- kind @k@ such that @s@, @t@, @a@, @b@ are rigid, there is no evidence that 27 | -- @s ~ t@ and @a ~ b@ and you want to pass @optic@ to one of the functions 28 | -- that accept read-only optic kinds. 29 | -- 30 | -- Example: 31 | -- 32 | -- >>> let fstIntToChar = _1 :: Lens (Int, r) (Char, r) Int Char 33 | -- 34 | -- >>> :t view fstIntToChar 35 | -- ... 36 | -- ...Couldn't match type ‘Char’ with ‘Int’ 37 | -- ... 38 | -- 39 | -- >>> :t view (getting fstIntToChar) 40 | -- view (getting fstIntToChar) :: (Int, r) -> Int 41 | getting :: Optic k is s t a b -> Optic' (ReadOnlyOptic k) is s a 42 | 43 | instance ToReadOnly An_Iso s t a b where 44 | type ReadOnlyOptic An_Iso = A_Getter 45 | getting o = Optic (getting__ o) 46 | {-# INLINE getting #-} 47 | 48 | instance ToReadOnly A_Lens s t a b where 49 | type ReadOnlyOptic A_Lens = A_Getter 50 | getting o = Optic (getting__ o) 51 | {-# INLINE getting #-} 52 | 53 | instance ToReadOnly A_Prism s t a b where 54 | type ReadOnlyOptic A_Prism = An_AffineFold 55 | getting o = Optic (getting__ o) 56 | {-# INLINE getting #-} 57 | 58 | instance ToReadOnly An_AffineTraversal s t a b where 59 | type ReadOnlyOptic An_AffineTraversal = An_AffineFold 60 | getting o = Optic (getting__ o) 61 | {-# INLINE getting #-} 62 | 63 | instance ToReadOnly A_Traversal s t a b where 64 | type ReadOnlyOptic A_Traversal = A_Fold 65 | getting o = Optic (getting__ o) 66 | {-# INLINE getting #-} 67 | 68 | instance ToReadOnly A_ReversedPrism s t a b where 69 | type ReadOnlyOptic A_ReversedPrism = A_Getter 70 | getting o = Optic (getting__ o) 71 | {-# INLINE getting #-} 72 | 73 | instance (s ~ t, a ~ b) => ToReadOnly A_Getter s t a b where 74 | type ReadOnlyOptic A_Getter = A_Getter 75 | getting = id 76 | {-# INLINE getting #-} 77 | 78 | instance (s ~ t, a ~ b) => ToReadOnly An_AffineFold s t a b where 79 | type ReadOnlyOptic An_AffineFold = An_AffineFold 80 | getting = id 81 | {-# INLINE getting #-} 82 | 83 | instance (s ~ t, a ~ b) => ToReadOnly A_Fold s t a b where 84 | type ReadOnlyOptic A_Fold = A_Fold 85 | getting = id 86 | {-# INLINE getting #-} 87 | 88 | -- | Internal implementation of 'getting'. 89 | getting__ 90 | :: (Profunctor p, Bicontravariant p, Constraints k p) 91 | => Optic k is s t a b 92 | -> Optic__ p i (Curry is i) s s a a 93 | getting__ (Optic o) = rphantom . o . rphantom 94 | {-# INLINE getting__ #-} 95 | 96 | -- $setup 97 | -- >>> import Optics.Core 98 | -------------------------------------------------------------------------------- /optics-core/src/Optics/ReversedLens.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.ReversedLens 3 | -- Description: A backwards 'Optics.Lens.Lens'. 4 | -- 5 | -- A 'ReversedLens' is a backwards 'Optics.Lens.Lens', i.e. a @'ReversedLens' s t 6 | -- a b@ is equivalent to a @'Optics.Lens.Lens' b a t s@. These are typically 7 | -- produced by calling 'Optics.Re.re' on a 'Optics.Lens.Lens'. They are 8 | -- distinguished from a 'Optics.Review.Review' so that @'Optics.Re.re' 9 | -- . 'Optics.Re.re'@ on a 'Optics.Lens.Lens' returns a 'Optics.Lens.Lens'. 10 | -- 11 | module Optics.ReversedLens 12 | ( 13 | -- * Formation 14 | ReversedLens 15 | , ReversedLens' 16 | 17 | -- * Introduction 18 | -- | 19 | -- 20 | -- There is no canonical introduction form for 'ReversedLens', but you can use 21 | -- 'Optics.Re.re' to construct one from a 'Optics.Lens.Lens': 22 | -- 23 | -- @ 24 | -- (\\ f g -> 'Optics.Re.re' ('Optics.Lens.lens' f g)) :: (b -> t) -> (b -> s -> a) -> 'ReversedLens' s t a b 25 | -- @ 26 | 27 | -- * Elimination 28 | -- | 29 | -- 30 | -- A 'ReversedLens' is a 'Optics.Review.Review', so you can specialise types to obtain: 31 | -- 32 | -- @ 33 | -- 'Optics.Review.review' :: 'ReversedLens'' s a -> a -> s 34 | -- @ 35 | -- 36 | -- There is no corresponding optic kind for a backwards 37 | -- 'Optics.Setter.Setter', but a reversed 'Optics.Setter.set' is definable 38 | -- using 'Optics.Re.re': 39 | -- 40 | -- @ 41 | -- 'Optics.Setter.set' . 'Optics.Re.re' :: 'ReversedLens' s t a b -> s -> b -> a 42 | -- @ 43 | 44 | -- * Computation 45 | -- | 46 | -- 47 | -- @ 48 | -- 'Optics.Review.review' $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ f 49 | -- 'Optics.Setter.set' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Lens.lens' f g) ≡ g 50 | -- @ 51 | 52 | -- * Subtyping 53 | , A_ReversedLens 54 | -- | <> 55 | ) where 56 | 57 | import Optics.Internal.Optic 58 | 59 | -- | Type synonym for a type-modifying reversed lens. 60 | type ReversedLens s t a b = Optic A_ReversedLens NoIx s t a b 61 | 62 | -- | Type synonym for a type-preserving reversed lens. 63 | type ReversedLens' t b = Optic' A_ReversedLens NoIx t b 64 | -------------------------------------------------------------------------------- /optics-core/src/Optics/ReversedPrism.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.ReversedPrism 3 | -- Description: A backwards 'Optics.Prism.Prism'. 4 | -- 5 | -- A 'ReversedPrism' is a backwards 'Optics.Prism.Prism', i.e. a 6 | -- @'ReversedPrism' s t a b@ is equivalent to a @'Optics.Prism.Prism' b a t 7 | -- s@. These are typically produced by calling 'Optics.Re.re' on a 8 | -- 'Optics.Prism.Prism'. They are distinguished from a 'Optics.Getter.Getter' 9 | -- so that @'Optics.Re.re' . 'Optics.Re.re'@ on a 'Optics.Prism.Prism' returns a 10 | -- 'Optics.Prism.Prism'. 11 | -- 12 | module Optics.ReversedPrism 13 | ( -- * Formation 14 | ReversedPrism 15 | , ReversedPrism' 16 | 17 | -- * Introduction 18 | -- | 19 | -- 20 | -- There is no canonical introduction form for 'ReversedPrism', but you can 21 | -- use 'Optics.Re.re' to construct one from a 'Optics.Prism.Prism': 22 | -- 23 | -- @ 24 | -- (\\ f g -> 'Optics.Re.re' ('Optics.Prism.prism' f g)) :: (s -> a) -> (b -> Either a t) -> 'ReversedPrism' s t a b 25 | -- @ 26 | 27 | -- * Elimination 28 | -- | 29 | -- 30 | -- A 'ReversedPrism' is a 'Optics.Getter.Getter', so you can specialise 31 | -- types to obtain: 32 | -- 33 | -- @ 34 | -- 'Optics.Getter.view' :: 'ReversedPrism'' s a -> s -> a 35 | -- @ 36 | -- 37 | -- There is no reversed 'Optics.AffineTraversal.matching' defined, but it is 38 | -- definable using 'Optics.Re.re': 39 | -- 40 | -- @ 41 | -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' :: 'ReversedPrism' s t a b -> b -> Either a t 42 | -- @ 43 | 44 | -- * Computation 45 | -- | 46 | -- 47 | -- @ 48 | -- 'Optics.Getter.view' $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ f 49 | -- 'Optics.AffineTraversal.matching' . 'Optics.Re.re' $ 'Optics.Re.re' ('Optics.Prism.prism' f g) ≡ g 50 | -- @ 51 | 52 | -- * Subtyping 53 | , A_ReversedPrism 54 | -- | <> 55 | ) where 56 | 57 | import Optics.Internal.Optic 58 | 59 | -- | Type synonym for a type-modifying reversed prism. 60 | type ReversedPrism s t a b = Optic A_ReversedPrism NoIx s t a b 61 | 62 | -- | Type synonym for a type-preserving reversed prism. 63 | type ReversedPrism' s a = Optic' A_ReversedPrism NoIx s a 64 | -------------------------------------------------------------------------------- /optics-core/src/Optics/Review.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Review 3 | -- Description: A backwards 'Optics.Getter.Getter', i.e. a function. 4 | -- 5 | -- A 'Review' is a backwards 'Optics.Getter.Getter', i.e. a 6 | -- @'Review' T B@ is just a function @B -> T@. 7 | -- 8 | module Optics.Review 9 | ( 10 | -- * Formation 11 | Review 12 | 13 | -- * Introduction 14 | , unto 15 | 16 | -- * Elimination 17 | , review 18 | 19 | -- * Computation 20 | -- | 21 | -- 22 | -- @ 23 | -- 'review' ('unto' f) = f 24 | -- @ 25 | 26 | -- * Subtyping 27 | , A_Review 28 | -- | <> 29 | ) 30 | where 31 | 32 | import Data.Profunctor.Indexed 33 | 34 | import Optics.Internal.Bi 35 | import Optics.Internal.Optic 36 | 37 | -- | Type synonym for a review. 38 | type Review t b = Optic' A_Review NoIx t b 39 | 40 | -- | Retrieve the value targeted by a 'Review'. 41 | -- 42 | -- >>> review _Left "hi" 43 | -- Left "hi" 44 | review :: Is k A_Review => Optic' k is t b -> b -> t 45 | review o = unTagged #. getOptic (castOptic @A_Review o) .# Tagged 46 | {-# INLINE review #-} 47 | 48 | -- | An analogue of 'Optics.Getter.to' for reviews. 49 | unto :: (b -> t) -> Review t b 50 | unto f = Optic (lphantom . rmap f) 51 | {-# INLINE unto #-} 52 | 53 | -- $setup 54 | -- >>> import Optics.Core 55 | -------------------------------------------------------------------------------- /optics-extra/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # optics-extra-0.4.2.1 (2022-05-20) 2 | * Fix for previous release when used with `mtl-2.3` and `transformers-0.5`. 3 | 4 | # optics-extra-0.4.2 (2022-05-19) 5 | * Allow `transformers-0.6` and `mtl-2.3` 6 | 7 | Note that `optics-extra` no longer defines `Zoom` instances for `ErrorT` or `ListT` when 8 | building with `mtl-2.3` or later. This is because `MonadState` is a superclass of 9 | `Zoom`, and the `MonadState` instances for `ErrorT` and `ListT` were removed in 10 | `mtl-2.3`. Be watchful of this if you build `optics-extra` with `mtl-2.3` (or 11 | later) combined with an older version of `transformers` (pre-0.6) that defines 12 | `ErrorT` or `ListT`. Similarly for `Magnify` and `MagnifyMany`. 13 | 14 | # optics-extra-0.4.1 (2022-03-22) 15 | * Add support for GHC-9.2 16 | 17 | # optics-extra-0.4 (2021-02-22) 18 | * Add support for GHC-9.0 19 | 20 | # optics-extra-0.3 (2020-04-15) 21 | * `optics-core-0.3` compatible release 22 | * GHC-8.10 support 23 | * Use stricter `uncurry'` for better performance 24 | 25 | # optics-extra-0.2 (2019-10-18) 26 | * `optics-core-0.2` compatible release 27 | * Move `use` from `Optics.View` to `Optics.State` and restrict its type 28 | * Add `preuse` to `Optics.State` 29 | * Rename `use`, `uses`, `listening` and `listenings` to reflect the fact that 30 | they have `ViewResult`-generalised types 31 | * Depend on new `indexed-profunctors` package 32 | 33 | # optics-extra-0.1 (2019-09-02) 34 | * Initial release 35 | -------------------------------------------------------------------------------- /optics-extra/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | This software incorporates code from the lens package (available from 34 | https://hackage.haskell.org/package/lens) under the following license: 35 | 36 | 37 | Copyright 2012-2016 Edward Kmett 38 | 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions 43 | are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright 46 | notice, this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright 49 | notice, this list of conditions and the following disclaimer in the 50 | documentation and/or other materials provided with the distribution. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 53 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 54 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 55 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 56 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 57 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 58 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 59 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 60 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 61 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 62 | POSSIBILITY OF SUCH DAMAGE. 63 | -------------------------------------------------------------------------------- /optics-extra/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /optics-extra/optics-extra.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-extra 3 | version: 0.4.2.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | maintainer: optics@well-typed.com 8 | author: Andrzej Rybczak 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, 12 | GHCJS ==8.4 13 | synopsis: Extra utilities and instances for optics-core 14 | category: Data, Optics, Lenses 15 | description: 16 | This package provides extra definitions and instances that extend the 17 | @@ package, 18 | without incurring too many dependencies. See the 19 | @@ package for more 20 | documentation. 21 | 22 | extra-doc-files: 23 | CHANGELOG.md 24 | 25 | bug-reports: https://github.com/well-typed/optics/issues 26 | source-repository head 27 | type: git 28 | location: https://github.com/well-typed/optics.git 29 | subdir: optics-extra 30 | 31 | common language 32 | ghc-options: -Wall -Wcompat 33 | 34 | default-language: Haskell2010 35 | 36 | default-extensions: BangPatterns 37 | ConstraintKinds 38 | DefaultSignatures 39 | DeriveFoldable 40 | DeriveFunctor 41 | DeriveGeneric 42 | DeriveTraversable 43 | EmptyCase 44 | FlexibleContexts 45 | FlexibleInstances 46 | FunctionalDependencies 47 | GADTs 48 | GeneralizedNewtypeDeriving 49 | InstanceSigs 50 | KindSignatures 51 | LambdaCase 52 | OverloadedLabels 53 | PatternSynonyms 54 | RankNTypes 55 | ScopedTypeVariables 56 | TupleSections 57 | TypeApplications 58 | TypeFamilies 59 | TypeOperators 60 | ViewPatterns 61 | 62 | library 63 | import: language 64 | hs-source-dirs: src 65 | 66 | build-depends: base >= 4.10 && <5 67 | , array >= 0.5.2.0 && <0.6 68 | , bytestring >= 0.10.8 && <0.13 69 | , containers >= 0.5.10.2 && <0.8 70 | , hashable >= 1.1.1 && <1.6 71 | , indexed-profunctors >= 0.1 && <0.2 72 | , mtl >= 2.2.2 && <2.4 73 | , optics-core >= 0.4.1 && <0.4.2 74 | , text >= 1.2 && <1.3 || >=2.0 && <2.2 75 | , transformers >= 0.5 && <0.7 76 | , unordered-containers >= 0.2.6 && <0.3 77 | , vector >= 0.11 && <0.14 78 | , indexed-traversable-instances >=0.1 && <0.2 79 | 80 | exposed-modules: Optics.Extra 81 | 82 | -- optic utilities 83 | Optics.At 84 | Optics.Cons 85 | Optics.Each 86 | Optics.Empty 87 | Optics.Indexed 88 | Optics.Passthrough 89 | Optics.State 90 | Optics.State.Operators 91 | Optics.View 92 | Optics.Zoom 93 | 94 | -- optics for data types 95 | Data.ByteString.Lazy.Optics 96 | Data.ByteString.Optics 97 | Data.ByteString.Strict.Optics 98 | Data.HashMap.Optics 99 | Data.HashSet.Optics 100 | Data.Text.Lazy.Optics 101 | Data.Text.Optics 102 | Data.Text.Strict.Optics 103 | Data.Vector.Generic.Optics 104 | Data.Vector.Optics 105 | 106 | -- internal modules 107 | Optics.Extra.Internal.ByteString 108 | Optics.Extra.Internal.Vector 109 | Optics.Extra.Internal.Zoom 110 | -------------------------------------------------------------------------------- /optics-extra/src/Data/ByteString/Strict/Optics.hs: -------------------------------------------------------------------------------- 1 | module Data.ByteString.Strict.Optics 2 | ( packedBytes, unpackedBytes, bytes 3 | , packedChars, unpackedChars, chars 4 | , pattern Bytes 5 | , pattern Chars 6 | ) where 7 | 8 | import Data.ByteString (ByteString) 9 | import qualified Data.ByteString as Words 10 | import qualified Data.ByteString.Char8 as Char8 11 | import Data.Int (Int64) 12 | import Data.Word (Word8) 13 | 14 | import Optics.Core 15 | import Optics.Extra.Internal.ByteString 16 | 17 | -- | 'Data.ByteString.pack' (or 'Data.ByteString.unpack') a list of bytes into a 'ByteString' 18 | -- 19 | -- @ 20 | -- 'packedBytes' ≡ 're' 'unpackedBytes' 21 | -- 'Data.ByteString.pack' x ≡ x '^.' 'packedBytes' 22 | -- 'Data.ByteString.unpack' x ≡ x '^.' 're' 'packedBytes' 23 | -- @ 24 | -- 25 | -- >>> [104,101,108,108,111] ^. packedBytes 26 | -- "hello" 27 | packedBytes :: Iso' [Word8] ByteString 28 | packedBytes = iso Words.pack Words.unpack 29 | {-# INLINE packedBytes #-} 30 | 31 | -- | 'Data.ByteString.unpack' (or 'Data.ByteString.pack') a 'ByteString' into a 32 | -- list of bytes. 33 | -- 34 | -- @ 35 | -- 'unpackedBytes' ≡ 're' 'packedBytes' 36 | -- 'Data.ByteString.unpack' x ≡ x '^.' 'unpackedBytes' 37 | -- 'Data.ByteString.pack' x ≡ x '^.' 're' 'unpackedBytes' 38 | -- @ 39 | -- 40 | -- >>> "hello" ^. packedChars % unpackedBytes 41 | -- [104,101,108,108,111] 42 | unpackedBytes :: Iso' ByteString [Word8] 43 | unpackedBytes = re packedBytes 44 | {-# INLINE unpackedBytes #-} 45 | 46 | -- | Traverse each 'Word8' in a 'ByteString'. 47 | -- 48 | -- This 'Traversal' walks the 'ByteString' in a tree-like fashion enable zippers 49 | -- to seek to locations in logarithmic time and accelerating many monoidal 50 | -- queries, but up to associativity (and constant factors) it is equivalent to 51 | -- the much slower: 52 | -- 53 | -- @ 54 | -- 'bytes' ≡ 'unpackedBytes' '%' 'traversed' 55 | -- @ 56 | -- 57 | -- >>> anyOf bytes (== 0x80) (Char8.pack "hello") 58 | -- False 59 | -- 60 | -- Note that when just using this as a 'Setter', @'sets' 'Data.ByteString.map'@ 61 | -- can be more efficient. 62 | bytes :: IxTraversal' Int64 ByteString Word8 63 | bytes = traversedStrictTree 64 | {-# INLINE bytes #-} 65 | 66 | -- | 'Data.ByteString.Char8.pack' (or 'Data.ByteString.Char8.unpack') a list of 67 | -- characters into a 'ByteString' 68 | -- 69 | -- When writing back to the 'ByteString' it is assumed that every 'Char' lies 70 | -- between @'\x00'@ and @'\xff'@. 71 | -- 72 | -- @ 73 | -- 'packedChars' ≡ 're' 'unpackedChars' 74 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 'packedChars' 75 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 're' 'packedChars' 76 | -- @ 77 | -- 78 | -- >>> foldOf (packedChars % each % to (\w -> let x = showHex w "" in if Prelude.length x == 1 then '0':x else x)) "hello" 79 | -- "68656c6c6f" 80 | packedChars :: Iso' String ByteString 81 | packedChars = iso Char8.pack Char8.unpack 82 | {-# INLINE packedChars #-} 83 | 84 | -- | 'Data.ByteString.Char8.unpack' (or 'Data.ByteString.Char8.pack') a list of 85 | -- characters into a 'ByteString' 86 | -- 87 | -- When writing back to the 'ByteString' it is assumed that every 'Char' lies 88 | -- between @'\x00'@ and @'\xff'@. 89 | -- 90 | -- @ 91 | -- 'unpackedChars' ≡ 're' 'packedChars' 92 | -- 'Data.ByteString.Char8.unpack' x ≡ x '^.' 'unpackedChars' 93 | -- 'Data.ByteString.Char8.pack' x ≡ x '^.' 're' 'unpackedChars' 94 | -- @ 95 | -- 96 | -- >>> [104,101,108,108,111] ^. packedBytes % unpackedChars 97 | -- "hello" 98 | unpackedChars :: Iso' ByteString String 99 | unpackedChars = re packedChars 100 | {-# INLINE unpackedChars #-} 101 | 102 | -- | Traverse the individual bytes in a 'ByteString' as characters. 103 | -- 104 | -- When writing back to the 'ByteString' it is assumed that every 'Char' lies 105 | -- between @'\x00'@ and @'\xff'@. 106 | -- 107 | -- This 'Traversal' walks the 'ByteString' in a tree-like fashion enable zippers 108 | -- to seek to locations in logarithmic time and accelerating many monoidal 109 | -- queries, but up to associativity (and constant factors) it is equivalent to 110 | -- the much slower: 111 | -- 112 | -- @ 113 | -- 'chars' = 'unpackedChars' '%' 'traversed' 114 | -- @ 115 | -- 116 | -- >>> anyOf chars (== 'h') $ Char8.pack "hello" 117 | -- True 118 | chars :: IxTraversal' Int64 ByteString Char 119 | chars = traversedStrictTree8 120 | {-# INLINE chars #-} 121 | 122 | pattern Bytes :: [Word8] -> ByteString 123 | pattern Bytes b <- (view unpackedBytes -> b) where 124 | Bytes b = review unpackedBytes b 125 | 126 | pattern Chars :: [Char] -> ByteString 127 | pattern Chars b <- (view unpackedChars -> b) where 128 | Chars b = review unpackedChars b 129 | 130 | -- $setup 131 | -- >>> import Numeric 132 | -- >>> import Optics.Each 133 | -------------------------------------------------------------------------------- /optics-extra/src/Data/HashMap/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | 3 | -- Module: Data.HashMap.Optics 4 | -- Description: Optics for working with 'Data.Map.HashMap's. 5 | -- 6 | -- This module exists to provide documentation for lenses for working with 7 | -- 'HashMap', which might otherwise be obscured by their genericity. 8 | -- 9 | -- 'HashMap' is an instance of 'Optics.At.Core.At' and provides 10 | -- 'Optics.At.Core.at' as a lens on values at keys: 11 | -- 12 | -- >>> HashMap.fromList [(1, "world")] ^. at 1 13 | -- Just "world" 14 | -- 15 | -- >>> HashMap.empty & at 1 .~ Just "world" 16 | -- fromList [(1,"world")] 17 | -- 18 | -- >>> HashMap.empty & at 0 .~ Just "hello" 19 | -- fromList [(0,"hello")] 20 | -- 21 | -- We can traverse, fold over, and map over key-value pairs in a 'HashMap', 22 | -- thanks to indexed traversals, folds and setters. 23 | -- 24 | -- >>> iover imapped const $ HashMap.fromList [(1, "Venus")] 25 | -- fromList [(1,1)] 26 | -- 27 | -- >>> ifoldMapOf ifolded (\i _ -> Sum i) $ HashMap.fromList [(2, "Earth"), (3, "Mars")] 28 | -- Sum {getSum = 5} 29 | -- 30 | -- >>> itraverseOf_ ifolded (curry print) $ HashMap.fromList [(4, "Jupiter")] 31 | -- (4,"Jupiter") 32 | -- 33 | -- >>> itoListOf ifolded $ HashMap.fromList [(5, "Saturn")] 34 | -- [(5,"Saturn")] 35 | -- 36 | -- A related class, 'Optics.At.Core.Ixed', allows us to use 'Optics.At.Core.ix' 37 | -- to traverse a value at a particular key. 38 | -- 39 | -- >>> HashMap.fromList [(2, "Earth")] & ix 2 %~ ("New " ++) 40 | -- fromList [(2,"New Earth")] 41 | -- 42 | -- >>> preview (ix 8) HashMap.empty 43 | -- Nothing 44 | -- 45 | module Data.HashMap.Optics 46 | ( toMapOf 47 | , at' 48 | ) where 49 | 50 | import Data.Hashable (Hashable) 51 | import Data.HashMap.Lazy (HashMap) 52 | import qualified Data.HashMap.Lazy as HashMap 53 | 54 | import Optics.Core 55 | 56 | -- | Construct a hash map from an 'IxFold'. 57 | -- 58 | -- The construction is left-biased (see 'HashMap.union'), i.e. the first 59 | -- occurrences of keys in the fold or traversal order are preferred. 60 | -- 61 | -- >>> toMapOf ifolded ["hello", "world"] 62 | -- fromList [(0,"hello"),(1,"world")] 63 | -- 64 | -- >>> toMapOf (folded % ifolded) [('a',"alpha"),('b', "beta")] 65 | -- fromList [('a',"alpha"),('b',"beta")] 66 | -- 67 | -- >>> toMapOf (folded % ifolded) [('a', "hello"), ('b', "world"), ('a', "dummy")] 68 | -- fromList [('a',"hello"),('b',"world")] 69 | -- 70 | toMapOf 71 | :: (Is k A_Fold, is `HasSingleIndex` i, Eq i, Hashable i) 72 | => Optic' k is s a -> s -> HashMap i a 73 | toMapOf o = ifoldMapOf o HashMap.singleton 74 | {-# INLINE toMapOf #-} 75 | 76 | -- $setup 77 | -- >>> import Data.Monoid 78 | -- >>> import Optics.At () 79 | -- >>> import Optics.Indexed () 80 | -------------------------------------------------------------------------------- /optics-extra/src/Data/HashSet/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.HashSet.Optics 3 | -- Description: Optics for working with 'HashSet's. 4 | -- 5 | -- This module defines optics for constructing and manipulating finite 6 | -- 'HashSet's. 7 | -- 8 | module Data.HashSet.Optics 9 | ( setmapped 10 | , setOf 11 | ) where 12 | 13 | import Data.Hashable (Hashable) 14 | import Data.HashSet (HashSet) 15 | import qualified Data.HashSet as HashSet 16 | 17 | import Optics.Fold 18 | import Optics.Optic 19 | import Optics.Setter 20 | 21 | -- | This 'Setter' can be used to change the type of a 'HashSet' by mapping the 22 | -- elements to new values. 23 | -- 24 | -- Sadly, you can't create a valid 'Optics.Traversal.Traversal' for a 'HashSet', 25 | -- but you can manipulate it by reading using 'Optics.Fold.folded' and 26 | -- reindexing it via 'setmapped'. 27 | -- 28 | -- >>> over setmapped (+1) (HashSet.fromList [1,2,3,4]) 29 | -- fromList [2,3,4,5] 30 | setmapped :: (Eq b, Hashable b) => Setter (HashSet a) (HashSet b) a b 31 | setmapped = sets HashSet.map 32 | {-# INLINE setmapped #-} 33 | 34 | -- | Construct a 'HashSet' from a fold. 35 | -- 36 | -- >>> setOf folded [1,2,3,4] 37 | -- fromList [1,2,3,4] 38 | -- 39 | -- >>> setOf (folded % _2) [("hello",1),("world",2),("!!!",3)] 40 | -- fromList [1,2,3] 41 | setOf :: (Is k A_Fold, Eq a, Hashable a) => Optic' k is s a -> s -> HashSet a 42 | setOf l = foldMapOf l HashSet.singleton 43 | {-# INLINE setOf #-} 44 | 45 | -- $setup 46 | -- >>> import Optics.Core 47 | -------------------------------------------------------------------------------- /optics-extra/src/Data/Text/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Data.Text.Optics 3 | -- Description: Optics for working with strict or lazy 'Text'. 4 | -- 5 | -- This module provides 'Iso's for converting strict or lazy 'Text' to or from a 6 | -- 'String' or 'Builder', and an 'IxTraversal' for traversing the individual 7 | -- characters of a 'Text'. 8 | -- 9 | -- The same combinators support both strict and lazy text using the 'IsText' 10 | -- typeclass. You can import "Data.Text.Strict.Optics" or 11 | -- "Data.Text.Lazy.Optics" instead if you prefer monomorphic versions. 12 | -- 13 | module Data.Text.Optics 14 | ( IsText(..) 15 | , unpacked 16 | , _Text 17 | , pattern Text 18 | ) where 19 | 20 | import qualified Data.Text as Strict 21 | import qualified Data.Text.Lazy as Lazy 22 | import qualified Data.Text.Lazy.Builder as B 23 | 24 | import Optics.Core 25 | import qualified Data.Text.Lazy.Optics as Lazy 26 | import qualified Data.Text.Strict.Optics as Strict 27 | 28 | -- | Traversals for strict or lazy 'Text' 29 | class IsText t where 30 | -- | This isomorphism can be used to 'pack' (or 'unpack') strict or lazy 31 | -- 'Text'. 32 | -- 33 | -- @ 34 | -- 'pack' x ≡ x 'Optics.Operators.^.' 'packed' 35 | -- 'unpack' x ≡ x 'Optics.Operators.^.' 're' 'packed' 36 | -- 'packed' ≡ 're' 'unpacked' 37 | -- @ 38 | packed :: Iso' String t 39 | 40 | -- | Convert between strict or lazy 'Text' and a 'Builder'. 41 | -- 42 | -- @ 43 | -- 'fromText' x ≡ x 'Optics.Operators.^.' 'builder' 44 | -- @ 45 | builder :: Iso' t B.Builder 46 | 47 | -- | Traverse the individual characters in strict or lazy 'Text'. 48 | -- 49 | -- @ 50 | -- 'text' = 'unpacked' . 'traversed' 51 | -- @ 52 | text :: IxTraversal' Int t Char 53 | text = unpacked % itraversed 54 | {-# INLINE text #-} 55 | 56 | instance IsText String where 57 | packed = iso id id 58 | text = itraversed 59 | builder = Lazy.packed % builder 60 | {-# INLINE packed #-} 61 | {-# INLINE text #-} 62 | {-# INLINE builder #-} 63 | 64 | -- | This isomorphism can be used to 'unpack' (or 'pack') both strict or lazy 65 | -- 'Text'. 66 | -- 67 | -- @ 68 | -- 'unpack' x ≡ x 'Optics.Operators.^.' 'unpacked' 69 | -- 'pack' x ≡ x 'Optics.Operators.^.' 're' 'unpacked' 70 | -- @ 71 | -- 72 | -- This 'Iso' is provided for notational convenience rather than out of great 73 | -- need, since 74 | -- 75 | -- @ 76 | -- 'unpacked' ≡ 're' 'packed' 77 | -- @ 78 | -- 79 | unpacked :: IsText t => Iso' t String 80 | unpacked = re packed 81 | {-# INLINE unpacked #-} 82 | 83 | -- | This is an alias for 'unpacked' that makes it clearer how to use it with 84 | -- @('Optics.Operators.#')@. 85 | -- 86 | -- @ 87 | -- '_Text' = 're' 'packed' 88 | -- @ 89 | -- 90 | -- >>> _Text # "hello" :: Strict.Text 91 | -- "hello" 92 | _Text :: IsText t => Iso' t String 93 | _Text = re packed 94 | {-# INLINE _Text #-} 95 | 96 | pattern Text :: IsText t => String -> t 97 | pattern Text a <- (view _Text -> a) where 98 | Text a = review _Text a 99 | 100 | instance IsText Strict.Text where 101 | packed = Strict.packed 102 | builder = Strict.builder 103 | text = Strict.text 104 | {-# INLINE packed #-} 105 | {-# INLINE builder #-} 106 | {-# INLINE text #-} 107 | 108 | instance IsText Lazy.Text where 109 | packed = Lazy.packed 110 | builder = Lazy.builder 111 | text = Lazy.text 112 | {-# INLINE packed #-} 113 | {-# INLINE builder #-} 114 | {-# INLINE text #-} 115 | -------------------------------------------------------------------------------- /optics-extra/src/Data/Vector/Optics.hs: -------------------------------------------------------------------------------- 1 | -- | This module provides lenses and traversals for working with vectors. 2 | module Data.Vector.Optics 3 | ( toVectorOf 4 | -- * Isomorphisms 5 | , vector 6 | , forced 7 | -- * Lenses 8 | , sliced 9 | -- * Traversal of individual indices 10 | , ordinals 11 | ) where 12 | 13 | import Data.Vector (Vector) 14 | import Optics.Core 15 | import qualified Data.Vector.Generic.Optics as G 16 | 17 | -- $setup 18 | -- >>> import Data.Vector as Vector 19 | 20 | -- | @sliced i n@ provides a 'Lens' that edits the @n@ elements starting at 21 | -- index @i@ from a 'Lens'. 22 | -- 23 | -- This is only a valid 'Lens' if you do not change the length of the resulting 24 | -- 'Vector'. 25 | -- 26 | -- Attempting to return a longer or shorter vector will result in violations of 27 | -- the 'Lens' laws. 28 | -- 29 | -- >>> Vector.fromList [1..10] ^. sliced 2 5 == Vector.fromList [3,4,5,6,7] 30 | -- True 31 | -- 32 | -- >>> (Vector.fromList [1..10] & sliced 2 5 % mapped .~ 0) == Vector.fromList [1,2,0,0,0,0,0,8,9,10] 33 | -- True 34 | sliced 35 | :: Int -- ^ @i@ starting index 36 | -> Int -- ^ @n@ length 37 | -> Lens' (Vector a) (Vector a) 38 | sliced = G.sliced 39 | {-# INLINE sliced #-} 40 | 41 | -- | Similar to 'toListOf', but returning a 'Vector'. 42 | -- 43 | -- >>> toVectorOf each (8,15) == Vector.fromList [8,15] 44 | -- True 45 | toVectorOf 46 | :: Is k A_Fold 47 | => Optic' k is s a 48 | -> s 49 | -> Vector a 50 | toVectorOf = G.toVectorOf 51 | {-# INLINE toVectorOf #-} 52 | 53 | -- | Convert a list to a 'Vector' (or back) 54 | -- 55 | -- >>> [1,2,3] ^. vector == Vector.fromList [1,2,3] 56 | -- True 57 | -- 58 | -- >>> [1,2,3] ^. vector % re vector 59 | -- [1,2,3] 60 | -- 61 | -- >>> Vector.fromList [0,8,15] ^. re vector % vector == Vector.fromList [0,8,15] 62 | -- True 63 | vector :: Iso [a] [b] (Vector a) (Vector b) 64 | vector = G.vector 65 | {-# INLINE vector #-} 66 | 67 | -- | Convert a 'Vector' to a version that doesn't retain any extra 68 | -- memory. 69 | forced :: Iso (Vector a) (Vector b) (Vector a) (Vector b) 70 | forced = G.forced 71 | {-# INLINE forced #-} 72 | 73 | -- | This 'Traversal' will ignore any duplicates in the supplied list of 74 | -- indices. 75 | -- 76 | -- >>> toListOf (ordinals [1,3,2,5,9,10]) $ Vector.fromList [2,4..40] 77 | -- [4,8,6,12,20,22] 78 | ordinals :: forall a. [Int] -> IxTraversal' Int (Vector a) a 79 | ordinals = G.ordinals 80 | {-# INLINE ordinals #-} 81 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Each.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Each 3 | -- Description: An 'IxTraversal' for 'each' element of a (potentially monomorphic) container. 4 | -- 5 | -- This module defines the 'Each' class, which provides an 'IxTraversal' that 6 | -- extracts 'each' element of a (potentially monomorphic) container. 7 | -- 8 | {-# LANGUAGE UndecidableInstances #-} 9 | {-# OPTIONS_GHC -fno-warn-orphans #-} 10 | module Optics.Each 11 | ( 12 | -- * Each 13 | Each(..) 14 | ) where 15 | 16 | import qualified Data.ByteString as SB 17 | import qualified Data.ByteString.Lazy as LB 18 | import Data.HashMap.Lazy (HashMap) 19 | import qualified Data.HashMap.Lazy as HashMap 20 | import Data.Int (Int64) 21 | import qualified Data.Text as ST 22 | import qualified Data.Text.Lazy as LT 23 | import Data.Text.Optics (text) 24 | import Data.Vector.Generic.Optics (vectorTraverse) 25 | import Data.Vector.Primitive (Prim) 26 | import Data.Vector.Storable (Storable) 27 | import Data.Vector.Unboxed (Unbox) 28 | import Data.Word (Word8) 29 | import qualified Data.Vector as V 30 | import qualified Data.Vector.Primitive as VP 31 | import qualified Data.Vector.Storable as VS 32 | import qualified Data.Vector.Unboxed as VU 33 | 34 | import Optics.Core 35 | import Optics.Indexed () 36 | import Optics.Extra.Internal.ByteString 37 | 38 | -- Extra instances 39 | 40 | -- | @'each' :: 'IxTraversal' k ('HashMap' k a) ('HashMap' k b) a b@ 41 | instance k ~ k' => Each k (HashMap k a) (HashMap k' b) a b where 42 | -- traverseWithKey has best performance for all flavours for some reason. 43 | each = itraversalVL HashMap.traverseWithKey 44 | {-# INLINE[1] each #-} 45 | 46 | -- | @'each' :: 'IxTraversal' Int ('V.Vector' a) ('V.Vector' b) a b@ 47 | instance Each Int (V.Vector a) (V.Vector b) a b where 48 | each = vectorTraverse 49 | {-# INLINE[1] each #-} 50 | 51 | -- | @'each' :: ('Prim' a, 'Prim' b) => 'IxTraversal' Int ('Prim.Vector' a) 52 | -- ('Prim.Vector' b) a b@ 53 | instance (Prim a, Prim b) => Each Int (VP.Vector a) (VP.Vector b) a b where 54 | each = vectorTraverse 55 | {-# INLINE[1] each #-} 56 | 57 | -- | @'each' :: ('Storable' a, 'Storable' b) => 'IxTraversal' 'Int' ('VS.Vector' 58 | -- a) ('VS.Vector' b) a b@ 59 | instance (Storable a, Storable b) => Each Int (VS.Vector a) (VS.Vector b) a b where 60 | each = vectorTraverse 61 | {-# INLINE[1] each #-} 62 | 63 | -- | @'each' :: ('Unbox' a, 'Unbox' b) => 'IxTraversal' 'Int' ('VU.Vector' a) 64 | -- ('VU.Vector' b) a b@ 65 | instance (Unbox a, Unbox b ) => Each Int (VU.Vector a) (VU.Vector b) a b where 66 | each = vectorTraverse 67 | {-# INLINE[1] each #-} 68 | 69 | -- | @'each' :: 'IxTraversal' 'Int' 'ST.Text' 'ST.Text' 'Char' 'Char'@ 70 | instance (a ~ Char, b ~ Char) => Each Int ST.Text ST.Text a b where 71 | each = text 72 | {-# INLINE[1] each #-} 73 | 74 | -- | @'each' :: 'IxTraversal' 'Int64' 'LT.Text' 'LT.Text' 'Char' 'Char'@ 75 | instance (a ~ Char, b ~ Char) => Each Int LT.Text LT.Text a b where 76 | each = text 77 | {-# INLINE[1] each #-} 78 | 79 | -- | @'each' :: 'IxTraversal' 'Int' 'SB.ByteString' 'SB.ByteString' 'Word8' 80 | -- 'Word8'@ 81 | instance (a ~ Word8, b ~ Word8) => Each Int64 SB.ByteString SB.ByteString a b where 82 | each = traversedStrictTree 83 | {-# INLINE[1] each #-} 84 | 85 | -- | @'each' :: 'IxTraversal' 'Int64' 'LB.ByteString' 'LB.ByteString' 'Word8' 86 | -- 'Word8'@ 87 | instance (a ~ Word8, b ~ Word8) => Each Int64 LB.ByteString LB.ByteString a b where 88 | each = traversedLazy 89 | {-# INLINE[1] each #-} 90 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Empty.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.Empty 3 | -- Description: A 'Prism' for a type that may be '_Empty'. 4 | -- 5 | -- This module defines the 'AsEmpty' class, which provides a 'Prism' for a type 6 | -- that may be '_Empty'. 7 | -- 8 | -- >>> isn't _Empty [1,2,3] 9 | -- True 10 | -- 11 | -- >>> case Nothing of { Empty -> True; _ -> False } 12 | -- True 13 | -- 14 | {-# OPTIONS_GHC -fno-warn-orphans #-} 15 | module Optics.Empty 16 | ( AsEmpty(..) 17 | , pattern Empty 18 | ) where 19 | 20 | import qualified Data.ByteString as StrictB 21 | import qualified Data.ByteString.Lazy as LazyB 22 | import Data.HashMap.Lazy (HashMap) 23 | import qualified Data.HashMap.Lazy as HashMap 24 | import Data.HashSet (HashSet) 25 | import qualified Data.HashSet as HashSet 26 | import qualified Data.Text as StrictT 27 | import qualified Data.Text.Lazy as LazyT 28 | import qualified Data.Vector as Vector 29 | import qualified Data.Vector.Storable as Storable 30 | import qualified Data.Vector.Unboxed as Unboxed 31 | 32 | import Optics.Core 33 | 34 | -- Extra instances 35 | 36 | instance AsEmpty (HashMap k a) where 37 | _Empty = nearly HashMap.empty HashMap.null 38 | {-# INLINE _Empty #-} 39 | 40 | instance AsEmpty (HashSet a) where 41 | _Empty = nearly HashSet.empty HashSet.null 42 | {-# INLINE _Empty #-} 43 | 44 | instance AsEmpty (Vector.Vector a) where 45 | _Empty = nearly Vector.empty Vector.null 46 | {-# INLINE _Empty #-} 47 | 48 | instance Unboxed.Unbox a => AsEmpty (Unboxed.Vector a) where 49 | _Empty = nearly Unboxed.empty Unboxed.null 50 | {-# INLINE _Empty #-} 51 | 52 | instance Storable.Storable a => AsEmpty (Storable.Vector a) where 53 | _Empty = nearly Storable.empty Storable.null 54 | {-# INLINE _Empty #-} 55 | 56 | instance AsEmpty StrictB.ByteString where 57 | _Empty = nearly StrictB.empty StrictB.null 58 | {-# INLINE _Empty #-} 59 | 60 | instance AsEmpty LazyB.ByteString where 61 | _Empty = nearly LazyB.empty LazyB.null 62 | {-# INLINE _Empty #-} 63 | 64 | instance AsEmpty StrictT.Text where 65 | _Empty = nearly StrictT.empty StrictT.null 66 | {-# INLINE _Empty #-} 67 | 68 | instance AsEmpty LazyT.Text where 69 | _Empty = nearly LazyT.empty LazyT.null 70 | {-# INLINE _Empty #-} 71 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Extra.hs: -------------------------------------------------------------------------------- 1 | module Optics.Extra 2 | ( module Optics.Core 3 | , module O 4 | ) where 5 | 6 | import Optics.Core 7 | 8 | import Optics.At as O 9 | import Optics.Cons as O 10 | import Optics.Each as O 11 | import Optics.Empty as O 12 | import Optics.Indexed as O 13 | import Optics.View as O 14 | import Optics.Zoom as O 15 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Extra/Internal/Vector.hs: -------------------------------------------------------------------------------- 1 | module Optics.Extra.Internal.Vector 2 | ( ordinalNub 3 | ) where 4 | 5 | import Data.IntSet (IntSet) 6 | import qualified Data.IntSet as IntSet 7 | 8 | -- | Return the the subset of given ordinals within a given bound and in order 9 | -- of the first occurrence seen. 10 | -- 11 | -- Bound: @0 <= x < l@ 12 | -- 13 | -- >>> ordinalNub 3 [-1,2,1,4,2,3] 14 | -- [2,1] 15 | ordinalNub :: 16 | Int {- ^ strict upper bound -} -> 17 | [Int] {- ^ ordinals -} -> 18 | [Int] {- ^ unique, in-bound ordinals, in order seen -} 19 | ordinalNub l xs = foldr (ordinalNubHelper l) (const []) xs IntSet.empty 20 | 21 | ordinalNubHelper :: Int -> Int -> (IntSet -> [Int]) -> (IntSet -> [Int]) 22 | ordinalNubHelper l x next seen 23 | | outOfBounds || notUnique = next seen 24 | | otherwise = x : next (IntSet.insert x seen) 25 | where 26 | outOfBounds = x < 0 || l <= x 27 | notUnique = x `IntSet.member` seen 28 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Indexed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UndecidableInstances #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | -- | 4 | -- Module: Optics.Indexed 5 | -- Description: Definitions of indexed optics. 6 | -- 7 | -- This module defines general functionality for indexed optics. See the 8 | -- "Indexed optics" section of the overview documentation in the @Optics@ module 9 | -- of the main @optics@ package for more details. 10 | -- 11 | -- Unlike "Optics.Indexed.Core", this includes the definitions from modules for 12 | -- specific indexed optic flavours such as "Optics.IxTraversal", and includes 13 | -- additional instances for 'FunctorWithIndex' and similar classes. 14 | -- 15 | module Optics.Indexed 16 | ( 17 | -- * Class for optic kinds that can be indexed 18 | IxOptic(..) 19 | 20 | , conjoined 21 | 22 | -- * Composition of indexed optics 23 | , (<%>) 24 | , (%>) 25 | , (<%) 26 | , reindexed 27 | , icompose 28 | , icompose3 29 | , icompose4 30 | , icompose5 31 | , icomposeN 32 | 33 | -- * Indexed optic flavours 34 | , module Optics.IxAffineFold 35 | , module Optics.IxAffineTraversal 36 | , module Optics.IxFold 37 | , module Optics.IxGetter 38 | , module Optics.IxLens 39 | , module Optics.IxSetter 40 | , module Optics.IxTraversal 41 | 42 | -- * Functors with index 43 | , FunctorWithIndex (..) 44 | -- ** Foldable with index 45 | , FoldableWithIndex (..) 46 | , itraverse_ 47 | , ifor_ 48 | , itoList 49 | -- ** Traversable with index 50 | , TraversableWithIndex (..) 51 | , ifor 52 | ) where 53 | 54 | import Optics.Indexed.Core 55 | import Optics.IxAffineFold 56 | import Optics.IxAffineTraversal 57 | import Optics.IxFold 58 | import Optics.IxGetter 59 | import Optics.IxLens 60 | import Optics.IxSetter 61 | import Optics.IxTraversal 62 | 63 | import Data.Functor.WithIndex.Instances () 64 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/Passthrough.hs: -------------------------------------------------------------------------------- 1 | module Optics.Passthrough where 2 | 3 | import Optics.Internal.Optic 4 | import Optics.AffineTraversal 5 | import Optics.Lens 6 | import Optics.Prism 7 | import Optics.Traversal 8 | import Optics.View 9 | 10 | class (Is k A_Traversal, ViewableOptic k r) => PermeableOptic k r where 11 | -- | Modify the target of an 'Optic' returning extra information of type 'r'. 12 | passthrough 13 | :: Optic k is s t a b 14 | -> (a -> (r, b)) 15 | -> s 16 | -> (ViewResult k r, t) 17 | 18 | instance PermeableOptic An_Iso r where 19 | passthrough o = toLensVL o 20 | {-# INLINE passthrough #-} 21 | 22 | instance PermeableOptic A_Lens r where 23 | passthrough o = toLensVL o 24 | {-# INLINE passthrough #-} 25 | 26 | instance PermeableOptic A_Prism r where 27 | passthrough o f s = withPrism o $ \bt sta -> case sta s of 28 | Left t -> (Nothing, t) 29 | Right a -> case f a of 30 | (r, b) -> (Just r, bt b) 31 | {-# INLINE passthrough #-} 32 | 33 | instance PermeableOptic An_AffineTraversal r where 34 | passthrough o f s = withAffineTraversal o $ \sta sbt -> case sta s of 35 | Left t -> (Nothing, t) 36 | Right a -> case f a of 37 | (r, b) -> (Just r, sbt s b) 38 | {-# INLINE passthrough #-} 39 | 40 | instance Monoid r => PermeableOptic A_Traversal r where 41 | passthrough = traverseOf 42 | {-# INLINE passthrough #-} 43 | -------------------------------------------------------------------------------- /optics-extra/src/Optics/State.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Module: Optics.State 3 | -- Description: 'Setter' utilities for working with 'MonadState'. 4 | -- 5 | -- This module contains utilities for working with 'Setter's in a 'MonadState' 6 | -- context. If you prefer operator versions, you may wish to import 7 | -- "Optics.State.Operators". 8 | -- 9 | module Optics.State 10 | ( modifying 11 | , modifying' 12 | , assign 13 | , assign' 14 | , use 15 | , preuse 16 | ) where 17 | 18 | import Control.Monad.State 19 | 20 | import Optics.Core 21 | 22 | -- | Map over the target(s) of an 'Optic' in our monadic state. 23 | -- 24 | -- >>> execState (do modifying _1 (*10); modifying _2 $ stimes 5) (6,"o") 25 | -- (60,"ooooo") 26 | -- 27 | -- >>> execState (modifying each $ stimes 2) ("a","b") 28 | -- ("aa","bb") 29 | modifying 30 | :: (Is k A_Setter, MonadState s m) 31 | => Optic k is s s a b 32 | -> (a -> b) 33 | -> m () 34 | modifying o = modify . over o 35 | {-# INLINE modifying #-} 36 | 37 | -- | Version of 'modifying' that is strict in both optic application and state 38 | -- modification. 39 | -- 40 | -- >>> flip evalState ('a','b') $ modifying _1 (errorWithoutStackTrace "oops") 41 | -- () 42 | -- 43 | -- >>> flip evalState ('a','b') $ modifying' _1 (errorWithoutStackTrace "oops") 44 | -- *** Exception: oops 45 | modifying' 46 | :: (Is k A_Setter, MonadState s m) 47 | => Optic k is s s a b 48 | -> (a -> b) 49 | -> m () 50 | modifying' o = modify' . over' o 51 | {-# INLINE modifying' #-} 52 | 53 | -- | Replace the target(s) of an 'Optic' in our monadic state with a new value, 54 | -- irrespective of the old. 55 | -- 56 | -- >>> execState (do assign _1 'c'; assign _2 'd') ('a','b') 57 | -- ('c','d') 58 | -- 59 | -- >>> execState (assign each 'c') ('a','b') 60 | -- ('c','c') 61 | assign 62 | :: (Is k A_Setter, MonadState s m) 63 | => Optic k is s s a b 64 | -> b 65 | -> m () 66 | assign o = modifying o . const 67 | {-# INLINE assign #-} 68 | 69 | -- | Version of 'assign' that is strict in both optic application and state 70 | -- modification. 71 | -- 72 | -- >>> flip evalState ('a','b') $ assign _1 (errorWithoutStackTrace "oops") 73 | -- () 74 | -- 75 | -- >>> flip evalState ('a','b') $ assign' _1 (errorWithoutStackTrace "oops") 76 | -- *** Exception: oops 77 | assign' 78 | :: (Is k A_Setter, MonadState s m) 79 | => Optic k is s s a b 80 | -> b 81 | -> m () 82 | assign' o = modifying' o . const 83 | {-# INLINE assign' #-} 84 | 85 | -- | Use the target of a 'Lens', 'Iso', or 'Getter' in the current state. 86 | -- 87 | -- >>> evalState (use _1) ('a','b') 88 | -- 'a' 89 | -- 90 | -- >>> evalState (use _2) ("hello","world") 91 | -- "world" 92 | -- 93 | use 94 | :: (Is k A_Getter, MonadState s m) 95 | => Optic' k is s a 96 | -> m a 97 | use o = gets (view o) 98 | {-# INLINE use #-} 99 | 100 | -- | Use the target of a 'AffineTraveral' or 'AffineFold' in the current state. 101 | -- 102 | -- >>> evalState (preuse $ _1 % _Right) (Right 'a','b') 103 | -- Just 'a' 104 | -- 105 | -- @since 0.2 106 | preuse 107 | :: (Is k An_AffineFold, MonadState s m) 108 | => Optic' k is s a 109 | -> m (Maybe a) 110 | preuse o = gets (preview o) 111 | {-# INLINE preuse #-} 112 | 113 | -- $setup 114 | -- >>> import Data.Semigroup 115 | -------------------------------------------------------------------------------- /optics-sop/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /optics-sop/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /optics-sop/optics-sop.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-sop 3 | version: 0.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | maintainer: optics@well-typed.com 8 | author: Adam Gundry, Andres Löh, Andrzej Rybczak 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, 12 | GHCJS ==8.4 13 | synopsis: Optics for generics-sop, and using generics-sop 14 | category: Data, Optics, Lenses, Generics 15 | description: 16 | This package provides: 17 | . 18 | * optics to work with @generics-sop@ (or @sop-core@) types, 19 | . 20 | * machinery to construct optics using @generics-sop@. 21 | 22 | bug-reports: https://github.com/well-typed/optics/issues 23 | source-repository head 24 | type: git 25 | location: https://github.com/well-typed/optics.git 26 | subdir: optics-sop 27 | 28 | common language 29 | ghc-options: -Wall -Wcompat 30 | 31 | default-language: Haskell2010 32 | 33 | default-extensions: BangPatterns 34 | ConstraintKinds 35 | DefaultSignatures 36 | DeriveFoldable 37 | DeriveFunctor 38 | DeriveGeneric 39 | DeriveTraversable 40 | EmptyCase 41 | FlexibleContexts 42 | FlexibleInstances 43 | FunctionalDependencies 44 | GADTs 45 | GeneralizedNewtypeDeriving 46 | InstanceSigs 47 | KindSignatures 48 | LambdaCase 49 | OverloadedLabels 50 | PatternSynonyms 51 | RankNTypes 52 | ScopedTypeVariables 53 | TupleSections 54 | TypeApplications 55 | TypeFamilies 56 | TypeOperators 57 | ViewPatterns 58 | 59 | library 60 | import: language 61 | hs-source-dirs: src 62 | 63 | build-depends: base >=4.10 && <5 64 | , generics-sop >=0.3.1.0 && <0.6 65 | , optics-core >=0.4 && <0.5 66 | 67 | exposed-modules: Optics.SOP 68 | Optics.SOP.ToTuple 69 | Generics.SOP.Optics 70 | -------------------------------------------------------------------------------- /optics-sop/src/Generics/SOP/Optics.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | -- | This module defines optics for working with the types in @generics-sop@. 4 | -- 5 | module Generics.SOP.Optics 6 | ( rep 7 | , sop 8 | , nsSingleton 9 | , _I 10 | , _K 11 | , productRep 12 | , npHead 13 | , npTail 14 | , npSingleton 15 | , _Z 16 | , _S 17 | ) 18 | where 19 | 20 | import Generics.SOP 21 | import Optics.Core hiding (to) 22 | 23 | -- | Iso between a generic type and its representation. 24 | rep :: (Generic a, Generic b) => Iso a b (Rep a) (Rep b) 25 | rep = iso from to 26 | 27 | -- | Iso induced by the 'SOP' newtype. 28 | sop :: Iso (SOP f xss) (SOP g yss) (NS (NP f) xss) (NS (NP g) yss) 29 | sop = iso unSOP SOP 30 | 31 | -- | Iso between a one-element sum and its contents. 32 | nsSingleton :: Iso (NS f '[ x ]) (NS g '[ y ]) (f x) (g y) 33 | nsSingleton = iso unZ Z 34 | 35 | -- | Iso induced by the 'I' newtype. 36 | _I :: Iso (I x) (I y) x y 37 | _I = iso unI I 38 | 39 | -- | Iso induced by the 'K' newtype. 40 | _K :: Iso (K a b) (K c d) a c 41 | _K = iso unK K 42 | 43 | -- | Iso between a generic product type and its product representation. 44 | productRep :: (IsProductType a xs, IsProductType b ys) => Iso a b (NP I xs) (NP I ys) 45 | productRep = rep % sop % nsSingleton 46 | 47 | -- | Lens accessing the head of an 'NP'. 48 | npHead :: Lens (NP f (x ': xs)) (NP f (y ': xs)) (f x) (f y) 49 | npHead = lensVL (\ f (x :* xs) -> (:* xs) <$> f x) 50 | 51 | -- | Lens accessing the tail of an 'NP'. 52 | npTail :: Lens (NP f (x ': xs)) (NP f (x ': ys)) (NP f xs) (NP f ys) 53 | npTail = lensVL (\ f (x :* xs) -> (x :*) <$> f xs) 54 | 55 | -- | Iso between a single-element 'NP' and its contents. 56 | npSingleton :: Iso (NP f '[ x ]) (NP g '[ y ]) (f x) (g y) 57 | npSingleton = iso hd (:* Nil) 58 | 59 | -- | Prism for the first option in an 'NS'. 60 | _Z :: Prism (NS f (x ': xs)) (NS f (y ': xs)) (f x) (f y) 61 | _Z = prism Z $ \ ns -> case ns of 62 | Z x -> Right x 63 | S y -> Left (S y) 64 | 65 | -- | Prism for the other options in an 'NS'. 66 | _S :: Prism (NS f (x ': xs)) (NS f (x ': ys)) (NS f xs) (NS f ys) 67 | _S = prism S $ \ ns -> case ns of 68 | Z y -> Left (Z y) 69 | S x -> Right x 70 | -------------------------------------------------------------------------------- /optics-sop/src/Optics/SOP/ToTuple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | -- | Conversions between lists of types (of length up to 16) and the 3 | -- corresponding tuple types. 4 | -- 5 | module Optics.SOP.ToTuple where 6 | 7 | import Data.Kind 8 | import Generics.SOP hiding (from, to) 9 | import Optics.Core 10 | 11 | import Generics.SOP.Optics 12 | 13 | -- | Convert a list of types into a tuple of those types. 14 | type family ToTuple (xs :: [Type]) :: Type where 15 | ToTuple '[] = () 16 | ToTuple '[x1] = x1 17 | ToTuple '[x1, x2] = (x1, x2) 18 | ToTuple '[x1, x2, x3] = (x1, x2, x3) 19 | ToTuple '[x1, x2, x3, x4] = (x1, x2, x3, x4) 20 | ToTuple '[x1, x2, x3, x4, x5] = (x1, x2, x3, x4, x5) 21 | ToTuple '[x1, x2, x3, x4, x5, x6] = (x1, x2, x3, x4, x5, x6) 22 | ToTuple '[x1, x2, x3, x4, x5, x6, x7] = (x1, x2, x3, x4, x5, x6, x7) 23 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8] = (x1, x2, x3, x4, x5, x6, x7, x8) 24 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9] = (x1, x2, x3, x4, x5, x6, x7, x8, x9) 25 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10) 26 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11) 27 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12) 28 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13) 29 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14) 30 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15) 31 | ToTuple '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16] = (x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16) 32 | 33 | -- | A list of types is 'TupleLike' if it is isomorphic to the tuple given by 34 | -- 'ToTuple', 35 | class TupleLike xs where 36 | -- | Value-level isomorphsim between a heterogeneous list and the 37 | -- corresponding tuple type. 38 | tuple :: Iso' (NP I xs) (ToTuple xs) 39 | default tuple :: (IsProductType a xs, ToTuple xs ~ a) => Iso' (NP I xs) (ToTuple xs) 40 | tuple = re productRep 41 | 42 | instance TupleLike '[] 43 | instance TupleLike '[x1] where 44 | tuple = npSingleton % _I 45 | instance TupleLike '[x1, x2] 46 | instance TupleLike '[x1, x2, x3] 47 | instance TupleLike '[x1, x2, x3, x4] 48 | instance TupleLike '[x1, x2, x3, x4, x5] 49 | instance TupleLike '[x1, x2, x3, x4, x5, x6] 50 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7] 51 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8] 52 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9] 53 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10] 54 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11] 55 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12] 56 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13] 57 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14] 58 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15] 59 | instance TupleLike '[x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11, x12, x13, x14, x15, x16] 60 | -------------------------------------------------------------------------------- /optics-th/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # optics-th-0.4.1 (2022-03-22) 2 | * Add support for GHC-9.2 3 | 4 | # optics-th-0.4 (2021-02-22) 5 | * Add support for GHC-9.0 6 | * Print missing language extensions during TH generation of labels if there are 7 | any ([#352](https://github.com/well-typed/optics/pull/352)) 8 | * Add support for getters of rank1 polymorphic fields to optics generated with 9 | the `makeFieldLabels` family of functions 10 | ([#365](https://github.com/well-typed/optics/pull/365)) 11 | * Extend support of type-changing optics generated with the `makeFieldLabels` 12 | family to type parameters that are phantom and applied to non-injective type 13 | families 14 | ([#365](https://github.com/well-typed/optics/pull/365)) 15 | * Fix TH generation of optics for poly-kinded data families 16 | ([#378](https://github.com/well-typed/optics/pull/378)) 17 | * Fix `declareFieldLabels` when a field type refers to a type defined in the 18 | same quote 19 | ([#380](https://github.com/well-typed/optics/pull/380)) 20 | 21 | # optics-th-0.3.0.2 (2020-08-20) 22 | * Fix tests on GHC 8.10.2 23 | 24 | # optics-th-0.3.0.1 (2020-08-05) 25 | * Fix handling of nullary type families 26 | * Fix `declareFieldLabels` and `declareLenses` with DuplicateRecordFields 27 | * Improve documentation of `Optics.TH` 28 | 29 | # optics-th-0.3 (2020-04-15) 30 | * `optics-core-0.3` compatible release 31 | * GHC-8.10 support 32 | * Improvements to TH-generated optics: 33 | - `LabelOptic` instances make optic kind a type equality for better type inference 34 | - `LabelOptic` instances for field optics work properly in the presence of type families 35 | - Fixed calculation of phantom types in `LabelOptic` prism instances 36 | - Better support for generating optics in the presence of kind polymorphism 37 | 38 | # optics-th-0.2 (2019-10-18) 39 | * Add `noPrefixFieldLabels` and `noPrefixNamer` to `Optics.TH` 40 | 41 | # optics-th-0.1 (2019-09-02) 42 | * Initial release 43 | -------------------------------------------------------------------------------- /optics-th/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | This software incorporates code from the lens package (available from 34 | https://hackage.haskell.org/package/lens) under the following license: 35 | 36 | 37 | Copyright 2012-2016 Edward Kmett 38 | 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions 43 | are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright 46 | notice, this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright 49 | notice, this list of conditions and the following disclaimer in the 50 | documentation and/or other materials provided with the distribution. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 53 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 54 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 55 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 56 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 57 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 58 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 59 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 60 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 61 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 62 | POSSIBILITY OF SUCH DAMAGE. 63 | -------------------------------------------------------------------------------- /optics-th/optics-th.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-th 3 | version: 0.4.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | maintainer: optics@well-typed.com 8 | author: Andrzej Rybczak 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, 12 | GHCJS ==8.4 13 | synopsis: Optics construction using TemplateHaskell 14 | category: Data, Optics, Lenses 15 | description: 16 | This package is part of the @@ 17 | package family. It provides machinery to construct optics using @TemplateHaskell@. 18 | . 19 | See the @template-haskell-optics@ package for optics to work with @template-haskell@ types. 20 | 21 | extra-doc-files: 22 | CHANGELOG.md 23 | 24 | bug-reports: https://github.com/well-typed/optics/issues 25 | source-repository head 26 | type: git 27 | location: https://github.com/well-typed/optics.git 28 | subdir: optics-th 29 | 30 | common language 31 | ghc-options: -Wall -Wcompat 32 | 33 | default-language: Haskell2010 34 | 35 | default-extensions: BangPatterns 36 | ConstraintKinds 37 | DefaultSignatures 38 | DeriveFoldable 39 | DeriveFunctor 40 | DeriveGeneric 41 | DeriveTraversable 42 | EmptyCase 43 | FlexibleContexts 44 | FlexibleInstances 45 | FunctionalDependencies 46 | GADTs 47 | GeneralizedNewtypeDeriving 48 | InstanceSigs 49 | KindSignatures 50 | LambdaCase 51 | OverloadedLabels 52 | PatternSynonyms 53 | RankNTypes 54 | ScopedTypeVariables 55 | TupleSections 56 | TypeApplications 57 | TypeFamilies 58 | TypeOperators 59 | ViewPatterns 60 | 61 | library 62 | import: language 63 | hs-source-dirs: src 64 | 65 | build-depends: base >= 4.10 && <5 66 | , containers >= 0.5.10.2 && <0.8 67 | , mtl >= 2.2.2 && <2.4 68 | , optics-core >= 0.4.1 && <0.5 69 | , template-haskell >= 2.12 && <2.23 70 | , th-abstraction >= 0.4 && <0.8 71 | , transformers >= 0.5 && <0.7 72 | 73 | exposed-modules: Optics.TH 74 | 75 | -- internal modules 76 | Optics.TH.Internal.Utils 77 | Optics.TH.Internal.Product 78 | Optics.TH.Internal.Sum 79 | 80 | other-modules: Language.Haskell.TH.Optics.Internal 81 | 82 | test-suite optics-th-tests 83 | import: language 84 | hs-source-dirs: tests 85 | 86 | build-depends: base 87 | , optics-core 88 | , optics-th 89 | , tagged 90 | 91 | type: exitcode-stdio-1.0 92 | main-is: Optics/TH/Tests.hs 93 | 94 | other-modules: Optics.TH.Tests.DuplicateRecordFields 95 | Optics.TH.Tests.T799 96 | -------------------------------------------------------------------------------- /optics-th/tests/Optics/TH/Tests/DuplicateRecordFields.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | -- | Test that 'declareFieldLabels' and 'declareLenses' work in the presence of 6 | -- @DuplicateRecordFields@ (see issue #323), including when the data constructor 7 | -- or field name contain a colon, and with data families (because data families 8 | -- are weird). 9 | module Optics.TH.Tests.DuplicateRecordFields where 10 | 11 | import Optics.Core 12 | import Optics.TH 13 | 14 | $(declareFieldLabels [d|data T = Z | MkT { foo :: Int, (<:) :: Int -> Int }|]) 15 | $(declareLenses [d|data U = MkU { foo :: Int, (<:) :: Int -> Int }|]) 16 | $(declareLenses [d|data (:::) = (:::) { (>:) :: Int -> Int }|]) 17 | 18 | foo' :: T -> [Int] 19 | foo' = toListOf #foo 20 | 21 | foo'' :: U -> Int 22 | foo'' = view foo 23 | 24 | (<::) :: U -> Int -> Int 25 | (<::) = view (<:) 26 | 27 | (>::) :: (:::) -> Int -> Int 28 | (>::) = view (>:) 29 | 30 | -- NB we cannot use the field name 'foo' here, because there is already a 31 | -- definition of 'foo' as a lens in scope (#338). 32 | $(declareFieldLabels 33 | [d|data family F x 34 | data instance F Int = MkF { woo :: Int }|]) 35 | $(declareLenses 36 | [d|data family G x 37 | data instance G Int = MkG { bar :: Int }|]) 38 | 39 | foo''' :: F Int -> Int 40 | foo''' = view #woo 41 | 42 | bar' :: G Int -> Int 43 | bar' = view bar 44 | -------------------------------------------------------------------------------- /optics-th/tests/Optics/TH/Tests/T799.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | -- | Test 'makeFields' on a field whose type has a data family. Unlike for type 3 | -- families, for data families we do not generate type equality constraints, as 4 | -- they are not needed to avoid the issue in #754. 5 | -- 6 | -- This tests that the fix for #799 is valid by putting this in a module in 7 | -- which UndecidableInstances is not enabled. 8 | module Optics.TH.Tests.T799 where 9 | 10 | import Optics.Lens 11 | import Optics.TH 12 | 13 | data family DF a 14 | newtype instance DF Int = FooInt Int 15 | 16 | data Bar = Bar { _barFoo :: DF Int } 17 | makeFields ''Bar 18 | 19 | checkBarFoo :: Lens' Bar (DF Int) 20 | checkBarFoo = foo 21 | -------------------------------------------------------------------------------- /optics-vl/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # optics-vl-0.2.1 (2020-04-15) 2 | * Provide conversions from `Iso`/`Prism` to their VL representation 3 | 4 | # optics-vl-0.2 (2019-10-18) 5 | * Depend on new `indexed-profunctors` package 6 | 7 | # optics-vl-0.1 (2019-09-02) 8 | * Initial release 9 | -------------------------------------------------------------------------------- /optics-vl/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /optics-vl/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main :: IO () 4 | main = defaultMain 5 | -------------------------------------------------------------------------------- /optics-vl/optics-vl.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: optics-vl 3 | version: 0.2.1 4 | license: BSD-3-Clause 5 | license-file: LICENSE 6 | build-type: Simple 7 | maintainer: optics@well-typed.com 8 | author: Andrzej Rybczak 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, 12 | GHCJS ==8.4 13 | synopsis: Utilities for compatibility with van Laarhoven optics 14 | category: Data, Optics, Lenses 15 | description: 16 | This package is part of the @@ 17 | package family. It provides utilities for converting between the 'Optic' type 18 | defined by @@ and the van 19 | Laarhoven representations of optics that require definitions outside of @base@ 20 | (in particular isomorphisms and prisms). 21 | 22 | extra-doc-files: 23 | CHANGELOG.md 24 | 25 | bug-reports: https://github.com/well-typed/optics/issues 26 | source-repository head 27 | type: git 28 | location: https://github.com/well-typed/optics.git 29 | subdir: optics-vl 30 | 31 | common language 32 | ghc-options: -Wall -Wcompat 33 | 34 | default-language: Haskell2010 35 | 36 | default-extensions: BangPatterns 37 | ConstraintKinds 38 | DefaultSignatures 39 | DeriveFoldable 40 | DeriveFunctor 41 | DeriveGeneric 42 | DeriveTraversable 43 | EmptyCase 44 | FlexibleContexts 45 | FlexibleInstances 46 | FunctionalDependencies 47 | GADTs 48 | GeneralizedNewtypeDeriving 49 | InstanceSigs 50 | KindSignatures 51 | LambdaCase 52 | OverloadedLabels 53 | PatternSynonyms 54 | RankNTypes 55 | ScopedTypeVariables 56 | TupleSections 57 | TypeApplications 58 | TypeFamilies 59 | TypeOperators 60 | ViewPatterns 61 | 62 | library 63 | import: language 64 | hs-source-dirs: src 65 | 66 | build-depends: base >= 4.10 && <5 67 | , indexed-profunctors >= 0.1 && <0.2 68 | , optics-core >= 0.2 && <0.5 69 | , profunctors >= 5.0 && <6.0 70 | 71 | exposed-modules: Optics.VL 72 | -------------------------------------------------------------------------------- /optics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | This software incorporates code from the lens package (available from 34 | https://hackage.haskell.org/package/lens) under the following license: 35 | 36 | 37 | Copyright 2012-2016 Edward Kmett 38 | 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions 43 | are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright 46 | notice, this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright 49 | notice, this list of conditions and the following disclaimer in the 50 | documentation and/or other materials provided with the distribution. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 53 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 54 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 55 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 56 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 57 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 58 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 59 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 60 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 61 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 62 | POSSIBILITY OF SUCH DAMAGE. 63 | -------------------------------------------------------------------------------- /optics/diagrams/indexedoptics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics/diagrams/indexedoptics.png -------------------------------------------------------------------------------- /optics/diagrams/optics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics/diagrams/optics.png -------------------------------------------------------------------------------- /optics/diagrams/reoptics.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/well-typed/optics/9ff982b6b47a79191e1c5d6c7e70386e002dbcc8/optics/diagrams/reoptics.png -------------------------------------------------------------------------------- /optics/tests/Optics/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-} 3 | module Main (main) where 4 | 5 | import Test.Tasty 6 | 7 | import Optics 8 | import Optics.Tests.Computation 9 | import Optics.Tests.Core 10 | import Optics.Tests.Eta 11 | import Optics.Tests.Labels.Generic 12 | import Optics.Tests.Labels.TH 13 | import Optics.Tests.Misc 14 | import Optics.Tests.Properties 15 | 16 | -- | Composing a lens and a traversal yields a traversal 17 | _comp1 :: Traversable t => Optic A_Traversal NoIx (t a, y) (t b, y) a b 18 | _comp1 = _1 % traversed 19 | 20 | -- | Composing two lenses yields a lens 21 | _comp2 :: Optic A_Lens NoIx ((a, y), y1) ((b, y), y1) a b 22 | _comp2 = _1 % _1 23 | 24 | -- | Composing a getter and a lens yields a getter 25 | _comp3 :: Optic A_Getter NoIx ((b, y), b1) ((b, y), b1) b b 26 | _comp3 = to fst % _1 27 | 28 | -- | Composing a prism and a lens yields a traversal 29 | _comp4 :: Optic An_AffineTraversal NoIx (Either c (a, y)) (Either c (b, y)) a b 30 | _comp4 = _Right % _1 31 | 32 | -- | An iso can be used as a getter 33 | _eg1 :: Int 34 | _eg1 = view (iso (+ 1) (\ x -> x - 1)) 5 35 | 36 | -- | A lens can be used as a getter 37 | _eg2 :: (a, b) -> a 38 | _eg2 = view _1 39 | 40 | -- These don't typecheck, as one would expect: 41 | -- to fst % mapped -- Cannot compose a getter with a setter 42 | -- toLens (to fst) -- Cannot use a getter as a lens 43 | 44 | main :: IO () 45 | main = defaultMain $ testGroup "Tests" 46 | [ testGroup "Inspection" 47 | [ coreTests 48 | , etaTests 49 | , genericLabelsTests 50 | , thLabelsTests 51 | , miscTests 52 | ] 53 | , computationTests 54 | , propertiesTests 55 | ] 56 | -------------------------------------------------------------------------------- /optics/tests/Optics/Tests/Computation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-} 3 | module Optics.Tests.Computation (computationTests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | import Test.Inspection 8 | 9 | import Optics 10 | import Optics.Tests.Utils 11 | 12 | computationTests :: TestTree 13 | computationTests = testGroup "computation" 14 | [ testGroup "Lens" 15 | [ testCase "view (lens f g) = f" $ 16 | assertSuccess $(inspectTest $ 'lens1lhs === 'lens1rhs) 17 | , testCase "set (lens f g) = g" $ 18 | assertSuccess $(inspectTest $ 'lens2lhs === 'lens2rhs) 19 | ] 20 | , testGroup "AffineTraversal" 21 | -- this doesn't hold definitionally: we need law here 22 | [ testCase "withAffineTraversal (atraversal f g) (\\ _ g' -> g') /= g" $ 23 | assertFailure' $(inspectTest $ 'atraversal1lhs === 'atraversal1rhs) 24 | , testCase "withAffineTraversal (atraversal f g) (\\ _ g' -> g') = ..." $ 25 | assertSuccess $(inspectTest $ 'atraversal1lhs === 'atraversal1rhs_) 26 | , testCase "withAffineTraversal (atraversal f g) (\\ f' _ -> f') = f" $ 27 | assertSuccess $(inspectTest $ 'atraversal2lhs === 'atraversal2rhs) 28 | ] 29 | , testGroup "AffineFold" 30 | [ testCase "preview (afolding f) = f" $ 31 | assertSuccess $(inspectTest $ 'afold1lhs === 'afold1rhs) 32 | ] 33 | , testGroup "Setter" 34 | [ testCase "over (sets f) = f" $ 35 | assertSuccess $(inspectTest $ 'setter1lhs === 'setter1rhs) 36 | ] 37 | ] 38 | 39 | lens1lhs, lens1rhs :: (s -> a) -> (s -> a -> s) -> (s -> a) 40 | lens1lhs f g s = view (lens f g) s 41 | lens1rhs f _ s = f s 42 | 43 | lens2lhs, lens2rhs :: (s -> a) -> (s -> b -> t) -> (s -> b -> t) 44 | lens2lhs f g s b = set (lens f g) b s 45 | lens2rhs _ g s b = g s b 46 | 47 | atraversal1lhs, atraversal1rhs, atraversal1rhs_ 48 | :: (s -> Either t a) -> (s -> b -> t) -> (s -> b -> t) 49 | atraversal1lhs f g s b = withAffineTraversal (atraversal f g) (\_ g' -> g') s b 50 | atraversal1rhs _ g s b = g s b 51 | atraversal1rhs_ f g s b = either id (\_ -> g s b) (f s) 52 | 53 | atraversal2lhs, atraversal2rhs 54 | :: (s -> Either t a) -> (s -> b -> t) -> (s -> Either t a) 55 | atraversal2lhs f g s = withAffineTraversal (atraversal f g) (\f' _ -> f') s 56 | atraversal2rhs f _ s = f s 57 | 58 | afold1lhs, afold1rhs :: (s -> Maybe a) -> s -> Maybe a 59 | afold1lhs sma s = preview (afolding sma) s 60 | afold1rhs sma s = sma s 61 | 62 | setter1lhs, setter1rhs :: ((a -> b) -> s -> t) -> ((a -> b) -> s -> t) 63 | setter1lhs f ab s = over (sets f) ab s 64 | setter1rhs f ab s = f ab s 65 | -------------------------------------------------------------------------------- /optics/tests/Optics/Tests/Misc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fplugin=Test.Inspection.Plugin -dsuppress-all #-} 3 | module Optics.Tests.Misc (miscTests) where 4 | 5 | import Test.Tasty 6 | import Test.Tasty.HUnit 7 | import Test.Inspection 8 | import qualified Data.Map as M 9 | import qualified Data.Sequence as S 10 | 11 | import Optics 12 | import Optics.Tests.Utils 13 | 14 | miscTests :: TestTree 15 | miscTests = testGroup "Miscellaneous" 16 | [ testCase "optimized sipleMapIx" $ 17 | assertSuccess $(inspectTest $ 'simpleMapIx `hasNoTypeClassesExcept` [''Ord]) 18 | , testCase "optimized mapIx" $ 19 | assertSuccess $(inspectTest $ hasNoProfunctors 'mapIx) 20 | , testCase "optimized seqIx" $ 21 | assertSuccess $(inspectTest $ hasNoProfunctors 'seqIx) 22 | , testCase "optimized itoList" $ 23 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkitoListOf) 24 | , testCase "optimized partsOf" $ 25 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkPartsOf) 26 | , testCase "optimized singular" $ 27 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkSingular) 28 | , testCase "optimized filteredBy" $ 29 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkFilteredBy) 30 | , testCase "optimized unsafeFilteredBy" $ 31 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkUnsafeFilteredBy) 32 | -- GHC <= 8.4 doesn't optimize away profunctor classes 33 | , testCase "optimized adjoin" $ 34 | ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkAdjoin) 35 | -- GHC <= 8.4 doesn't optimize away profunctor classes 36 | , testCase "optimized iadjoin" $ 37 | ghcLE84failure $(inspectTest $ hasNoProfunctors 'checkIxAdjoin) 38 | , testCase "optimized gplate (profunctors)" $ 39 | assertSuccess $(inspectTest $ hasNoProfunctors 'checkGplate) 40 | , testCase "optimized gplate (generics)" $ 41 | assertSuccess $(inspectTest $ hasNoGenericRep 'checkGplate) 42 | , testCase "optimized icomposeN/appendIndices" $ 43 | assertSuccess $ $(inspectTest $ hasNoIndexClasses 'checkNoIndexFunctions) 44 | ] 45 | 46 | simpleMapIx 47 | :: Ord k => k -> Either a (M.Map k (b, v)) -> Maybe v 48 | simpleMapIx k = preview (_Right % ix k % _2) 49 | 50 | mapIx 51 | :: (Foldable f, Foldable g, Ord k) 52 | => (f (Either a (g (M.Map k v))), b) -> k -> [v] 53 | mapIx m k = toListOf (_1 % folded % _Right % folded % ix k) m 54 | 55 | seqIx :: Int -> [S.Seq a] -> [a] 56 | seqIx i = toListOf (folded % ix i) 57 | 58 | checkitoListOf :: Int -> [S.Seq a] -> [(Int, a)] 59 | checkitoListOf i = itoListOf (ifolded % ix i) 60 | 61 | checkPartsOf 62 | :: Traversable f 63 | => (f (Either a b), c) 64 | -> (f (Either a b), c) 65 | checkPartsOf = partsOf (_1 % traversed % _Right) %~ reverse 66 | 67 | checkSingular 68 | :: Traversable f 69 | => Either (f (a, Char)) b 70 | -> Either (f (a, Char)) b 71 | checkSingular = singular (_Left % traversed % _2) .~ 'x' 72 | 73 | checkFilteredBy 74 | :: Applicative f 75 | => ((Maybe i, b) -> f r) 76 | -> (Maybe i, b) 77 | -> f () 78 | checkFilteredBy = atraverseOf_ (filteredBy (_1 % _Just)) pure 79 | 80 | checkUnsafeFilteredBy 81 | :: Applicative f 82 | => (i -> Either a1 (a, Maybe i) -> f (Either a1 (a, Maybe i))) 83 | -> Either a1 (a, Maybe i) 84 | -> f (Either a1 (a, Maybe i)) 85 | checkUnsafeFilteredBy = iatraverseOf (unsafeFilteredBy (_Right % _2 % _Just)) pure 86 | 87 | checkAdjoin :: (a -> a) -> (Maybe a, Either a a, [a]) -> (Maybe a, Either a a, [a]) 88 | checkAdjoin = over (_1 % _Just `adjoin` _2 % chosen `adjoin` _3 % traversed) 89 | 90 | checkIxAdjoin :: (Int -> a -> a) -> ((Int, a), [a], (Int, Maybe a)) -> ((Int, a), [a], (Int, Maybe a)) 91 | checkIxAdjoin = iover (_1 % itraversed `iadjoin` _2 % itraversed `iadjoin` _3 % itraversed % _Just) 92 | 93 | checkGplate 94 | :: (Char, ([Either Char ()], Char, Maybe Char), [Char], Either Char Int) 95 | -> [Char] 96 | checkGplate = toListOf gplate 97 | 98 | checkNoIndexFunctions 99 | :: ( TraversableWithIndex i1 f1, TraversableWithIndex i2 f2 100 | , TraversableWithIndex i3 f3, TraversableWithIndex i4 f4 101 | , TraversableWithIndex i5 f5, TraversableWithIndex i6 f6 102 | , TraversableWithIndex i7 f7, TraversableWithIndex i8 f8 103 | ) => Optic A_Traversal 104 | (WithIx (i1, i2, i3, i4, i5, i6, i7, i8)) 105 | (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 a)))))))) 106 | (f1 (f2 (f3 (f4 (f5 (f6 (f7 (f8 b)))))))) 107 | a 108 | b 109 | checkNoIndexFunctions 110 | = icomposeN (,,,,,,,) $ (((itraversed % itraversed) % itraversed) % itraversed) 111 | % (itraversed % (itraversed % (itraversed % itraversed))) 112 | -------------------------------------------------------------------------------- /optics/tests/Optics/Tests/Properties.hs: -------------------------------------------------------------------------------- 1 | module Optics.Tests.Properties (propertiesTests) where 2 | 3 | import Data.Either (isRight) 4 | import Test.Tasty (TestTree, testGroup) 5 | import Test.Tasty.QuickCheck (testProperty) 6 | import Test.QuickCheck (Fun, expectFailure, applyFun, applyFun2, Property, (===), (==>)) 7 | import Test.QuickCheck.Poly (A, B, C, OrdA) 8 | 9 | import Optics 10 | import Optics.Internal.Optic 11 | import Optics.Internal.Bi 12 | 13 | type S = C 14 | type T = OrdA 15 | 16 | propertiesTests :: TestTree 17 | propertiesTests = testGroup "properties" 18 | -- lens bundles /any/ two functions together 19 | [ testGroup "Lens" 20 | [ testProperty "view (lens f g) = f" $ 21 | let prop :: Fun S A -> Fun (S, B) T -> S -> Property 22 | prop f g s = 23 | view (getting (lens (applyFun f) (applyFun2 g))) s 24 | === 25 | applyFun f s 26 | 27 | in prop 28 | , testProperty "set (lens f g) = g" $ 29 | let prop :: Fun S A -> Fun (S, B) T -> S -> B -> Property 30 | prop f g s b = 31 | set (lens (applyFun f) (applyFun2 g)) b s 32 | === 33 | applyFun2 g s b 34 | 35 | in prop 36 | ] 37 | 38 | -- also prisms 39 | , testGroup "Prism" 40 | [ testProperty "review (prism f g) = f" $ 41 | let prop :: Fun B T -> Fun S (Either T A) -> B -> Property 42 | prop f g b = 43 | review (reviewing (castOptic (prism (applyFun f) (applyFun g)))) b 44 | === 45 | applyFun f b 46 | in prop 47 | , testProperty "matching (prism f g) = g" $ 48 | let prop :: Fun B T -> Fun S (Either T A) -> S -> Property 49 | prop f g s = 50 | matching (prism (applyFun f) (applyFun g)) s 51 | === 52 | applyFun g s 53 | in prop 54 | ] 55 | 56 | -- affine traversals are trickier, atraversal doesn't just bundle 57 | -- two arbitrary functions together. 58 | , testGroup "AffineTraversal" 59 | [ testProperty "matching (atraversal f g) = g" $ 60 | let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> Property 61 | prop f g s = 62 | matching (atraversal (applyFun f) (applyFun2 g)) s 63 | === 64 | applyFun f s 65 | in prop 66 | , testProperty "set (atraversal f g) ~= flip g" $ 67 | let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> B -> Property 68 | prop f g s b = 69 | set (atraversal (applyFun f) (applyFun2 g)) b s 70 | === 71 | applyFun2 g s b 72 | in expectFailure prop 73 | , testProperty "isRight (f s) ==> set (atraversal f g) = flip g" $ 74 | let prop :: Fun S (Either T A) -> Fun (S, B) T -> S -> B -> Property 75 | prop f g s b = 76 | isRight (applyFun f s) 77 | ==> 78 | set (atraversal (applyFun f) (applyFun2 g)) b s 79 | === 80 | applyFun2 g s b 81 | in prop 82 | ] 83 | ] 84 | 85 | reviewing :: Optic A_Review NoIx s t a b -> Review t b 86 | reviewing (Optic o) = Optic (lphantom . o . lphantom) 87 | -------------------------------------------------------------------------------- /optics/tests/Optics/Tests/Utils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | module Optics.Tests.Utils where 4 | 5 | import Language.Haskell.TH (Name) 6 | import Test.Tasty.HUnit 7 | import Test.Inspection 8 | import qualified GHC.Generics as G 9 | 10 | import Optics.Internal.Optic 11 | import qualified Data.Profunctor.Indexed as P 12 | 13 | hasNoProfunctors :: Name -> Obligation 14 | hasNoProfunctors name = mkObligation name $ NoUseOf 15 | [ 'P.dimap 16 | , 'P.lmap 17 | , 'P.rmap 18 | , 'P.lcoerce' 19 | , 'P.rcoerce' 20 | , 'P.conjoined__ 21 | , 'P.ixcontramap 22 | , 'P.first' 23 | , 'P.second' 24 | , 'P.linear 25 | , 'P.ilinear 26 | , 'P.unfirst 27 | , 'P.unsecond 28 | , 'P.left' 29 | , 'P.right' 30 | , 'P.unleft 31 | , 'P.unright 32 | , 'P.visit 33 | , 'P.ivisit 34 | , 'P.wander 35 | , 'P.iwander 36 | , 'P.roam 37 | , 'P.iroam 38 | , 'appendIndices 39 | , 'composeN 40 | ] 41 | 42 | hasNoIndexClasses :: Name -> Obligation 43 | hasNoIndexClasses name = mkObligation name $ NoUseOf 44 | [ 'appendIndices 45 | , 'composeN 46 | ] 47 | 48 | -- | 'hasNoGenerics' from 'Test.Inspection' checks for lack of data types, but 49 | -- they show up in coercions even though the representation was optimized away; 50 | -- check for functions and data constructors instead. 51 | hasNoGenericRep :: Name -> Obligation 52 | hasNoGenericRep name = mkObligation name $ NoUseOf 53 | [ 'G.from 54 | , 'G.to 55 | , '(G.:*:) 56 | , 'G.K1 57 | , 'G.L1 58 | , 'G.M1 59 | , 'G.R1 60 | , 'G.U1 61 | ] 62 | 63 | assertSuccess :: Result -> IO () 64 | assertSuccess (Success _) = return () 65 | assertSuccess (Failure err) = assertFailure err 66 | 67 | assertFailure' :: Result -> IO () 68 | assertFailure' (Success err) = assertFailure err 69 | assertFailure' (Failure _) = return () 70 | 71 | ghc82to86failure :: Result -> IO () 72 | #if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 806 73 | ghc82to86failure = assertFailure' 74 | #else 75 | ghc82to86failure = assertSuccess 76 | #endif 77 | 78 | ghc86to810failure :: Result -> IO () 79 | #if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ <= 810 80 | ghc86to810failure = assertFailure' 81 | #else 82 | ghc86to810failure = assertSuccess 83 | #endif 84 | 85 | ghc82failure :: Result -> IO () 86 | #if __GLASGOW_HASKELL__ == 802 87 | ghc82failure = assertFailure' 88 | #else 89 | ghc82failure = assertSuccess 90 | #endif 91 | 92 | ghc810failure :: Result -> IO () 93 | #if __GLASGOW_HASKELL__ == 810 94 | ghc810failure = assertFailure' 95 | #else 96 | ghc810failure = assertSuccess 97 | #endif 98 | 99 | ghcGE86failure :: Result -> IO () 100 | #if __GLASGOW_HASKELL__ >= 806 101 | ghcGE86failure = assertFailure' 102 | #else 103 | ghcGE86failure = assertSuccess 104 | #endif 105 | 106 | ghcLE84failure :: Result -> IO () 107 | #if __GLASGOW_HASKELL__ <= 804 108 | ghcLE84failure = assertFailure' 109 | #else 110 | ghcLE84failure = assertSuccess 111 | #endif 112 | 113 | ghc82andGE90failure :: Result -> IO () 114 | #if __GLASGOW_HASKELL__ == 802 \ 115 | || __GLASGOW_HASKELL__ >= 900 116 | ghc82andGE90failure = assertFailure' 117 | #else 118 | ghc82andGE90failure = assertSuccess 119 | #endif 120 | 121 | ghc82and86to810and92to94failure :: Result -> IO () 122 | #if __GLASGOW_HASKELL__ == 802 \ 123 | || __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ <= 810 \ 124 | || __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ <= 904 125 | ghc82and86to810and92to94failure = assertFailure' 126 | #else 127 | ghc82and86to810and92to94failure = assertSuccess 128 | #endif 129 | 130 | ghcGE90failure :: Result -> IO () 131 | #if __GLASGOW_HASKELL__ >= 900 132 | ghcGE90failure = assertFailure' 133 | #else 134 | ghcGE90failure = assertSuccess 135 | #endif 136 | 137 | ghc92and94failure :: Result -> IO () 138 | #if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ <= 904 139 | ghc92and94failure = assertFailure' 140 | #else 141 | ghc92and94failure = assertSuccess 142 | #endif 143 | 144 | ghc86to810and92to94failure :: Result -> IO () 145 | #if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ <= 810 \ 146 | || __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ <= 904 147 | ghc86to810and92to94failure = assertFailure' 148 | #else 149 | ghc86to810and92to94failure = assertSuccess 150 | #endif 151 | -------------------------------------------------------------------------------- /template-haskell-optics/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # template-haskell-optics-0.3 (2023-11-16) 2 | * Add support for GHC 9.4 to 9.8 3 | 4 | # template-haskell-optics-0.2 (2022-03-22) 5 | * Add support for GHC 9.0 and 9.2 6 | * Drop the `DataPrim` type synonym 7 | 8 | # template-haskell-optics-0.1 (2020-08-29) 9 | * Initial release 10 | -------------------------------------------------------------------------------- /template-haskell-optics/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2019, Well-Typed LLP 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Well-Typed LLP nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | This software incorporates code from the lens package (available from 34 | https://hackage.haskell.org/package/lens) under the following license: 35 | 36 | 37 | Copyright 2012-2016 Edward Kmett 38 | 39 | All rights reserved. 40 | 41 | Redistribution and use in source and binary forms, with or without 42 | modification, are permitted provided that the following conditions 43 | are met: 44 | 45 | 1. Redistributions of source code must retain the above copyright 46 | notice, this list of conditions and the following disclaimer. 47 | 48 | 2. Redistributions in binary form must reproduce the above copyright 49 | notice, this list of conditions and the following disclaimer in the 50 | documentation and/or other materials provided with the distribution. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 53 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 54 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 55 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 56 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 57 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 58 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 59 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 60 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 61 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 62 | POSSIBILITY OF SUCH DAMAGE. 63 | -------------------------------------------------------------------------------- /template-haskell-optics/template-haskell-optics.cabal: -------------------------------------------------------------------------------- 1 | name: template-haskell-optics 2 | version: 0.3 3 | license: BSD3 4 | license-file: LICENSE 5 | build-type: Simple 6 | maintainer: optics@well-typed.com 7 | author: Andrzej Rybczak 8 | cabal-version: 1.18 9 | tested-with: GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 10 | || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.5 || ==9.8.2 11 | || ==9.10.1, GHCJS ==8.4 12 | synopsis: Optics for template-haskell types 13 | category: Data, Optics, Lenses 14 | description: 15 | This package provides optics to work with @template-haskell@ types. 16 | . 17 | See the @optics-th@ package for machinery to construct optics using @TemplateHaskell@. 18 | 19 | extra-doc-files: 20 | CHANGELOG.md 21 | 22 | bug-reports: https://github.com/well-typed/optics/issues 23 | source-repository head 24 | type: git 25 | location: https://github.com/well-typed/optics.git 26 | subdir: template-haskell-optics 27 | 28 | library 29 | default-language: Haskell2010 30 | hs-source-dirs: src 31 | ghc-options: -Wall 32 | 33 | build-depends: base >= 4.10 && <5 34 | , optics-core >= 0.4 && <0.5 35 | , containers >= 0.5.10.2 && <0.8 36 | , template-haskell >= 2.12 && <2.23 37 | , th-abstraction >= 0.4 && <0.8 38 | 39 | exposed-modules: Language.Haskell.TH.Optics 40 | --------------------------------------------------------------------------------