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.

Initial set of exercises, no answers

Tony Morris 77da1bf3 825eb489

+2804 -8
-2
.ghci
··· 6 6 :set -fno-warn-unused-do-bind 7 7 :set -fno-warn-unused-imports 8 8 :set -fno-warn-type-defaults 9 - :set -XNoImplicitPrelude 10 9 :set -XScopedTypeVariables 11 10 :set -XOverloadedStrings 12 - :set -XRebindableSyntax
+66
README.markdown
··· 1 1 # Let's Lens 2 + 3 + ![NICTA](http://i.imgur.com/sMXB9XB.jpg) 4 + 5 + 6 + ### Abstract 7 + 8 + Let's Lens presents a series of exercises, in a similar format to 9 + [the NICTA functional programming course material](http://github.com/NICTA/course). 10 + The subject of the exercises is around the concept of lenses, initially proposed 11 + by Foster et al., to solve the view-update problem of relational databases. 12 + 13 + The theories around lenses have been advanced significantly in recent years, 14 + resulting in a library, implemented in Haskell, called `lens`. 15 + 16 + http://hackage.haskell.org/package/lens 17 + 18 + The exercises take into account various possible goals. For example, if you wish 19 + to study the history of lenses, then build up to the most recent theories, it is 20 + best to start at the `Lets.GetSetLens` module. If you wish to derive the 21 + structure of lenses from first principles, then derive the more modern theories, 22 + start at the `Lets.Lens.Lens` module. 23 + 24 + ---- 25 + 26 + ### Exercise modules 27 + 28 + ##### `Lets.GetSetLens` 29 + 30 + This module presents a series of exercises, representing lenses as a traditional 31 + pair of "`get` and `set`" functions. This representation may be beneficial as it 32 + easily appeals to an intuition of "what a lens is", however, it is outdated. 33 + 34 + These exercises are useful to gain an initial understanding of the problems that 35 + lenses solve, as well as to gain an insight into the history of lenses and how 36 + the theories have developed over time. 37 + 38 + ##### `Lets.StoreLens` 39 + 40 + This series of exercises is similar to `Lets.GetSetLens`, however, using a 41 + slightly altered representation of a lens, based on the `Store` comonad, which 42 + fuses the typical `get` and `set` operations into a data structure. This 43 + representation is described in detail in 44 + *Morris, Tony. "Asymmetric Lenses in Scala." (2012).* 45 + 46 + ##### `Lets.OpticPolyLens` 47 + 48 + This series of exercises introduces a new representation of lenses, first 49 + described by Twan van Laarhoven. This representation also introduces a 50 + generalisation of lenses to permit *polymorphic update* of structures. 51 + 52 + ##### `Lets.Lens.Lens` 53 + 54 + This series of exercises starts at first principles to derive the concept of a 55 + lens, as it was first described by Twan van Laarhoven. The derivation then goes 56 + on to described other structures to solve various practical problems such as 57 + *multi-update* and *partial update*. 58 + 59 + This representation presents a generalisation, permitting *polymorphic update* 60 + over structures. After lenses are derived, further concepts are introduced, such 61 + as `Fold`s, `Traversal`s and `Prism`s. 62 + 63 + ---- 64 + 65 + ### Credits 66 + 67 + * Edward Kmett on the [derivation of lenses](https://github.com/ekmett/lens/wiki/Derivation)
+8 -5
lets-lens.cabal
··· 36 36 -fno-warn-unused-imports 37 37 -fno-warn-type-defaults 38 38 39 - default-extensions: NoImplicitPrelude 40 - ScopedTypeVariables 41 - InstanceSigs 42 - RebindableSyntax 43 - 44 39 hs-source-dirs: src 45 40 46 41 exposed-modules: Lets 42 + Lets.Data 43 + Lets.GetSetLens 44 + Lets.Lens 45 + Lets.Lens.Choice 46 + Lets.Lens.Lens 47 + Lets.Lens.Profunctor 48 + Lets.OpticPolyLens 49 + Lets.StoreLens 47 50 48 51 test-suite doctests 49 52 type:
+8 -1
src/Lets.hs
··· 1 - module Lets where 1 + module Lets ( 2 + module L 3 + ) where 2 4 5 + import Lets.Data as L 6 + import Lets.GetSetLens as L() 7 + import Lets.Lens as L() 8 + import Lets.OpticPolyLens as L() 9 + import Lets.StoreLens as L()
+180
src/Lets/Data.hs
··· 1 + module Lets.Data ( 2 + Locality(..) 3 + , Address(..) 4 + , Person(..) 5 + , IntAnd(..) 6 + , IntOr(..) 7 + , fredLocality 8 + , fredAddress 9 + , fred 10 + , maryLocality 11 + , maryAddress 12 + , mary 13 + , Store(..) 14 + , Const (..) 15 + , Tagged(..) 16 + , Identity(..) 17 + , AlongsideLeft(..) 18 + , AlongsideRight(..) 19 + ) where 20 + 21 + import Control.Applicative(Applicative(..)) 22 + import Data.Monoid(Monoid(..)) 23 + 24 + data Locality = 25 + Locality 26 + String -- city 27 + String -- state 28 + String -- country 29 + deriving (Eq, Show) 30 + 31 + data Address = 32 + Address 33 + String -- street 34 + String -- suburb 35 + Locality 36 + deriving (Eq, Show) 37 + 38 + data Person = 39 + Person 40 + Int -- age 41 + String -- name 42 + Address -- address 43 + deriving (Eq, Show) 44 + 45 + data IntAnd a = 46 + IntAnd 47 + Int 48 + a 49 + deriving (Eq, Show) 50 + 51 + data IntOr a = 52 + IntOrIs Int 53 + | IntOrIsNot a 54 + deriving (Eq, Show) 55 + 56 + fredLocality :: 57 + Locality 58 + fredLocality = 59 + Locality 60 + "Fredmania" 61 + "New South Fred" 62 + "Fredalia" 63 + 64 + fredAddress :: 65 + Address 66 + fredAddress = 67 + Address 68 + "15 Fred St" 69 + "Fredville" 70 + fredLocality 71 + 72 + fred :: 73 + Person 74 + fred = 75 + Person 76 + 24 77 + "Fred" 78 + fredAddress 79 + 80 + maryLocality :: 81 + Locality 82 + maryLocality = 83 + Locality 84 + "Mary Mary" 85 + "Western Mary" 86 + "Maristan" 87 + 88 + maryAddress :: 89 + Address 90 + maryAddress = 91 + Address 92 + "83 Mary Ln" 93 + "Maryland" 94 + maryLocality 95 + 96 + mary :: 97 + Person 98 + mary = 99 + Person 100 + 28 101 + "Mary" 102 + maryAddress 103 + 104 + ---- 105 + 106 + data Store s a = 107 + Store 108 + (s -> a) 109 + s 110 + 111 + data Const a b = 112 + Const { 113 + getConst :: 114 + a 115 + } 116 + deriving (Eq, Show) 117 + 118 + instance Functor (Const a) where 119 + fmap _ (Const a) = 120 + Const a 121 + 122 + instance Monoid a => Applicative (Const a) where 123 + pure _ = 124 + Const mempty 125 + Const f <*> Const a = 126 + Const (f `mappend` a) 127 + 128 + data Tagged a b = 129 + Tagged { 130 + getTagged :: 131 + b 132 + } 133 + deriving (Eq, Show) 134 + 135 + instance Functor (Tagged a) where 136 + fmap f (Tagged b) = 137 + Tagged (f b) 138 + 139 + instance Applicative (Tagged a) where 140 + pure = 141 + Tagged 142 + Tagged f <*> Tagged a = 143 + Tagged (f a) 144 + 145 + data Identity a = 146 + Identity { 147 + getIdentity :: 148 + a 149 + } 150 + deriving (Eq, Show) 151 + 152 + instance Functor Identity where 153 + fmap f (Identity a) = 154 + Identity (f a) 155 + 156 + instance Applicative Identity where 157 + pure = 158 + Identity 159 + Identity f <*> Identity a = 160 + Identity (f a) 161 + 162 + data AlongsideLeft f b a = 163 + AlongsideLeft { 164 + getAlongsideLeft :: 165 + f (a, b) 166 + } 167 + 168 + instance Functor f => Functor (AlongsideLeft f b) where 169 + fmap f (AlongsideLeft x) = 170 + AlongsideLeft (fmap (\(a, b) -> (f a, b)) x) 171 + 172 + data AlongsideRight f a b = 173 + AlongsideRight { 174 + getAlongsideRight :: 175 + f (a, b) 176 + } 177 + 178 + instance Functor f => Functor (AlongsideRight f a) where 179 + fmap f (AlongsideRight x) = 180 + AlongsideRight (fmap (\(a, b) -> (a, f b)) x)
+544
src/Lets/GetSetLens.hs
··· 1 + module Lets.GetSetLens ( 2 + Lens(..) 3 + , getsetLaw 4 + , setgetLaw 5 + , setsetLaw 6 + , get 7 + , set 8 + , modify 9 + , (%~) 10 + , fmodify 11 + , (|=) 12 + , fstL 13 + , sndL 14 + , mapL 15 + , setL 16 + , compose 17 + , (|.) 18 + , identity 19 + , product 20 + , (***) 21 + , choice 22 + , (|||) 23 + , cityL 24 + , countryL 25 + , streetL 26 + , suburbL 27 + , localityL 28 + , ageL 29 + , nameL 30 + , addressL 31 + , getSuburb 32 + , setStreet 33 + , getAgeAndCountry 34 + , setCityAndLocality 35 + , getSuburbOrCity 36 + , setStreetOrState 37 + , modifyCityUppercase 38 + ) where 39 + 40 + import Control.Applicative((<*>)) 41 + import Data.Bool(bool) 42 + import Data.Char(toUpper) 43 + import Data.Map(Map) 44 + import qualified Data.Map as Map(insert, delete, lookup) 45 + import Data.Set(Set) 46 + import qualified Data.Set as Set(insert, delete, member) 47 + import Lets.Data 48 + import Prelude hiding (product) 49 + 50 + -- $setup 51 + -- >>> import qualified Data.Map as Map(fromList) 52 + -- >>> import qualified Data.Set as Set(fromList) 53 + -- >>> import Data.Char(ord) 54 + 55 + data Lens a b = 56 + Lens 57 + (a -> b -> a) 58 + (a -> b) 59 + 60 + -- | 61 + -- 62 + -- >>> get fstL (0 :: Int, "abc") 63 + -- 0 64 + -- 65 + -- >>> get sndL ("abc", 0 :: Int) 66 + -- 0 67 + -- 68 + -- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x 69 + -- 70 + -- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y 71 + get :: 72 + Lens a b 73 + -> a 74 + -> b 75 + get (Lens _ g) = 76 + g 77 + 78 + -- | 79 + -- 80 + -- >>> set fstL (0 :: Int, "abc") 1 81 + -- (1,"abc") 82 + -- 83 + -- >>> set sndL ("abc", 0 :: Int) 1 84 + -- ("abc",1) 85 + -- 86 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) 87 + -- 88 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) 89 + set :: 90 + Lens a b 91 + -> a 92 + -> b 93 + -> a 94 + set (Lens s _) a = 95 + s a 96 + 97 + -- | The get/set law of lenses. This function should always return @True@. 98 + getsetLaw :: 99 + Eq a => 100 + Lens a b 101 + -> a 102 + -> Bool 103 + getsetLaw l = 104 + \a -> set l a (get l a) == a 105 + 106 + -- | The set/get law of lenses. This function should always return @True@. 107 + setgetLaw :: 108 + Eq b => 109 + Lens a b 110 + -> a 111 + -> b 112 + -> Bool 113 + setgetLaw l a b = 114 + get l (set l a b) == b 115 + 116 + -- | The set/set law of lenses. This function should always return @True@. 117 + setsetLaw :: 118 + Eq a => 119 + Lens a b 120 + -> a 121 + -> b 122 + -> b 123 + -> Bool 124 + setsetLaw l a b1 b2 = 125 + set l (set l a b1) b2 == set l a b2 126 + 127 + ---- 128 + 129 + -- | 130 + -- 131 + -- >>> modify fstL (+1) (0 :: Int, "abc") 132 + -- (1,"abc") 133 + -- 134 + -- >>> modify sndL (+1) ("abc", 0 :: Int) 135 + -- ("abc",1) 136 + -- 137 + -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 138 + -- 139 + -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 140 + modify :: 141 + Lens a b 142 + -> (b -> b) 143 + -> a 144 + -> a 145 + modify = 146 + error "todo: modify" 147 + 148 + -- | An alias for @modify@. 149 + (%~) :: 150 + Lens a b 151 + -> (b -> b) 152 + -> a 153 + -> a 154 + (%~) = 155 + modify 156 + 157 + infixr 4 %~ 158 + 159 + -- | 160 + -- 161 + -- >>> fstL .~ 1 $ (0 :: Int, "abc") 162 + -- (1,"abc") 163 + -- 164 + -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 165 + -- ("abc",1) 166 + -- 167 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 168 + -- 169 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 170 + (.~) :: 171 + Lens a b 172 + -> b 173 + -> a 174 + -> a 175 + (.~) = 176 + error "todo: (.~)" 177 + 178 + infixl 5 .~ 179 + 180 + -- | 181 + -- 182 + -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 183 + -- (13,"abc") 184 + -- 185 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 186 + -- Just (20,"abc") 187 + -- 188 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 189 + -- Nothing 190 + fmodify :: 191 + Functor f => 192 + Lens a b 193 + -> (b -> f b) 194 + -> a 195 + -> f a 196 + fmodify = 197 + error "todo: fmodify" 198 + 199 + -- | 200 + -- 201 + -- >>> fstL |= Just 3 $ (7, "abc") 202 + -- Just (3,"abc") 203 + -- 204 + -- >>> (fstL |= (+1) $ (3, "abc")) 17 205 + -- (18,"abc") 206 + (|=) :: 207 + Functor f => 208 + Lens a b 209 + -> f b 210 + -> a 211 + -> f a 212 + (|=) = 213 + error "todo: (|=)" 214 + 215 + infixl 5 |= 216 + 217 + -- | 218 + -- 219 + -- >>> modify fstL (*10) (3, "abc") 220 + -- (30,"abc") 221 + -- 222 + -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 223 + -- 224 + -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 225 + -- 226 + -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 227 + fstL :: 228 + Lens (x, y) x 229 + fstL = 230 + error "todo: fstL" 231 + 232 + -- | 233 + -- 234 + -- >>> modify sndL (++ "def") (13, "abc") 235 + -- (13,"abcdef") 236 + -- 237 + -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 238 + -- 239 + -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 240 + -- 241 + -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 242 + sndL :: 243 + Lens (x, y) y 244 + sndL = 245 + error "todo: sndL" 246 + 247 + -- | 248 + -- 249 + -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 250 + -- Just 'c' 251 + -- 252 + -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 253 + -- Nothing 254 + -- 255 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 256 + -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 257 + -- 258 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 259 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 260 + -- 261 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 262 + -- fromList [(1,'a'),(2,'b'),(4,'d')] 263 + -- 264 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 265 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 266 + mapL :: 267 + Ord k => 268 + k 269 + -> Lens (Map k v) (Maybe v) 270 + mapL = 271 + error "todo: mapL" 272 + 273 + -- | 274 + -- 275 + -- >>> get (setL 3) (Set.fromList [1..5]) 276 + -- True 277 + -- 278 + -- >>> get (setL 33) (Set.fromList [1..5]) 279 + -- False 280 + -- 281 + -- >>> set (setL 3) (Set.fromList [1..5]) True 282 + -- fromList [1,2,3,4,5] 283 + -- 284 + -- >>> set (setL 3) (Set.fromList [1..5]) False 285 + -- fromList [1,2,4,5] 286 + -- 287 + -- >>> set (setL 33) (Set.fromList [1..5]) True 288 + -- fromList [1,2,3,4,5,33] 289 + -- 290 + -- >>> set (setL 33) (Set.fromList [1..5]) False 291 + -- fromList [1,2,3,4,5] 292 + setL :: 293 + Ord k => 294 + k 295 + -> Lens (Set k) Bool 296 + setL = 297 + error "todo: setL" 298 + 299 + -- | 300 + -- 301 + -- >>> get (compose fstL sndL) ("abc", (7, "def")) 302 + -- 7 303 + -- 304 + -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 305 + -- ("abc",(8,"def")) 306 + compose :: 307 + Lens b c 308 + -> Lens a b 309 + -> Lens a c 310 + compose = 311 + error "todo: compose" 312 + 313 + -- | An alias for @compose@. 314 + (|.) :: 315 + Lens b c 316 + -> Lens a b 317 + -> Lens a c 318 + (|.) = 319 + compose 320 + 321 + infixr 9 |. 322 + 323 + -- | 324 + -- 325 + -- >>> get identity 3 326 + -- 3 327 + -- 328 + -- >>> set identity 3 4 329 + -- 4 330 + identity :: 331 + Lens a a 332 + identity = 333 + error "todo: identity" 334 + 335 + -- | 336 + -- 337 + -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 338 + -- ("abc","def") 339 + -- 340 + -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 341 + -- (("ghi",3),(4,"jkl")) 342 + product :: 343 + Lens a b 344 + -> Lens c d 345 + -> Lens (a, c) (b, d) 346 + product = 347 + error "todo: product" 348 + 349 + -- | An alias for @product@. 350 + (***) :: 351 + Lens a b 352 + -> Lens c d 353 + -> Lens (a, c) (b, d) 354 + (***) = 355 + product 356 + 357 + infixr 3 *** 358 + 359 + -- | 360 + -- 361 + -- >>> get (choice fstL sndL) (Left ("abc", 7)) 362 + -- "abc" 363 + -- 364 + -- >>> get (choice fstL sndL) (Right ("abc", 7)) 365 + -- 7 366 + -- 367 + -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 368 + -- Left ("def",7) 369 + -- 370 + -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 371 + -- Right ("abc",8) 372 + choice :: 373 + Lens a x 374 + -> Lens b x 375 + -> Lens (Either a b) x 376 + choice = 377 + error "todo: choice" 378 + 379 + -- | An alias for @choice@. 380 + (|||) :: 381 + Lens a x 382 + -> Lens b x 383 + -> Lens (Either a b) x 384 + (|||) = 385 + choice 386 + 387 + infixr 2 ||| 388 + 389 + ---- 390 + 391 + cityL :: 392 + Lens Locality String 393 + cityL = 394 + Lens 395 + (\(Locality _ t y) c -> Locality c t y) 396 + (\(Locality c _ _) -> c) 397 + 398 + stateL :: 399 + Lens Locality String 400 + stateL = 401 + Lens 402 + (\(Locality c _ y) t -> Locality c t y) 403 + (\(Locality _ t _) -> t) 404 + 405 + countryL :: 406 + Lens Locality String 407 + countryL = 408 + Lens 409 + (\(Locality c t _) y -> Locality c t y) 410 + (\(Locality _ _ y) -> y) 411 + 412 + streetL :: 413 + Lens Address String 414 + streetL = 415 + Lens 416 + (\(Address _ s l) t -> Address t s l) 417 + (\(Address t _ _) -> t) 418 + 419 + suburbL :: 420 + Lens Address String 421 + suburbL = 422 + Lens 423 + (\(Address t _ l) s -> Address t s l) 424 + (\(Address _ s _) -> s) 425 + 426 + localityL :: 427 + Lens Address Locality 428 + localityL = 429 + Lens 430 + (\(Address t s _) l -> Address t s l) 431 + (\(Address _ _ l) -> l) 432 + 433 + ageL :: 434 + Lens Person Int 435 + ageL = 436 + Lens 437 + (\(Person _ n d) a -> Person a n d) 438 + (\(Person a _ _) -> a) 439 + 440 + nameL :: 441 + Lens Person String 442 + nameL = 443 + Lens 444 + (\(Person a _ d) n -> Person a n d) 445 + (\(Person _ n _) -> n) 446 + 447 + addressL :: 448 + Lens Person Address 449 + addressL = 450 + Lens 451 + (\(Person a n _) d -> Person a n d) 452 + (\(Person _ _ d) -> d) 453 + 454 + -- | 455 + -- 456 + -- >>> get (suburbL |. addressL) fred 457 + -- "Fredville" 458 + -- 459 + -- >>> get (suburbL |. addressL) mary 460 + -- "Maryland" 461 + getSuburb :: 462 + Person 463 + -> String 464 + getSuburb = 465 + error "todo: getSuburb" 466 + 467 + -- | 468 + -- 469 + -- >>> setStreet fred "Some Other St" 470 + -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 471 + -- 472 + -- >>> setStreet mary "Some Other St" 473 + -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 474 + setStreet :: 475 + Person 476 + -> String 477 + -> Person 478 + setStreet = 479 + error "todo: setStreet" 480 + 481 + -- | 482 + -- 483 + -- >>> getAgeAndCountry (fred, maryLocality) 484 + -- (24,"Maristan") 485 + -- 486 + -- >>> getAgeAndCountry (mary, fredLocality) 487 + -- (28,"Fredalia") 488 + getAgeAndCountry :: 489 + (Person, Locality) 490 + -> (Int, String) 491 + getAgeAndCountry = 492 + error "todo: getAgeAndCountry" 493 + 494 + -- | 495 + -- 496 + -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 497 + -- (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")) 498 + -- 499 + -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 500 + -- (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")) 501 + setCityAndLocality :: 502 + (Person, Address) -> (String, Locality) -> (Person, Address) 503 + setCityAndLocality = 504 + error "todo: setCityAndLocality" 505 + 506 + -- | 507 + -- 508 + -- >>> getSuburbOrCity (Left maryAddress) 509 + -- "Maryland" 510 + -- 511 + -- >>> getSuburbOrCity (Right fredLocality) 512 + -- "Fredmania" 513 + getSuburbOrCity :: 514 + Either Address Locality 515 + -> String 516 + getSuburbOrCity = 517 + error "todo: getSuburbOrCity" 518 + 519 + -- | 520 + -- 521 + -- >>> setStreetOrState (Right maryLocality) "Some Other State" 522 + -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 523 + -- 524 + -- >>> setStreetOrState (Left fred) "Some Other St" 525 + -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 526 + setStreetOrState :: 527 + Either Person Locality 528 + -> String 529 + -> Either Person Locality 530 + setStreetOrState = 531 + error "todo: setStreetOrState" 532 + 533 + -- | 534 + -- 535 + -- >>> modifyCityUppercase fred 536 + -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 537 + -- 538 + -- >>> modifyCityUppercase mary 539 + -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 540 + modifyCityUppercase :: 541 + Person 542 + -> Person 543 + modifyCityUppercase = 544 + error "todo: modifyCityUppercase"
+7
src/Lets/Lens.hs
··· 1 + module Lets.Lens ( 2 + module L 3 + ) where 4 + 5 + import Lets.Lens.Choice as L 6 + import Lets.Lens.Lens as L 7 + import Lets.Lens.Profunctor as L
+43
src/Lets/Lens/Choice.hs
··· 1 + module Lets.Lens.Choice 2 + ( 3 + Choice(..) 4 + ) where 5 + 6 + import Lets.Data 7 + import Lets.Lens.Profunctor 8 + 9 + diswap :: 10 + Profunctor p => 11 + p (Either a b) (Either c d) 12 + -> p (Either b a) (Either d c) 13 + diswap = 14 + let swap = either Right Left 15 + in dimap swap swap 16 + 17 + -- | Map on left or right of @Either@. Only one of @left@ or @right@ needs to be 18 + -- provided. 19 + class Profunctor p => Choice p where 20 + left :: 21 + p a b 22 + -> p (Either a c) (Either b c) 23 + left = 24 + diswap . right 25 + 26 + right :: 27 + p a b 28 + -> p (Either c a) (Either c b) 29 + right = 30 + diswap . left 31 + 32 + instance Choice (->) where 33 + left f = 34 + either (Left . f) Right 35 + right f = 36 + either Left (Right . f) 37 + 38 + instance Choice Tagged where 39 + left (Tagged x) = 40 + Tagged (Left x) 41 + right (Tagged x) = 42 + Tagged (Right x) 43 +
+788
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(..)) 77 + import Data.Bool(bool) 78 + import Data.Char(toUpper) 79 + import Data.Foldable(Foldable(..)) 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(..)) 86 + import Lets.Data 87 + import Lets.Lens.Choice 88 + import Lets.Lens.Profunctor 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"
+22
src/Lets/Lens/Profunctor.hs
··· 1 + module Lets.Lens.Profunctor 2 + ( 3 + Profunctor(dimap) 4 + ) where 5 + 6 + import Lets.Data 7 + 8 + -- | A profunctor is a binary functor, with the first argument in contravariant 9 + -- (negative) position and the second argument in covariant (positive) position. 10 + class Profunctor p where 11 + dimap :: 12 + (b -> a) 13 + -> (c -> d) 14 + -> p a c 15 + -> p b d 16 + 17 + instance Profunctor (->) where 18 + dimap f g = \h -> g . h . f 19 + 20 + instance Profunctor Tagged where 21 + dimap _ g (Tagged x) = 22 + Tagged (g x)
+546
src/Lets/OpticPolyLens.hs
··· 1 + {-# LANGUAGE RankNTypes #-} 2 + 3 + module Lets.OpticPolyLens ( 4 + Lens(..) 5 + , getsetLaw 6 + , setgetLaw 7 + , setsetLaw 8 + , get 9 + , set 10 + , modify 11 + , (%~) 12 + , fmodify 13 + , (|=) 14 + , fstL 15 + , sndL 16 + , mapL 17 + , setL 18 + , compose 19 + , (|.) 20 + , identity 21 + , product 22 + , (***) 23 + , choice 24 + , (|||) 25 + , cityL 26 + , countryL 27 + , streetL 28 + , suburbL 29 + , localityL 30 + , ageL 31 + , nameL 32 + , addressL 33 + , intAndIntL 34 + , intAndL 35 + , getSuburb 36 + , setStreet 37 + , getAgeAndCountry 38 + , setCityAndLocality 39 + , getSuburbOrCity 40 + , setStreetOrState 41 + , modifyCityUppercase 42 + , modifyIntandLengthEven 43 + ) where 44 + 45 + import Data.Bool(bool) 46 + import Data.Char(toUpper) 47 + import Data.Map(Map) 48 + import qualified Data.Map as Map(insert, delete, lookup) 49 + import Data.Set(Set) 50 + import qualified Data.Set as Set(insert, delete, member) 51 + import Lets.Data 52 + import Prelude hiding (product) 53 + 54 + -- $setup 55 + -- >>> import qualified Data.Map as Map(fromList) 56 + -- >>> import qualified Data.Set as Set(fromList) 57 + -- >>> import Data.Char(ord) 58 + 59 + data Lens s t a b = 60 + Lens 61 + (forall f. Functor f => (a -> f b) -> s -> f t) 62 + 63 + get :: 64 + Lens s t a b 65 + -> s 66 + -> a 67 + get (Lens r) = 68 + getConst . r Const 69 + 70 + set :: 71 + Lens s t a b 72 + -> s 73 + -> b 74 + -> t 75 + set (Lens r) a b = 76 + getIdentity (r (const (Identity b)) a) 77 + 78 + -- | The get/set law of lenses. This function should always return @True@. 79 + getsetLaw :: 80 + Eq s => 81 + Lens s s a a 82 + -> s 83 + -> Bool 84 + getsetLaw l = 85 + \a -> set l a (get l a) == a 86 + 87 + -- | The set/get law of lenses. This function should always return @True@. 88 + setgetLaw :: 89 + Eq a => 90 + Lens s s a a 91 + -> s 92 + -> a 93 + -> Bool 94 + setgetLaw l a b = 95 + get l (set l a b) == b 96 + 97 + -- | The set/set law of lenses. This function should always return @True@. 98 + setsetLaw :: 99 + Eq s => 100 + Lens s s a b 101 + -> s 102 + -> b 103 + -> b 104 + -> Bool 105 + setsetLaw l a b1 b2 = 106 + set l (set l a b1) b2 == set l a b2 107 + 108 + ---- 109 + 110 + -- | 111 + -- 112 + -- >>> modify fstL (+1) (0 :: Int, "abc") 113 + -- (1,"abc") 114 + -- 115 + -- >>> modify sndL (+1) ("abc", 0 :: Int) 116 + -- ("abc",1) 117 + -- 118 + -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 119 + -- 120 + -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 121 + modify :: 122 + Lens s t a b 123 + -> (a -> b) 124 + -> s 125 + -> t 126 + modify = 127 + error "todo: modify" 128 + 129 + -- | An alias for @modify@. 130 + (%~) :: 131 + Lens s t a b 132 + -> (a -> b) 133 + -> s 134 + -> t 135 + (%~) = 136 + modify 137 + 138 + infixr 4 %~ 139 + 140 + -- | 141 + -- 142 + -- >>> fstL .~ 1 $ (0 :: Int, "abc") 143 + -- (1,"abc") 144 + -- 145 + -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 146 + -- ("abc",1) 147 + -- 148 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 149 + -- 150 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 151 + (.~) :: 152 + Lens s t a b 153 + -> b 154 + -> s 155 + -> t 156 + (.~) = 157 + error "todo: (.~)" 158 + 159 + infixl 5 .~ 160 + 161 + -- | 162 + -- 163 + -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 164 + -- (13,"abc") 165 + -- 166 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 167 + -- Just (20,"abc") 168 + -- 169 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 170 + -- Nothing 171 + fmodify :: 172 + Functor f => 173 + Lens s t a b 174 + -> (a -> f b) 175 + -> s 176 + -> f t 177 + fmodify = 178 + error "todo: fmodify" 179 + 180 + -- | 181 + -- 182 + -- >>> fstL |= Just 3 $ (7, "abc") 183 + -- Just (3,"abc") 184 + -- 185 + -- >>> (fstL |= (+1) $ (3, "abc")) 17 186 + -- (18,"abc") 187 + (|=) :: 188 + Functor f => 189 + Lens s t a b 190 + -> f b 191 + -> s 192 + -> f t 193 + (|=) = 194 + error "todo: (|=)" 195 + 196 + infixl 5 |= 197 + 198 + -- | 199 + -- 200 + -- >>> modify fstL (*10) (3, "abc") 201 + -- (30,"abc") 202 + -- 203 + -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 204 + -- 205 + -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 206 + -- 207 + -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 208 + fstL :: 209 + Lens (a, x) (b, x) a b 210 + fstL = 211 + error "todo: fstL" 212 + 213 + -- | 214 + -- 215 + -- >>> modify sndL (++ "def") (13, "abc") 216 + -- (13,"abcdef") 217 + -- 218 + -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 219 + -- 220 + -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 221 + -- 222 + -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 223 + sndL :: 224 + Lens (x, a) (x, b) a b 225 + sndL = 226 + error "todo: sndL" 227 + 228 + -- | 229 + -- 230 + -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 231 + -- Just 'c' 232 + -- 233 + -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 234 + -- Nothing 235 + -- 236 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 237 + -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 238 + -- 239 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 240 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 241 + -- 242 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 243 + -- fromList [(1,'a'),(2,'b'),(4,'d')] 244 + -- 245 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 246 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 247 + mapL :: 248 + Ord k => 249 + k 250 + -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) 251 + mapL = 252 + error "todo: mapL" 253 + 254 + -- | 255 + -- 256 + -- >>> get (setL 3) (Set.fromList [1..5]) 257 + -- True 258 + -- 259 + -- >>> get (setL 33) (Set.fromList [1..5]) 260 + -- False 261 + -- 262 + -- >>> set (setL 3) (Set.fromList [1..5]) True 263 + -- fromList [1,2,3,4,5] 264 + -- 265 + -- >>> set (setL 3) (Set.fromList [1..5]) False 266 + -- fromList [1,2,4,5] 267 + -- 268 + -- >>> set (setL 33) (Set.fromList [1..5]) True 269 + -- fromList [1,2,3,4,5,33] 270 + -- 271 + -- >>> set (setL 33) (Set.fromList [1..5]) False 272 + -- fromList [1,2,3,4,5] 273 + setL :: 274 + Ord k => 275 + k 276 + -> Lens (Set k) (Set k) Bool Bool 277 + setL = 278 + error "todo: setL" 279 + 280 + -- | 281 + -- 282 + -- >>> get (compose fstL sndL) ("abc", (7, "def")) 283 + -- 7 284 + -- 285 + -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 286 + -- ("abc",(8,"def")) 287 + compose :: 288 + Lens s t a b 289 + -> Lens q r s t 290 + -> Lens q r a b 291 + compose = 292 + error "todo: compose" 293 + 294 + -- | An alias for @compose@. 295 + (|.) :: 296 + Lens s t a b 297 + -> Lens q r s t 298 + -> Lens q r a b 299 + (|.) = 300 + compose 301 + 302 + infixr 9 |. 303 + 304 + -- | 305 + -- 306 + -- >>> get identity 3 307 + -- 3 308 + -- 309 + -- >>> set identity 3 4 310 + -- 4 311 + identity :: 312 + Lens a b a b 313 + identity = 314 + error "todo: identity" 315 + 316 + -- | 317 + -- 318 + -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 319 + -- ("abc","def") 320 + -- 321 + -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 322 + -- (("ghi",3),(4,"jkl")) 323 + product :: 324 + Lens s t a b 325 + -> Lens q r c d 326 + -> Lens (s, q) (t, r) (a, c) (b, d) 327 + product = 328 + error "todo: product" 329 + 330 + -- | An alias for @product@. 331 + (***) :: 332 + Lens s t a b 333 + -> Lens q r c d 334 + -> Lens (s, q) (t, r) (a, c) (b, d) 335 + (***) = 336 + product 337 + 338 + infixr 3 *** 339 + 340 + -- | 341 + -- 342 + -- >>> get (choice fstL sndL) (Left ("abc", 7)) 343 + -- "abc" 344 + -- 345 + -- >>> get (choice fstL sndL) (Right ("abc", 7)) 346 + -- 7 347 + -- 348 + -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 349 + -- Left ("def",7) 350 + -- 351 + -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 352 + -- Right ("abc",8) 353 + choice :: 354 + Lens s t a b 355 + -> Lens q r a b 356 + -> Lens (Either s q) (Either t r) a b 357 + choice = 358 + error "todo: choice" 359 + 360 + -- | An alias for @choice@. 361 + (|||) :: 362 + Lens s t a b 363 + -> Lens q r a b 364 + -> Lens (Either s q) (Either t r) a b 365 + (|||) = 366 + choice 367 + 368 + infixr 2 ||| 369 + 370 + ---- 371 + 372 + type Lens' a b = 373 + Lens a a b b 374 + 375 + cityL :: 376 + Lens' Locality String 377 + cityL = 378 + Lens 379 + (\p (Locality c t y) -> fmap (\c' -> Locality c' t y) (p c)) 380 + 381 + stateL :: 382 + Lens' Locality String 383 + stateL = 384 + Lens 385 + (\p (Locality c t y) -> fmap (\t' -> Locality c t' y) (p t)) 386 + 387 + countryL :: 388 + Lens' Locality String 389 + countryL = 390 + Lens 391 + (\p (Locality c t y) -> fmap (\y' -> Locality c t y') (p y)) 392 + 393 + streetL :: 394 + Lens' Address String 395 + streetL = 396 + Lens 397 + (\p (Address t s l) -> fmap (\t' -> Address t' s l) (p t)) 398 + 399 + suburbL :: 400 + Lens' Address String 401 + suburbL = 402 + Lens 403 + (\p (Address t s l) -> fmap (\s' -> Address t s' l) (p s)) 404 + 405 + localityL :: 406 + Lens' Address Locality 407 + localityL = 408 + Lens 409 + (\p (Address t s l) -> fmap (\l' -> Address t s l') (p l)) 410 + 411 + ageL :: 412 + Lens' Person Int 413 + ageL = 414 + Lens 415 + (\p (Person a n d) -> fmap (\a' -> Person a' n d) (p a)) 416 + 417 + nameL :: 418 + Lens' Person String 419 + nameL = 420 + Lens 421 + (\p (Person a n d) -> fmap (\n' -> Person a n' d) (p n)) 422 + 423 + addressL :: 424 + Lens' Person Address 425 + addressL = 426 + Lens 427 + (\p (Person a n d) -> fmap (\d' -> Person a n d') (p d)) 428 + 429 + intAndIntL :: 430 + Lens' (IntAnd a) Int 431 + intAndIntL = 432 + Lens 433 + (\p (IntAnd n a) -> fmap (\n' -> IntAnd n' a) (p n)) 434 + 435 + -- lens for polymorphic update 436 + intAndL :: 437 + Lens (IntAnd a) (IntAnd b) a b 438 + intAndL = 439 + Lens 440 + (\p (IntAnd n a) -> fmap (\a' -> IntAnd n a') (p a)) 441 + 442 + -- | 443 + -- 444 + -- >>> get (suburbL |. addressL) fred 445 + -- "Fredville" 446 + -- 447 + -- >>> get (suburbL |. addressL) mary 448 + -- "Maryland" 449 + getSuburb :: 450 + Person 451 + -> String 452 + getSuburb = 453 + error "todo: getSuburb" 454 + 455 + 456 + -- | 457 + -- 458 + -- >>> setStreet fred "Some Other St" 459 + -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 460 + -- 461 + -- >>> setStreet mary "Some Other St" 462 + -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 463 + setStreet :: 464 + Person 465 + -> String 466 + -> Person 467 + setStreet = 468 + error "todo: setStreet" 469 + 470 + -- | 471 + -- 472 + -- >>> getAgeAndCountry (fred, maryLocality) 473 + -- (24,"Maristan") 474 + -- 475 + -- >>> getAgeAndCountry (mary, fredLocality) 476 + -- (28,"Fredalia") 477 + getAgeAndCountry :: 478 + (Person, Locality) 479 + -> (Int, String) 480 + getAgeAndCountry = 481 + error "todo: getAgeAndCountry" 482 + 483 + -- | 484 + -- 485 + -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 486 + -- (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")) 487 + -- 488 + -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 489 + -- (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")) 490 + setCityAndLocality :: 491 + (Person, Address) -> (String, Locality) -> (Person, Address) 492 + setCityAndLocality = 493 + error "todo: setCityAndLocality" 494 + 495 + -- | 496 + -- 497 + -- >>> getSuburbOrCity (Left maryAddress) 498 + -- "Maryland" 499 + -- 500 + -- >>> getSuburbOrCity (Right fredLocality) 501 + -- "Fredmania" 502 + getSuburbOrCity :: 503 + Either Address Locality 504 + -> String 505 + getSuburbOrCity = 506 + get (suburbL ||| cityL) 507 + 508 + -- | 509 + -- 510 + -- >>> setStreetOrState (Right maryLocality) "Some Other State" 511 + -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 512 + -- 513 + -- >>> setStreetOrState (Left fred) "Some Other St" 514 + -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 515 + setStreetOrState :: 516 + Either Person Locality 517 + -> String 518 + -> Either Person Locality 519 + setStreetOrState = 520 + set (streetL |. addressL ||| stateL) 521 + 522 + -- | 523 + -- 524 + -- >>> modifyCityUppercase fred 525 + -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 526 + -- 527 + -- >>> modifyCityUppercase mary 528 + -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 529 + modifyCityUppercase :: 530 + Person 531 + -> Person 532 + modifyCityUppercase = 533 + cityL |. localityL |. addressL %~ map toUpper 534 + 535 + -- | 536 + -- 537 + -- >>> modify intAndL (even . length) (IntAnd 10 "abc") 538 + -- IntAnd 10 False 539 + -- 540 + -- >>> modify intAndL (even . length) (IntAnd 10 "abcd") 541 + -- IntAnd 10 True 542 + modifyIntandLengthEven :: 543 + IntAnd [a] 544 + -> IntAnd Bool 545 + modifyIntandLengthEven = 546 + intAndL %~ even . length
+592
src/Lets/StoreLens.hs
··· 1 + module Lets.StoreLens ( 2 + Store(..) 3 + , setS 4 + , getS 5 + , mapS 6 + , duplicateS 7 + , extendS 8 + , extractS 9 + , Lens(..) 10 + , getsetLaw 11 + , setgetLaw 12 + , setsetLaw 13 + , get 14 + , set 15 + , modify 16 + , (%~) 17 + , fmodify 18 + , (|=) 19 + , fstL 20 + , sndL 21 + , mapL 22 + , setL 23 + , compose 24 + , (|.) 25 + , identity 26 + , product 27 + , (***) 28 + , choice 29 + , (|||) 30 + , cityL 31 + , countryL 32 + , streetL 33 + , suburbL 34 + , localityL 35 + , ageL 36 + , nameL 37 + , addressL 38 + , getSuburb 39 + , setStreet 40 + , getAgeAndCountry 41 + , setCityAndLocality 42 + , getSuburbOrCity 43 + , setStreetOrState 44 + , modifyCityUppercase 45 + ) where 46 + 47 + import Control.Applicative((<*>)) 48 + import Data.Bool(bool) 49 + import Data.Char(toUpper) 50 + import Data.Functor((<$>)) 51 + import Data.Map(Map) 52 + import qualified Data.Map as Map(insert, delete, lookup) 53 + import Data.Set(Set) 54 + import qualified Data.Set as Set(insert, delete, member) 55 + import Lets.Data 56 + import Prelude hiding (product) 57 + 58 + -- $setup 59 + -- >>> import qualified Data.Map as Map(fromList) 60 + -- >>> import qualified Data.Set as Set(fromList) 61 + -- >>> import Data.Char(ord) 62 + 63 + setS :: 64 + Store s a 65 + -> s 66 + -> a 67 + setS (Store s _) = 68 + s 69 + 70 + getS :: 71 + Store s a 72 + -> s 73 + getS (Store _ g) = 74 + g 75 + 76 + mapS :: 77 + (a -> b) 78 + -> Store s a 79 + -> Store s b 80 + mapS = 81 + error "todo: mapS" 82 + 83 + duplicateS :: 84 + Store s a 85 + -> Store s (Store s a) 86 + duplicateS = 87 + error "todo: duplicateS" 88 + 89 + extendS :: 90 + (Store s a -> b) 91 + -> Store s a 92 + -> Store s b 93 + extendS = 94 + error "todo: extendS" 95 + 96 + extractS :: 97 + Store s a 98 + -> a 99 + extractS = 100 + error "todo: extractS" 101 + 102 + ---- 103 + 104 + data Lens a b = 105 + Lens 106 + (a -> Store b a) 107 + 108 + -- | 109 + -- 110 + -- >>> get fstL (0 :: Int, "abc") 111 + -- 0 112 + -- 113 + -- >>> get sndL ("abc", 0 :: Int) 114 + -- 0 115 + -- 116 + -- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x 117 + -- 118 + -- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y 119 + get :: 120 + Lens a b 121 + -> a 122 + -> b 123 + get (Lens r) = 124 + getS . r 125 + 126 + -- | 127 + -- 128 + -- >>> set fstL (0 :: Int, "abc") 1 129 + -- (1,"abc") 130 + -- 131 + -- >>> set sndL ("abc", 0 :: Int) 1 132 + -- ("abc",1) 133 + -- 134 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) 135 + -- 136 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) 137 + set :: 138 + Lens a b 139 + -> a 140 + -> b 141 + -> a 142 + set (Lens r) = 143 + setS . r 144 + 145 + -- | The get/set law of lenses. This function should always return @True@. 146 + getsetLaw :: 147 + Eq a => 148 + Lens a b 149 + -> a 150 + -> Bool 151 + getsetLaw l = 152 + \a -> set l a (get l a) == a 153 + 154 + -- | The set/get law of lenses. This function should always return @True@. 155 + setgetLaw :: 156 + Eq b => 157 + Lens a b 158 + -> a 159 + -> b 160 + -> Bool 161 + setgetLaw l a b = 162 + get l (set l a b) == b 163 + 164 + -- | The set/set law of lenses. This function should always return @True@. 165 + setsetLaw :: 166 + Eq a => 167 + Lens a b 168 + -> a 169 + -> b 170 + -> b 171 + -> Bool 172 + setsetLaw l a b1 b2 = 173 + set l (set l a b1) b2 == set l a b2 174 + 175 + ---- 176 + 177 + -- | 178 + -- 179 + -- >>> modify fstL (+1) (0 :: Int, "abc") 180 + -- (1,"abc") 181 + -- 182 + -- >>> modify sndL (+1) ("abc", 0 :: Int) 183 + -- ("abc",1) 184 + -- 185 + -- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) 186 + -- 187 + -- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) 188 + modify :: 189 + Lens a b 190 + -> (b -> b) 191 + -> a 192 + -> a 193 + modify = 194 + error "todo: modify" 195 + 196 + -- | An alias for @modify@. 197 + (%~) :: 198 + Lens a b 199 + -> (b -> b) 200 + -> a 201 + -> a 202 + (%~) = 203 + modify 204 + 205 + infixr 4 %~ 206 + 207 + -- | 208 + -- 209 + -- >>> fstL .~ 1 $ (0 :: Int, "abc") 210 + -- (1,"abc") 211 + -- 212 + -- >>> sndL .~ 1 $ ("abc", 0 :: Int) 213 + -- ("abc",1) 214 + -- 215 + -- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) 216 + -- 217 + -- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) 218 + (.~) :: 219 + Lens a b 220 + -> b 221 + -> a 222 + -> a 223 + (.~) = 224 + error "todo: (.~)" 225 + 226 + infixl 5 .~ 227 + 228 + -- | 229 + -- 230 + -- >>> fmodify fstL (+) (5 :: Int, "abc") 8 231 + -- (13,"abc") 232 + -- 233 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") 234 + -- Just (20,"abc") 235 + -- 236 + -- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") 237 + -- Nothing 238 + fmodify :: 239 + Functor f => 240 + Lens a b 241 + -> (b -> f b) 242 + -> a 243 + -> f a 244 + fmodify = 245 + error "todo: fmodify" 246 + 247 + -- | 248 + -- 249 + -- >>> fstL |= Just 3 $ (7, "abc") 250 + -- Just (3,"abc") 251 + -- 252 + -- >>> (fstL |= (+1) $ (3, "abc")) 17 253 + -- (18,"abc") 254 + (|=) :: 255 + Functor f => 256 + Lens a b 257 + -> f b 258 + -> a 259 + -> f a 260 + (|=) = 261 + error "todo: (|=)" 262 + 263 + infixl 5 |= 264 + 265 + -- | 266 + -- 267 + -- >>> modify fstL (*10) (3, "abc") 268 + -- (30,"abc") 269 + -- 270 + -- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) 271 + -- 272 + -- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z 273 + -- 274 + -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z 275 + fstL :: 276 + Lens (x, y) x 277 + fstL = 278 + error "todo: fstL" 279 + 280 + -- | 281 + -- 282 + -- >>> modify sndL (++ "def") (13, "abc") 283 + -- (13,"abcdef") 284 + -- 285 + -- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) 286 + -- 287 + -- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z 288 + -- 289 + -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z 290 + sndL :: 291 + Lens (x, y) y 292 + sndL = 293 + error "todo: sndL" 294 + 295 + -- | 296 + -- 297 + -- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 298 + -- Just 'c' 299 + -- 300 + -- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) 301 + -- Nothing 302 + -- 303 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 304 + -- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] 305 + -- 306 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') 307 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] 308 + -- 309 + -- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 310 + -- fromList [(1,'a'),(2,'b'),(4,'d')] 311 + -- 312 + -- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing 313 + -- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] 314 + mapL :: 315 + Ord k => 316 + k 317 + -> Lens (Map k v) (Maybe v) 318 + mapL = 319 + error "todo: mapL" 320 + 321 + -- | 322 + -- 323 + -- >>> get (setL 3) (Set.fromList [1..5]) 324 + -- True 325 + -- 326 + -- >>> get (setL 33) (Set.fromList [1..5]) 327 + -- False 328 + -- 329 + -- >>> set (setL 3) (Set.fromList [1..5]) True 330 + -- fromList [1,2,3,4,5] 331 + -- 332 + -- >>> set (setL 3) (Set.fromList [1..5]) False 333 + -- fromList [1,2,4,5] 334 + -- 335 + -- >>> set (setL 33) (Set.fromList [1..5]) True 336 + -- fromList [1,2,3,4,5,33] 337 + -- 338 + -- >>> set (setL 33) (Set.fromList [1..5]) False 339 + -- fromList [1,2,3,4,5] 340 + setL :: 341 + Ord k => 342 + k 343 + -> Lens (Set k) Bool 344 + setL = 345 + error "todo: setL" 346 + 347 + -- | 348 + -- 349 + -- >>> get (compose fstL sndL) ("abc", (7, "def")) 350 + -- 7 351 + -- 352 + -- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 353 + -- ("abc",(8,"def")) 354 + compose :: 355 + Lens b c 356 + -> Lens a b 357 + -> Lens a c 358 + compose = 359 + error "todo: compose" 360 + 361 + -- | An alias for @compose@. 362 + (|.) :: 363 + Lens b c 364 + -> Lens a b 365 + -> Lens a c 366 + (|.) = 367 + compose 368 + 369 + infixr 9 |. 370 + 371 + -- | 372 + -- 373 + -- >>> get identity 3 374 + -- 3 375 + -- 376 + -- >>> set identity 3 4 377 + -- 4 378 + identity :: 379 + Lens a a 380 + identity = 381 + error "todo: identity" 382 + 383 + -- | 384 + -- 385 + -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) 386 + -- ("abc","def") 387 + -- 388 + -- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") 389 + -- (("ghi",3),(4,"jkl")) 390 + product :: 391 + Lens a b 392 + -> Lens c d 393 + -> Lens (a, c) (b, d) 394 + product = 395 + error "todo: product" 396 + 397 + -- | An alias for @product@. 398 + (***) :: 399 + Lens a b 400 + -> Lens c d 401 + -> Lens (a, c) (b, d) 402 + (***) = 403 + product 404 + 405 + infixr 3 *** 406 + 407 + -- | 408 + -- 409 + -- >>> get (choice fstL sndL) (Left ("abc", 7)) 410 + -- "abc" 411 + -- 412 + -- >>> get (choice fstL sndL) (Right ("abc", 7)) 413 + -- 7 414 + -- 415 + -- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" 416 + -- Left ("def",7) 417 + -- 418 + -- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 419 + -- Right ("abc",8) 420 + choice :: 421 + Lens a x 422 + -> Lens b x 423 + -> Lens (Either a b) x 424 + choice = 425 + error "todo: choice" 426 + 427 + -- | An alias for @choice@. 428 + (|||) :: 429 + Lens a x 430 + -> Lens b x 431 + -> Lens (Either a b) x 432 + (|||) = 433 + choice 434 + 435 + infixr 2 ||| 436 + 437 + ---- 438 + 439 + cityL :: 440 + Lens Locality String 441 + cityL = 442 + Lens 443 + (\(Locality c t y) -> 444 + Store (\c' -> Locality c' t y) c) 445 + 446 + stateL :: 447 + Lens Locality String 448 + stateL = 449 + Lens 450 + (\(Locality c t y) -> 451 + Store (\t' -> Locality c t' y) t) 452 + 453 + countryL :: 454 + Lens Locality String 455 + countryL = 456 + Lens 457 + (\(Locality c t y) -> 458 + Store (\y' -> Locality c t y') y) 459 + 460 + streetL :: 461 + Lens Address String 462 + streetL = 463 + Lens 464 + (\(Address t s l) -> 465 + Store (\t' -> Address t' s l) t) 466 + 467 + suburbL :: 468 + Lens Address String 469 + suburbL = 470 + Lens 471 + (\(Address t s l) -> 472 + Store (\s' -> Address t s' l) s) 473 + 474 + localityL :: 475 + Lens Address Locality 476 + localityL = 477 + Lens 478 + (\(Address t s l) -> 479 + Store (\l' -> Address t s l') l) 480 + 481 + ageL :: 482 + Lens Person Int 483 + ageL = 484 + Lens 485 + (\(Person a n d) -> 486 + Store (\a' -> Person a' n d) a) 487 + 488 + nameL :: 489 + Lens Person String 490 + nameL = 491 + Lens 492 + (\(Person a n d) -> 493 + Store (\n' -> Person a n' d) n) 494 + 495 + addressL :: 496 + Lens Person Address 497 + addressL = 498 + Lens 499 + (\(Person a n d) -> 500 + Store (\d' -> Person a n d') d) 501 + 502 + -- | 503 + -- 504 + -- >>> get (suburbL |. addressL) fred 505 + -- "Fredville" 506 + -- 507 + -- >>> get (suburbL |. addressL) mary 508 + -- "Maryland" 509 + getSuburb :: 510 + Person 511 + -> String 512 + getSuburb = 513 + error "todo: getSuburb" 514 + 515 + -- | 516 + -- 517 + -- >>> setStreet fred "Some Other St" 518 + -- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) 519 + -- 520 + -- >>> setStreet mary "Some Other St" 521 + -- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) 522 + setStreet :: 523 + Person 524 + -> String 525 + -> Person 526 + setStreet = 527 + error "todo: setStreet" 528 + 529 + -- | 530 + -- 531 + -- >>> getAgeAndCountry (fred, maryLocality) 532 + -- (24,"Maristan") 533 + -- 534 + -- >>> getAgeAndCountry (mary, fredLocality) 535 + -- (28,"Fredalia") 536 + getAgeAndCountry :: 537 + (Person, Locality) 538 + -> (Int, String) 539 + getAgeAndCountry = 540 + error "todo: getAgeAndCountry" 541 + 542 + -- | 543 + -- 544 + -- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) 545 + -- (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")) 546 + -- 547 + -- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) 548 + -- (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")) 549 + setCityAndLocality :: 550 + (Person, Address) -> (String, Locality) -> (Person, Address) 551 + setCityAndLocality = 552 + error "todo: setCityAndLocality" 553 + 554 + -- | 555 + -- 556 + -- >>> getSuburbOrCity (Left maryAddress) 557 + -- "Maryland" 558 + -- 559 + -- >>> getSuburbOrCity (Right fredLocality) 560 + -- "Fredmania" 561 + getSuburbOrCity :: 562 + Either Address Locality 563 + -> String 564 + getSuburbOrCity = 565 + error "todo: getSuburbOrCity" 566 + 567 + -- | 568 + -- 569 + -- >>> setStreetOrState (Right maryLocality) "Some Other State" 570 + -- Right (Locality "Mary Mary" "Some Other State" "Maristan") 571 + -- 572 + -- >>> setStreetOrState (Left fred) "Some Other St" 573 + -- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) 574 + setStreetOrState :: 575 + Either Person Locality 576 + -> String 577 + -> Either Person Locality 578 + setStreetOrState = 579 + error "todo: setStreetOrState" 580 + 581 + -- | 582 + -- 583 + -- >>> modifyCityUppercase fred 584 + -- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) 585 + -- 586 + -- >>> modifyCityUppercase mary 587 + -- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) 588 + modifyCityUppercase :: 589 + Person 590 + -> Person 591 + modifyCityUppercase = 592 + error "todo: modifyCityUppercase"