├── .ghci ├── .gitignore ├── LICENCE ├── README.markdown ├── Setup.hs ├── changelog ├── default.nix ├── lets-lens.cabal ├── lets-lens.nix ├── shell.nix ├── src ├── Lets.hs └── Lets │ ├── Choice.hs │ ├── Data.hs │ ├── GetSetLens.hs │ ├── Lens.hs │ ├── OpticPolyLens.hs │ ├── Profunctor.hs │ └── StoreLens.hs └── test └── doctests.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :l src/Lets.hs 3 | :set prompt ">> " 4 | :set -Wall 5 | :set -fno-warn-unused-binds 6 | :set -fno-warn-unused-do-bind 7 | :set -fno-warn-unused-imports 8 | :set -fno-warn-type-defaults 9 | :set -XScopedTypeVariables 10 | :set -XOverloadedStrings 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | /dist 6 | /dist-newstyle 7 | /cabal-dev 8 | /.cabal-sandbox 9 | /cabal.sandbox.config 10 | .ghc.environment.* 11 | 12 | # Haskell Program Coverage 13 | /.hpc 14 | 15 | # Leksah 16 | *.lkshs 17 | 18 | # Intellij IDEA 19 | /.idea 20 | 21 | # darcs 22 | /_darcs 23 | 24 | # ctags 25 | TAGS 26 | 27 | # sbt 28 | /project 29 | /target 30 | 31 | *.swp 32 | 33 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2012-2015 National ICT Australia Limited 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 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Let's Lens 2 | 3 | ![System-F](https://logo.systemf.com.au/systemf-450x450.png) 4 | 5 | Let's Lens presents a series of exercises, in a similar format to 6 | [the Data61 functional programming course material](http://github.com/data61/fp-course). 7 | The subject of the exercises is around the concept of lenses, initially proposed 8 | by Foster et al., to solve the view-update problem of relational databases. 9 | 10 | The theories around lenses have been advanced significantly in recent years, 11 | resulting in a library, implemented in Haskell, called `lens`. 12 | 13 | http://hackage.haskell.org/package/lens 14 | 15 | The exercises take into account various possible goals. For example, if you wish 16 | to study the history of lenses, then build up to the most recent theories, it is 17 | best to start at the `Lets.GetSetLens` module. If you wish to derive the 18 | structure of lenses from first principles, then derive the more modern theories, 19 | start at the `Lets.Lens` module. 20 | 21 | Exercises can be recognised by filling in a function body that has a placeholder 22 | of `error "todo: "`. 23 | 24 | ---- 25 | 26 | ### Exercise modules 27 | 28 | ##### `Lets.GetSetLens` 29 | 30 | This module presents a series of exercises, representing lenses as a traditional 31 | pair of "`get` and `set`" functions. This representation may be beneficial as it 32 | easily appeals to an intuition of "what a lens is", however, it is outdated. 33 | 34 | These exercises are useful to gain an initial understanding of the problems that 35 | lenses solve, as well as to gain an insight into the history of lenses and how 36 | the theories have developed over time. 37 | 38 | ##### `Lets.StoreLens` 39 | 40 | This series of exercises is similar to `Lets.GetSetLens`, however, using a 41 | slightly altered representation of a lens, based on the `Store` comonad, which 42 | fuses the typical `get` and `set` operations into a data structure. This 43 | representation is described in detail in 44 | *Morris, Tony. "Asymmetric Lenses in Scala." (2012).* 45 | 46 | ##### `Lets.OpticPolyLens` 47 | 48 | This series of exercises introduces a new representation of lenses, first 49 | described by Twan van Laarhoven. This representation also introduces a 50 | generalisation of lenses to permit *polymorphic update* of structures. 51 | 52 | ##### `Lets.Lens` 53 | 54 | This series of exercises starts at first principles to derive the concept of a 55 | lens, as it was first described by Twan van Laarhoven. The derivation then goes 56 | on to described other structures to solve various practical problems such as 57 | *multi-update* and *partial update*. 58 | 59 | This representation presents a generalisation, permitting *polymorphic update* 60 | over structures. After lenses are derived, further concepts are introduced, such 61 | as `Fold`s, `Traversal`s and `Prism`s. 62 | 63 | ---- 64 | 65 | ### Credits 66 | 67 | * Edward Kmett on the [derivation of lenses](https://github.com/ekmett/lens/wiki/Derivation) 68 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | 0.0.1 2 | 3 | Init 4 | 5 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | haskellPackages = if compiler == "default" 5 | then pkgs.haskellPackages 6 | else pkgs.haskell.packages.${compiler}; 7 | 8 | tasty-hedgehog-github = pkgs.callPackage (pkgs.fetchFromGitHub { 9 | owner = "qfpl"; 10 | repo = "tasty-hedgehog"; 11 | rev = "5da389f5534943b430300a213c5ffb5d0e13459e"; 12 | sha256 = "04pmr9q70gakd327sywpxr7qp8jnl3b0y2sqxxxcj6zj2q45q38m"; 13 | }) {}; 14 | 15 | modifiedHaskellPackages = haskellPackages.override { 16 | overrides = self: super: { 17 | tasty-hedgehog = 18 | if super ? tasty-hedgehog 19 | then super.tasty-hedgehog 20 | else tasty-hedgehog-github; 21 | }; 22 | }; 23 | 24 | lets-lens = modifiedHaskellPackages.callPackage ./lets-lens.nix {}; 25 | in 26 | lets-lens 27 | -------------------------------------------------------------------------------- /lets-lens.cabal: -------------------------------------------------------------------------------- 1 | name: lets-lens 2 | version: 0.0.1 3 | license: BSD3 4 | license-file: LICENCE 5 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 6 | maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 7 | copyright: Copyright (C) 2015-2016 National ICT Australia Limited, 8 | Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. 9 | synopsis: Source code for exercises on the lens concept 10 | category: Education 11 | description: Source code for exercises on the lens concept 12 | homepage: https://github.com/data61/lets-lens 13 | bug-reports: https://github.com/data61/lets-lens/issues 14 | cabal-version: >= 1.10 15 | build-type: Simple 16 | extra-source-files: changelog 17 | 18 | source-repository head 19 | type: git 20 | location: git@github.com:data61/lets-lens.git 21 | 22 | flag small_base 23 | description: Choose the new, split-up base package. 24 | 25 | library 26 | default-language: Haskell2010 27 | 28 | build-depends: base >= 4.8 && < 5 29 | , containers >= 0.4.0.0 30 | 31 | ghc-options: -Wall 32 | -fno-warn-unused-binds 33 | -fno-warn-unused-do-bind 34 | -fno-warn-unused-imports 35 | -fno-warn-type-defaults 36 | 37 | hs-source-dirs: src 38 | 39 | exposed-modules: Lets 40 | Lets.Choice 41 | Lets.Data 42 | Lets.GetSetLens 43 | Lets.Lens 44 | Lets.OpticPolyLens 45 | Lets.Profunctor 46 | Lets.StoreLens 47 | 48 | test-suite doctests 49 | type: 50 | exitcode-stdio-1.0 51 | 52 | main-is: 53 | doctests.hs 54 | 55 | default-language: 56 | Haskell2010 57 | 58 | build-depends: 59 | base < 5 && >= 3 60 | , doctest >= 0.9.7 61 | , filepath >= 1.3 62 | , directory >= 1.1 63 | , QuickCheck >= 2.0 64 | , template-haskell >= 2.8 65 | 66 | ghc-options: 67 | -Wall 68 | -threaded 69 | 70 | hs-source-dirs: 71 | test 72 | -------------------------------------------------------------------------------- /lets-lens.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, containers, directory, doctest, filepath 2 | , QuickCheck, stdenv, template-haskell 3 | }: 4 | mkDerivation { 5 | pname = "lets-lens"; 6 | version = "0.0.1"; 7 | src = ./.; 8 | libraryHaskellDepends = [ base containers ]; 9 | testHaskellDepends = [ 10 | base directory doctest filepath QuickCheck template-haskell 11 | ]; 12 | homepage = "https://github.com/data61/lets-lens"; 13 | description = "Source code for exercises on the lens concept"; 14 | license = stdenv.lib.licenses.bsd3; 15 | } 16 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | drv = import ./default.nix { inherit nixpkgs compiler; }; 5 | drvWithTools = pkgs.haskell.lib.addBuildDepends drv [ pkgs.cabal-install ]; 6 | in 7 | if pkgs.lib.inNixShell then drvWithTools.env else drvWithTools 8 | -------------------------------------------------------------------------------- /src/Lets.hs: -------------------------------------------------------------------------------- 1 | module Lets ( 2 | module L 3 | ) where 4 | 5 | import Lets.Data as L 6 | import Lets.GetSetLens as L() 7 | import Lets.Lens as L() 8 | import Lets.OpticPolyLens as L() 9 | import Lets.StoreLens as L() 10 | -------------------------------------------------------------------------------- /src/Lets/Choice.hs: -------------------------------------------------------------------------------- 1 | module Lets.Choice ( 2 | Choice(..) 3 | ) where 4 | 5 | import Lets.Data 6 | import Lets.Profunctor 7 | 8 | diswap :: 9 | Profunctor p => 10 | p (Either a b) (Either c d) 11 | -> p (Either b a) (Either d c) 12 | diswap = 13 | let swap = either Right Left 14 | in dimap swap swap 15 | 16 | -- | Map on left or right of @Either@. Only one of @left@ or @right@ needs to be 17 | -- provided. 18 | class Profunctor p => Choice p where 19 | left :: 20 | p a b 21 | -> p (Either a c) (Either b c) 22 | left = 23 | diswap . right 24 | 25 | right :: 26 | p a b 27 | -> p (Either c a) (Either c b) 28 | right = 29 | diswap . left 30 | 31 | instance Choice (->) where 32 | left f = 33 | either (Left . f) Right 34 | right f = 35 | either Left (Right . f) 36 | 37 | instance Choice Tagged where 38 | left (Tagged x) = 39 | Tagged (Left x) 40 | right (Tagged x) = 41 | Tagged (Right x) 42 | 43 | -------------------------------------------------------------------------------- /src/Lets/Data.hs: -------------------------------------------------------------------------------- 1 | module Lets.Data ( 2 | Locality(..) 3 | , Address(..) 4 | , Person(..) 5 | , IntAnd(..) 6 | , IntOr(..) 7 | , fredLocality 8 | , fredAddress 9 | , fred 10 | , maryLocality 11 | , maryAddress 12 | , mary 13 | , Store(..) 14 | , Const (..) 15 | , Tagged(..) 16 | , Identity(..) 17 | , AlongsideLeft(..) 18 | , AlongsideRight(..) 19 | ) where 20 | 21 | import Control.Applicative(Applicative(..)) 22 | import Data.Monoid(Monoid(..)) 23 | 24 | data Locality = 25 | Locality 26 | String -- city 27 | String -- state 28 | String -- country 29 | deriving (Eq, Show) 30 | 31 | data Address = 32 | Address 33 | String -- street 34 | String -- suburb 35 | Locality 36 | deriving (Eq, Show) 37 | 38 | data Person = 39 | Person 40 | Int -- age 41 | String -- name 42 | Address -- address 43 | deriving (Eq, Show) 44 | 45 | data IntAnd a = 46 | IntAnd 47 | Int 48 | a 49 | deriving (Eq, Show) 50 | 51 | data IntOr a = 52 | IntOrIs Int 53 | | IntOrIsNot a 54 | deriving (Eq, Show) 55 | 56 | fredLocality :: 57 | Locality 58 | fredLocality = 59 | Locality 60 | "Fredmania" 61 | "New South Fred" 62 | "Fredalia" 63 | 64 | fredAddress :: 65 | Address 66 | fredAddress = 67 | Address 68 | "15 Fred St" 69 | "Fredville" 70 | fredLocality 71 | 72 | fred :: 73 | Person 74 | fred = 75 | Person 76 | 24 77 | "Fred" 78 | fredAddress 79 | 80 | maryLocality :: 81 | Locality 82 | maryLocality = 83 | Locality 84 | "Mary Mary" 85 | "Western Mary" 86 | "Maristan" 87 | 88 | maryAddress :: 89 | Address 90 | maryAddress = 91 | Address 92 | "83 Mary Ln" 93 | "Maryland" 94 | maryLocality 95 | 96 | mary :: 97 | Person 98 | mary = 99 | Person 100 | 28 101 | "Mary" 102 | maryAddress 103 | 104 | ---- 105 | 106 | data Store s a = 107 | Store 108 | (s -> a) 109 | s 110 | 111 | data Const a b = 112 | Const { 113 | getConst :: 114 | a 115 | } 116 | deriving (Eq, Show) 117 | 118 | instance Functor (Const a) where 119 | fmap _ (Const a) = 120 | Const a 121 | 122 | instance Monoid a => Applicative (Const a) where 123 | pure _ = 124 | Const mempty 125 | Const f <*> Const a = 126 | Const (f `mappend` a) 127 | 128 | data Tagged a b = 129 | Tagged { 130 | getTagged :: 131 | b 132 | } 133 | deriving (Eq, Show) 134 | 135 | instance Functor (Tagged a) where 136 | fmap f (Tagged b) = 137 | Tagged (f b) 138 | 139 | instance Applicative (Tagged a) where 140 | pure = 141 | Tagged 142 | Tagged f <*> Tagged a = 143 | Tagged (f a) 144 | 145 | data Identity a = 146 | Identity { 147 | getIdentity :: 148 | a 149 | } 150 | deriving (Eq, Show) 151 | 152 | instance Functor Identity where 153 | fmap f (Identity a) = 154 | Identity (f a) 155 | 156 | instance Applicative Identity where 157 | pure = 158 | Identity 159 | Identity f <*> Identity a = 160 | Identity (f a) 161 | 162 | data AlongsideLeft f b a = 163 | AlongsideLeft { 164 | getAlongsideLeft :: 165 | f (a, b) 166 | } 167 | 168 | instance Functor f => Functor (AlongsideLeft f b) where 169 | fmap f (AlongsideLeft x) = 170 | AlongsideLeft (fmap (\(a, b) -> (f a, b)) x) 171 | 172 | data AlongsideRight f a b = 173 | AlongsideRight { 174 | getAlongsideRight :: 175 | f (a, b) 176 | } 177 | 178 | instance Functor f => Functor (AlongsideRight f a) where 179 | fmap f (AlongsideRight x) = 180 | AlongsideRight (fmap (\(a, b) -> (a, f b)) x) 181 | -------------------------------------------------------------------------------- /src/Lets/GetSetLens.hs: -------------------------------------------------------------------------------- 1 | module Lets.GetSetLens ( 2 | Lens(..) 3 | , getsetLaw 4 | , setgetLaw 5 | , setsetLaw 6 | , get 7 | , set 8 | , modify 9 | , (%~) 10 | , (.~) 11 | , fmodify 12 | , (|=) 13 | , fstL 14 | , sndL 15 | , mapL 16 | , setL 17 | , compose 18 | , (|.) 19 | , identity 20 | , product 21 | , (***) 22 | , choice 23 | , (|||) 24 | , cityL 25 | , countryL 26 | , streetL 27 | , suburbL 28 | , localityL 29 | , ageL 30 | , nameL 31 | , addressL 32 | , getSuburb 33 | , setStreet 34 | , getAgeAndCountry 35 | , setCityAndLocality 36 | , getSuburbOrCity 37 | , setStreetOrState 38 | , modifyCityUppercase 39 | ) where 40 | 41 | import Control.Applicative(Applicative((<*>))) 42 | import Data.Char(toUpper) 43 | import Data.Map(Map) 44 | import qualified Data.Map as Map(insert, delete, lookup) 45 | import Data.Set(Set) 46 | import qualified Data.Set as Set(insert, delete, member) 47 | import Lets.Data(Person(Person), Locality(Locality), Address(Address)) 48 | import Prelude hiding (product) 49 | 50 | -- $setup 51 | -- >>> import qualified Data.Map as Map(fromList) 52 | -- >>> import qualified Data.Set as Set(fromList) 53 | -- >>> import Data.Bool(bool) 54 | -- >>> import Data.Char(ord) 55 | -- >>> import Lets.Data 56 | 57 | data Lens a b = 58 | Lens 59 | (a -> b -> a) 60 | (a -> b) 61 | 62 | -- | 63 | -- 64 | -- >>> get fstL (0 :: Int, "abc") 65 | -- 0 66 | -- 67 | -- >>> get sndL ("abc", 0 :: Int) 68 | -- 0 69 | -- 70 | -- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x 71 | -- 72 | -- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y 73 | get :: 74 | Lens a b 75 | -> a 76 | -> b 77 | get (Lens _ g) = 78 | g 79 | 80 | -- | 81 | -- 82 | -- >>> set fstL (0 :: Int, "abc") 1 83 | -- (1,"abc") 84 | -- 85 | -- >>> set sndL ("abc", 0 :: Int) 1 86 | -- ("abc",1) 87 | -- 88 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) 89 | -- 90 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) 91 | set :: 92 | Lens a b 93 | -> a 94 | -> b 95 | -> a 96 | set (Lens s _) a = 97 | s a 98 | 99 | -- | The get/set law of lenses. This function should always return @True@. 100 | getsetLaw :: 101 | Eq a => 102 | Lens a b 103 | -> a 104 | -> Bool 105 | getsetLaw l = 106 | \a -> set l a (get l a) == a 107 | 108 | -- | The set/get law of lenses. This function should always return @True@. 109 | setgetLaw :: 110 | Eq b => 111 | Lens a b 112 | -> a 113 | -> b 114 | -> Bool 115 | setgetLaw l a b = 116 | get l (set l a b) == b 117 | 118 | -- | The set/set law of lenses. This function should always return @True@. 119 | setsetLaw :: 120 | Eq a => 121 | Lens a b 122 | -> a 123 | -> b 124 | -> b 125 | -> Bool 126 | setsetLaw l a b1 b2 = 127 | set l (set l a b1) b2 == set l a b2 128 | 129 | ---- 130 | 131 | -- | 132 | -- 133 | -- >>> modify fstL (+1) (0 :: Int, "abc") 134 | -- (1,"abc") 135 | -- 136 | -- >>> modify sndL (+1) ("abc", 0 :: Int) 137 | -- ("abc",1) 138 | -- 139 | -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 140 | -- 141 | -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 142 | modify :: 143 | Lens a b 144 | -> (b -> b) 145 | -> a 146 | -> a 147 | modify = 148 | error "todo: modify" 149 | 150 | -- | An alias for @modify@. 151 | (%~) :: 152 | Lens a b 153 | -> (b -> b) 154 | -> a 155 | -> a 156 | (%~) = 157 | modify 158 | 159 | infixr 4 %~ 160 | 161 | -- | 162 | -- 163 | -- >>> fstL .~ 1 $ (0 :: Int, "abc") 164 | -- (1,"abc") 165 | -- 166 | -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 167 | -- ("abc",1) 168 | -- 169 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 170 | -- 171 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 172 | (.~) :: 173 | Lens a b 174 | -> b 175 | -> a 176 | -> a 177 | (.~) = 178 | error "todo: (.~)" 179 | 180 | infixl 5 .~ 181 | 182 | -- | 183 | -- 184 | -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 185 | -- (13,"abc") 186 | -- 187 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 188 | -- Just (20,"abc") 189 | -- 190 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 191 | -- Nothing 192 | fmodify :: 193 | Functor f => 194 | Lens a b 195 | -> (b -> f b) 196 | -> a 197 | -> f a 198 | fmodify = 199 | error "todo: fmodify" 200 | 201 | -- | 202 | -- 203 | -- >>> fstL |= Just 3 $ (7, "abc") 204 | -- Just (3,"abc") 205 | -- 206 | -- >>> (fstL |= (+1) $ (3, "abc")) 17 207 | -- (18,"abc") 208 | (|=) :: 209 | Functor f => 210 | Lens a b 211 | -> f b 212 | -> a 213 | -> f a 214 | (|=) = 215 | error "todo: (|=)" 216 | 217 | infixl 5 |= 218 | 219 | -- | 220 | -- 221 | -- >>> modify fstL (*10) (3, "abc") 222 | -- (30,"abc") 223 | -- 224 | -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 225 | -- 226 | -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 227 | -- 228 | -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 229 | fstL :: 230 | Lens (x, y) x 231 | fstL = 232 | error "todo: fstL" 233 | 234 | -- | 235 | -- 236 | -- >>> modify sndL (++ "def") (13, "abc") 237 | -- (13,"abcdef") 238 | -- 239 | -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 240 | -- 241 | -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 242 | -- 243 | -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 244 | sndL :: 245 | Lens (x, y) y 246 | sndL = 247 | error "todo: sndL" 248 | 249 | -- | 250 | -- 251 | -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 252 | -- Just 'c' 253 | -- 254 | -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 255 | -- Nothing 256 | -- 257 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 258 | -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 259 | -- 260 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 261 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 262 | -- 263 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 264 | -- fromList [(1,'a'),(2,'b'),(4,'d')] 265 | -- 266 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 267 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 268 | mapL :: 269 | Ord k => 270 | k 271 | -> Lens (Map k v) (Maybe v) 272 | mapL = 273 | error "todo: mapL" 274 | 275 | -- | 276 | -- 277 | -- >>> get (setL 3) (Set.fromList [1..5]) 278 | -- True 279 | -- 280 | -- >>> get (setL 33) (Set.fromList [1..5]) 281 | -- False 282 | -- 283 | -- >>> set (setL 3) (Set.fromList [1..5]) True 284 | -- fromList [1,2,3,4,5] 285 | -- 286 | -- >>> set (setL 3) (Set.fromList [1..5]) False 287 | -- fromList [1,2,4,5] 288 | -- 289 | -- >>> set (setL 33) (Set.fromList [1..5]) True 290 | -- fromList [1,2,3,4,5,33] 291 | -- 292 | -- >>> set (setL 33) (Set.fromList [1..5]) False 293 | -- fromList [1,2,3,4,5] 294 | setL :: 295 | Ord k => 296 | k 297 | -> Lens (Set k) Bool 298 | setL = 299 | error "todo: setL" 300 | 301 | -- | 302 | -- 303 | -- >>> get (compose fstL sndL) ("abc", (7, "def")) 304 | -- 7 305 | -- 306 | -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 307 | -- ("abc",(8,"def")) 308 | compose :: 309 | Lens b c 310 | -> Lens a b 311 | -> Lens a c 312 | compose = 313 | error "todo: compose" 314 | 315 | -- | An alias for @compose@. 316 | (|.) :: 317 | Lens b c 318 | -> Lens a b 319 | -> Lens a c 320 | (|.) = 321 | compose 322 | 323 | infixr 9 |. 324 | 325 | -- | 326 | -- 327 | -- >>> get identity 3 328 | -- 3 329 | -- 330 | -- >>> set identity 3 4 331 | -- 4 332 | identity :: 333 | Lens a a 334 | identity = 335 | error "todo: identity" 336 | 337 | -- | 338 | -- 339 | -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 340 | -- ("abc","def") 341 | -- 342 | -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 343 | -- (("ghi",3),(4,"jkl")) 344 | product :: 345 | Lens a b 346 | -> Lens c d 347 | -> Lens (a, c) (b, d) 348 | product = 349 | error "todo: product" 350 | 351 | -- | An alias for @product@. 352 | (***) :: 353 | Lens a b 354 | -> Lens c d 355 | -> Lens (a, c) (b, d) 356 | (***) = 357 | product 358 | 359 | infixr 3 *** 360 | 361 | -- | 362 | -- 363 | -- >>> get (choice fstL sndL) (Left ("abc", 7)) 364 | -- "abc" 365 | -- 366 | -- >>> get (choice fstL sndL) (Right ("abc", 7)) 367 | -- 7 368 | -- 369 | -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 370 | -- Left ("def",7) 371 | -- 372 | -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 373 | -- Right ("abc",8) 374 | choice :: 375 | Lens a x 376 | -> Lens b x 377 | -> Lens (Either a b) x 378 | choice = 379 | error "todo: choice" 380 | 381 | -- | An alias for @choice@. 382 | (|||) :: 383 | Lens a x 384 | -> Lens b x 385 | -> Lens (Either a b) x 386 | (|||) = 387 | choice 388 | 389 | infixr 2 ||| 390 | 391 | ---- 392 | 393 | cityL :: 394 | Lens Locality String 395 | cityL = 396 | Lens 397 | (\(Locality _ t y) c -> Locality c t y) 398 | (\(Locality c _ _) -> c) 399 | 400 | stateL :: 401 | Lens Locality String 402 | stateL = 403 | Lens 404 | (\(Locality c _ y) t -> Locality c t y) 405 | (\(Locality _ t _) -> t) 406 | 407 | countryL :: 408 | Lens Locality String 409 | countryL = 410 | Lens 411 | (\(Locality c t _) y -> Locality c t y) 412 | (\(Locality _ _ y) -> y) 413 | 414 | streetL :: 415 | Lens Address String 416 | streetL = 417 | Lens 418 | (\(Address _ s l) t -> Address t s l) 419 | (\(Address t _ _) -> t) 420 | 421 | suburbL :: 422 | Lens Address String 423 | suburbL = 424 | Lens 425 | (\(Address t _ l) s -> Address t s l) 426 | (\(Address _ s _) -> s) 427 | 428 | localityL :: 429 | Lens Address Locality 430 | localityL = 431 | Lens 432 | (\(Address t s _) l -> Address t s l) 433 | (\(Address _ _ l) -> l) 434 | 435 | ageL :: 436 | Lens Person Int 437 | ageL = 438 | Lens 439 | (\(Person _ n d) a -> Person a n d) 440 | (\(Person a _ _) -> a) 441 | 442 | nameL :: 443 | Lens Person String 444 | nameL = 445 | Lens 446 | (\(Person a _ d) n -> Person a n d) 447 | (\(Person _ n _) -> n) 448 | 449 | addressL :: 450 | Lens Person Address 451 | addressL = 452 | Lens 453 | (\(Person a n _) d -> Person a n d) 454 | (\(Person _ _ d) -> d) 455 | 456 | -- | 457 | -- 458 | -- >>> getSuburb fred 459 | -- "Fredville" 460 | -- 461 | -- >>> getSuburb mary 462 | -- "Maryland" 463 | getSuburb :: 464 | Person 465 | -> String 466 | getSuburb = 467 | error "todo: getSuburb" 468 | 469 | -- | 470 | -- 471 | -- >>> setStreet fred "Some Other St" 472 | -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 473 | -- 474 | -- >>> setStreet mary "Some Other St" 475 | -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 476 | setStreet :: 477 | Person 478 | -> String 479 | -> Person 480 | setStreet = 481 | error "todo: setStreet" 482 | 483 | -- | 484 | -- 485 | -- >>> getAgeAndCountry (fred, maryLocality) 486 | -- (24,"Maristan") 487 | -- 488 | -- >>> getAgeAndCountry (mary, fredLocality) 489 | -- (28,"Fredalia") 490 | getAgeAndCountry :: 491 | (Person, Locality) 492 | -> (Int, String) 493 | getAgeAndCountry = 494 | error "todo: getAgeAndCountry" 495 | 496 | -- | 497 | -- 498 | -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 499 | -- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) 500 | -- 501 | -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 502 | -- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) 503 | setCityAndLocality :: 504 | (Person, Address) -> (String, Locality) -> (Person, Address) 505 | setCityAndLocality = 506 | error "todo: setCityAndLocality" 507 | 508 | -- | 509 | -- 510 | -- >>> getSuburbOrCity (Left maryAddress) 511 | -- "Maryland" 512 | -- 513 | -- >>> getSuburbOrCity (Right fredLocality) 514 | -- "Fredmania" 515 | getSuburbOrCity :: 516 | Either Address Locality 517 | -> String 518 | getSuburbOrCity = 519 | error "todo: getSuburbOrCity" 520 | 521 | -- | 522 | -- 523 | -- >>> setStreetOrState (Right maryLocality) "Some Other State" 524 | -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 525 | -- 526 | -- >>> setStreetOrState (Left fred) "Some Other St" 527 | -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 528 | setStreetOrState :: 529 | Either Person Locality 530 | -> String 531 | -> Either Person Locality 532 | setStreetOrState = 533 | error "todo: setStreetOrState" 534 | 535 | -- | 536 | -- 537 | -- >>> modifyCityUppercase fred 538 | -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 539 | -- 540 | -- >>> modifyCityUppercase mary 541 | -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 542 | modifyCityUppercase :: 543 | Person 544 | -> Person 545 | modifyCityUppercase = 546 | error "todo: modifyCityUppercase" 547 | -------------------------------------------------------------------------------- /src/Lets/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Lets.Lens ( 4 | fmapT 5 | , over 6 | , fmapTAgain 7 | , Set 8 | , sets 9 | , mapped 10 | , set 11 | , foldMapT 12 | , foldMapOf 13 | , foldMapTAgain 14 | , Fold 15 | , folds 16 | , folded 17 | , Get 18 | , get 19 | , Traversal 20 | , both 21 | , traverseLeft 22 | , traverseRight 23 | , Traversal' 24 | , Lens 25 | , Prism 26 | , _Left 27 | , _Right 28 | , prism 29 | , _Just 30 | , _Nothing 31 | , setP 32 | , getP 33 | , Prism' 34 | , modify 35 | , (%~) 36 | , (.~) 37 | , fmodify 38 | , (|=) 39 | , fstL 40 | , sndL 41 | , mapL 42 | , setL 43 | , compose 44 | , (|.) 45 | , identity 46 | , product 47 | , (***) 48 | , choice 49 | , (|||) 50 | , Lens' 51 | , cityL 52 | , stateL 53 | , countryL 54 | , streetL 55 | , suburbL 56 | , localityL 57 | , ageL 58 | , nameL 59 | , addressL 60 | , intAndIntL 61 | , intAndL 62 | , getSuburb 63 | , setStreet 64 | , getAgeAndCountry 65 | , setCityAndLocality 66 | , getSuburbOrCity 67 | , setStreetOrState 68 | , modifyCityUppercase 69 | , modifyIntAndLengthEven 70 | , traverseLocality 71 | , intOrIntP 72 | , intOrP 73 | , intOrLengthEven 74 | ) where 75 | 76 | import Control.Applicative(Applicative((<*>), pure)) 77 | import Data.Char(toUpper) 78 | import Data.Foldable(Foldable(foldMap)) 79 | import Data.Functor((<$>)) 80 | import Data.Map(Map) 81 | import qualified Data.Map as Map(insert, delete, lookup) 82 | import Data.Monoid(Monoid) 83 | import qualified Data.Set as Set(Set, insert, delete, member) 84 | import Data.Traversable(Traversable(traverse)) 85 | import Lets.Data(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), Tagged(Tagged, getTagged), IntOr(IntOrIs, IntOrIsNot), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address)) 86 | import Lets.Choice(Choice(left, right)) 87 | import Lets.Profunctor(Profunctor(dimap)) 88 | import Prelude hiding (product) 89 | 90 | -- $setup 91 | -- >>> import qualified Data.Map as Map(fromList) 92 | -- >>> import qualified Data.Set as Set(fromList) 93 | -- >>> import Data.Bool(bool) 94 | -- >>> import Data.Char(ord) 95 | -- >>> import Lets.Data 96 | 97 | -- Let's remind ourselves of Traversable, noting Foldable and Functor. 98 | -- 99 | -- class (Foldable t, Functor t) => Traversable t where 100 | -- traverse :: 101 | -- Applicative f => 102 | -- (a -> f b) 103 | -- -> t a 104 | -- -> f (t b) 105 | 106 | -- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. 107 | -- 108 | -- /Reminder:/ fmap :: Functor t => (a -> b) -> t a -> t b 109 | fmapT :: 110 | Traversable t => 111 | (a -> b) 112 | -> t a 113 | -> t b 114 | fmapT = 115 | error "todo: fmapT" 116 | 117 | -- | Let's refactor out the call to @traverse@ as an argument to @fmapT@. 118 | over :: 119 | ((a -> Identity b) -> s -> Identity t) 120 | -> (a -> b) 121 | -> s 122 | -> t 123 | over = 124 | error "todo: over" 125 | 126 | -- | Here is @fmapT@ again, passing @traverse@ to @over@. 127 | fmapTAgain :: 128 | Traversable t => 129 | (a -> b) 130 | -> t a 131 | -> t b 132 | fmapTAgain = 133 | error "todo: fmapTAgain" 134 | 135 | -- | Let's create a type-alias for this type of function. 136 | type Set s t a b = 137 | (a -> Identity b) 138 | -> s 139 | -> Identity t 140 | 141 | -- | Let's write an inverse to @over@ that does the @Identity@ wrapping & 142 | -- unwrapping. 143 | sets :: 144 | ((a -> b) -> s -> t) 145 | -> Set s t a b 146 | sets = 147 | error "todo: sets" 148 | 149 | mapped :: 150 | Functor f => 151 | Set (f a) (f b) a b 152 | mapped = 153 | error "todo: mapped" 154 | 155 | set :: 156 | Set s t a b 157 | -> s 158 | -> b 159 | -> t 160 | set = 161 | error "todo: set" 162 | 163 | ---- 164 | 165 | -- | Observe that @foldMap@ can be recovered from @traverse@ using @Const@. 166 | -- 167 | -- /Reminder:/ foldMap :: (Foldable t, Monoid b) => (a -> b) -> t a -> b 168 | foldMapT :: 169 | (Traversable t, Monoid b) => 170 | (a -> b) 171 | -> t a 172 | -> b 173 | foldMapT = 174 | error "todo: foldMapT" 175 | 176 | -- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@. 177 | foldMapOf :: 178 | ((a -> Const r b) -> s -> Const r t) 179 | -> (a -> r) 180 | -> s 181 | -> r 182 | foldMapOf = 183 | error "todo: foldMapOf" 184 | 185 | -- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@. 186 | foldMapTAgain :: 187 | (Traversable t, Monoid b) => 188 | (a -> b) 189 | -> t a 190 | -> b 191 | foldMapTAgain = 192 | error "todo: foldMapTAgain" 193 | 194 | -- | Let's create a type-alias for this type of function. 195 | type Fold s t a b = 196 | forall r. 197 | Monoid r => 198 | (a -> Const r b) 199 | -> s 200 | -> Const r t 201 | 202 | -- | Let's write an inverse to @foldMapOf@ that does the @Const@ wrapping & 203 | -- unwrapping. 204 | folds :: 205 | ((a -> b) -> s -> t) 206 | -> (a -> Const b a) 207 | -> s 208 | -> Const t s 209 | folds = 210 | error "todo: folds" 211 | 212 | folded :: 213 | Foldable f => 214 | Fold (f a) (f a) a a 215 | folded = 216 | error "todo: folded" 217 | 218 | ---- 219 | 220 | -- | @Get@ is like @Fold@, but without the @Monoid@ constraint. 221 | type Get r s a = 222 | (a -> Const r a) 223 | -> s 224 | -> Const r s 225 | 226 | get :: 227 | Get a s a 228 | -> s 229 | -> a 230 | get = 231 | error "todo: get" 232 | 233 | ---- 234 | 235 | -- | Let's generalise @Identity@ and @Const r@ to any @Applicative@ instance. 236 | type Traversal s t a b = 237 | forall f. 238 | Applicative f => 239 | (a -> f b) 240 | -> s 241 | -> f t 242 | 243 | -- | Traverse both sides of a pair. 244 | both :: 245 | Traversal (a, a) (b, b) a b 246 | both = 247 | error "todo: both" 248 | 249 | -- | Traverse the left side of @Either@. 250 | traverseLeft :: 251 | Traversal (Either a x) (Either b x) a b 252 | traverseLeft = 253 | error "todo: traverseLeft" 254 | 255 | -- | Traverse the right side of @Either@. 256 | traverseRight :: 257 | Traversal (Either x a) (Either x b) a b 258 | traverseRight = 259 | error "todo: traverseRight" 260 | 261 | type Traversal' a b = 262 | Traversal a a b b 263 | 264 | ---- 265 | 266 | -- | @Const r@ is @Applicative@, if @Monoid r@, however, without the @Monoid@ 267 | -- constraint (as in @Get@), the only shared abstraction between @Identity@ and 268 | -- @Const r@ is @Functor@. 269 | -- 270 | -- Consequently, we arrive at our lens derivation: 271 | type Lens s t a b = 272 | forall f. 273 | Functor f => 274 | (a -> f b) 275 | -> s 276 | -> f t 277 | 278 | ---- 279 | 280 | -- | A prism is a less specific type of traversal. 281 | type Prism s t a b = 282 | forall p f. 283 | (Choice p, Applicative f) => 284 | p a (f b) 285 | -> p s (f t) 286 | 287 | _Left :: 288 | Prism (Either a x) (Either b x) a b 289 | _Left = 290 | error "todo: _Left" 291 | 292 | _Right :: 293 | Prism (Either x a) (Either x b) a b 294 | _Right = 295 | error "todo: _Right" 296 | 297 | prism :: 298 | (b -> t) 299 | -> (s -> Either t a) 300 | -> Prism s t a b 301 | prism = 302 | error "todo: prism" 303 | 304 | _Just :: 305 | Prism (Maybe a) (Maybe b) a b 306 | _Just = 307 | error "todo: _Just" 308 | 309 | _Nothing :: 310 | Prism (Maybe a) (Maybe a) () () 311 | _Nothing = 312 | error "todo: _Nothing" 313 | 314 | setP :: 315 | Prism s t a b 316 | -> s 317 | -> Either t a 318 | setP _ _ = 319 | error "todo: setP" 320 | 321 | getP :: 322 | Prism s t a b 323 | -> b 324 | -> t 325 | getP _ _ = 326 | error "todo: getP" 327 | 328 | type Prism' a b = 329 | Prism a a b b 330 | 331 | ---- 332 | 333 | -- | 334 | -- 335 | -- >>> modify fstL (+1) (0 :: Int, "abc") 336 | -- (1,"abc") 337 | -- 338 | -- >>> modify sndL (+1) ("abc", 0 :: Int) 339 | -- ("abc",1) 340 | -- 341 | -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 342 | -- 343 | -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 344 | modify :: 345 | Lens s t a b 346 | -> (a -> b) 347 | -> s 348 | -> t 349 | modify _ _ _ = 350 | error "todo: modify" 351 | 352 | -- | An alias for @modify@. 353 | (%~) :: 354 | Lens s t a b 355 | -> (a -> b) 356 | -> s 357 | -> t 358 | (%~) = 359 | modify 360 | 361 | infixr 4 %~ 362 | 363 | -- | 364 | -- 365 | -- >>> fstL .~ 1 $ (0 :: Int, "abc") 366 | -- (1,"abc") 367 | -- 368 | -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 369 | -- ("abc",1) 370 | -- 371 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 372 | -- 373 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 374 | (.~) :: 375 | Lens s t a b 376 | -> b 377 | -> s 378 | -> t 379 | (.~) _ _ _ = 380 | error "todo: (.~)" 381 | 382 | infixl 5 .~ 383 | 384 | -- | 385 | -- 386 | -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 387 | -- (13,"abc") 388 | -- 389 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 390 | -- Just (20,"abc") 391 | -- 392 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 393 | -- Nothing 394 | fmodify :: 395 | Functor f => 396 | Lens s t a b 397 | -> (a -> f b) 398 | -> s 399 | -> f t 400 | fmodify _ _ _ = 401 | error "todo: fmodify" 402 | 403 | -- | 404 | -- 405 | -- >>> fstL |= Just 3 $ (7, "abc") 406 | -- Just (3,"abc") 407 | -- 408 | -- >>> (fstL |= (+1) $ (3, "abc")) 17 409 | -- (18,"abc") 410 | (|=) :: 411 | Functor f => 412 | Lens s t a b 413 | -> f b 414 | -> s 415 | -> f t 416 | (|=) _ _ _ = 417 | error "todo: (|=)" 418 | 419 | infixl 5 |= 420 | 421 | -- | 422 | -- 423 | -- >>> modify fstL (*10) (3, "abc") 424 | -- (30,"abc") 425 | fstL :: 426 | Lens (a, x) (b, x) a b 427 | fstL = 428 | error "todo: fstL" 429 | 430 | -- | 431 | -- 432 | -- >>> modify sndL (++ "def") (13, "abc") 433 | -- (13,"abcdef") 434 | sndL :: 435 | Lens (x, a) (x, b) a b 436 | sndL = 437 | error "todo: sndL" 438 | 439 | -- | 440 | -- 441 | -- To work on `Map k a`: 442 | -- Map.lookup :: Ord k => k -> Map k a -> Maybe a 443 | -- Map.insert :: Ord k => k -> a -> Map k a -> Map k a 444 | -- Map.delete :: Ord k => k -> Map k a -> Map k a 445 | -- 446 | -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 447 | -- Just 'c' 448 | -- 449 | -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 450 | -- Nothing 451 | -- 452 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 453 | -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 454 | -- 455 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 456 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 457 | -- 458 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 459 | -- fromList [(1,'a'),(2,'b'),(4,'d')] 460 | -- 461 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 462 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 463 | mapL :: 464 | Ord k => 465 | k 466 | -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) 467 | mapL = 468 | error "todo: mapL" 469 | 470 | -- | 471 | -- 472 | -- To work on `Set a`: 473 | -- Set.insert :: Ord a => a -> Set a -> Set a 474 | -- Set.member :: Ord a => a -> Set a -> Bool 475 | -- Set.delete :: Ord a => a -> Set a -> Set a 476 | -- 477 | -- >>> get (setL 3) (Set.fromList [1..5]) 478 | -- True 479 | -- 480 | -- >>> get (setL 33) (Set.fromList [1..5]) 481 | -- False 482 | -- 483 | -- >>> set (setL 3) (Set.fromList [1..5]) True 484 | -- fromList [1,2,3,4,5] 485 | -- 486 | -- >>> set (setL 3) (Set.fromList [1..5]) False 487 | -- fromList [1,2,4,5] 488 | -- 489 | -- >>> set (setL 33) (Set.fromList [1..5]) True 490 | -- fromList [1,2,3,4,5,33] 491 | -- 492 | -- >>> set (setL 33) (Set.fromList [1..5]) False 493 | -- fromList [1,2,3,4,5] 494 | setL :: 495 | Ord k => 496 | k 497 | -> Lens (Set.Set k) (Set.Set k) Bool Bool 498 | setL = 499 | error "todo: setL" 500 | 501 | -- | 502 | -- 503 | -- >>> get (compose fstL sndL) ("abc", (7, "def")) 504 | -- 7 505 | -- 506 | -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 507 | -- ("abc",(8,"def")) 508 | compose :: 509 | Lens s t a b 510 | -> Lens q r s t 511 | -> Lens q r a b 512 | compose _ _ = 513 | error "todo: compose" 514 | 515 | -- | An alias for @compose@. 516 | (|.) :: 517 | Lens s t a b 518 | -> Lens q r s t 519 | -> Lens q r a b 520 | (|.) = 521 | compose 522 | 523 | infixr 9 |. 524 | 525 | -- | 526 | -- 527 | -- >>> get identity 3 528 | -- 3 529 | -- 530 | -- >>> set identity 3 4 531 | -- 4 532 | identity :: 533 | Lens a b a b 534 | identity = 535 | error "todo: identity" 536 | 537 | -- | 538 | -- 539 | -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 540 | -- ("abc","def") 541 | -- 542 | -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 543 | -- (("ghi",3),(4,"jkl")) 544 | product :: 545 | Lens s t a b 546 | -> Lens q r c d 547 | -> Lens (s, q) (t, r) (a, c) (b, d) 548 | product _ _ = 549 | error "todo: product" 550 | 551 | -- | An alias for @product@. 552 | (***) :: 553 | Lens s t a b 554 | -> Lens q r c d 555 | -> Lens (s, q) (t, r) (a, c) (b, d) 556 | (***) = 557 | product 558 | 559 | infixr 3 *** 560 | 561 | -- | 562 | -- 563 | -- >>> get (choice fstL sndL) (Left ("abc", 7)) 564 | -- "abc" 565 | -- 566 | -- >>> get (choice fstL sndL) (Right ("abc", 7)) 567 | -- 7 568 | -- 569 | -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 570 | -- Left ("def",7) 571 | -- 572 | -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 573 | -- Right ("abc",8) 574 | choice :: 575 | Lens s t a b 576 | -> Lens q r a b 577 | -> Lens (Either s q) (Either t r) a b 578 | choice _ _ = 579 | error "todo: choice" 580 | 581 | -- | An alias for @choice@. 582 | (|||) :: 583 | Lens s t a b 584 | -> Lens q r a b 585 | -> Lens (Either s q) (Either t r) a b 586 | (|||) = 587 | choice 588 | 589 | infixr 2 ||| 590 | 591 | ---- 592 | 593 | type Lens' a b = 594 | Lens a a b b 595 | 596 | cityL :: 597 | Lens' Locality String 598 | cityL p (Locality c t y) = 599 | fmap (\c' -> Locality c' t y) (p c) 600 | 601 | stateL :: 602 | Lens' Locality String 603 | stateL p (Locality c t y) = 604 | fmap (\t' -> Locality c t' y) (p t) 605 | 606 | countryL :: 607 | Lens' Locality String 608 | countryL p (Locality c t y) = 609 | fmap (\y' -> Locality c t y') (p y) 610 | 611 | streetL :: 612 | Lens' Address String 613 | streetL p (Address t s l) = 614 | fmap (\t' -> Address t' s l) (p t) 615 | 616 | suburbL :: 617 | Lens' Address String 618 | suburbL p (Address t s l) = 619 | fmap (\s' -> Address t s' l) (p s) 620 | 621 | localityL :: 622 | Lens' Address Locality 623 | localityL p (Address t s l) = 624 | fmap (\l' -> Address t s l') (p l) 625 | 626 | ageL :: 627 | Lens' Person Int 628 | ageL p (Person a n d) = 629 | fmap (\a' -> Person a' n d) (p a) 630 | 631 | nameL :: 632 | Lens' Person String 633 | nameL p (Person a n d) = 634 | fmap (\n' -> Person a n' d) (p n) 635 | 636 | addressL :: 637 | Lens' Person Address 638 | addressL p (Person a n d) = 639 | fmap (\d' -> Person a n d') (p d) 640 | 641 | intAndIntL :: 642 | Lens' (IntAnd a) Int 643 | intAndIntL p (IntAnd n a) = 644 | fmap (\n' -> IntAnd n' a) (p n) 645 | 646 | -- lens for polymorphic update 647 | intAndL :: 648 | Lens (IntAnd a) (IntAnd b) a b 649 | intAndL p (IntAnd n a) = 650 | fmap (\a' -> IntAnd n a') (p a) 651 | 652 | -- | 653 | -- 654 | -- >>> getSuburb fred 655 | -- "Fredville" 656 | -- 657 | -- >>> getSuburb mary 658 | -- "Maryland" 659 | getSuburb :: 660 | Person 661 | -> String 662 | getSuburb = 663 | error "todo: getSuburb" 664 | 665 | -- | 666 | -- 667 | -- >>> setStreet fred "Some Other St" 668 | -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 669 | -- 670 | -- >>> setStreet mary "Some Other St" 671 | -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 672 | setStreet :: 673 | Person 674 | -> String 675 | -> Person 676 | setStreet = 677 | error "todo: setStreet" 678 | 679 | -- | 680 | -- 681 | -- >>> getAgeAndCountry (fred, maryLocality) 682 | -- (24,"Maristan") 683 | -- 684 | -- >>> getAgeAndCountry (mary, fredLocality) 685 | -- (28,"Fredalia") 686 | getAgeAndCountry :: 687 | (Person, Locality) 688 | -> (Int, String) 689 | getAgeAndCountry = 690 | error "todo: getAgeAndCountry" 691 | 692 | -- | 693 | -- 694 | -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 695 | -- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) 696 | -- 697 | -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 698 | -- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) 699 | setCityAndLocality :: 700 | (Person, Address) -> (String, Locality) -> (Person, Address) 701 | setCityAndLocality = 702 | error "todo: setCityAndLocality" 703 | 704 | -- | 705 | -- 706 | -- >>> getSuburbOrCity (Left maryAddress) 707 | -- "Maryland" 708 | -- 709 | -- >>> getSuburbOrCity (Right fredLocality) 710 | -- "Fredmania" 711 | getSuburbOrCity :: 712 | Either Address Locality 713 | -> String 714 | getSuburbOrCity = 715 | error "todo: getSuburbOrCity" 716 | 717 | -- | 718 | -- 719 | -- >>> setStreetOrState (Right maryLocality) "Some Other State" 720 | -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 721 | -- 722 | -- >>> setStreetOrState (Left fred) "Some Other St" 723 | -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 724 | setStreetOrState :: 725 | Either Person Locality 726 | -> String 727 | -> Either Person Locality 728 | setStreetOrState = 729 | error "todo: setStreetOrState" 730 | 731 | -- | 732 | -- 733 | -- >>> modifyCityUppercase fred 734 | -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 735 | -- 736 | -- >>> modifyCityUppercase mary 737 | -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 738 | modifyCityUppercase :: 739 | Person 740 | -> Person 741 | modifyCityUppercase = 742 | error "todo: modifyCityUppercase" 743 | 744 | -- | 745 | -- 746 | -- >>> modifyIntAndLengthEven (IntAnd 10 "abc") 747 | -- IntAnd 10 False 748 | -- 749 | -- >>> modifyIntAndLengthEven (IntAnd 10 "abcd") 750 | -- IntAnd 10 True 751 | modifyIntAndLengthEven :: 752 | IntAnd [a] 753 | -> IntAnd Bool 754 | modifyIntAndLengthEven = 755 | error "todo: modifyIntAndLengthEven" 756 | 757 | ---- 758 | 759 | -- | 760 | -- 761 | -- >>> over traverseLocality (map toUpper) (Locality "abc" "def" "ghi") 762 | -- Locality "ABC" "DEF" "GHI" 763 | traverseLocality :: 764 | Traversal' Locality String 765 | traverseLocality = 766 | error "todo: traverseLocality" 767 | 768 | -- | 769 | -- 770 | -- >>> over intOrIntP (*10) (IntOrIs 3) 771 | -- IntOrIs 30 772 | -- 773 | -- >>> over intOrIntP (*10) (IntOrIsNot "abc") 774 | -- IntOrIsNot "abc" 775 | intOrIntP :: 776 | Prism' (IntOr a) Int 777 | intOrIntP = 778 | error "todo: intOrIntP" 779 | 780 | intOrP :: 781 | Prism (IntOr a) (IntOr b) a b 782 | intOrP = 783 | error "todo: intOrP" 784 | 785 | -- | 786 | -- 787 | -- >> intOrLengthEven (IntOrIsNot "abc") 788 | -- IntOrIsNot False 789 | -- 790 | -- >>> intOrLengthEven (IntOrIsNot "abcd") 791 | -- IntOrIsNot True 792 | -- 793 | -- >>> intOrLengthEven (IntOrIs 10) 794 | -- IntOrIs 10 795 | intOrLengthEven :: 796 | IntOr [a] 797 | -> IntOr Bool 798 | intOrLengthEven = 799 | error "todo: intOrLengthEven" 800 | -------------------------------------------------------------------------------- /src/Lets/OpticPolyLens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Lets.OpticPolyLens ( 4 | Lens(..) 5 | , getsetLaw 6 | , setgetLaw 7 | , setsetLaw 8 | , get 9 | , set 10 | , modify 11 | , (%~) 12 | , (.~) 13 | , fmodify 14 | , (|=) 15 | , fstL 16 | , sndL 17 | , mapL 18 | , setL 19 | , compose 20 | , (|.) 21 | , identity 22 | , product 23 | , (***) 24 | , choice 25 | , (|||) 26 | , cityL 27 | , countryL 28 | , streetL 29 | , suburbL 30 | , localityL 31 | , ageL 32 | , nameL 33 | , addressL 34 | , intAndIntL 35 | , intAndL 36 | , getSuburb 37 | , setStreet 38 | , getAgeAndCountry 39 | , setCityAndLocality 40 | , getSuburbOrCity 41 | , setStreetOrState 42 | , modifyCityUppercase 43 | , modifyIntandLengthEven 44 | ) where 45 | 46 | import Data.Char(toUpper) 47 | import Data.Map(Map) 48 | import qualified Data.Map as Map(insert, delete, lookup) 49 | import Data.Set(Set) 50 | import qualified Data.Set as Set(insert, delete, member) 51 | import Lets.Data(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address)) 52 | import Prelude hiding (product) 53 | 54 | -- $setup 55 | -- >>> import qualified Data.Map as Map(fromList) 56 | -- >>> import qualified Data.Set as Set(fromList) 57 | -- >>> import Data.Bool(bool) 58 | -- >>> import Data.Char(ord) 59 | -- >>> import Lets.Data 60 | 61 | data Lens s t a b = 62 | Lens 63 | (forall f. Functor f => (a -> f b) -> s -> f t) 64 | 65 | get :: 66 | Lens s t a b 67 | -> s 68 | -> a 69 | get (Lens r) = 70 | getConst . r Const 71 | 72 | set :: 73 | Lens s t a b 74 | -> s 75 | -> b 76 | -> t 77 | set (Lens r) a b = 78 | getIdentity (r (const (Identity b)) a) 79 | 80 | -- | The get/set law of lenses. This function should always return @True@. 81 | getsetLaw :: 82 | Eq s => 83 | Lens s s a a 84 | -> s 85 | -> Bool 86 | getsetLaw l = 87 | \a -> set l a (get l a) == a 88 | 89 | -- | The set/get law of lenses. This function should always return @True@. 90 | setgetLaw :: 91 | Eq a => 92 | Lens s s a a 93 | -> s 94 | -> a 95 | -> Bool 96 | setgetLaw l a b = 97 | get l (set l a b) == b 98 | 99 | -- | The set/set law of lenses. This function should always return @True@. 100 | setsetLaw :: 101 | Eq s => 102 | Lens s s a b 103 | -> s 104 | -> b 105 | -> b 106 | -> Bool 107 | setsetLaw l a b1 b2 = 108 | set l (set l a b1) b2 == set l a b2 109 | 110 | ---- 111 | 112 | -- | 113 | -- 114 | -- >>> modify fstL (+1) (0 :: Int, "abc") 115 | -- (1,"abc") 116 | -- 117 | -- >>> modify sndL (+1) ("abc", 0 :: Int) 118 | -- ("abc",1) 119 | -- 120 | -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 121 | -- 122 | -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 123 | modify :: 124 | Lens s t a b 125 | -> (a -> b) 126 | -> s 127 | -> t 128 | modify = 129 | error "todo: modify" 130 | 131 | -- | An alias for @modify@. 132 | (%~) :: 133 | Lens s t a b 134 | -> (a -> b) 135 | -> s 136 | -> t 137 | (%~) = 138 | modify 139 | 140 | infixr 4 %~ 141 | 142 | -- | 143 | -- 144 | -- >>> fstL .~ 1 $ (0 :: Int, "abc") 145 | -- (1,"abc") 146 | -- 147 | -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 148 | -- ("abc",1) 149 | -- 150 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 151 | -- 152 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 153 | (.~) :: 154 | Lens s t a b 155 | -> b 156 | -> s 157 | -> t 158 | (.~) = 159 | error "todo: (.~)" 160 | 161 | infixl 5 .~ 162 | 163 | -- | 164 | -- 165 | -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 166 | -- (13,"abc") 167 | -- 168 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 169 | -- Just (20,"abc") 170 | -- 171 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 172 | -- Nothing 173 | fmodify :: 174 | Functor f => 175 | Lens s t a b 176 | -> (a -> f b) 177 | -> s 178 | -> f t 179 | fmodify = 180 | error "todo: fmodify" 181 | 182 | -- | 183 | -- 184 | -- >>> fstL |= Just 3 $ (7, "abc") 185 | -- Just (3,"abc") 186 | -- 187 | -- >>> (fstL |= (+1) $ (3, "abc")) 17 188 | -- (18,"abc") 189 | (|=) :: 190 | Functor f => 191 | Lens s t a b 192 | -> f b 193 | -> s 194 | -> f t 195 | (|=) = 196 | error "todo: (|=)" 197 | 198 | infixl 5 |= 199 | 200 | -- | 201 | -- 202 | -- >>> modify fstL (*10) (3, "abc") 203 | -- (30,"abc") 204 | -- 205 | -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 206 | -- 207 | -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 208 | -- 209 | -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 210 | fstL :: 211 | Lens (a, x) (b, x) a b 212 | fstL = 213 | error "todo: fstL" 214 | 215 | -- | 216 | -- 217 | -- >>> modify sndL (++ "def") (13, "abc") 218 | -- (13,"abcdef") 219 | -- 220 | -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 221 | -- 222 | -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 223 | -- 224 | -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 225 | sndL :: 226 | Lens (x, a) (x, b) a b 227 | sndL = 228 | error "todo: sndL" 229 | 230 | -- | 231 | -- 232 | -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 233 | -- Just 'c' 234 | -- 235 | -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 236 | -- Nothing 237 | -- 238 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 239 | -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 240 | -- 241 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 242 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 243 | -- 244 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 245 | -- fromList [(1,'a'),(2,'b'),(4,'d')] 246 | -- 247 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 248 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 249 | mapL :: 250 | Ord k => 251 | k 252 | -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) 253 | mapL = 254 | error "todo: mapL" 255 | 256 | -- | 257 | -- 258 | -- >>> get (setL 3) (Set.fromList [1..5]) 259 | -- True 260 | -- 261 | -- >>> get (setL 33) (Set.fromList [1..5]) 262 | -- False 263 | -- 264 | -- >>> set (setL 3) (Set.fromList [1..5]) True 265 | -- fromList [1,2,3,4,5] 266 | -- 267 | -- >>> set (setL 3) (Set.fromList [1..5]) False 268 | -- fromList [1,2,4,5] 269 | -- 270 | -- >>> set (setL 33) (Set.fromList [1..5]) True 271 | -- fromList [1,2,3,4,5,33] 272 | -- 273 | -- >>> set (setL 33) (Set.fromList [1..5]) False 274 | -- fromList [1,2,3,4,5] 275 | setL :: 276 | Ord k => 277 | k 278 | -> Lens (Set k) (Set k) Bool Bool 279 | setL = 280 | error "todo: setL" 281 | 282 | -- | 283 | -- 284 | -- >>> get (compose fstL sndL) ("abc", (7, "def")) 285 | -- 7 286 | -- 287 | -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 288 | -- ("abc",(8,"def")) 289 | compose :: 290 | Lens s t a b 291 | -> Lens q r s t 292 | -> Lens q r a b 293 | compose = 294 | error "todo: compose" 295 | 296 | -- | An alias for @compose@. 297 | (|.) :: 298 | Lens s t a b 299 | -> Lens q r s t 300 | -> Lens q r a b 301 | (|.) = 302 | compose 303 | 304 | infixr 9 |. 305 | 306 | -- | 307 | -- 308 | -- >>> get identity 3 309 | -- 3 310 | -- 311 | -- >>> set identity 3 4 312 | -- 4 313 | identity :: 314 | Lens a b a b 315 | identity = 316 | error "todo: identity" 317 | 318 | -- | 319 | -- 320 | -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 321 | -- ("abc","def") 322 | -- 323 | -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 324 | -- (("ghi",3),(4,"jkl")) 325 | product :: 326 | Lens s t a b 327 | -> Lens q r c d 328 | -> Lens (s, q) (t, r) (a, c) (b, d) 329 | product = 330 | error "todo: product" 331 | 332 | -- | An alias for @product@. 333 | (***) :: 334 | Lens s t a b 335 | -> Lens q r c d 336 | -> Lens (s, q) (t, r) (a, c) (b, d) 337 | (***) = 338 | product 339 | 340 | infixr 3 *** 341 | 342 | -- | 343 | -- 344 | -- >>> get (choice fstL sndL) (Left ("abc", 7)) 345 | -- "abc" 346 | -- 347 | -- >>> get (choice fstL sndL) (Right ("abc", 7)) 348 | -- 7 349 | -- 350 | -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 351 | -- Left ("def",7) 352 | -- 353 | -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 354 | -- Right ("abc",8) 355 | choice :: 356 | Lens s t a b 357 | -> Lens q r a b 358 | -> Lens (Either s q) (Either t r) a b 359 | choice = 360 | error "todo: choice" 361 | 362 | -- | An alias for @choice@. 363 | (|||) :: 364 | Lens s t a b 365 | -> Lens q r a b 366 | -> Lens (Either s q) (Either t r) a b 367 | (|||) = 368 | choice 369 | 370 | infixr 2 ||| 371 | 372 | ---- 373 | 374 | type Lens' a b = 375 | Lens a a b b 376 | 377 | cityL :: 378 | Lens' Locality String 379 | cityL = 380 | Lens 381 | (\p (Locality c t y) -> fmap (\c' -> Locality c' t y) (p c)) 382 | 383 | stateL :: 384 | Lens' Locality String 385 | stateL = 386 | Lens 387 | (\p (Locality c t y) -> fmap (\t' -> Locality c t' y) (p t)) 388 | 389 | countryL :: 390 | Lens' Locality String 391 | countryL = 392 | Lens 393 | (\p (Locality c t y) -> fmap (\y' -> Locality c t y') (p y)) 394 | 395 | streetL :: 396 | Lens' Address String 397 | streetL = 398 | Lens 399 | (\p (Address t s l) -> fmap (\t' -> Address t' s l) (p t)) 400 | 401 | suburbL :: 402 | Lens' Address String 403 | suburbL = 404 | Lens 405 | (\p (Address t s l) -> fmap (\s' -> Address t s' l) (p s)) 406 | 407 | localityL :: 408 | Lens' Address Locality 409 | localityL = 410 | Lens 411 | (\p (Address t s l) -> fmap (\l' -> Address t s l') (p l)) 412 | 413 | ageL :: 414 | Lens' Person Int 415 | ageL = 416 | Lens 417 | (\p (Person a n d) -> fmap (\a' -> Person a' n d) (p a)) 418 | 419 | nameL :: 420 | Lens' Person String 421 | nameL = 422 | Lens 423 | (\p (Person a n d) -> fmap (\n' -> Person a n' d) (p n)) 424 | 425 | addressL :: 426 | Lens' Person Address 427 | addressL = 428 | Lens 429 | (\p (Person a n d) -> fmap (\d' -> Person a n d') (p d)) 430 | 431 | intAndIntL :: 432 | Lens' (IntAnd a) Int 433 | intAndIntL = 434 | Lens 435 | (\p (IntAnd n a) -> fmap (\n' -> IntAnd n' a) (p n)) 436 | 437 | -- lens for polymorphic update 438 | intAndL :: 439 | Lens (IntAnd a) (IntAnd b) a b 440 | intAndL = 441 | Lens 442 | (\p (IntAnd n a) -> fmap (\a' -> IntAnd n a') (p a)) 443 | 444 | -- | 445 | -- 446 | -- >>> getSuburb fred 447 | -- "Fredville" 448 | -- 449 | -- >>> getSuburb mary 450 | -- "Maryland" 451 | getSuburb :: 452 | Person 453 | -> String 454 | getSuburb = 455 | error "todo: getSuburb" 456 | 457 | 458 | -- | 459 | -- 460 | -- >>> setStreet fred "Some Other St" 461 | -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 462 | -- 463 | -- >>> setStreet mary "Some Other St" 464 | -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 465 | setStreet :: 466 | Person 467 | -> String 468 | -> Person 469 | setStreet = 470 | error "todo: setStreet" 471 | 472 | -- | 473 | -- 474 | -- >>> getAgeAndCountry (fred, maryLocality) 475 | -- (24,"Maristan") 476 | -- 477 | -- >>> getAgeAndCountry (mary, fredLocality) 478 | -- (28,"Fredalia") 479 | getAgeAndCountry :: 480 | (Person, Locality) 481 | -> (Int, String) 482 | getAgeAndCountry = 483 | error "todo: getAgeAndCountry" 484 | 485 | -- | 486 | -- 487 | -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 488 | -- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) 489 | -- 490 | -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 491 | -- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) 492 | setCityAndLocality :: 493 | (Person, Address) -> (String, Locality) -> (Person, Address) 494 | setCityAndLocality = 495 | error "todo: setCityAndLocality" 496 | 497 | -- | 498 | -- 499 | -- >>> getSuburbOrCity (Left maryAddress) 500 | -- "Maryland" 501 | -- 502 | -- >>> getSuburbOrCity (Right fredLocality) 503 | -- "Fredmania" 504 | getSuburbOrCity :: 505 | Either Address Locality 506 | -> String 507 | getSuburbOrCity = 508 | get (suburbL ||| cityL) 509 | 510 | -- | 511 | -- 512 | -- >>> setStreetOrState (Right maryLocality) "Some Other State" 513 | -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 514 | -- 515 | -- >>> setStreetOrState (Left fred) "Some Other St" 516 | -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 517 | setStreetOrState :: 518 | Either Person Locality 519 | -> String 520 | -> Either Person Locality 521 | setStreetOrState = 522 | set (streetL |. addressL ||| stateL) 523 | 524 | -- | 525 | -- 526 | -- >>> modifyCityUppercase fred 527 | -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 528 | -- 529 | -- >>> modifyCityUppercase mary 530 | -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 531 | modifyCityUppercase :: 532 | Person 533 | -> Person 534 | modifyCityUppercase = 535 | cityL |. localityL |. addressL %~ map toUpper 536 | 537 | -- | 538 | -- 539 | -- >>> modify intAndL (even . length) (IntAnd 10 "abc") 540 | -- IntAnd 10 False 541 | -- 542 | -- >>> modify intAndL (even . length) (IntAnd 10 "abcd") 543 | -- IntAnd 10 True 544 | modifyIntandLengthEven :: 545 | IntAnd [a] 546 | -> IntAnd Bool 547 | modifyIntandLengthEven = 548 | intAndL %~ even . length 549 | -------------------------------------------------------------------------------- /src/Lets/Profunctor.hs: -------------------------------------------------------------------------------- 1 | module Lets.Profunctor ( 2 | Profunctor(dimap) 3 | ) where 4 | 5 | import Lets.Data 6 | 7 | -- | A profunctor is a binary functor, with the first argument in contravariant 8 | -- (negative) position and the second argument in covariant (positive) position. 9 | class Profunctor p where 10 | dimap :: 11 | (b -> a) 12 | -> (c -> d) 13 | -> p a c 14 | -> p b d 15 | 16 | instance Profunctor (->) where 17 | dimap f g = \h -> g . h . f 18 | 19 | instance Profunctor Tagged where 20 | dimap _ g (Tagged x) = 21 | Tagged (g x) 22 | -------------------------------------------------------------------------------- /src/Lets/StoreLens.hs: -------------------------------------------------------------------------------- 1 | module Lets.StoreLens ( 2 | Store(..) 3 | , setS 4 | , getS 5 | , mapS 6 | , duplicateS 7 | , extendS 8 | , extractS 9 | , Lens(..) 10 | , getsetLaw 11 | , setgetLaw 12 | , setsetLaw 13 | , get 14 | , set 15 | , modify 16 | , (%~) 17 | , (.~) 18 | , fmodify 19 | , (|=) 20 | , fstL 21 | , sndL 22 | , mapL 23 | , setL 24 | , compose 25 | , (|.) 26 | , identity 27 | , product 28 | , (***) 29 | , choice 30 | , (|||) 31 | , cityL 32 | , stateL 33 | , countryL 34 | , streetL 35 | , suburbL 36 | , localityL 37 | , ageL 38 | , nameL 39 | , addressL 40 | , getSuburb 41 | , setStreet 42 | , getAgeAndCountry 43 | , setCityAndLocality 44 | , getSuburbOrCity 45 | , setStreetOrState 46 | , modifyCityUppercase 47 | ) where 48 | 49 | import Control.Applicative(Applicative((<*>))) 50 | import Data.Char(toUpper) 51 | import Data.Functor((<$>)) 52 | import Data.Map(Map) 53 | import qualified Data.Map as Map(insert, delete, lookup) 54 | import Data.Set(Set) 55 | import qualified Data.Set as Set(insert, delete, member) 56 | import Lets.Data(Store(Store), Person(Person), Locality(Locality), Address(Address)) 57 | import Prelude hiding (product) 58 | 59 | -- $setup 60 | -- >>> import qualified Data.Map as Map(fromList) 61 | -- >>> import qualified Data.Set as Set(fromList) 62 | -- >>> import Data.Bool(bool) 63 | -- >>> import Data.Char(ord) 64 | -- >>> import Lets.Data 65 | 66 | setS :: 67 | Store s a 68 | -> s 69 | -> a 70 | setS (Store s _) = 71 | s 72 | 73 | getS :: 74 | Store s a 75 | -> s 76 | getS (Store _ g) = 77 | g 78 | 79 | mapS :: 80 | (a -> b) 81 | -> Store s a 82 | -> Store s b 83 | mapS = 84 | error "todo: mapS" 85 | 86 | duplicateS :: 87 | Store s a 88 | -> Store s (Store s a) 89 | duplicateS = 90 | error "todo: duplicateS" 91 | 92 | extendS :: 93 | (Store s a -> b) 94 | -> Store s a 95 | -> Store s b 96 | extendS = 97 | error "todo: extendS" 98 | 99 | extractS :: 100 | Store s a 101 | -> a 102 | extractS = 103 | error "todo: extractS" 104 | 105 | ---- 106 | 107 | data Lens a b = 108 | Lens 109 | (a -> Store b a) 110 | 111 | -- | 112 | -- 113 | -- >>> get fstL (0 :: Int, "abc") 114 | -- 0 115 | -- 116 | -- >>> get sndL ("abc", 0 :: Int) 117 | -- 0 118 | -- 119 | -- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x 120 | -- 121 | -- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y 122 | get :: 123 | Lens a b 124 | -> a 125 | -> b 126 | get (Lens r) = 127 | getS . r 128 | 129 | -- | 130 | -- 131 | -- >>> set fstL (0 :: Int, "abc") 1 132 | -- (1,"abc") 133 | -- 134 | -- >>> set sndL ("abc", 0 :: Int) 1 135 | -- ("abc",1) 136 | -- 137 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) 138 | -- 139 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) 140 | set :: 141 | Lens a b 142 | -> a 143 | -> b 144 | -> a 145 | set (Lens r) = 146 | setS . r 147 | 148 | -- | The get/set law of lenses. This function should always return @True@. 149 | getsetLaw :: 150 | Eq a => 151 | Lens a b 152 | -> a 153 | -> Bool 154 | getsetLaw l = 155 | \a -> set l a (get l a) == a 156 | 157 | -- | The set/get law of lenses. This function should always return @True@. 158 | setgetLaw :: 159 | Eq b => 160 | Lens a b 161 | -> a 162 | -> b 163 | -> Bool 164 | setgetLaw l a b = 165 | get l (set l a b) == b 166 | 167 | -- | The set/set law of lenses. This function should always return @True@. 168 | setsetLaw :: 169 | Eq a => 170 | Lens a b 171 | -> a 172 | -> b 173 | -> b 174 | -> Bool 175 | setsetLaw l a b1 b2 = 176 | set l (set l a b1) b2 == set l a b2 177 | 178 | ---- 179 | 180 | -- | 181 | -- 182 | -- >>> modify fstL (+1) (0 :: Int, "abc") 183 | -- (1,"abc") 184 | -- 185 | -- >>> modify sndL (+1) ("abc", 0 :: Int) 186 | -- ("abc",1) 187 | -- 188 | -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 189 | -- 190 | -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 191 | modify :: 192 | Lens a b 193 | -> (b -> b) 194 | -> a 195 | -> a 196 | modify = 197 | error "todo: modify" 198 | 199 | -- | An alias for @modify@. 200 | (%~) :: 201 | Lens a b 202 | -> (b -> b) 203 | -> a 204 | -> a 205 | (%~) = 206 | modify 207 | 208 | infixr 4 %~ 209 | 210 | -- | 211 | -- 212 | -- >>> fstL .~ 1 $ (0 :: Int, "abc") 213 | -- (1,"abc") 214 | -- 215 | -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 216 | -- ("abc",1) 217 | -- 218 | -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 219 | -- 220 | -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 221 | (.~) :: 222 | Lens a b 223 | -> b 224 | -> a 225 | -> a 226 | (.~) = 227 | error "todo: (.~)" 228 | 229 | infixl 5 .~ 230 | 231 | -- | 232 | -- 233 | -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 234 | -- (13,"abc") 235 | -- 236 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 237 | -- Just (20,"abc") 238 | -- 239 | -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 240 | -- Nothing 241 | fmodify :: 242 | Functor f => 243 | Lens a b 244 | -> (b -> f b) 245 | -> a 246 | -> f a 247 | fmodify = 248 | error "todo: fmodify" 249 | 250 | -- | 251 | -- 252 | -- >>> fstL |= Just 3 $ (7, "abc") 253 | -- Just (3,"abc") 254 | -- 255 | -- >>> (fstL |= (+1) $ (3, "abc")) 17 256 | -- (18,"abc") 257 | (|=) :: 258 | Functor f => 259 | Lens a b 260 | -> f b 261 | -> a 262 | -> f a 263 | (|=) = 264 | error "todo: (|=)" 265 | 266 | infixl 5 |= 267 | 268 | -- | 269 | -- 270 | -- >>> modify fstL (*10) (3, "abc") 271 | -- (30,"abc") 272 | -- 273 | -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 274 | -- 275 | -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 276 | -- 277 | -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 278 | fstL :: 279 | Lens (x, y) x 280 | fstL = 281 | error "todo: fstL" 282 | 283 | -- | 284 | -- 285 | -- >>> modify sndL (++ "def") (13, "abc") 286 | -- (13,"abcdef") 287 | -- 288 | -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 289 | -- 290 | -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 291 | -- 292 | -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 293 | sndL :: 294 | Lens (x, y) y 295 | sndL = 296 | error "todo: sndL" 297 | 298 | -- | 299 | -- 300 | -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 301 | -- Just 'c' 302 | -- 303 | -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 304 | -- Nothing 305 | -- 306 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 307 | -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 308 | -- 309 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 310 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 311 | -- 312 | -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 313 | -- fromList [(1,'a'),(2,'b'),(4,'d')] 314 | -- 315 | -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 316 | -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 317 | mapL :: 318 | Ord k => 319 | k 320 | -> Lens (Map k v) (Maybe v) 321 | mapL = 322 | error "todo: mapL" 323 | 324 | -- | 325 | -- 326 | -- >>> get (setL 3) (Set.fromList [1..5]) 327 | -- True 328 | -- 329 | -- >>> get (setL 33) (Set.fromList [1..5]) 330 | -- False 331 | -- 332 | -- >>> set (setL 3) (Set.fromList [1..5]) True 333 | -- fromList [1,2,3,4,5] 334 | -- 335 | -- >>> set (setL 3) (Set.fromList [1..5]) False 336 | -- fromList [1,2,4,5] 337 | -- 338 | -- >>> set (setL 33) (Set.fromList [1..5]) True 339 | -- fromList [1,2,3,4,5,33] 340 | -- 341 | -- >>> set (setL 33) (Set.fromList [1..5]) False 342 | -- fromList [1,2,3,4,5] 343 | setL :: 344 | Ord k => 345 | k 346 | -> Lens (Set k) Bool 347 | setL = 348 | error "todo: setL" 349 | 350 | -- | 351 | -- 352 | -- >>> get (compose fstL sndL) ("abc", (7, "def")) 353 | -- 7 354 | -- 355 | -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 356 | -- ("abc",(8,"def")) 357 | compose :: 358 | Lens b c 359 | -> Lens a b 360 | -> Lens a c 361 | compose = 362 | error "todo: compose" 363 | 364 | -- | An alias for @compose@. 365 | (|.) :: 366 | Lens b c 367 | -> Lens a b 368 | -> Lens a c 369 | (|.) = 370 | compose 371 | 372 | infixr 9 |. 373 | 374 | -- | 375 | -- 376 | -- >>> get identity 3 377 | -- 3 378 | -- 379 | -- >>> set identity 3 4 380 | -- 4 381 | identity :: 382 | Lens a a 383 | identity = 384 | error "todo: identity" 385 | 386 | -- | 387 | -- 388 | -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 389 | -- ("abc","def") 390 | -- 391 | -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 392 | -- (("ghi",3),(4,"jkl")) 393 | product :: 394 | Lens a b 395 | -> Lens c d 396 | -> Lens (a, c) (b, d) 397 | product = 398 | error "todo: product" 399 | 400 | -- | An alias for @product@. 401 | (***) :: 402 | Lens a b 403 | -> Lens c d 404 | -> Lens (a, c) (b, d) 405 | (***) = 406 | product 407 | 408 | infixr 3 *** 409 | 410 | -- | 411 | -- 412 | -- >>> get (choice fstL sndL) (Left ("abc", 7)) 413 | -- "abc" 414 | -- 415 | -- >>> get (choice fstL sndL) (Right ("abc", 7)) 416 | -- 7 417 | -- 418 | -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 419 | -- Left ("def",7) 420 | -- 421 | -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 422 | -- Right ("abc",8) 423 | choice :: 424 | Lens a x 425 | -> Lens b x 426 | -> Lens (Either a b) x 427 | choice = 428 | error "todo: choice" 429 | 430 | -- | An alias for @choice@. 431 | (|||) :: 432 | Lens a x 433 | -> Lens b x 434 | -> Lens (Either a b) x 435 | (|||) = 436 | choice 437 | 438 | infixr 2 ||| 439 | 440 | ---- 441 | 442 | cityL :: 443 | Lens Locality String 444 | cityL = 445 | Lens 446 | (\(Locality c t y) -> 447 | Store (\c' -> Locality c' t y) c) 448 | 449 | stateL :: 450 | Lens Locality String 451 | stateL = 452 | Lens 453 | (\(Locality c t y) -> 454 | Store (\t' -> Locality c t' y) t) 455 | 456 | countryL :: 457 | Lens Locality String 458 | countryL = 459 | Lens 460 | (\(Locality c t y) -> 461 | Store (\y' -> Locality c t y') y) 462 | 463 | streetL :: 464 | Lens Address String 465 | streetL = 466 | Lens 467 | (\(Address t s l) -> 468 | Store (\t' -> Address t' s l) t) 469 | 470 | suburbL :: 471 | Lens Address String 472 | suburbL = 473 | Lens 474 | (\(Address t s l) -> 475 | Store (\s' -> Address t s' l) s) 476 | 477 | localityL :: 478 | Lens Address Locality 479 | localityL = 480 | Lens 481 | (\(Address t s l) -> 482 | Store (\l' -> Address t s l') l) 483 | 484 | ageL :: 485 | Lens Person Int 486 | ageL = 487 | Lens 488 | (\(Person a n d) -> 489 | Store (\a' -> Person a' n d) a) 490 | 491 | nameL :: 492 | Lens Person String 493 | nameL = 494 | Lens 495 | (\(Person a n d) -> 496 | Store (\n' -> Person a n' d) n) 497 | 498 | addressL :: 499 | Lens Person Address 500 | addressL = 501 | Lens 502 | (\(Person a n d) -> 503 | Store (\d' -> Person a n d') d) 504 | 505 | -- | 506 | -- 507 | -- >>> getSuburb fred 508 | -- "Fredville" 509 | -- 510 | -- >>> getSuburb mary 511 | -- "Maryland" 512 | getSuburb :: 513 | Person 514 | -> String 515 | getSuburb = 516 | error "todo: getSuburb" 517 | 518 | -- | 519 | -- 520 | -- >>> setStreet fred "Some Other St" 521 | -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 522 | -- 523 | -- >>> setStreet mary "Some Other St" 524 | -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 525 | setStreet :: 526 | Person 527 | -> String 528 | -> Person 529 | setStreet = 530 | error "todo: setStreet" 531 | 532 | -- | 533 | -- 534 | -- >>> getAgeAndCountry (fred, maryLocality) 535 | -- (24,"Maristan") 536 | -- 537 | -- >>> getAgeAndCountry (mary, fredLocality) 538 | -- (28,"Fredalia") 539 | getAgeAndCountry :: 540 | (Person, Locality) 541 | -> (Int, String) 542 | getAgeAndCountry = 543 | error "todo: getAgeAndCountry" 544 | 545 | -- | 546 | -- 547 | -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 548 | -- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) 549 | -- 550 | -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 551 | -- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) 552 | setCityAndLocality :: 553 | (Person, Address) -> (String, Locality) -> (Person, Address) 554 | setCityAndLocality = 555 | error "todo: setCityAndLocality" 556 | 557 | -- | 558 | -- 559 | -- >>> getSuburbOrCity (Left maryAddress) 560 | -- "Maryland" 561 | -- 562 | -- >>> getSuburbOrCity (Right fredLocality) 563 | -- "Fredmania" 564 | getSuburbOrCity :: 565 | Either Address Locality 566 | -> String 567 | getSuburbOrCity = 568 | error "todo: getSuburbOrCity" 569 | 570 | -- | 571 | -- 572 | -- >>> setStreetOrState (Right maryLocality) "Some Other State" 573 | -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 574 | -- 575 | -- >>> setStreetOrState (Left fred) "Some Other St" 576 | -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 577 | setStreetOrState :: 578 | Either Person Locality 579 | -> String 580 | -> Either Person Locality 581 | setStreetOrState = 582 | error "todo: setStreetOrState" 583 | 584 | -- | 585 | -- 586 | -- >>> modifyCityUppercase fred 587 | -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 588 | -- 589 | -- >>> modifyCityUppercase mary 590 | -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 591 | modifyCityUppercase :: 592 | Person 593 | -> Person 594 | modifyCityUppercase = 595 | error "todo: modifyCityUppercase" 596 | -------------------------------------------------------------------------------- /test/doctests.hs: -------------------------------------------------------------------------------- 1 | import Test.DocTest 2 | 3 | main :: IO () 4 | main = doctest 5 | [ "-isrc" 6 | , "src/Lets/GetSetLens.hs" 7 | , "src/Lets/Lens.hs" 8 | , "src/Lets/OpticPolyLens.hs" 9 | , "src/Lets/StoreLens.hs" 10 | ] 11 | --------------------------------------------------------------------------------