kaushikc.org / lets-lens
this repo has no description
0
fork

Configure Feed

Select the types of activity you want to include in your feed.

merge module reorganisation

Tony Morris 4ddd582d dd1f3370

+792 -826
+2 -2
README.markdown
··· 16 16 to study the history of lenses, then build up to the most recent theories, it is 17 17 best to start at the `Lets.GetSetLens` module. If you wish to derive the 18 18 structure of lenses from first principles, then derive the more modern theories, 19 - start at the `Lets.Lens.Lens` module. 19 + start at the `Lets.Lens` module. 20 20 21 21 Exercises can be recognised by filling in a function body that has a placeholder 22 22 of `error "todo: <function-name>"`. ··· 49 49 described by Twan van Laarhoven. This representation also introduces a 50 50 generalisation of lenses to permit *polymorphic update* of structures. 51 51 52 - ##### `Lets.Lens.Lens` 52 + ##### `Lets.Lens` 53 53 54 54 This series of exercises starts at first principles to derive the concept of a 55 55 lens, as it was first described by Twan van Laarhoven. The derivation then goes
+2 -3
lets-lens.cabal
··· 39 39 hs-source-dirs: src 40 40 41 41 exposed-modules: Lets 42 + Lets.Choice 42 43 Lets.Data 43 44 Lets.GetSetLens 44 45 Lets.Lens 45 - Lets.Lens.Choice 46 - Lets.Lens.Lens 47 - Lets.Lens.Profunctor 48 46 Lets.OpticPolyLens 47 + Lets.Profunctor 49 48 Lets.StoreLens 50 49 51 50 test-suite doctests
+785 -4
src/Lets/Lens.hs
··· 1 + {-# LANGUAGE RankNTypes #-} 2 + 1 3 module Lets.Lens ( 2 - module L 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 3 74 ) where 4 75 5 - import Lets.Lens.Choice as L 6 - import Lets.Lens.Lens as L 7 - import Lets.Lens.Profunctor as L 76 + import Control.Applicative(Applicative((<*>), pure)) 77 + import Data.Bool(bool) 78 + import Data.Char(toUpper) 79 + import Data.Foldable(Foldable(foldMap)) 80 + import Data.Functor((<$>)) 81 + import Data.Map(Map) 82 + import qualified Data.Map as Map(insert, delete, lookup) 83 + import Data.Monoid(Monoid) 84 + import qualified Data.Set as Set(Set, insert, delete, member) 85 + import Data.Traversable(Traversable(traverse)) 86 + 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)) 87 + import Lets.Choice(Choice(left, right)) 88 + import Lets.Profunctor(Profunctor(dimap)) 89 + import Prelude hiding (product) 90 + 91 + -- $setup 92 + -- >>> import qualified Data.Map as Map(fromList) 93 + -- >>> import qualified Data.Set as Set(fromList) 94 + -- >>> import Data.Char(ord) 95 + 96 + -- Let's remind ourselves of Traversable, noting Foldable and Functor. 97 + -- 98 + -- class (Foldable t, Functor t) => Traversable t where 99 + -- traverse :: 100 + -- Applicative f => 101 + -- (a -> f b) 102 + -- -> t a 103 + -- -> f (t b) 104 + 105 + -- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. 106 + -- 107 + -- /Reminder:/ fmap :: Functor t => (a -> b) -> t a -> t b 108 + fmapT :: 109 + Traversable t => 110 + (a -> b) 111 + -> t a 112 + -> t b 113 + fmapT = 114 + error "todo: fmapT" 115 + 116 + -- | Let's refactor out the call to @traverse@ as an argument to @fmapT@. 117 + over :: 118 + ((a -> Identity b) -> s -> Identity t) 119 + -> (a -> b) 120 + -> s 121 + -> t 122 + over = 123 + error "todo: over" 124 + 125 + -- | Here is @fmapT@ again, passing @traverse@ to @over@. 126 + fmapTAgain :: 127 + Traversable t => 128 + (a -> b) 129 + -> t a 130 + -> t b 131 + fmapTAgain = 132 + error "todo: fmapTAgain" 133 + 134 + -- | Let's create a type-alias for this type of function. 135 + type Set s t a b = 136 + (a -> Identity b) 137 + -> s 138 + -> Identity t 139 + 140 + -- | Let's write an inverse to @over@ that does the @Identity@ wrapping & 141 + -- unwrapping. 142 + sets :: 143 + ((a -> b) -> s -> t) 144 + -> Set s t a b 145 + sets = 146 + error "todo: sets" 147 + 148 + mapped :: 149 + Functor f => 150 + Set (f a) (f b) a b 151 + mapped = 152 + error "todo: mapped" 153 + 154 + set :: 155 + Set s t a b 156 + -> s 157 + -> b 158 + -> t 159 + set = 160 + error "todo: set" 161 + 162 + ---- 163 + 164 + -- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. 165 + -- 166 + -- /Reminder:/ foldMap :: (Foldable t, Monoid b) => (a -> b) -> t a -> b 167 + foldMapT :: 168 + (Traversable t, Monoid b) => 169 + (a -> b) 170 + -> t a 171 + -> b 172 + foldMapT = 173 + error "todo: foldMapT" 174 + 175 + -- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@. 176 + foldMapOf :: 177 + ((a -> Const r b) -> s -> Const r t) 178 + -> (a -> r) 179 + -> s 180 + -> r 181 + foldMapOf = 182 + error "todo: foldMapOf" 183 + 184 + -- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@. 185 + foldMapTAgain :: 186 + (Traversable t, Monoid b) => 187 + (a -> b) 188 + -> t a 189 + -> b 190 + foldMapTAgain = 191 + error "todo: foldMapTAgain" 192 + 193 + -- | Let's create a type-alias for this type of function. 194 + type Fold s t a b = 195 + forall r. 196 + Monoid r => 197 + (a -> Const r b) 198 + -> s 199 + -> Const r t 200 + 201 + -- | Let's write an inverse to @foldMapOf@ that does the @Const@ wrapping & 202 + -- unwrapping. 203 + folds :: 204 + ((a -> b) -> s -> t) 205 + -> (a -> Const b a) 206 + -> s 207 + -> Const t s 208 + folds = 209 + error "todo: folds" 210 + 211 + folded :: 212 + Foldable f => 213 + Fold (f a) (f a) a a 214 + folded = 215 + error "todo: folded" 216 + 217 + ---- 218 + 219 + -- | @Get@ is like @Fold@, but without the @Monoid@ constraint. 220 + type Get r s a = 221 + (a -> Const r a) 222 + -> s 223 + -> Const r s 224 + 225 + get :: 226 + Get a s a 227 + -> s 228 + -> a 229 + get = 230 + error "todo: get" 231 + 232 + ---- 233 + 234 + -- | Let's generalise @Identity@ and @Const r@ to any @Applicative@ instance. 235 + type Traversal s t a b = 236 + forall f. 237 + Applicative f => 238 + (a -> f b) 239 + -> s 240 + -> f t 241 + 242 + -- | Traverse both sides of a pair. 243 + both :: 244 + Traversal (a, a) (b, b) a b 245 + both = 246 + error "todo: both" 247 + 248 + -- | Traverse the left side of @Either@. 249 + traverseLeft :: 250 + Traversal (Either a x) (Either b x) a b 251 + traverseLeft = 252 + error "todo: traverseLeft" 253 + 254 + -- | Traverse the right side of @Either@. 255 + traverseRight :: 256 + Traversal (Either x a) (Either x b) a b 257 + traverseRight = 258 + error "todo: traverseRight" 259 + 260 + type Traversal' a b = 261 + Traversal a a b b 262 + 263 + ---- 264 + 265 + -- | @Const r@ is @Applicative@, if @Monoid r@, however, without the @Monoid@ 266 + -- constraint (as in @Get@), the only shared abstraction between @Identity@ and 267 + -- @Const r@ is @Functor@. 268 + -- 269 + -- Consequently, we arrive at our lens derivation: 270 + type Lens s t a b = 271 + forall f. 272 + Functor f => 273 + (a -> f b) 274 + -> s 275 + -> f t 276 + 277 + ---- 278 + 279 + -- | A prism is a less specific type of traversal. 280 + type Prism s t a b = 281 + forall p f. 282 + (Choice p, Applicative f) => 283 + p a (f b) 284 + -> p s (f t) 285 + 286 + _Left :: 287 + Prism (Either a x) (Either b x) a b 288 + _Left = 289 + error "todo: _Left" 290 + 291 + _Right :: 292 + Prism (Either x a) (Either x b) a b 293 + _Right = 294 + error "todo: _Right" 295 + 296 + prism :: 297 + (b -> t) 298 + -> (s -> Either t a) 299 + -> Prism s t a b 300 + prism = 301 + error "todo: prism" 302 + 303 + _Just :: 304 + Prism (Maybe a) (Maybe b) a b 305 + _Just = 306 + error "todo: _Just" 307 + 308 + _Nothing :: 309 + Prism (Maybe a) (Maybe a) () () 310 + _Nothing = 311 + error "todo: _Nothing" 312 + 313 + setP :: 314 + Prism s t a b 315 + -> s 316 + -> Either t a 317 + setP = 318 + error "todo: setP" 319 + 320 + getP :: 321 + Prism s t a b 322 + -> b 323 + -> t 324 + getP = 325 + error "todo: getP" 326 + 327 + type Prism' a b = 328 + Prism a a b b 329 + 330 + ---- 331 + 332 + -- | 333 + -- 334 + -- >>> modify fstL (+1) (0 :: Int, "abc") 335 + -- (1,"abc") 336 + -- 337 + -- >>> modify sndL (+1) ("abc", 0 :: Int) 338 + -- ("abc",1) 339 + -- 340 + -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 341 + -- 342 + -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 343 + modify :: 344 + Lens s t a b 345 + -> (a -> b) 346 + -> s 347 + -> t 348 + modify = 349 + error "todo: modify" 350 + 351 + -- | An alias for @modify@. 352 + (%~) :: 353 + Lens s t a b 354 + -> (a -> b) 355 + -> s 356 + -> t 357 + (%~) = 358 + modify 359 + 360 + infixr 4 %~ 361 + 362 + -- | 363 + -- 364 + -- >>> fstL .~ 1 $ (0 :: Int, "abc") 365 + -- (1,"abc") 366 + -- 367 + -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 368 + -- ("abc",1) 369 + -- 370 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 371 + -- 372 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 373 + (.~) :: 374 + Lens s t a b 375 + -> b 376 + -> s 377 + -> t 378 + (.~) = 379 + error "todo: (.~)" 380 + 381 + infixl 5 .~ 382 + 383 + -- | 384 + -- 385 + -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 386 + -- (13,"abc") 387 + -- 388 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 389 + -- Just (20,"abc") 390 + -- 391 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 392 + -- Nothing 393 + fmodify :: 394 + Functor f => 395 + Lens s t a b 396 + -> (a -> f b) 397 + -> s 398 + -> f t 399 + fmodify = 400 + error "todo: fmodify" 401 + 402 + -- | 403 + -- 404 + -- >>> fstL |= Just 3 $ (7, "abc") 405 + -- Just (3,"abc") 406 + -- 407 + -- >>> (fstL |= (+1) $ (3, "abc")) 17 408 + -- (18,"abc") 409 + (|=) :: 410 + Functor f => 411 + Lens s t a b 412 + -> f b 413 + -> s 414 + -> f t 415 + (|=) = 416 + error "todo: (|=)" 417 + 418 + infixl 5 |= 419 + 420 + -- | 421 + -- 422 + -- >>> modify fstL (*10) (3, "abc") 423 + -- (30,"abc") 424 + fstL :: 425 + Lens (a, x) (b, x) a b 426 + fstL = 427 + error "todo: fstL" 428 + 429 + -- | 430 + -- 431 + -- >>> modify sndL (++ "def") (13, "abc") 432 + -- (13,"abcdef") 433 + sndL :: 434 + Lens (x, a) (x, b) a b 435 + sndL = 436 + error "todo: sndL" 437 + 438 + -- | 439 + -- 440 + -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 441 + -- Just 'c' 442 + -- 443 + -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 444 + -- Nothing 445 + -- 446 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 447 + -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 448 + -- 449 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 450 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 451 + -- 452 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 453 + -- fromList [(1,'a'),(2,'b'),(4,'d')] 454 + -- 455 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 456 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 457 + mapL :: 458 + Ord k => 459 + k 460 + -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) 461 + mapL = 462 + error "todo: mapL" 463 + 464 + -- | 465 + -- 466 + -- >>> get (setL 3) (Set.fromList [1..5]) 467 + -- True 468 + -- 469 + -- >>> get (setL 33) (Set.fromList [1..5]) 470 + -- False 471 + -- 472 + -- >>> set (setL 3) (Set.fromList [1..5]) True 473 + -- fromList [1,2,3,4,5] 474 + -- 475 + -- >>> set (setL 3) (Set.fromList [1..5]) False 476 + -- fromList [1,2,4,5] 477 + -- 478 + -- >>> set (setL 33) (Set.fromList [1..5]) True 479 + -- fromList [1,2,3,4,5,33] 480 + -- 481 + -- >>> set (setL 33) (Set.fromList [1..5]) False 482 + -- fromList [1,2,3,4,5] 483 + setL :: 484 + Ord k => 485 + k 486 + -> Lens (Set.Set k) (Set.Set k) Bool Bool 487 + setL = 488 + error "todo: setL" 489 + 490 + -- | 491 + -- 492 + -- >>> get (compose fstL sndL) ("abc", (7, "def")) 493 + -- 7 494 + -- 495 + -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 496 + -- ("abc",(8,"def")) 497 + compose :: 498 + Lens s t a b 499 + -> Lens q r s t 500 + -> Lens q r a b 501 + compose = 502 + error "todo: compose" 503 + 504 + -- | An alias for @compose@. 505 + (|.) :: 506 + Lens s t a b 507 + -> Lens q r s t 508 + -> Lens q r a b 509 + (|.) = 510 + compose 511 + 512 + infixr 9 |. 513 + 514 + -- | 515 + -- 516 + -- >>> get identity 3 517 + -- 3 518 + -- 519 + -- >>> set identity 3 4 520 + -- 4 521 + identity :: 522 + Lens a b a b 523 + identity = 524 + error "todo: identity" 525 + 526 + -- | 527 + -- 528 + -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 529 + -- ("abc","def") 530 + -- 531 + -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 532 + -- (("ghi",3),(4,"jkl")) 533 + product :: 534 + Lens s t a b 535 + -> Lens q r c d 536 + -> Lens (s, q) (t, r) (a, c) (b, d) 537 + product = 538 + error "todo: product" 539 + 540 + -- | An alias for @product@. 541 + (***) :: 542 + Lens s t a b 543 + -> Lens q r c d 544 + -> Lens (s, q) (t, r) (a, c) (b, d) 545 + (***) = 546 + product 547 + 548 + infixr 3 *** 549 + 550 + -- | 551 + -- 552 + -- >>> get (choice fstL sndL) (Left ("abc", 7)) 553 + -- "abc" 554 + -- 555 + -- >>> get (choice fstL sndL) (Right ("abc", 7)) 556 + -- 7 557 + -- 558 + -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 559 + -- Left ("def",7) 560 + -- 561 + -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 562 + -- Right ("abc",8) 563 + choice :: 564 + Lens s t a b 565 + -> Lens q r a b 566 + -> Lens (Either s q) (Either t r) a b 567 + choice = 568 + error "todo: choice" 569 + 570 + -- | An alias for @choice@. 571 + (|||) :: 572 + Lens s t a b 573 + -> Lens q r a b 574 + -> Lens (Either s q) (Either t r) a b 575 + (|||) = 576 + choice 577 + 578 + infixr 2 ||| 579 + 580 + ---- 581 + 582 + type Lens' a b = 583 + Lens a a b b 584 + 585 + cityL :: 586 + Lens' Locality String 587 + cityL p (Locality c t y) = 588 + fmap (\c' -> Locality c' t y) (p c) 589 + 590 + stateL :: 591 + Lens' Locality String 592 + stateL p (Locality c t y) = 593 + fmap (\t' -> Locality c t' y) (p t) 594 + 595 + countryL :: 596 + Lens' Locality String 597 + countryL p (Locality c t y) = 598 + fmap (\y' -> Locality c t y') (p y) 599 + 600 + streetL :: 601 + Lens' Address String 602 + streetL p (Address t s l) = 603 + fmap (\t' -> Address t' s l) (p t) 604 + 605 + suburbL :: 606 + Lens' Address String 607 + suburbL p (Address t s l) = 608 + fmap (\s' -> Address t s' l) (p s) 609 + 610 + localityL :: 611 + Lens' Address Locality 612 + localityL p (Address t s l) = 613 + fmap (\l' -> Address t s l') (p l) 614 + 615 + ageL :: 616 + Lens' Person Int 617 + ageL p (Person a n d) = 618 + fmap (\a' -> Person a' n d) (p a) 619 + 620 + nameL :: 621 + Lens' Person String 622 + nameL p (Person a n d) = 623 + fmap (\n' -> Person a n' d) (p n) 624 + 625 + addressL :: 626 + Lens' Person Address 627 + addressL p (Person a n d) = 628 + fmap (\d' -> Person a n d') (p d) 629 + 630 + intAndIntL :: 631 + Lens' (IntAnd a) Int 632 + intAndIntL p (IntAnd n a) = 633 + fmap (\n' -> IntAnd n' a) (p n) 634 + 635 + -- lens for polymorphic update 636 + intAndL :: 637 + Lens (IntAnd a) (IntAnd b) a b 638 + intAndL p (IntAnd n a) = 639 + fmap (\a' -> IntAnd n a') (p a) 640 + 641 + -- | 642 + -- 643 + -- >>> get (suburbL |. addressL) fred 644 + -- "Fredville" 645 + -- 646 + -- >>> get (suburbL |. addressL) mary 647 + -- "Maryland" 648 + getSuburb :: 649 + Person 650 + -> String 651 + getSuburb = 652 + error "todo: getSuburb" 653 + 654 + -- | 655 + -- 656 + -- >>> setStreet fred "Some Other St" 657 + -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 658 + -- 659 + -- >>> setStreet mary "Some Other St" 660 + -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 661 + setStreet :: 662 + Person 663 + -> String 664 + -> Person 665 + setStreet = 666 + error "todo: setStreet" 667 + 668 + -- | 669 + -- 670 + -- >>> getAgeAndCountry (fred, maryLocality) 671 + -- (24,"Maristan") 672 + -- 673 + -- >>> getAgeAndCountry (mary, fredLocality) 674 + -- (28,"Fredalia") 675 + getAgeAndCountry :: 676 + (Person, Locality) 677 + -> (Int, String) 678 + getAgeAndCountry = 679 + error "todo: getAgeAndCountry" 680 + 681 + -- | 682 + -- 683 + -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 684 + -- (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")) 685 + -- 686 + -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 687 + -- (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")) 688 + setCityAndLocality :: 689 + (Person, Address) -> (String, Locality) -> (Person, Address) 690 + setCityAndLocality = 691 + error "todo: setCityAndLocality" 692 + 693 + -- | 694 + -- 695 + -- >>> getSuburbOrCity (Left maryAddress) 696 + -- "Maryland" 697 + -- 698 + -- >>> getSuburbOrCity (Right fredLocality) 699 + -- "Fredmania" 700 + getSuburbOrCity :: 701 + Either Address Locality 702 + -> String 703 + getSuburbOrCity = 704 + error "todo: getSuburbOrCity" 705 + 706 + -- | 707 + -- 708 + -- >>> setStreetOrState (Right maryLocality) "Some Other State" 709 + -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 710 + -- 711 + -- >>> setStreetOrState (Left fred) "Some Other St" 712 + -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 713 + setStreetOrState :: 714 + Either Person Locality 715 + -> String 716 + -> Either Person Locality 717 + setStreetOrState = 718 + error "todo: setStreetOrState" 719 + 720 + -- | 721 + -- 722 + -- >>> modifyCityUppercase fred 723 + -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 724 + -- 725 + -- >>> modifyCityUppercase mary 726 + -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 727 + modifyCityUppercase :: 728 + Person 729 + -> Person 730 + modifyCityUppercase = 731 + error "todo: modifyCityUppercase" 732 + 733 + -- | 734 + -- 735 + -- >>> modifyIntAndLengthEven (IntAnd 10 "abc") 736 + -- IntAnd 10 False 737 + -- 738 + -- >>> modifyIntAndLengthEven (IntAnd 10 "abcd") 739 + -- IntAnd 10 True 740 + modifyIntAndLengthEven :: 741 + IntAnd [a] 742 + -> IntAnd Bool 743 + modifyIntAndLengthEven = 744 + error "todo: modifyIntAndLengthEven" 745 + 746 + ---- 747 + 748 + -- | 749 + -- 750 + -- >>> over traverseLocality (map toUpper) (Locality "abc" "def" "ghi") 751 + -- Locality "ABC" "DEF" "GHI" 752 + traverseLocality :: 753 + Traversal' Locality String 754 + traverseLocality = 755 + error "todo: traverseLocality" 756 + 757 + -- | 758 + -- 759 + -- >>> over intOrIntP (*10) (IntOrIs 3) 760 + -- IntOrIs 30 761 + -- 762 + -- >>> over intOrIntP (*10) (IntOrIsNot "abc") 763 + -- IntOrIsNot "abc" 764 + intOrIntP :: 765 + Prism' (IntOr a) Int 766 + intOrIntP = 767 + error "todo: intOrIntP" 768 + 769 + intOrP :: 770 + Prism (IntOr a) (IntOr b) a b 771 + intOrP = 772 + error "todo: intOrP" 773 + 774 + -- | 775 + -- 776 + -- >> over intOrP (even . length) (IntOrIsNot "abc") 777 + -- IntOrIsNot False 778 + -- 779 + -- >>> over intOrP (even . length) (IntOrIsNot "abcd") 780 + -- IntOrIsNot True 781 + -- 782 + -- >>> over intOrP (even . length) (IntOrIs 10) 783 + -- IntOrIs 10 784 + intOrLengthEven :: 785 + IntOr [a] 786 + -> IntOr Bool 787 + intOrLengthEven = 788 + error "todo: intOrLengthEven"
+2 -2
src/Lets/Lens/Choice.hs src/Lets/Choice.hs
··· 1 - module Lets.Lens.Choice ( 1 + module Lets.Choice ( 2 2 Choice(..) 3 3 ) where 4 4 5 5 import Lets.Data 6 - import Lets.Lens.Profunctor 6 + import Lets.Profunctor 7 7 8 8 diswap :: 9 9 Profunctor p =>
-814
src/Lets/Lens/Lens.hs
··· 1 - {-# LANGUAGE RankNTypes #-} 2 - 3 - module Lets.Lens.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.Bool(bool) 78 - import Data.Char(toUpper) 79 - import Data.Foldable(Foldable(foldMap)) 80 - import Data.Functor((<$>)) 81 - import Data.Map(Map) 82 - import qualified Data.Map as Map(insert, delete, lookup) 83 - import Data.Monoid(Monoid) 84 - import qualified Data.Set as Set(Set, insert, delete, member) 85 - import Data.Traversable(Traversable(traverse)) 86 - 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)) 87 - import Lets.Lens.Choice(Choice(left, right)) 88 - import Lets.Lens.Profunctor(Profunctor(dimap)) 89 - import Prelude hiding (product) 90 - 91 - -- $setup 92 - -- >>> import qualified Data.Map as Map(fromList) 93 - -- >>> import qualified Data.Set as Set(fromList) 94 - -- >>> import Data.Char(ord) 95 - 96 - -- Let's remind ourselves of Traversable, noting Foldable and Functor. 97 - -- 98 - -- class (Foldable t, Functor t) => Traversable t where 99 - -- traverse :: 100 - -- Applicative f => 101 - -- (a -> f b) 102 - -- -> t a 103 - -- -> f (t b) 104 - 105 - -- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. 106 - -- 107 - -- /Reminder:/ fmap :: Functor t => (a -> b) -> t a -> t b 108 - fmapT :: 109 - Traversable t => 110 - (a -> b) 111 - -> t a 112 - -> t b 113 - fmapT f = 114 - getIdentity . traverse (Identity . f) 115 - 116 - -- | Let's refactor out the call to @traverse@ as an argument to @fmapT@. 117 - over :: 118 - ((a -> Identity b) -> s -> Identity t) 119 - -> (a -> b) 120 - -> s 121 - -> t 122 - over t f = 123 - getIdentity . t (Identity . f) 124 - 125 - -- | Here is @fmapT@ again, passing @traverse@ to @over@. 126 - fmapTAgain :: 127 - Traversable t => 128 - (a -> b) 129 - -> t a 130 - -> t b 131 - fmapTAgain = 132 - over traverse 133 - 134 - -- | Let's create a type-alias for this type of function. 135 - type Set s t a b = 136 - (a -> Identity b) 137 - -> s 138 - -> Identity t 139 - 140 - -- | Let's write an inverse to @over@ that does the @Identity@ wrapping & 141 - -- unwrapping. 142 - sets :: 143 - ((a -> b) -> s -> t) 144 - -> Set s t a b 145 - sets t f = 146 - Identity . t (getIdentity . f) 147 - 148 - mapped :: 149 - Functor f => 150 - Set (f a) (f b) a b 151 - mapped = 152 - sets fmap 153 - 154 - set :: 155 - Set s t a b 156 - -> s 157 - -> b 158 - -> t 159 - set t s b = 160 - over t (const b) s 161 - 162 - ---- 163 - 164 - -- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. 165 - -- 166 - -- /Reminder:/ foldMap :: (Foldable t, Monoid b) => (a -> b) -> t a -> b 167 - foldMapT :: 168 - (Traversable t, Monoid b) => 169 - (a -> b) 170 - -> t a 171 - -> b 172 - foldMapT f = 173 - getConst . traverse (Const . f) 174 - 175 - -- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@. 176 - foldMapOf :: 177 - ((a -> Const r b) -> s -> Const r t) 178 - -> (a -> r) 179 - -> s 180 - -> r 181 - foldMapOf t f = 182 - getConst . t (Const . f) 183 - 184 - -- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@. 185 - foldMapTAgain :: 186 - (Traversable t, Monoid b) => 187 - (a -> b) 188 - -> t a 189 - -> b 190 - foldMapTAgain = 191 - foldMapOf traverse 192 - 193 - -- | Let's create a type-alias for this type of function. 194 - type Fold s t a b = 195 - forall r. 196 - Monoid r => 197 - (a -> Const r b) 198 - -> s 199 - -> Const r t 200 - 201 - -- | Let's write an inverse to @foldMapOf@ that does the @Const@ wrapping & 202 - -- unwrapping. 203 - folds :: 204 - ((a -> b) -> s -> t) 205 - -> (a -> Const b a) 206 - -> s 207 - -> Const t s 208 - folds t f = 209 - Const . t (getConst . f) 210 - 211 - folded :: 212 - Foldable f => 213 - Fold (f a) (f a) a a 214 - folded = 215 - folds foldMap 216 - 217 - ---- 218 - 219 - -- | @Get@ is like @Fold@, but without the @Monoid@ constraint. 220 - type Get r s a = 221 - (a -> Const r a) 222 - -> s 223 - -> Const r s 224 - 225 - get :: 226 - Get a s a 227 - -> s 228 - -> a 229 - get t = 230 - getConst . t Const 231 - 232 - ---- 233 - 234 - -- | Let's generalise @Identity@ and @Const r@ to any @Applicative@ instance. 235 - type Traversal s t a b = 236 - forall f. 237 - Applicative f => 238 - (a -> f b) 239 - -> s 240 - -> f t 241 - 242 - -- | Traverse both sides of a pair. 243 - both :: 244 - Traversal (a, a) (b, b) a b 245 - both f (a, b) = 246 - (,) <$> f a <*> f b 247 - 248 - -- | Traverse the left side of @Either@. 249 - traverseLeft :: 250 - Traversal (Either a x) (Either b x) a b 251 - traverseLeft f (Left a) = 252 - Left <$> f a 253 - traverseLeft _ (Right x) = 254 - pure (Right x) 255 - 256 - -- | Traverse the right side of @Either@. 257 - traverseRight :: 258 - Traversal (Either x a) (Either x b) a b 259 - traverseRight _ (Left x) = 260 - pure (Left x) 261 - traverseRight f (Right a) = 262 - Right <$> f a 263 - 264 - type Traversal' a b = 265 - Traversal a a b b 266 - 267 - ---- 268 - 269 - -- | @Const r@ is @Applicative@, if @Monoid r@, however, without the @Monoid@ 270 - -- constraint (as in @Get@), the only shared abstraction between @Identity@ and 271 - -- @Const r@ is @Functor@. 272 - -- 273 - -- Consequently, we arrive at our lens derivation: 274 - type Lens s t a b = 275 - forall f. 276 - Functor f => 277 - (a -> f b) 278 - -> s 279 - -> f t 280 - 281 - ---- 282 - 283 - -- | A prism is a less specific type of traversal. 284 - type Prism s t a b = 285 - forall p f. 286 - (Choice p, Applicative f) => 287 - p a (f b) 288 - -> p s (f t) 289 - 290 - _Left :: 291 - Prism (Either a x) (Either b x) a b 292 - _Left = 293 - dimap (either Right (Left . Right)) (either pure (fmap Left)) . right 294 - 295 - _Right :: 296 - Prism (Either x a) (Either x b) a b 297 - _Right = 298 - dimap (either (Left . Left) Right) (either pure (fmap Right)) . right 299 - 300 - prism :: 301 - (b -> t) 302 - -> (s -> Either t a) 303 - -> Prism s t a b 304 - prism to fr = 305 - dimap fr (either pure (fmap to)) . right 306 - 307 - _Just :: 308 - Prism (Maybe a) (Maybe b) a b 309 - _Just = 310 - prism 311 - Just 312 - (maybe (Left Nothing) Right) 313 - 314 - _Nothing :: 315 - Prism (Maybe a) (Maybe a) () () 316 - _Nothing = 317 - prism 318 - (\() -> Nothing) 319 - (maybe (Right ()) (Left . Just)) 320 - 321 - setP :: 322 - Prism s t a b 323 - -> s 324 - -> Either t a 325 - setP p = 326 - either Right Left . p Left 327 - 328 - getP :: 329 - Prism s t a b 330 - -> b 331 - -> t 332 - getP p = 333 - getIdentity . getTagged . p . Tagged . Identity 334 - 335 - type Prism' a b = 336 - Prism a a b b 337 - 338 - ---- 339 - 340 - -- | 341 - -- 342 - -- >>> modify fstL (+1) (0 :: Int, "abc") 343 - -- (1,"abc") 344 - -- 345 - -- >>> modify sndL (+1) ("abc", 0 :: Int) 346 - -- ("abc",1) 347 - -- 348 - -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 349 - -- 350 - -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 351 - modify :: 352 - Lens s t a b 353 - -> (a -> b) 354 - -> s 355 - -> t 356 - modify r f = 357 - getIdentity . r (Identity . f) 358 - 359 - -- | An alias for @modify@. 360 - (%~) :: 361 - Lens s t a b 362 - -> (a -> b) 363 - -> s 364 - -> t 365 - (%~) = 366 - modify 367 - 368 - infixr 4 %~ 369 - 370 - -- | 371 - -- 372 - -- >>> fstL .~ 1 $ (0 :: Int, "abc") 373 - -- (1,"abc") 374 - -- 375 - -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 376 - -- ("abc",1) 377 - -- 378 - -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 379 - -- 380 - -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 381 - (.~) :: 382 - Lens s t a b 383 - -> b 384 - -> s 385 - -> t 386 - (.~) l = 387 - modify l . const 388 - 389 - infixl 5 .~ 390 - 391 - -- | 392 - -- 393 - -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 394 - -- (13,"abc") 395 - -- 396 - -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 397 - -- Just (20,"abc") 398 - -- 399 - -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 400 - -- Nothing 401 - fmodify :: 402 - Functor f => 403 - Lens s t a b 404 - -> (a -> f b) 405 - -> s 406 - -> f t 407 - fmodify l = 408 - l 409 - 410 - -- | 411 - -- 412 - -- >>> fstL |= Just 3 $ (7, "abc") 413 - -- Just (3,"abc") 414 - -- 415 - -- >>> (fstL |= (+1) $ (3, "abc")) 17 416 - -- (18,"abc") 417 - (|=) :: 418 - Functor f => 419 - Lens s t a b 420 - -> f b 421 - -> s 422 - -> f t 423 - (|=) l = 424 - fmodify l . const 425 - 426 - infixl 5 |= 427 - 428 - -- | 429 - -- 430 - -- >>> modify fstL (*10) (3, "abc") 431 - -- (30,"abc") 432 - fstL :: 433 - Lens (a, x) (b, x) a b 434 - fstL p (x, y) = 435 - fmap (\x' -> (x', y)) (p x) 436 - 437 - -- | 438 - -- 439 - -- >>> modify sndL (++ "def") (13, "abc") 440 - -- (13,"abcdef") 441 - sndL :: 442 - Lens (x, a) (x, b) a b 443 - sndL p (x, y) = 444 - fmap (\y' -> (x, y')) (p y) 445 - 446 - -- | 447 - -- 448 - -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 449 - -- Just 'c' 450 - -- 451 - -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 452 - -- Nothing 453 - -- 454 - -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 455 - -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 456 - -- 457 - -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 458 - -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 459 - -- 460 - -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 461 - -- fromList [(1,'a'),(2,'b'),(4,'d')] 462 - -- 463 - -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 464 - -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 465 - mapL :: 466 - Ord k => 467 - k 468 - -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) 469 - mapL k p m = 470 - let z = Map.lookup k m 471 - in fmap (\y -> case y of 472 - Just v -> Map.insert k v m 473 - Nothing -> case z of 474 - Just _ -> Map.delete k m 475 - Nothing -> m) (p z) 476 - 477 - -- | 478 - -- 479 - -- >>> get (setL 3) (Set.fromList [1..5]) 480 - -- True 481 - -- 482 - -- >>> get (setL 33) (Set.fromList [1..5]) 483 - -- False 484 - -- 485 - -- >>> set (setL 3) (Set.fromList [1..5]) True 486 - -- fromList [1,2,3,4,5] 487 - -- 488 - -- >>> set (setL 3) (Set.fromList [1..5]) False 489 - -- fromList [1,2,4,5] 490 - -- 491 - -- >>> set (setL 33) (Set.fromList [1..5]) True 492 - -- fromList [1,2,3,4,5,33] 493 - -- 494 - -- >>> set (setL 33) (Set.fromList [1..5]) False 495 - -- fromList [1,2,3,4,5] 496 - setL :: 497 - Ord k => 498 - k 499 - -> Lens (Set.Set k) (Set.Set k) Bool Bool 500 - setL k = 501 - (\p s -> fmap (\b -> bool Set.delete Set.insert b k s) (p (Set.member k s))) 502 - 503 - -- | 504 - -- 505 - -- >>> get (compose fstL sndL) ("abc", (7, "def")) 506 - -- 7 507 - -- 508 - -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 509 - -- ("abc",(8,"def")) 510 - compose :: 511 - Lens s t a b 512 - -> Lens q r s t 513 - -> Lens q r a b 514 - compose r1 r2 = 515 - r2 . r1 516 - 517 - -- | An alias for @compose@. 518 - (|.) :: 519 - Lens s t a b 520 - -> Lens q r s t 521 - -> Lens q r a b 522 - (|.) = 523 - compose 524 - 525 - infixr 9 |. 526 - 527 - -- | 528 - -- 529 - -- >>> get identity 3 530 - -- 3 531 - -- 532 - -- >>> set identity 3 4 533 - -- 4 534 - identity :: 535 - Lens a b a b 536 - identity = 537 - id 538 - 539 - -- | 540 - -- 541 - -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 542 - -- ("abc","def") 543 - -- 544 - -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 545 - -- (("ghi",3),(4,"jkl")) 546 - product :: 547 - Lens s t a b 548 - -> Lens q r c d 549 - -> Lens (s, q) (t, r) (a, c) (b, d) 550 - product r1 r2 p (a, c) = 551 - getAlongsideRight (r2 (\b2 -> AlongsideRight ( 552 - getAlongsideLeft (r1 (\b1 -> AlongsideLeft ( 553 - p (b1,b2))) a))) c) 554 - 555 - -- | An alias for @product@. 556 - (***) :: 557 - Lens s t a b 558 - -> Lens q r c d 559 - -> Lens (s, q) (t, r) (a, c) (b, d) 560 - (***) = 561 - product 562 - 563 - infixr 3 *** 564 - 565 - -- | 566 - -- 567 - -- >>> get (choice fstL sndL) (Left ("abc", 7)) 568 - -- "abc" 569 - -- 570 - -- >>> get (choice fstL sndL) (Right ("abc", 7)) 571 - -- 7 572 - -- 573 - -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 574 - -- Left ("def",7) 575 - -- 576 - -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 577 - -- Right ("abc",8) 578 - choice :: 579 - Lens s t a b 580 - -> Lens q r a b 581 - -> Lens (Either s q) (Either t r) a b 582 - choice r1 r2 = 583 - 584 - (\p e -> case e of 585 - Left a -> fmap Left (r1 p a) 586 - Right b -> fmap Right (r2 p b)) 587 - 588 - -- | An alias for @choice@. 589 - (|||) :: 590 - Lens s t a b 591 - -> Lens q r a b 592 - -> Lens (Either s q) (Either t r) a b 593 - (|||) = 594 - choice 595 - 596 - infixr 2 ||| 597 - 598 - ---- 599 - 600 - type Lens' a b = 601 - Lens a a b b 602 - 603 - cityL :: 604 - Lens' Locality String 605 - cityL p (Locality c t y) = 606 - fmap (\c' -> Locality c' t y) (p c) 607 - 608 - stateL :: 609 - Lens' Locality String 610 - stateL p (Locality c t y) = 611 - fmap (\t' -> Locality c t' y) (p t) 612 - 613 - countryL :: 614 - Lens' Locality String 615 - countryL p (Locality c t y) = 616 - fmap (\y' -> Locality c t y') (p y) 617 - 618 - streetL :: 619 - Lens' Address String 620 - streetL p (Address t s l) = 621 - fmap (\t' -> Address t' s l) (p t) 622 - 623 - suburbL :: 624 - Lens' Address String 625 - suburbL p (Address t s l) = 626 - fmap (\s' -> Address t s' l) (p s) 627 - 628 - localityL :: 629 - Lens' Address Locality 630 - localityL p (Address t s l) = 631 - fmap (\l' -> Address t s l') (p l) 632 - 633 - ageL :: 634 - Lens' Person Int 635 - ageL p (Person a n d) = 636 - fmap (\a' -> Person a' n d) (p a) 637 - 638 - nameL :: 639 - Lens' Person String 640 - nameL p (Person a n d) = 641 - fmap (\n' -> Person a n' d) (p n) 642 - 643 - addressL :: 644 - Lens' Person Address 645 - addressL p (Person a n d) = 646 - fmap (\d' -> Person a n d') (p d) 647 - 648 - intAndIntL :: 649 - Lens' (IntAnd a) Int 650 - intAndIntL p (IntAnd n a) = 651 - fmap (\n' -> IntAnd n' a) (p n) 652 - 653 - -- lens for polymorphic update 654 - intAndL :: 655 - Lens (IntAnd a) (IntAnd b) a b 656 - intAndL p (IntAnd n a) = 657 - fmap (\a' -> IntAnd n a') (p a) 658 - 659 - -- | 660 - -- 661 - -- >>> get (suburbL |. addressL) fred 662 - -- "Fredville" 663 - -- 664 - -- >>> get (suburbL |. addressL) mary 665 - -- "Maryland" 666 - getSuburb :: 667 - Person 668 - -> String 669 - getSuburb = 670 - get (suburbL |. addressL) 671 - 672 - -- | 673 - -- 674 - -- >>> setStreet fred "Some Other St" 675 - -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 676 - -- 677 - -- >>> setStreet mary "Some Other St" 678 - -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 679 - setStreet :: 680 - Person 681 - -> String 682 - -> Person 683 - setStreet = 684 - set (streetL |. addressL) 685 - 686 - -- | 687 - -- 688 - -- >>> getAgeAndCountry (fred, maryLocality) 689 - -- (24,"Maristan") 690 - -- 691 - -- >>> getAgeAndCountry (mary, fredLocality) 692 - -- (28,"Fredalia") 693 - getAgeAndCountry :: 694 - (Person, Locality) 695 - -> (Int, String) 696 - getAgeAndCountry = 697 - get (ageL *** countryL) 698 - 699 - -- | 700 - -- 701 - -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 702 - -- (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")) 703 - -- 704 - -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 705 - -- (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")) 706 - setCityAndLocality :: 707 - (Person, Address) -> (String, Locality) -> (Person, Address) 708 - setCityAndLocality = 709 - set (cityL |. localityL |. addressL *** localityL) 710 - 711 - -- | 712 - -- 713 - -- >>> getSuburbOrCity (Left maryAddress) 714 - -- "Maryland" 715 - -- 716 - -- >>> getSuburbOrCity (Right fredLocality) 717 - -- "Fredmania" 718 - getSuburbOrCity :: 719 - Either Address Locality 720 - -> String 721 - getSuburbOrCity = 722 - get (suburbL ||| cityL) 723 - 724 - -- | 725 - -- 726 - -- >>> setStreetOrState (Right maryLocality) "Some Other State" 727 - -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 728 - -- 729 - -- >>> setStreetOrState (Left fred) "Some Other St" 730 - -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 731 - setStreetOrState :: 732 - Either Person Locality 733 - -> String 734 - -> Either Person Locality 735 - setStreetOrState = 736 - set (streetL |. addressL ||| stateL) 737 - 738 - -- | 739 - -- 740 - -- >>> modifyCityUppercase fred 741 - -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 742 - -- 743 - -- >>> modifyCityUppercase mary 744 - -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 745 - modifyCityUppercase :: 746 - Person 747 - -> Person 748 - modifyCityUppercase = 749 - cityL |. localityL |. addressL %~ map toUpper 750 - 751 - -- | 752 - -- 753 - -- >>> modifyIntAndLengthEven (IntAnd 10 "abc") 754 - -- IntAnd 10 False 755 - -- 756 - -- >>> modifyIntAndLengthEven (IntAnd 10 "abcd") 757 - -- IntAnd 10 True 758 - modifyIntAndLengthEven :: 759 - IntAnd [a] 760 - -> IntAnd Bool 761 - modifyIntAndLengthEven = 762 - intAndL %~ even . length 763 - 764 - ---- 765 - 766 - -- | 767 - -- 768 - -- >>> over traverseLocality (map toUpper) (Locality "abc" "def" "ghi") 769 - -- Locality "ABC" "DEF" "GHI" 770 - traverseLocality :: 771 - Traversal' Locality String 772 - traverseLocality f (Locality c t y) = 773 - Locality <$> f c <*> f t <*> f y 774 - 775 - -- | 776 - -- 777 - -- >>> over intOrIntP (*10) (IntOrIs 3) 778 - -- IntOrIs 30 779 - -- 780 - -- >>> over intOrIntP (*10) (IntOrIsNot "abc") 781 - -- IntOrIsNot "abc" 782 - intOrIntP :: 783 - Prism' (IntOr a) Int 784 - intOrIntP = 785 - prism 786 - IntOrIs 787 - (\i -> case i of 788 - IntOrIs n -> Right n 789 - IntOrIsNot a -> Left (IntOrIsNot a)) 790 - 791 - intOrP :: 792 - Prism (IntOr a) (IntOr b) a b 793 - intOrP = 794 - prism 795 - IntOrIsNot 796 - (\i -> case i of 797 - IntOrIs n -> Left (IntOrIs n) 798 - IntOrIsNot a -> Right a) 799 - 800 - -- | 801 - -- 802 - -- >> over intOrP (even . length) (IntOrIsNot "abc") 803 - -- IntOrIsNot False 804 - -- 805 - -- >>> over intOrP (even . length) (IntOrIsNot "abcd") 806 - -- IntOrIsNot True 807 - -- 808 - -- >>> over intOrP (even . length) (IntOrIs 10) 809 - -- IntOrIs 10 810 - intOrLengthEven :: 811 - IntOr [a] 812 - -> IntOr Bool 813 - intOrLengthEven = 814 - over intOrP (even . length)
+1 -1
src/Lets/Lens/Profunctor.hs src/Lets/Profunctor.hs
··· 1 - module Lets.Lens.Profunctor ( 1 + module Lets.Profunctor ( 2 2 Profunctor(dimap) 3 3 ) where 4 4