├── .gitignore ├── .purs-repl ├── LICENSE ├── README.md ├── bower.json ├── clean ├── misc └── cover.jpg ├── old ├── ArrayMap.purs ├── ArrayMapExercises.purs ├── ArrayMapSolutions.purs ├── Critter4Us │ ├── Animal.purs │ ├── Repl.purs │ └── State.purs ├── DictPath.purs ├── EffectsTraversal.purs └── Traversal.purs └── src ├── Compositions.purs ├── Critter4Us ├── Animal.purs ├── Main.purs ├── Model.purs └── TagDb.purs ├── Critter4UsRefactored ├── Animal.purs ├── Main.purs └── Model.purs ├── Index.purs ├── IndexStart.purs ├── Intro.purs ├── Map.purs ├── Product.purs ├── ProductExercises.purs ├── ProductSolutions.purs ├── SumType.purs ├── SumTypeSolutions.purs ├── SumTypeStart.purs ├── Traversal.purs └── TraversalStart.purs /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc* 7 | /.psa* 8 | -------------------------------------------------------------------------------- /.purs-repl: -------------------------------------------------------------------------------- 1 | import Prelude 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Brian Marick 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Supporting code for 2 | [*Lenses for the Mere Mortal: PureScript Edition*](https://leanpub.com/lenses). 3 | 4 | 5 | ![](misc/cover.jpg) 6 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-lenses", 3 | "ignore": [ 4 | "**/.*", 5 | "node_modules", 6 | "bower_components", 7 | "output" 8 | ], 9 | "dependencies": { 10 | "purescript-prelude": "^4.0.1", 11 | "purescript-console": "^4.1.0", 12 | "purescript-effect": "^2.0.0", 13 | "purescript-profunctor-lenses": "^4.0.0", 14 | "purescript-colors": "^5.0.0", 15 | "purescript-random": "^4.0.0", 16 | "purescript-record-extra": "^1.0.0", 17 | "purescript-foreign-object": "^1.0.0", 18 | "purescript-generics-rep": "^6.0.0" 19 | }, 20 | "devDependencies": { 21 | "purescript-psci-support": "^4.0.0" 22 | } 23 | } 24 | -------------------------------------------------------------------------------- /clean: -------------------------------------------------------------------------------- 1 | rm -rf output/ArrayMap* 2 | rm -rf output/Product* 3 | rm -rf output/SumType* 4 | rm -rf output/Map* 5 | rm -rf output/Critter4Us* 6 | -------------------------------------------------------------------------------- /misc/cover.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/marick/purescript-lenses/cc3185f13a3bb34dd1687d5227ce2fdb72bd4d4f/misc/cover.jpg -------------------------------------------------------------------------------- /old/ArrayMap.purs: -------------------------------------------------------------------------------- 1 | module ArrayMap where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Data.Maybe 6 | import Data.Tuple 7 | import Data.Array as Array 8 | import Data.Map as Map 9 | import Data.Map (Map) 10 | import Data.StrMap as StrMap 11 | import Data.Set as Set 12 | 13 | import Data.Lens 14 | import Data.Lens.Index (ix) 15 | import Data.Lens.At (at) 16 | 17 | import ArrayMap 18 | 19 | -} 20 | 21 | import Prelude 22 | import Data.Tuple (Tuple(..)) 23 | import Data.Maybe (Maybe(..)) 24 | 25 | import Data.Map as Map 26 | import Data.Map (Map) 27 | 28 | import Data.Lens (view, set, lens, Lens', _2, Traversal', _Just) 29 | import Data.Lens.Index (ix) 30 | import Data.Lens.At (at, class At) 31 | import Data.Foldable (and) 32 | 33 | {- The type of `ix 1` -} 34 | 35 | ix1 :: forall a. Traversal' (Array a) a 36 | ix1 = ix 1 37 | 38 | {- Composing optics -} 39 | 40 | 41 | -- Index and Index 42 | -- If you make an `Index` that you want to compose, you probably want to 43 | -- assign it a type. 44 | 45 | _oneOneTyped :: forall a. 46 | Traversal' (Array (Array a)) a 47 | _oneOneTyped = ix 1 <<< ix 1 48 | 49 | _array2D :: forall a. 50 | Int -> Int -> Traversal' (Array (Array a)) a 51 | _array2D i j = ix i <<< ix j 52 | 53 | 54 | -- Lenses and indexes 55 | 56 | -- These aren't the same names as in the text because (1) the point of the 57 | -- text is that you don't need annotations, but (2) `pulp build` will 58 | -- spew warnings unless there are annotations. 59 | 60 | _lensFirst' :: forall a rest. Traversal' {first :: a | rest} a 61 | _lensFirst' = lens _.first $ _ { first = _ } 62 | 63 | _lensFirstFirst' :: forall a rest. Traversal' {first :: Array a | rest } a 64 | _lensFirstFirst' = _lensFirst' <<< ix 1 65 | 66 | _ixFirstFirst' :: forall a rest. Traversal' (Array {first :: a | rest}) a 67 | _ixFirstFirst' = ix 1 <<< _lensFirst' 68 | 69 | --- Indexes and lenses and indexes 70 | 71 | _chain :: forall key rest value . Ord key => 72 | Int -> key -> 73 | Traversal' 74 | (Array { first :: Map key value | rest }) 75 | value 76 | _chain i key = ix i <<< _lensFirst' <<< ix key 77 | 78 | 79 | 80 | {- at -} 81 | 82 | -- a home-grown implementation of `At.at` 83 | _upsertable :: forall key val. Ord key => 84 | key -> Lens' (Map key val) (Maybe val) 85 | _upsertable key = 86 | lens getter setter 87 | where 88 | getter = 89 | Map.lookup key 90 | setter whole wrapped = 91 | case wrapped of 92 | Nothing -> Map.delete key whole 93 | Just new -> Map.insert key new whole 94 | 95 | -- Laws 96 | _someKey :: forall val. Lens' (Map String val) (Maybe val) 97 | _someKey = _upsertable "key" 98 | 99 | mapWithKey_Present :: Map String String 100 | mapWithKey_Present = Map.singleton "key" "val" 101 | 102 | mapWithKey_Absent :: Map String String 103 | mapWithKey_Absent = Map.singleton "missing" "val2" 104 | 105 | set_get :: Boolean 106 | set_get = 107 | and [ check (Just "NEW") mapWithKey_Present 108 | , check (Just "NEW") mapWithKey_Absent 109 | , check Nothing mapWithKey_Present 110 | , check Nothing mapWithKey_Absent 111 | ] 112 | where 113 | check new whole = 114 | (set _someKey new whole # view _someKey) == new 115 | 116 | get_set :: Boolean 117 | get_set = 118 | and [ check mapWithKey_Present 119 | , check mapWithKey_Absent 120 | ] 121 | where 122 | check whole = 123 | set _someKey (view _someKey whole) whole == whole 124 | 125 | set_set :: Boolean 126 | set_set = 127 | and [ check (Just "NEW") mapWithKey_Present 128 | , check (Just "NEW") mapWithKey_Absent 129 | , check Nothing mapWithKey_Present 130 | , check Nothing mapWithKey_Absent 131 | ] 132 | where 133 | check new whole = 134 | (set _someKey new whole # set _someKey new) == 135 | set _someKey new whole 136 | 137 | -- An example of an `at` type declaration: 138 | _x :: forall whole part. At whole String part => 139 | Lens' whole (Maybe part) 140 | _x = at "x" 141 | 142 | 143 | -- Adding an `At` lens after one of last chapter's lenses 144 | 145 | tupleMap :: Tuple Int (Map String Int) 146 | tupleMap = Tuple 1 $ Map.singleton "x" 1 147 | 148 | _tupleMap :: forall ignore val. 149 | Lens' 150 | (Tuple ignore (Map String val)) 151 | (Maybe val) 152 | _tupleMap = _2 <<< at "x" 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | -- How `at` lenses compose with Index optics. 164 | 165 | arrayMap :: Array (Map String Int) 166 | arrayMap = [Map.empty, Map.singleton "x" 1] 167 | 168 | arrayMapTyped :: forall focus. 169 | Traversal' (Array (Map String focus)) (Maybe focus) 170 | arrayMapTyped = ix 1 <<< at "x" 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | -- Adding `_Just` to simplify results 180 | 181 | arrayMapJust :: forall focus. 182 | Traversal' (Array (Map String focus)) focus 183 | arrayMapJust = ix 1 <<< at "x" <<< _Just 184 | 185 | -- The versions with and without `Just` have very similar types. 186 | 187 | whatsit :: forall focus. 188 | Traversal' 189 | (Array (Map String (Maybe focus))) 190 | (Maybe focus) 191 | whatsit = ix 1 <<< at "x" <<< _Just 192 | 193 | 194 | 195 | -------------------------------------------------------------------------------- /old/ArrayMapExercises.purs: -------------------------------------------------------------------------------- 1 | module ArrayMapExercises where 2 | 3 | {- 4 | These are commented out to keep `pulp build` from complaining. 5 | 6 | import Prelude 7 | import Data.Array as Array 8 | import Data.Lens.Index (ix) 9 | import Data.Lens (Lens', lens, set) 10 | import Data.Maybe (Maybe(..), fromMaybe) 11 | import Data.Tuple (Tuple(..)) 12 | 13 | -} 14 | 15 | -------------------------------------------------------------------------------- /old/ArrayMapSolutions.purs: -------------------------------------------------------------------------------- 1 | module ArrayMapSolutions where 2 | 3 | import Prelude 4 | import Data.Array as Array 5 | import Data.Lens.Index (ix) 6 | import Data.Lens (Lens', lens, set) 7 | import Data.Maybe (Maybe(..), fromMaybe) 8 | import Data.Tuple (Tuple(..)) 9 | 10 | {- `ix` exercise -} 11 | 12 | mystery :: Int -> String 13 | mystery = set (ix 1) "blue" show 14 | -- :type showLens 15 | -- Int -> String 16 | 17 | {- 18 | > mystery 0 19 | "0" 20 | 21 | > mystery 1 22 | "blue" 23 | -} 24 | 25 | {- At exercise -} 26 | 27 | at' :: forall a. Int -> Lens' (Array a) (Maybe a) 28 | at' index = 29 | lens getter setter 30 | where 31 | getter = 32 | flip Array.index index 33 | 34 | setter whole new = 35 | case Tuple new $ classify index whole of 36 | Tuple _ WayPastEnd -> whole 37 | Tuple Nothing LastElement -> Array.dropEnd 1 whole 38 | Tuple Nothing _ -> whole 39 | 40 | Tuple (Just _) JustPastEnd -> setWith Array.insertAt new whole 41 | Tuple (Just _) _ -> setWith Array.updateAt new whole 42 | 43 | setWith f new whole = 44 | new >>= flip (f index) whole # fromMaybe whole 45 | 46 | data IndexClassification 47 | = InteriorElement 48 | | LastElement 49 | | JustPastEnd 50 | | WayPastEnd 51 | 52 | classify :: forall a. Int -> Array a -> IndexClassification 53 | classify index array = 54 | if index < len - 1 then 55 | InteriorElement 56 | else if index == len - 1 then 57 | LastElement 58 | else if index == len then 59 | JustPastEnd 60 | else 61 | WayPastEnd 62 | where 63 | len = Array.length array 64 | 65 | 66 | {- Step 2: But there's a problem. If we set a value way past the end of 67 | the array, the result will be an unchanged array. 68 | 69 | But the set-get law requires that what you `set` via a lens can be 70 | `view`ed via the same lens. But: 71 | 72 | 73 | > set (at' 9999) (Just 555) shortArray # view (at' 9999) 74 | Nothing 75 | 76 | -} 77 | -------------------------------------------------------------------------------- /old/Critter4Us/Animal.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.Animal where 2 | 3 | import Prelude 4 | import Data.Lens 5 | import Data.Array 6 | 7 | type Name = String 8 | 9 | type Animal = 10 | { name :: Name 11 | , tags :: Array String 12 | } 13 | 14 | make :: Name -> Array String -> Animal 15 | make name tags = { name : name, tags : tags } 16 | 17 | addTag :: String -> Animal -> Animal 18 | addTag tag animal = over tags (insert tag) animal 19 | 20 | 21 | {- Lenses -} 22 | 23 | name :: Lens' Animal String 24 | name = lens _.name $ _ { name = _ } 25 | 26 | tags :: Lens' Animal (Array String) 27 | tags = lens _.tags $ _ { tags = _ } 28 | 29 | -------------------------------------------------------------------------------- /old/Critter4Us/Repl.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.Repl where 2 | 3 | 4 | -------------------------------------------------------------------------------- /old/Critter4Us/State.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.State where 2 | 3 | import Prelude 4 | import Data.Map as Map 5 | import Data.Map (Map) 6 | import Data.Lens.Index (ix) 7 | import Data.Lens 8 | import Critter4Us.Animal as Animal 9 | import Critter4Us.Animal (Animal) 10 | import Data.Array 11 | import Data.Tuple 12 | import Data.FoldableWithIndex 13 | 14 | 15 | type Id = Int 16 | 17 | type State = 18 | { animals :: Map Int Animal 19 | } 20 | 21 | init = 22 | { animals : animals [ Tuple "jake" ["gelding", "skittish"] 23 | , Tuple "betsy" ["first calf heifer"] 24 | ] 25 | } 26 | where 27 | animals = 28 | foldlWithIndex nextAnimal Map.empty 29 | nextAnimal id acc description = 30 | Map.insert id (animal description) acc 31 | animal = 32 | uncurry Animal.make 33 | 34 | 35 | -- addTag :: String -> String -> State 36 | -- addTag name 37 | 38 | {- Lenses -} 39 | 40 | animals :: Lens' State (Map Id Animal) 41 | animals = lens _.animals $ _ { animals = _ } 42 | 43 | animal :: Id -> Traversal' State Animal 44 | animal id = animals <<< ix id 45 | 46 | -------------------------------------------------------------------------------- /old/DictPath.purs: -------------------------------------------------------------------------------- 1 | module DictPath where 2 | 3 | import Prelude 4 | import Data.Tuple (Tuple(..)) 5 | import Data.Map as Map 6 | import Data.Map (Map) 7 | import Data.Lens.Index (ix) 8 | import Data.Lens.At (at, class At) 9 | import Data.Lens (preview, view, set, over, Lens', lens, _Just) 10 | import Data.Maybe (Maybe(..)) 11 | import Data.Profunctor.Strong 12 | import Data.Record.ShowRecord 13 | 14 | type Animal = 15 | { tags :: Int 16 | } 17 | 18 | type Model = 19 | { animals :: Map String Animal 20 | } 21 | 22 | model :: Model 23 | model = 24 | { animals : 25 | Map.fromFoldable 26 | [ Tuple "jake" {tags : 4} 27 | , Tuple "skitter" {tags : 6} 28 | ] 29 | } 30 | 31 | modelToAnimals :: Lens' Model (Map String Animal) 32 | modelToAnimals = lens _.animals $ _ { animals = _ } 33 | 34 | {- The following is the type that the compiler suggests: 35 | mapToAnimal :: forall b a m. At m a b => a -> (forall p. Strong p => p (Maybe b) (Maybe b) -> p m m) 36 | Interestingly, if you uncomment that, you'll get the following error: 37 | 38 | 35 mapToAnimal = at 39 | ^^ 40 | Could not match constrained type 41 | 42 | Strong t3 => t3 (Maybe t4) (Maybe t4) -> t3 t5 t5 43 | 44 | with type 45 | 46 | Strong p6 => p6 (Maybe b1) (Maybe b1) -> p6 m2 m2 47 | 48 | 49 | What's up with that? Compiler error? 50 | 51 | -} 52 | 53 | animalsToAnimal = at 54 | 55 | animalToTags :: Lens' Animal Int 56 | animalToTags = lens _.tags $ _ { tags = _ } 57 | 58 | 59 | {- 60 | What I *want* to say with these three lenses is this: 61 | 62 | modelToTag id = 63 | modelToAnimals <<< animalsToAnimal id <<< animalToTags 64 | 65 | I can get partway there with this: 66 | 67 | > :t view (modelToAnimals <<< animalsToAnimal "jake") model 68 | Maybe 69 | { tags :: Int 70 | } 71 | 72 | ... but I don't know how to add on past that. 73 | -} 74 | 75 | modelToTag id = 76 | modelToAnimals <<< animalsToAnimal id <<< _Just <<< animalToTags 77 | 78 | -------------------------------------------------------------------------------- /old/EffectsTraversal.purs: -------------------------------------------------------------------------------- 1 | module EffectsTraversal where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Data.Maybe 6 | import Data.Either 7 | import Data.Lens 8 | import Data.Lens as Lens 9 | import Data.Tuple 10 | import Data.List 11 | import Data.String as String 12 | 13 | import Control.Monad.Eff.Random 14 | import Data.Traversable 15 | -} 16 | 17 | import Prelude 18 | import Data.Lens 19 | import Data.Lens as Lens 20 | import Effect.Random 21 | import Data.Traversable 22 | import Data.Maybe 23 | 24 | invertified = traverse (randomInt 0) [10, 20, 30] -- not the lens version 25 | -- [6,7,11] 26 | 27 | 28 | {- 29 | sequenceOf traversed $ map (randomInt 3) [10, 20, 30] 30 | 31 | 32 | > (traverseOf traversed pure [10, 20, 30]) :: Maybe (Array Int) 33 | (Just [10,20,30]) 34 | 35 | > pure [10, 20, 30] :: Maybe (Array Int) 36 | (Just [10,20,30]) 37 | 38 | 39 | traverseOf traversed pure ≡ pure 40 | 41 | -} 42 | 43 | -- t :: (Int -> Maybe Int) -> Array Int -> Maybe (Array Int) 44 | t = traverseOf traversed 45 | 46 | t1 :: forall f. Applicative f => f Int -> Maybe (f Int) 47 | t1 = Just 48 | 49 | t2 :: Int -> Maybe Int 50 | t2 = Just <<< ((-) 3) 51 | 52 | -------------------------------------------------------------------------------- /old/Traversal.purs: -------------------------------------------------------------------------------- 1 | module Traversal where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Traversal 6 | 7 | import Data.Maybe 8 | import Data.Lens 9 | import Data.Lens as Lens 10 | import Data.Tuple 11 | import Data.List 12 | import Data.String as String 13 | import Data.Map as Map 14 | import Data.Lens.Index (ix) 15 | import Data.Lens.At (at) 16 | 17 | -} 18 | 19 | import Prelude 20 | import Data.Tuple (Tuple) 21 | import Data.Maybe (Maybe) 22 | 23 | import Data.Lens ( _1 -- old 24 | , Traversal, Traversal', _Just, element, traversed -- new 25 | ) 26 | import Data.Lens.Index (class Index, ix) 27 | import Data.Traversable (class Traversable) 28 | import Data.Lens.At (class At, at) 29 | import Data.Map (Map) 30 | import Data.Map as Map 31 | 32 | element1 :: Traversal' (Array String) String 33 | element1 = element 1 traversed 34 | 35 | _ix1 :: Traversal' (Array String) String 36 | _ix1 = ix 1 37 | 38 | 39 | -- Composition 40 | _firsts :: forall focus ignore traversable. Traversable traversable => 41 | Traversal' (traversable (Tuple focus ignore)) focus 42 | _firsts = traversed <<< _1 43 | 44 | 45 | _firsts' :: forall trav a b ignore. Traversable trav => 46 | Traversal (trav (Tuple a ignore)) (trav (Tuple b ignore)) 47 | a b 48 | _firsts' = traversed <<< _1 49 | 50 | 51 | 52 | _firstThenTraverse :: forall trav a b ignore. 53 | Traversable trav => 54 | Traversal (Tuple (trav a) ignore) (Tuple (trav b) ignore) 55 | a b 56 | _firstThenTraverse = _1 <<< traversed 57 | 58 | 59 | 60 | _depth2 :: forall t1 t2 a b. 61 | Traversable t1 => Traversable t2 => 62 | Traversal (t1 (t2 a)) (t1 (t2 b)) a b 63 | _depth2 = traversed <<< traversed 64 | 65 | 66 | 67 | _traverse2ix :: forall a. Traversal' (Array (Array a)) a 68 | _traverse2ix = traversed <<< ix 0 69 | 70 | _traverse2ix' :: forall t1 t2 a. 71 | Traversable t1 => 72 | Index (t2 a) Int a => 73 | Traversal' (t1 (t2 a)) a 74 | _traverse2ix' = traversed <<< ix 0 75 | 76 | _traverse2ix'' :: forall t1 t2 index a. 77 | Traversable t1 => 78 | Index (t2 a) index a => 79 | index -> Traversal' (t1 (t2 a)) a 80 | _traverse2ix'' index = traversed <<< ix index 81 | 82 | -- The following will not compile because a traversal containing an 83 | -- `Index` can't change types. 84 | 85 | {- 86 | _ixBogus :: forall t1 t2 index a b. 87 | Traversable t1 => 88 | Index (t2 a) index a => 89 | index -> Traversal (t1 (t2 a)) (t1 (t2 b)) a b 90 | _ixBogus index = traversed <<< ix index 91 | 92 | -} 93 | 94 | 95 | _ix2traverse :: forall t1 t2 a. 96 | Index (t1 (t2 a)) Int (t2 a) => 97 | Traversable t2 => 98 | Traversal' (t1 (t2 a)) a 99 | _ix2traverse = ix 0 <<< traversed 100 | 101 | 102 | _traverse2at :: forall v trav at. 103 | Traversable trav => 104 | At (at String v) String v => 105 | Traversal' (trav (at String v)) (Maybe v) 106 | _traverse2at = traversed <<< at "key" 107 | 108 | 109 | 110 | _at2traverse :: Traversal' (Map String (Array String)) (Array String) 111 | _at2traverse = at "key" <<< traversed 112 | 113 | at2_1 :: Map String (Array Int) 114 | at2_1 = Map.singleton "key" [1, 2, 3] 115 | 116 | _deeper :: Traversal' (Map String (Array String)) String 117 | _deeper = _at2traverse <<< traversed 118 | 119 | _deeper' :: forall v trav at . 120 | Traversable trav => 121 | At (at String (trav v)) String (trav v) => 122 | Traversal' (at String (trav v)) v 123 | _deeper' = at "key" <<< _Just <<< traversed 124 | -------------------------------------------------------------------------------- /src/Compositions.purs: -------------------------------------------------------------------------------- 1 | module Compositions where 2 | 3 | {- The various compositions used in the catalog of compositions. 4 | Here if they're not explained in the text (so in a chapter's source files). 5 | -} 6 | import Prelude 7 | import Data.Tuple (Tuple) 8 | import Data.Maybe (Maybe) 9 | import Data.Lens (Lens', Traversal', _1, traversed) 10 | import Data.Lens.At (class At, at) 11 | 12 | _1_1 :: forall a _1_ _2_ . Lens' (Tuple (Tuple a _1_) _2_) a 13 | _1_1 = _1 <<< _1 14 | 15 | _1_at :: forall keyed _2_ a . 16 | At keyed Int a => 17 | Lens' (Tuple keyed _2_) (Maybe a) 18 | _1_at = _1 <<< at 1 19 | 20 | 21 | _at_trav :: forall keyed a . 22 | At keyed Int a => 23 | Traversal' keyed a 24 | _at_trav = at 1 <<< traversed 25 | 26 | 27 | _at_Just :: forall keyed a . 28 | At keyed Int a => 29 | Traversal' keyed a 30 | _at_Just = at 1 <<< traversed 31 | 32 | -------------------------------------------------------------------------------- /src/Critter4Us/Animal.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.Animal 2 | ( Animal 3 | , Id 4 | , Tags 5 | , named 6 | , addTag 7 | , clearTags 8 | ) 9 | where 10 | 11 | import Prelude 12 | import Data.Lens (Lens', lens, over, set) 13 | import Data.Array (snoc) 14 | 15 | type Id = Int 16 | type Tags = Array String 17 | 18 | type Animal = 19 | { id :: Id 20 | , name :: String 21 | , tags :: Tags 22 | } 23 | 24 | named :: String -> Id -> Animal 25 | named name id = 26 | { id, name, tags : [] } 27 | 28 | clearTags :: Animal -> Animal 29 | clearTags = set _tags [] 30 | 31 | -- Note: let's make it the UI's job to disallow duplicate tags. 32 | addTag :: String -> Animal -> Animal 33 | addTag tag = 34 | over _tags (flip snoc tag) 35 | 36 | 37 | {- Internal -} 38 | 39 | _tags :: Lens' Animal Tags 40 | _tags = lens _.tags $ _ { tags = _ } 41 | -------------------------------------------------------------------------------- /src/Critter4Us/Main.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.Main where 2 | 3 | {- For the repl, use these imports: 4 | 5 | import Critter4Us.Main 6 | import Critter4Us.Model 7 | 8 | > initialModel 9 | { animals: (fromFoldable [(Tuple 3838 { id: 3838, name: "Genesis", tags: ["mare"] })]) } 10 | 11 | > update initialModel (AddAnimal 1 "Bossy") 12 | { animals: (fromFoldable [(Tuple 1 { id: 1, name: "Bossy", tags: [] }),(Tuple 3838 { id: 3838, name: "Genesis", tags: ["mare"] })]) } 13 | 14 | > update initialModel (AddTag 3838 "skittish") 15 | { animals: (fromFoldable [(Tuple 3838 { id: 3838, name: "Genesis", tags: ["mare","skittish"] })]) } 16 | 17 | -} 18 | 19 | import Critter4Us.Animal as Animal 20 | import Critter4Us.Model as Model 21 | import Critter4Us.Model (Model) 22 | 23 | data Action 24 | = AddAnimal Animal.Id String 25 | | AddTag Animal.Id String 26 | 27 | 28 | update :: Model -> Action -> Model 29 | 30 | update model (AddAnimal animalId name) = 31 | Model.addAnimal animalId name model 32 | 33 | update model (AddTag animalId tag) = 34 | Model.addAnimalTag animalId tag model 35 | -------------------------------------------------------------------------------- /src/Critter4Us/Model.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.Model 2 | ( Model 3 | , initialModel 4 | , addAnimal 5 | , addAnimalTag 6 | ) 7 | where 8 | 9 | import Prelude 10 | import Critter4Us.Animal (Animal) 11 | import Critter4Us.Animal as Animal 12 | -- import Critter4Us.TagDb (TagDb) 13 | -- import Critter4Us.TagDb as TagDb 14 | import Data.Map (Map) 15 | import Data.Map as Map 16 | import Data.Lens (Lens', lens, over, setJust) 17 | import Data.Lens.At (at) 18 | import Data.Maybe (Maybe) 19 | 20 | type Model = 21 | { animals :: Map Animal.Id Animal 22 | } 23 | 24 | initialModel :: Model 25 | initialModel = 26 | { animals : Map.singleton startingAnimal.id startingAnimal 27 | } 28 | where 29 | startingAnimal = 30 | Animal.named "Genesis" 3838 # Animal.addTag "mare" 31 | 32 | addAnimalTag :: Animal.Id -> String -> Model -> Model 33 | addAnimalTag id tag = 34 | over (_oneAnimal id) (map $ Animal.addTag tag) 35 | 36 | addAnimal :: Animal.Id -> String -> Model -> Model 37 | addAnimal id name = 38 | setJust (_oneAnimal id) (Animal.named name id) 39 | 40 | {- Internal -} 41 | 42 | _animals :: Lens' Model (Map Animal.Id Animal) 43 | _animals = 44 | lens _.animals $ _ { animals = _ } 45 | 46 | _oneAnimal :: Animal.Id -> Lens' Model (Maybe Animal) 47 | _oneAnimal id = 48 | _animals <<< at id 49 | 50 | -------------------------------------------------------------------------------- /src/Critter4Us/TagDb.purs: -------------------------------------------------------------------------------- 1 | module Critter4Us.TagDb 2 | ( empty 3 | , addTag 4 | , tagsFor 5 | , idsFor 6 | , TagDb 7 | , Tags 8 | , Ids 9 | ) 10 | where 11 | 12 | import Prelude 13 | import Critter4UsRefactored.Animal as Animal 14 | import Data.Map as Map 15 | import Data.Map (Map) 16 | import Data.Lens (Lens', lens, over, view) 17 | import Data.Lens.At (at) 18 | import Data.Maybe (Maybe(..), fromMaybe) 19 | import Data.Unfoldable (class Unfoldable, singleton) 20 | 21 | type Tags = Array String 22 | type Ids = Array Animal.Id 23 | 24 | type TagDb = 25 | { tagsById :: Map Animal.Id Tags 26 | , idsByTag :: Map String Ids 27 | } 28 | 29 | empty :: TagDb 30 | empty = 31 | { tagsById : Map.empty 32 | , idsByTag : Map.empty 33 | } 34 | 35 | 36 | addTag :: Animal.Id -> String -> TagDb -> TagDb 37 | addTag id tag db = 38 | db 39 | # addTagTo id tag 40 | # addIdTo tag id 41 | 42 | tagsFor :: Animal.Id -> TagDb -> Tags 43 | tagsFor id tagDb = 44 | view (_idTags id) tagDb # fromMaybe [] 45 | 46 | idsFor :: String -> TagDb -> Ids 47 | idsFor name tagDb = 48 | view (_tagIds name) tagDb # fromMaybe [] 49 | 50 | 51 | --- Helpers 52 | 53 | addTagTo :: Animal.Id -> String -> TagDb -> TagDb 54 | addTagTo id tag = 55 | over (_idTags id) $ appendOrCreate tag 56 | 57 | addIdTo :: String -> Animal.Id -> TagDb -> TagDb 58 | addIdTo tag id = 59 | over (_tagIds tag) $ appendOrCreate id 60 | 61 | -- I can't find a Lens function that does this for me. 62 | appendOrCreate :: forall a f. Monoid (f a) => Unfoldable f => 63 | a -> Maybe (f a) -> Maybe (f a) 64 | appendOrCreate new = 65 | fromMaybe mempty 66 | >>> (_ <> singleton new) 67 | >>> Just 68 | 69 | -- Lenses 70 | 71 | _tagsById :: Lens' TagDb (Map Animal.Id Tags) 72 | _tagsById = 73 | lens _.tagsById $ _ { tagsById = _ } 74 | 75 | _idsByTag :: Lens' TagDb (Map String Ids) 76 | _idsByTag = 77 | lens _.idsByTag $ _ { idsByTag = _ } 78 | 79 | _idTags :: Animal.Id -> Lens' TagDb (Maybe (Array String)) 80 | _idTags id = 81 | _tagsById <<< at id 82 | 83 | _tagIds :: String -> Lens' TagDb (Maybe (Array Animal.Id)) 84 | _tagIds tag = 85 | _idsByTag <<< at tag 86 | 87 | -------------------------------------------------------------------------------- /src/Critter4UsRefactored/Animal.purs: -------------------------------------------------------------------------------- 1 | module Critter4UsRefactored.Animal 2 | ( Animal 3 | , Id 4 | , Tags 5 | , named 6 | ) 7 | where 8 | 9 | type Id = Int 10 | type Tags = Array String 11 | 12 | type Animal = 13 | { id :: Id 14 | , name :: String 15 | } 16 | 17 | named :: String -> Id -> Animal 18 | named name id = 19 | { id, name } 20 | 21 | -------------------------------------------------------------------------------- /src/Critter4UsRefactored/Main.purs: -------------------------------------------------------------------------------- 1 | module Critter4UsRefactored.Main where 2 | 3 | {- For the repl, use these imports: 4 | 5 | import Critter4UsRefactored.Main 6 | import Critter4UsRefactored.Model 7 | import Critter4Us.TagDb (tagsFor, idsFor) 8 | 9 | initialModel 10 | update initialModel (AddAnimal 1 "Bossy") 11 | update initialModel (AddTag 3838 "skittish") 12 | 13 | m = update initialModel (AddTag 3838 "skittish") 14 | tagsFor 3838 m.tagDb 15 | idsFor "skittish" m.tagDb 16 | idsFor "missing" m.tagDb 17 | 18 | -} 19 | 20 | import Critter4UsRefactored.Animal as Animal 21 | import Critter4UsRefactored.Model as Model 22 | import Critter4UsRefactored.Model (Model) 23 | 24 | data Action 25 | = AddAnimal Animal.Id String 26 | | AddTag Animal.Id String 27 | 28 | 29 | update :: Model -> Action -> Model 30 | 31 | update model (AddAnimal animalId name) = 32 | Model.addAnimal animalId name model 33 | 34 | update model (AddTag animalId tag) = 35 | Model.addAnimalTag animalId tag model 36 | -------------------------------------------------------------------------------- /src/Critter4UsRefactored/Model.purs: -------------------------------------------------------------------------------- 1 | module Critter4UsRefactored.Model 2 | ( Model 3 | , initialModel 4 | , addAnimal 5 | , addAnimalTag 6 | ) 7 | where 8 | 9 | import Prelude 10 | import Critter4UsRefactored.Animal (Animal) 11 | import Critter4UsRefactored.Animal as Animal 12 | import Critter4Us.TagDb (TagDb) 13 | import Critter4Us.TagDb as TagDb 14 | import Data.Map (Map) 15 | import Data.Map as Map 16 | import Data.Lens (Lens', lens, over, setJust) 17 | import Data.Lens.At (at) 18 | import Data.Maybe (Maybe) 19 | 20 | type Model = 21 | { animals :: Map Animal.Id Animal 22 | , tagDb :: TagDb 23 | } 24 | 25 | initialModel :: Model 26 | initialModel = 27 | { animals : Map.singleton startingAnimal.id startingAnimal 28 | , tagDb : TagDb.addTag startingAnimal.id "mare" TagDb.empty 29 | } 30 | where 31 | startingAnimal = 32 | Animal.named "Genesis" 3838 33 | 34 | addAnimalTag :: Animal.Id -> String -> Model -> Model 35 | addAnimalTag id tag = 36 | over _tagDb $ TagDb.addTag id tag 37 | 38 | addAnimal :: Animal.Id -> String -> Model -> Model 39 | addAnimal id name = 40 | setJust (_oneAnimal id) (Animal.named name id) 41 | 42 | {- Internal -} 43 | 44 | _animals :: Lens' Model (Map Animal.Id Animal) 45 | _animals = 46 | lens _.animals $ _ { animals = _ } 47 | 48 | _tagDb :: Lens' Model TagDb 49 | _tagDb = 50 | lens _.tagDb $ _ { tagDb = _ } 51 | 52 | _oneAnimal :: Animal.Id -> Lens' Model (Maybe Animal) 53 | _oneAnimal id = 54 | _animals <<< at id 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/Index.purs: -------------------------------------------------------------------------------- 1 | module Index where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Index 6 | 7 | import Data.Maybe 8 | import Data.Lens 9 | import Data.Map as Map 10 | import Data.Lens.At (at) 11 | import Data.Lens.Index (ix) 12 | import Data.String as String 13 | 14 | -} 15 | 16 | import Prelude 17 | import Data.Maybe (Maybe) 18 | import Data.Lens (Lens', Traversal', _1, traversed) 19 | import Data.Lens.At (class At, at) 20 | import Data.Lens.Index (class Index, ix) 21 | import Data.Traversable (class Traversable) 22 | import Data.Tuple (Tuple) 23 | 24 | 25 | _at1 :: forall s a . At s Int a => 26 | Lens' s (Maybe a) 27 | _at1 = at 1 28 | 29 | _ix1 :: forall s a . Index s Int a => 30 | Traversal' s a 31 | _ix1 = ix 1 32 | 33 | {- Composition -} 34 | 35 | _trav_ix1 :: forall trav indexed a. 36 | Traversable trav => Index indexed Int a => 37 | Traversal' (trav indexed) a 38 | 39 | _trav_ix1 = traversed <<< ix 1 40 | 41 | 42 | _ix1_trav :: forall indexed trav a. 43 | Index indexed Int (trav a) => Traversable trav => 44 | Traversal' indexed a 45 | _ix1_trav = ix 1 <<< traversed 46 | 47 | 48 | _at1_ix1 :: forall keyed indexed a. 49 | At keyed Int indexed => Index indexed Int a => 50 | Traversal' keyed a 51 | _at1_ix1 = at 1 <<< traversed <<< ix 1 52 | 53 | 54 | {- Composition exercise -} 55 | 56 | _1_ix1 :: forall indexed a _1_ . 57 | Index indexed Int a => 58 | Traversal' (Tuple indexed _1_) a 59 | _1_ix1 = _1 <<< ix 1 60 | 61 | 62 | _ix1_1 :: forall indexed a _1_ . 63 | Index indexed Int (Tuple a _1_) => 64 | Traversal' indexed a 65 | _ix1_1 = ix 1 <<< _1 66 | 67 | 68 | _ix1_at1 :: forall indexed keyed a. 69 | Index indexed Int keyed => At keyed Int a => 70 | Traversal' indexed (Maybe a) 71 | _ix1_at1 = ix 1 <<< at 1 72 | 73 | _ix1_ix1 :: forall indexed1 indexed2 a. 74 | Index indexed1 Int indexed2 => 75 | Index indexed2 Int a => 76 | Traversal' indexed1 a 77 | _ix1_ix1 = ix 1 <<< ix 1 78 | -------------------------------------------------------------------------------- /src/IndexStart.purs: -------------------------------------------------------------------------------- 1 | module IndexStart where 2 | 3 | -- Exercises for the chapter on `Index` optics. 4 | 5 | {- 6 | 7 | import Prelude 8 | 9 | import Data.Maybe 10 | import Data.Lens 11 | import Data.Lens.At 12 | import Data.Lens.Index 13 | import Data.Traversable 14 | import Data.Tuple 15 | 16 | 17 | _1_ix1 :: 18 | _1_ix1 = _1 <<< ix 1 19 | 20 | 21 | _ix1_1 :: 22 | _ix1_1 = ix 1 <<< _1 23 | 24 | 25 | _ix1_at1 :: 26 | _ix1_at1 = ix 1 <<< at 1 27 | 28 | _ix1_ix1 :: 29 | _ix1_ix1 = ix 1 <<< ix 1 30 | -} 31 | -------------------------------------------------------------------------------- /src/Intro.purs: -------------------------------------------------------------------------------- 1 | module Intro where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Intro 6 | import Data.Map as Map 7 | import Critter4Us.Animal as Animal 8 | import Data.Maybe 9 | import Data.Lens as Lens 10 | -} 11 | 12 | -- Examples used in the introduction. 13 | -- This file isn't mentioned in the book. 14 | 15 | import Prelude 16 | import Critter4Us.Animal as Animal 17 | import Critter4Us.Animal (Animal) 18 | import Critter4Us.Model as Model 19 | import Critter4Us.Model (Model) 20 | 21 | import Data.Maybe (Maybe) 22 | import Data.Map as Map 23 | import Data.Map (Map) 24 | 25 | import Data.Lens.At (at) 26 | import Data.Lens (Lens', lens) 27 | 28 | model :: Model 29 | model = Model.initialModel 30 | 31 | viewAnimal :: Animal.Id -> Model -> Maybe Animal 32 | viewAnimal id = _.animals >>> Map.lookup id 33 | 34 | _animal :: Animal.Id -> Model -> Maybe Animal 35 | _animal id = _.animals >>> Map.lookup id 36 | 37 | view :: forall whole part . (whole -> part) -> whole -> part 38 | view optic whole = optic whole 39 | 40 | _animals :: Lens' Model (Map Animal.Id Animal) 41 | _animals = 42 | lens _.animals $ _ { animals = _ } 43 | 44 | _animal' :: Animal.Id -> Lens' Model (Maybe Animal) 45 | _animal' id = _animals <<< at id 46 | -------------------------------------------------------------------------------- /src/Map.purs: -------------------------------------------------------------------------------- 1 | module Map where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Map 6 | 7 | import Data.Map as Map 8 | import Data.Map (Map) 9 | import Data.Set as Set 10 | 11 | import Data.Maybe 12 | import Data.Tuple 13 | import Data.String as String 14 | 15 | import Data.Lens 16 | import Data.Lens.At (at) 17 | import Foreign.Object as Object 18 | 19 | -} 20 | 21 | import Prelude 22 | import Data.Tuple (Tuple) 23 | import Data.Maybe (Maybe(..)) 24 | 25 | import Data.Map as Map 26 | import Data.Map (Map) 27 | import Data.Set (Set) 28 | 29 | import Data.Lens (lens, Lens', _1, _2) 30 | import Data.Lens.At (at, class At) 31 | 32 | 33 | _key :: forall focus . 34 | Lens' (Map String focus) (Maybe focus) 35 | _key = 36 | lens getter setter 37 | where 38 | getter = Map.lookup "key" 39 | setter whole wrapped = 40 | case wrapped of 41 | Just new -> Map.insert "key" new whole 42 | Nothing -> Map.delete "key" whole 43 | 44 | 45 | _atKey :: forall key focus . Ord key => 46 | key -> Lens' (Map key focus) (Maybe focus) 47 | _atKey key = 48 | lens getter setter 49 | where 50 | getter = Map.lookup key 51 | setter whole wrapped = 52 | case wrapped of 53 | Just new -> Map.insert key new whole 54 | Nothing -> Map.delete key whole 55 | 56 | 57 | 58 | _at3 :: forall whole part. At whole Int part => 59 | Lens' whole (Maybe part) 60 | _at3 = at 3 61 | 62 | 63 | _at3' :: forall part. Lens' (Map Int part) (Maybe part) 64 | _at3' = _at3 65 | 66 | -- 67 | 68 | type Rec= { field :: Maybe Int } 69 | 70 | _field :: Lens' Rec (Maybe Int) 71 | _field = lens _.field $ _ { field = _ } 72 | 73 | 74 | 75 | _element :: forall a . Ord a => a -> Lens' (Set a) (Maybe Unit) 76 | _element x = at x 77 | 78 | composed :: forall focus focusHolder _1_ _2_ . 79 | At focusHolder Int focus => 80 | Lens' 81 | (Tuple (Tuple _1_ focusHolder) _2_) 82 | (Maybe focus) 83 | composed = _1 <<< _2 <<< at 3 84 | -------------------------------------------------------------------------------- /src/Product.purs: -------------------------------------------------------------------------------- 1 | module Product where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Product 6 | import Data.Lens (lens, view, set, over, _1, _2) 7 | 8 | import Data.Tuple 9 | import Data.String as String 10 | -} 11 | 12 | import Prelude 13 | import Data.Tuple (Tuple(..), fst) 14 | import Data.Lens (lens, Lens, Lens', _2) 15 | import Data.Profunctor.Strong (class Strong) 16 | 17 | {- Section: Tuple -} 18 | 19 | aTuple :: Tuple String Int 20 | aTuple = Tuple "one" 1 21 | 22 | 23 | -- For this annotation, I'm using the same type the compiler would infer: 24 | _first :: forall p t6 t7 t8. Strong p => 25 | p t6 t8 -> p (Tuple t6 t7) (Tuple t8 t7) 26 | _first = 27 | lens getter setter 28 | where 29 | getter = fst 30 | setter (Tuple _ kept) new = Tuple new kept 31 | 32 | -- A more readable type annotation would be this: 33 | _first' :: forall a b ignored . 34 | Lens (Tuple a ignored) 35 | (Tuple b ignored) 36 | a b 37 | _first' = _first 38 | 39 | {- Section: Records -} 40 | 41 | type Event = 42 | { subject :: String 43 | , object :: String 44 | , action :: String 45 | , count :: Int 46 | } 47 | 48 | duringNetflix :: Event 49 | duringNetflix = { subject : "Brian" 50 | , object : "Dawn" 51 | , action : "cafuné" 52 | , count : 0 53 | } 54 | 55 | -- A verbose way of defining a record lens 56 | _action :: forall a b rest . 57 | Lens {action :: a | rest } 58 | {action :: b | rest } 59 | a b 60 | _action = 61 | lens getter setter 62 | where 63 | getter = _.action 64 | setter whole new = whole { action = new } 65 | 66 | 67 | _count :: Lens' Event Int 68 | -- Could also use the long form: 69 | -- _count :: Lens Event Event Int Int 70 | _count = lens _.count $ _ { count = _ } 71 | 72 | 73 | {- Section: Composing lenses -} 74 | 75 | both :: Tuple String Event 76 | both = Tuple "example" duringNetflix 77 | 78 | _bothCount :: Lens' (Tuple String Event) Int 79 | _bothCount = _2 <<< _count 80 | -------------------------------------------------------------------------------- /src/ProductExercises.purs: -------------------------------------------------------------------------------- 1 | module ProductExercises where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Product 6 | import Data.Tuple.Nested 7 | import Data.Lens 8 | import Data.Lens as Lens 9 | 10 | -} 11 | 12 | {- 13 | 14 | -- These are imports you're likely to need. 15 | -- They're commented out to keep `pulp build` from whining about them. 16 | 17 | import Product (both, Event) 18 | 19 | import Prelude 20 | import Data.Tuple (Tuple(..), fst, snd) 21 | import Data.Tuple.Nested (T2, T3, T4, get1, get2, get3) 22 | import Data.Lens (lens, set, view, over, _2, Lens, Lens') 23 | 24 | -} 25 | 26 | -------------------------------------------------------------------------------- /src/ProductSolutions.purs: -------------------------------------------------------------------------------- 1 | module ProductSolutions where 2 | 3 | {- To help with the second exercise, paste the following into the repl: 4 | 5 | import Product 6 | import Data.Tuple.Nested 7 | import Data.Lens 8 | import Data.Lens as Lens 9 | 10 | -} 11 | 12 | import Product (both, Event) 13 | 14 | import Prelude 15 | import Data.Tuple (Tuple(..), fst, snd) 16 | import Data.Tuple.Nested (T2, T3, T4, get1, get2, get3) 17 | import Data.Lens (lens, set, view, over, _2, Lens, Lens') 18 | 19 | 20 | {- Composition Exercise -} 21 | 22 | -- 1: 23 | 24 | _object :: Lens' Event String 25 | _object = lens _.object (_ { object = _ }) 26 | 27 | -- 2: show 28 | 29 | stringified :: Tuple String String 30 | stringified = over _2 show both 31 | 32 | -- 3: Take your pick of these single-line solutions 33 | 34 | solution1 :: Tuple String String 35 | solution1 = 36 | set _2 (view (_2 <<< _object) both) both 37 | 38 | solution2 :: Tuple String String 39 | solution2 = 40 | view (_2 <<< _object) both # flip (set _2) both 41 | 42 | solution3 :: Tuple String String 43 | solution3 = 44 | flip (set _2) both $ view (_2 <<< _object) both 45 | 46 | -- Or, if you want to be one of those *kids these days* with your 47 | -- "readability" and your "intention-revealing names" and all that: 48 | 49 | solution4 :: Tuple String String 50 | solution4 = 51 | let 52 | new = view (_2 <<< _object) both 53 | in 54 | set _2 new both 55 | 56 | 57 | 58 | {- The Second Composition Exercise -} 59 | 60 | 61 | -- Part 1: 62 | 63 | set1 :: forall focus rest new. 64 | T2 focus rest -> new -> T2 new rest 65 | set1 (Tuple _ rest) new = 66 | Tuple new rest 67 | 68 | set2 :: forall p1 focus rest new. 69 | T3 p1 focus rest -> new -> T3 p1 new rest 70 | set2 (Tuple head rest) new = 71 | Tuple head (set1 rest new) 72 | 73 | set3 :: forall p1 p2 focus rest new. 74 | T4 p1 p2 focus rest -> new -> T4 p1 p2 new rest 75 | set3 (Tuple head rest) new = 76 | Tuple head (set2 rest new) 77 | 78 | -- Part 2 79 | 80 | _elt1 :: forall focus new rest. 81 | Lens (T2 focus rest) (T2 new rest) focus new 82 | _elt1 = lens get1 set1 83 | 84 | 85 | _elt2 :: forall p1 focus new rest. 86 | Lens (T3 p1 focus rest) (T3 p1 new rest) focus new 87 | _elt2 = lens get2 set2 88 | 89 | _elt3 :: forall p1 p2 focus new rest. 90 | Lens (T4 p1 p2 focus rest) (T4 p1 p2 new rest) focus new 91 | _elt3 = lens get3 set3 92 | 93 | 94 | 95 | 96 | {- Law exercise -} 97 | 98 | -- An easy way to violate set-get is to use a different focus for the 99 | -- setter and getter. 100 | 101 | _setGetOops :: forall a. Lens' (Tuple a a) a 102 | _setGetOops = 103 | lens getter setter 104 | where 105 | setter (Tuple _ kept) new = Tuple new kept 106 | getter = snd -- should be `fst` 107 | 108 | -- > Tuple 1 2 # set _setGetOops 3333 # view _setGetOops 109 | -- 2 110 | 111 | 112 | 113 | -- The following satisfies set-get but not get-set: 114 | 115 | _getSetOops :: forall a. Lens' (Tuple a a) a 116 | _getSetOops = 117 | lens getter setter 118 | where 119 | getter = fst 120 | setter (Tuple _ _) new = Tuple new new 121 | 122 | -- > view _getSetOops (Tuple 1 2) 123 | -- 1 124 | 125 | -- > set _getSetOops 1 (Tuple 1 2) 126 | -- (Tuple 1 1) 127 | 128 | 129 | 130 | 131 | -- The solution for `set-get` also violates `set-set`: 132 | 133 | -- > set _setGetOops 333 t == set _setGetOops 3333 (set _setGetOops 3333 t) 134 | -- false 135 | -------------------------------------------------------------------------------- /src/SumType.purs: -------------------------------------------------------------------------------- 1 | module SumType where 2 | 3 | {- If you want to try out examples, paste the following into the repl. 4 | 5 | import SumType 6 | import Data.Lens 7 | import Data.Lens.Prism 8 | import Color as Color 9 | import Data.Maybe 10 | import Data.Either 11 | import Data.Tuple 12 | import Data.Lens.At 13 | import Data.Lens.Index 14 | -} 15 | 16 | import Prelude 17 | import Data.Lens (Prism', Traversal, Traversal', _1, _Left, _Right, _Just, is, 18 | isn't, nearly, only, preview, prism, prism', review, traversed) 19 | import Data.Lens.At (class At, at) 20 | import Data.Lens.Index (class Index, ix) 21 | 22 | import Color (Color) 23 | import Color as Color 24 | 25 | import Data.Generic.Rep (class Generic) 26 | import Data.Generic.Rep.Eq as GEq 27 | import Data.Generic.Rep.Show as GShow 28 | import Data.Maybe (Maybe(..), maybe) 29 | import Data.Either (Either(..)) 30 | import Data.Tuple (Tuple) 31 | import Data.Traversable (class Traversable) 32 | 33 | 34 | {- The types in question -} 35 | 36 | newtype Percent = Percent Number 37 | data Point = Point Number Number 38 | 39 | data Fill -- think of a paint program filling a shape 40 | = Solid Color 41 | | LinearGradient Color Color Percent 42 | | RadialGradient Color Color Point 43 | | NoFill 44 | 45 | {------ Some samples to work with ------} 46 | 47 | fillBlackToWhite :: Fill 48 | fillBlackToWhite = LinearGradient Color.black Color.white $ Percent 3.3 49 | 50 | fillWhiteToBlack :: Fill 51 | fillWhiteToBlack = LinearGradient Color.white Color.black $ Percent 3.3 52 | 53 | fillRadial :: Fill 54 | fillRadial = RadialGradient Color.white Color.black $ Point 1.0 3.4 55 | 56 | 57 | {------ Making prisms with Maybe and `prism'` ------} 58 | 59 | -- `prism'` (note the apostrophe) takes two functions. One is a data 60 | -- constructor for the type in question. The other converts your 61 | -- desired case to a `Just ` or `Nothing`. 62 | 63 | _solidFill :: Prism' Fill Color 64 | _solidFill = prism' constructor focuser 65 | where 66 | constructor = Solid 67 | focuser fill = case fill of 68 | Solid color -> Just color 69 | otherCases -> Nothing 70 | 71 | -- In real life, you might abbreviate the above to this: 72 | 73 | _solidFill' :: Prism' Fill Color 74 | _solidFill' = prism' Solid case _ of 75 | Solid color -> Just color 76 | _ -> Nothing 77 | 78 | 79 | 80 | {------ Basic usage: `preview`, `review`, `is`, and `isn't` ------} 81 | 82 | -- After building a prism, you focus in on a color with `preview`: 83 | 84 | s1 :: Maybe Color 85 | s1 = preview _solidFill (Solid Color.white) 86 | -- (Just rgba 255 255 255 1.0) 87 | 88 | s2 :: Maybe Color 89 | s2 = preview _solidFill fillRadial 90 | -- Nothing 91 | 92 | -- ... or you can create a Fill from a color with `review`: 93 | 94 | s3 :: Fill 95 | s3 = review _solidFill Color.white 96 | -- (Solid rgba 255 255 255 1.0) 97 | 98 | -- ... or you can ask whether a given value matches the prism: 99 | 100 | s4 :: Boolean 101 | s4 = is _solidFill (Solid Color.white) :: Boolean 102 | -- true 103 | 104 | s5 :: Boolean 105 | s5 = isn't _solidFill (Solid Color.white) :: Boolean 106 | -- false 107 | 108 | 109 | {------ Making prisms with Either and `prism` ------} 110 | 111 | _anotherSolidFill :: Prism' Fill Color 112 | _anotherSolidFill = prism Solid case _ of 113 | Solid color -> Right color 114 | otherCases -> Left otherCases 115 | 116 | 117 | {------ Making prisms with `only` ------} 118 | 119 | _solidWhite :: Prism' Fill Unit 120 | _solidWhite = only (Solid Color.white) 121 | 122 | -- To make the above work, I had to make `Fill` implement `class Eq`. See the 123 | -- end of the file for how. (There may be easier methods these days.) 124 | 125 | {------ Making prisms with `nearly` ------} 126 | 127 | _solidWhite' :: Prism' Fill Unit 128 | _solidWhite' = 129 | nearly (Solid Color.white) case _ of 130 | Solid color -> color == Color.white 131 | _ -> false 132 | 133 | 134 | n5 :: Fill 135 | n5 = review _solidWhite' unit 136 | -- (Solid rgba 204 204 204 1.0) 137 | 138 | 139 | 140 | 141 | {------ Multiple wrapped values ------} 142 | 143 | 144 | -- This would violate the lens laws: 145 | 146 | _centerPoint :: Prism' Fill Point 147 | _centerPoint = prism' constructor focuser 148 | where 149 | focuser = case _ of 150 | RadialGradient _ _ point -> Just point 151 | _ -> Nothing 152 | 153 | constructor point = 154 | RadialGradient Color.black Color.white point 155 | 156 | -- So we must bundle all the `RadialGradient` values. I'll use a record: 157 | 158 | type RadialInterchange = 159 | { color1 :: Color 160 | , color2 :: Color 161 | , center :: Point 162 | } 163 | 164 | _centerPoint' :: Prism' Fill RadialInterchange 165 | _centerPoint' = prism constructor focuser 166 | where 167 | focuser = case _ of 168 | RadialGradient color1 color2 center -> 169 | Right {color1, color2, center} 170 | otherCases -> 171 | Left otherCases 172 | 173 | constructor {color1, color2, center} = 174 | RadialGradient color1 color2 center 175 | 176 | 177 | -- Even though made differently than `_solidFill`, `_centerPoint'` is 178 | -- used the same way: 179 | 180 | l1 :: String 181 | l1 = preview _centerPoint' fillRadial # maybe "!" show 182 | -- "{ color1: rgba 0 0 0 1.0, color2: rgba 255 255 255 1.0, percent: (3.3%) }" 183 | 184 | l2 :: Fill 185 | l2 = review _centerPoint' { color1 : Color.black 186 | , color2 : Color.white 187 | , center : Point 1.3 2.4 188 | } 189 | 190 | 191 | 192 | {------ Composition ------} 193 | 194 | _right_solidFill :: forall ignore. 195 | Prism' (Either ignore Fill) Color 196 | _right_solidFill = _Right <<< _solidFill 197 | 198 | _traversed_solidFill :: forall trav . 199 | Traversable trav => 200 | Traversal' (trav Fill) Color 201 | _traversed_solidFill = traversed <<< _solidFill 202 | 203 | 204 | _right_traversed :: forall trav a b _1_ . 205 | Traversable trav => 206 | Traversal (Either _1_ (trav a)) 207 | (Either _1_ (trav b)) 208 | a b 209 | _right_traversed = _Right <<< traversed 210 | 211 | 212 | _1_solidFill :: forall _1_ . 213 | Traversal' (Tuple Fill _1_) Color 214 | _1_solidFill = _1 <<< _solidFill 215 | 216 | 217 | _left_1 ::forall a b _1_ _2_. 218 | Traversal (Either (Tuple a _1_) _2_) 219 | (Either (Tuple b _1_) _2_) 220 | a b 221 | _left_1 = _Left <<< _1 222 | 223 | 224 | _left_ix1 :: forall _1_ indexed a. 225 | Index indexed Int a => 226 | Traversal' (Either indexed _1_) a 227 | _left_ix1 = _Left <<< ix 1 228 | 229 | 230 | _ix1_left :: forall _1_ indexed a. 231 | Index indexed Int (Either a _1_) => 232 | Traversal' indexed a 233 | _ix1_left = ix 1 <<< _Left 234 | 235 | _at1_just :: forall keyed a . 236 | At keyed Int a => 237 | Traversal' keyed a 238 | _at1_just = at 1 <<< _Just 239 | 240 | 241 | {---- Not used in chapter, but an interesting use of records. ----} 242 | 243 | _hslaSolid :: Prism' Fill { h :: Number, s :: Number, l :: Number, a :: Number } 244 | _hslaSolid = prism' constructor focuser 245 | where 246 | focuser = case _ of 247 | Solid color -> Just $ Color.toHSLA color 248 | _ -> Nothing 249 | 250 | constructor {h,s,l,a} = 251 | Solid $ Color.hsla h s l a 252 | 253 | 254 | {------ Eq and Show are always nice ------} 255 | 256 | -- ... although Eq is only required for `only`. 257 | 258 | derive instance genericPercent :: Generic Percent _ 259 | instance eqPercent :: Eq Percent where 260 | eq = GEq.genericEq 261 | instance showPercent :: Show Percent where 262 | show (Percent f) = "(" <> show f <> "%)" 263 | 264 | derive instance genericPoint :: Generic Point _ 265 | instance eqPoint :: Eq Point where 266 | eq = GEq.genericEq 267 | instance showPoint :: Show Point where 268 | show (Point x y) = "(" <> show x <> ", " <> show y <> ")" 269 | 270 | derive instance genericFill :: Generic Fill _ 271 | instance eqFill :: Eq Fill where 272 | eq = GEq.genericEq 273 | instance showFill :: Show Fill where 274 | show x = GShow.genericShow x 275 | 276 | 277 | -------------------------------------------------------------------------------- /src/SumTypeSolutions.purs: -------------------------------------------------------------------------------- 1 | module SumTypeSolutions where 2 | 3 | {- If you want to try out examples, paste the following into the repl. 4 | 5 | import SumTypeSolutions 6 | import Data.Lens 7 | import Data.Lens.Prism 8 | import Data.Maybe 9 | import Data.Either 10 | -} 11 | 12 | import Prelude 13 | import Data.Lens (Prism', prism') 14 | 15 | import Data.Maybe (Maybe(..)) 16 | import Data.Int (fromString) 17 | 18 | -- 1: 19 | _intSource :: Prism' String String 20 | _intSource = 21 | prism' identity focuser 22 | where 23 | focuser s = case (fromString s) of 24 | Just _ -> Just s 25 | Nothing -> Nothing 26 | 27 | {- 28 | The prism laws: 29 | 30 | -- review-preview 31 | > "3838" # review _intSource # preview _intSource 32 | (Just "3838") 33 | 34 | 35 | -- preview-review 36 | > "38383" # preview _intSource <#> review _intSource 37 | (Just "38383") 38 | -} 39 | 40 | 41 | -- 2: 42 | _int :: Prism' String Int 43 | _int = 44 | prism' show focuser 45 | where 46 | focuser s = case (fromString s) of 47 | Just i -> Just i 48 | Nothing -> Nothing 49 | 50 | {- 51 | Yes, it obeys the prism laws. 52 | 53 | The prism laws: 54 | 55 | -- review-preview 56 | > 3838 # review _int # preview _int 57 | (Just 3838) 58 | 59 | -- preview-review 60 | > "38383" # preview _int <#> review _int 61 | (Just "38383") 62 | 63 | -} 64 | 65 | 66 | 67 | -- 3 68 | 69 | -- Well, *I* can't figure out how. Consider this implementation: 70 | 71 | 72 | _word :: forall a . Eq a => a -> Prism' a a 73 | _word focus = 74 | prism' (const focus) focuser 75 | where 76 | focuser a = 77 | if a == focus then 78 | Just a 79 | else 80 | Nothing 81 | 82 | {- 83 | 84 | Now think about the "`preview` retrieves what was given to `review`." law. 85 | 86 | Here's an example of `review`: 87 | 88 | > review (_word "Dawn") "anything" 89 | "Dawn" 90 | 91 | But `preview` doesn't produce (Just "anything"): it can only produce 92 | `(Just "Dawn")` or `Nothing`. 93 | 94 | > preview (_word "Dawn") "Dawn" 95 | (Just "Dawn") 96 | 97 | ... or, to more closely match the example in the statement of the law: 98 | 99 | > _dawn = _word "Dawn" 100 | > "anything" # review _dawn # preview _dawn 101 | (Just "Dawn") 102 | 103 | -} 104 | 105 | -- We can get the prism to return its argument by making `identity` the constructor: 106 | 107 | _word' :: forall a . Eq a => a -> Prism' a a 108 | _word' focus = 109 | prism' identity focuser 110 | --^^^^^^ 111 | where 112 | focuser a = 113 | if a == focus then 114 | Just a 115 | else 116 | Nothing 117 | 118 | {- 119 | That makes `review` produce its input, but now `preview` produces nothing. 120 | 121 | > review (_word' "Dawn") "anything" 122 | "anything" 123 | 124 | > preview (_word' "Dawn") "anything" 125 | Nothing 126 | 127 | ... or: 128 | 129 | > _dawn = _word' "Dawn" 130 | > "anything" # review _dawn # preview _dawn 131 | Nothing 132 | -} 133 | -------------------------------------------------------------------------------- /src/SumTypeStart.purs: -------------------------------------------------------------------------------- 1 | module SumTypeStart where 2 | 3 | {- If you want to try out examples, paste the following into the repl. 4 | 5 | import SumTypeSolutions 6 | import Data.Lens 7 | import Data.Lens.Prism 8 | import Data.Maybe 9 | import Data.Either 10 | -} 11 | 12 | {- Commented out to keep the compiler from whining 13 | import Prelude 14 | import Data.Lens (Prism', prism') 15 | 16 | import Data.Maybe (Maybe(..)) 17 | import Data.Int (fromString) 18 | 19 | -} 20 | -------------------------------------------------------------------------------- /src/Traversal.purs: -------------------------------------------------------------------------------- 1 | module Traversal where 2 | 3 | {- Paste the following into the repl 4 | 5 | import Traversal 6 | 7 | import Data.Maybe 8 | import Data.Either 9 | import Data.Lens 10 | import Data.Lens as Lens 11 | import Data.Tuple 12 | import Data.List 13 | import Data.String as String 14 | import Data.Map as Map 15 | import Data.Lens.At (at) 16 | import Data.Monoid 17 | import Data.Monoid.Additive 18 | 19 | -} 20 | 21 | import Prelude 22 | import Data.Tuple (Tuple(..)) 23 | import Data.Maybe (Maybe) 24 | import Data.Lens (Traversal', Traversal, _1, traversed, element) 25 | import Data.Traversable (class Traversable) 26 | import Data.Lens.At (class At, at) 27 | import Data.Map (Map) 28 | import Data.Map as Map 29 | 30 | 31 | {- Useful structures -} 32 | 33 | tupleMap :: Map Int (Tuple Int String) 34 | tupleMap = Map.fromFoldable [ (Tuple 3 (Tuple 8 "s")) 35 | , (Tuple 4 (Tuple 1 "_2_"))] 36 | 37 | mapArray :: Array (Map Int String) 38 | mapArray = [ Map.singleton 3 "3" 39 | , Map.empty 40 | , Map.singleton 4 "4" 41 | ] 42 | 43 | {- Lenses -} 44 | 45 | _element1 :: Traversal' (Array String) String 46 | _element1 = element 1 traversed 47 | 48 | 49 | {- Solution to exercise about use of `traversed <<< traversed` 50 | 51 | > view (traversed <<< traversed) [["1"], ["2", "3"]] 52 | "123" 53 | 54 | > _trav_trav = traversed <<< traversed 55 | > view _trav_trav $ over _trav_trav Additive [[1], [2, 3]] 56 | (Additive 6) 57 | 58 | -} 59 | 60 | _trav_1 :: forall traversable a b _1_. 61 | Traversable traversable => 62 | Traversal (traversable (Tuple a _1_)) 63 | (traversable (Tuple b _1_)) 64 | a b 65 | _trav_1 = traversed <<< _1 66 | 67 | {- Solution to exercise about use of `traversed <<< _1` 68 | 69 | > preview _trav_1 [ Tuple 1 2, Tuple 3 4 ] 70 | (Just 1) 71 | 72 | -} 73 | 74 | _at3_trav_1 :: forall a _1_ atlike . 75 | At atlike Int (Tuple a _1_) => 76 | Traversal' (Map Int (Tuple a _1_)) a 77 | _at3_trav_1 = at 3 <<< traversed <<< _1 78 | 79 | 80 | 81 | -- Exercise solutions 82 | 83 | _trav_trav :: forall a b trav1 trav2 . 84 | Traversable trav1 => Traversable trav2 => 85 | Traversal (trav1 (trav2 a)) 86 | (trav1 (trav2 b)) 87 | a b 88 | _trav_trav = traversed <<< traversed 89 | 90 | 91 | _1_trav :: forall trav a b _1_ . 92 | Traversable trav => 93 | Traversal (Tuple (trav a) _1_) 94 | (Tuple (trav b) _1_) 95 | a b 96 | _1_trav = _1 <<< traversed 97 | 98 | 99 | _trav_at3 :: forall trav keyed a. 100 | Traversable trav => At keyed Int a => 101 | Traversal' (trav keyed) (Maybe a) 102 | _trav_at3 = traversed <<< at 3 103 | 104 | -- Why must `s` be the same as `t` and `a` be the same as `b`? 105 | -- 106 | -- Consider this: 107 | -- 108 | -- set _trav_at3 5 [Map.singleton 3 "3", Map.singleton 4 "4"] 109 | -- 110 | -- If the optic could change the type, the result would be 111 | -- this nonsensical array: 112 | -- 113 | -- [Map.singleton 3 5, Map.singleton 4 "4"] 114 | 115 | 116 | _at3_trav_1' :: forall a _1_ keyed . 117 | At keyed Int a => 118 | Traversal' (Map Int (Tuple a _1_)) a 119 | _at3_trav_1' = at 3 <<< traversed <<< _1 120 | 121 | -------------------------------------------------------------------------------- /src/TraversalStart.purs: -------------------------------------------------------------------------------- 1 | module TraversalStart where 2 | 3 | {- 4 | 5 | import Prelude 6 | import Data.Tuple (Tuple) 7 | import Data.Maybe (Maybe) 8 | import Data.Lens (Traversal', Traversal, _1, traversed) 9 | import Data.Traversable (class Traversable) 10 | import Data.Lens.At (class At, at) 11 | import Data.Map (Map) 12 | 13 | 14 | _trav_trav :: 15 | _trav_trav = traversed <<< traversed 16 | 17 | 18 | _1_trav :: 19 | _1_trav = _1 <<< traversed 20 | 21 | _trav_at3 :: 22 | _trav_at3 = traversed <<< at 3 23 | 24 | -- Convert the following so that it makes no explicit reference to `Map` 25 | 26 | _at3_trav_1' :: forall a _1_ . 27 | Traversal' (Map Int (Tuple a _1_)) a 28 | _at3_trav_1' = at 3 <<< traversed <<< _1 29 | 30 | -} 31 | 32 | --------------------------------------------------------------------------------