Initial set of exercises, no answers

.ghci

@@ -6,7 +6,5 @@
 :set -fno-warn-unused-do-bind
 :set -fno-warn-unused-imports
 :set -fno-warn-type-defaults
-:set -XNoImplicitPrelude
 :set -XScopedTypeVariables
 :set -XOverloadedStrings
-:set -XRebindableSyntax

README.markdown

@@ -1 +1,67 @@
 # Let's Lens
+
+![NICTA](http://i.imgur.com/sMXB9XB.jpg)
+
+
+### Abstract
+
+Let's Lens presents a series of exercises, in a similar format to
+[the NICTA functional programming course material](http://github.com/NICTA/course).
+The subject of the exercises is around the concept of lenses, initially proposed
+by  Foster et al., to solve the view-update problem of relational databases.
+
+The theories around lenses have been advanced significantly in recent years,
+resulting in a library, implemented in Haskell, called `lens`.
+
+http://hackage.haskell.org/package/lens
+
+The exercises take into account various possible goals. For example, if you wish
+to study the history of lenses, then build up to the most recent theories, it is
+best to start at the `Lets.GetSetLens` module. If you wish to derive the
+structure of lenses from first principles, then derive the more modern theories,
+start at the `Lets.Lens.Lens` module.
+
+----
+
+### Exercise modules
+
+##### `Lets.GetSetLens`
+
+This module presents a series of exercises, representing lenses as a traditional
+pair of "`get` and `set`" functions. This representation may be beneficial as it
+easily appeals to an intuition of "what a lens is", however, it is outdated. 
+
+These exercises are useful to gain an initial understanding of the problems that
+lenses solve, as well as to gain an insight into the history of lenses and how
+the theories have developed over time.
+
+##### `Lets.StoreLens`
+
+This series of exercises is similar to `Lets.GetSetLens`, however, using a
+slightly altered representation of a lens, based on the `Store` comonad, which
+fuses the typical `get` and `set` operations into a data structure. This
+representation is described in detail in
+*Morris, Tony. "Asymmetric Lenses in Scala." (2012).*
+
+##### `Lets.OpticPolyLens`
+
+This series of exercises introduces a new representation of lenses, first
+described by Twan van Laarhoven. This representation also introduces a
+generalisation of lenses to permit *polymorphic update* of structures.
+
+##### `Lets.Lens.Lens`
+
+This series of exercises starts at first principles to derive the concept of a
+lens, as it was first described by Twan van Laarhoven. The derivation then goes
+on to described other structures to solve various practical problems such as
+*multi-update* and *partial update*.
+
+This representation presents a generalisation, permitting *polymorphic update*
+over structures. After lenses are derived, further concepts are introduced, such
+as `Fold`s, `Traversal`s and `Prism`s.
+
+----
+
+### Credits
+
+* Edward Kmett on the [derivation of lenses](https://github.com/ekmett/lens/wiki/Derivation)

lets-lens.cabal

@@ -36,14 +36,17 @@ library
                       -fno-warn-unused-imports
                       -fno-warn-type-defaults
 
-  default-extensions: NoImplicitPrelude
-                      ScopedTypeVariables
-                      InstanceSigs
-                      RebindableSyntax
-
   hs-source-dirs:     src
 
   exposed-modules:    Lets
+                      Lets.Data
+                      Lets.GetSetLens
+                      Lets.Lens
+                      Lets.Lens.Choice
+                      Lets.Lens.Lens
+                      Lets.Lens.Profunctor
+                      Lets.OpticPolyLens
+                      Lets.StoreLens
                       
 test-suite            doctests
   type:

src/Lets.hs

@@ -1,2 +1,9 @@
-module Lets where
+module Lets (
+  module L
+) where
 
+import Lets.Data as L
+import Lets.GetSetLens as L()
+import Lets.Lens as L()
+import Lets.OpticPolyLens as L()
+import Lets.StoreLens as L()

src/Lets/Data.hs

@@ -0,0 +1,180 @@
+module Lets.Data (
+  Locality(..)
+, Address(..)
+, Person(..)
+, IntAnd(..)
+, IntOr(..)
+, fredLocality
+, fredAddress
+, fred
+, maryLocality
+, maryAddress
+, mary
+, Store(..)
+, Const (..)
+, Tagged(..)
+, Identity(..)
+, AlongsideLeft(..)
+, AlongsideRight(..)
+) where
+
+import Control.Applicative(Applicative(..))
+import Data.Monoid(Monoid(..))
+
+data Locality =
+  Locality
+    String -- city
+    String -- state
+    String -- country
+  deriving (Eq, Show)  
+
+data Address =
+  Address
+    String -- street
+    String -- suburb
+    Locality
+  deriving (Eq, Show)  
+
+data Person =
+  Person
+    Int -- age
+    String -- name
+    Address -- address
+  deriving (Eq, Show)
+
+data IntAnd a =
+  IntAnd
+    Int
+    a
+  deriving (Eq, Show)
+
+data IntOr a =
+  IntOrIs Int
+  | IntOrIsNot a
+  deriving (Eq, Show)
+
+fredLocality ::
+  Locality
+fredLocality =
+  Locality
+    "Fredmania"
+    "New South Fred"
+    "Fredalia"
+
+fredAddress ::
+  Address
+fredAddress =
+  Address
+    "15 Fred St"
+    "Fredville"
+    fredLocality
+
+fred ::
+  Person
+fred =
+  Person
+    24
+    "Fred"
+    fredAddress
+
+maryLocality ::
+  Locality
+maryLocality =
+  Locality
+    "Mary Mary"
+    "Western Mary"
+    "Maristan"
+
+maryAddress ::
+  Address
+maryAddress =
+  Address
+    "83 Mary Ln"
+    "Maryland"
+    maryLocality
+
+mary ::
+  Person
+mary =
+  Person
+    28
+    "Mary"
+    maryAddress
+
+----
+
+data Store s a =
+  Store
+    (s -> a)
+    s
+
+data Const a b =
+  Const {
+    getConst :: 
+      a
+  }
+  deriving (Eq, Show)
+
+instance Functor (Const a) where
+  fmap _ (Const a) =
+    Const a
+
+instance Monoid a => Applicative (Const a) where
+  pure _ =
+    Const mempty
+  Const f <*> Const a =
+    Const (f `mappend` a)
+
+data Tagged a b = 
+  Tagged {
+    getTagged ::
+      b
+  }
+  deriving (Eq, Show)
+
+instance Functor (Tagged a) where
+  fmap f (Tagged b) =
+    Tagged (f b)
+
+instance Applicative (Tagged a) where
+  pure =
+    Tagged
+  Tagged f <*> Tagged a =
+    Tagged (f a)
+
+data Identity a =
+  Identity {
+    getIdentity ::
+      a
+  }
+  deriving (Eq, Show)
+
+instance Functor Identity where
+  fmap f (Identity a) =
+    Identity (f a)
+
+instance Applicative Identity where
+  pure =
+    Identity
+  Identity f <*> Identity a =
+    Identity (f a)
+
+data AlongsideLeft f b a =
+  AlongsideLeft {
+    getAlongsideLeft :: 
+      f (a, b)
+  }
+
+instance Functor f => Functor (AlongsideLeft f b) where
+  fmap f (AlongsideLeft x) =
+    AlongsideLeft (fmap (\(a, b) -> (f a, b)) x)
+
+data AlongsideRight f a b =
+  AlongsideRight {
+    getAlongsideRight :: 
+      f (a, b)
+  }
+
+instance Functor f => Functor (AlongsideRight f a) where
+  fmap f (AlongsideRight x) =
+    AlongsideRight (fmap (\(a, b) -> (a, f b)) x)

src/Lets/GetSetLens.hs

@@ -0,0 +1,544 @@
+module Lets.GetSetLens (
+  Lens(..)
+, getsetLaw
+, setgetLaw
+, setsetLaw
+, get
+, set
+, modify
+, (%~)
+, fmodify
+, (|=)
+, fstL
+, sndL
+, mapL
+, setL
+, compose
+, (|.)
+, identity
+, product
+, (***)
+, choice
+, (|||)
+, cityL
+, countryL
+, streetL
+, suburbL
+, localityL
+, ageL
+, nameL
+, addressL
+, getSuburb
+, setStreet
+, getAgeAndCountry
+, setCityAndLocality
+, getSuburbOrCity
+, setStreetOrState
+, modifyCityUppercase
+) where
+
+import Control.Applicative((<*>))
+import Data.Bool(bool)
+import Data.Char(toUpper)
+import Data.Map(Map)
+import qualified Data.Map as Map(insert, delete, lookup)
+import Data.Set(Set)
+import qualified Data.Set as Set(insert, delete, member)
+import Lets.Data
+import Prelude hiding (product)
+
+-- $setup
+-- >>> import qualified Data.Map as Map(fromList)
+-- >>> import qualified Data.Set as Set(fromList)
+-- >>> import Data.Char(ord)
+
+data Lens a b =
+  Lens
+    (a -> b -> a)
+    (a -> b)
+
+-- |
+--
+-- >>> get fstL (0 :: Int, "abc")
+-- 0
+--
+-- >>> get sndL ("abc", 0 :: Int)
+-- 0
+--
+-- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x
+--
+-- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y
+get ::
+  Lens a b
+  -> a
+  -> b
+get (Lens _ g) =
+  g
+
+-- |
+--
+-- >>> set fstL (0 :: Int, "abc") 1
+-- (1,"abc")
+--
+-- >>> set sndL ("abc", 0 :: Int) 1
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y)
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z)
+set ::
+  Lens a b
+  -> a 
+  -> b
+  -> a
+set (Lens s _) a =
+  s a
+
+-- | The get/set law of lenses. This function should always return @True@.
+getsetLaw ::
+  Eq a =>
+  Lens a b
+  -> a
+  -> Bool
+getsetLaw l =
+  \a -> set l a (get l a) == a
+  
+-- | The set/get law of lenses. This function should always return @True@.
+setgetLaw ::
+  Eq b =>
+  Lens a b
+  -> a
+  -> b
+  -> Bool
+setgetLaw l a b =
+  get l (set l a b) == b
+  
+-- | The set/set law of lenses. This function should always return @True@.
+setsetLaw ::
+  Eq a =>
+  Lens a b
+  -> a
+  -> b
+  -> b
+  -> Bool
+setsetLaw l a b1 b2 =
+  set l (set l a b1) b2 == set l a b2
+
+----
+
+-- |
+--
+-- >>> modify fstL (+1) (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> modify sndL (+1) ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y)
+modify ::
+  Lens a b
+  -> (b -> b)
+  -> a
+  -> a
+modify =
+  error "todo: modify"
+
+-- | An alias for @modify@.
+(%~) ::
+  Lens a b
+  -> (b -> b)
+  -> a
+  -> a
+(%~) =
+  modify
+
+infixr 4 %~
+
+-- |
+--
+-- >>> fstL .~ 1 $ (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> sndL .~ 1 $ ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y))
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y))
+(.~) ::
+  Lens a b
+  -> b
+  -> a
+  -> a
+(.~) =
+  error "todo: (.~)"
+
+infixl 5 .~
+
+-- |
+--
+-- >>> fmodify fstL (+) (5 :: Int, "abc") 8
+-- (13,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc")
+-- Just (20,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc")
+-- Nothing
+fmodify ::
+  Functor f =>
+  Lens a b
+  -> (b -> f b)
+  -> a
+  -> f a
+fmodify =
+  error "todo: fmodify"
+
+-- |
+--
+-- >>> fstL |= Just 3 $ (7, "abc")
+-- Just (3,"abc")
+--
+-- >>> (fstL |= (+1) $ (3, "abc")) 17
+-- (18,"abc")
+(|=) ::
+  Functor f =>
+  Lens a b
+  -> f b
+  -> a
+  -> f a
+(|=) =
+  error "todo: (|=)"
+
+infixl 5 |=
+
+-- |
+--
+-- >>> modify fstL (*10) (3, "abc")
+-- (30,"abc")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
+fstL ::
+  Lens (x, y) x
+fstL =
+  error "todo: fstL"
+
+-- |
+--
+-- >>> modify sndL (++ "def") (13, "abc")
+-- (13,"abcdef")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
+sndL ::
+  Lens (x, y) y
+sndL =
+  error "todo: sndL"
+
+-- |
+--
+-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Just 'c'
+--
+-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Nothing
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')]
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
+mapL ::
+  Ord k =>
+  k
+  -> Lens (Map k v) (Maybe v)
+mapL =
+  error "todo: mapL"
+
+-- |
+--
+-- >>> get (setL 3) (Set.fromList [1..5])
+-- True
+--
+-- >>> get (setL 33) (Set.fromList [1..5])
+-- False
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5]
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) False
+-- fromList [1,2,4,5]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5,33]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) False
+-- fromList [1,2,3,4,5]
+setL ::
+  Ord k =>
+  k
+  -> Lens (Set k) Bool
+setL =
+  error "todo: setL"
+
+-- |
+--
+-- >>> get (compose fstL sndL) ("abc", (7, "def"))
+-- 7
+--
+-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8
+-- ("abc",(8,"def"))
+compose ::
+  Lens b c
+  -> Lens a b
+  -> Lens a c
+compose =
+  error "todo: compose"
+
+-- | An alias for @compose@.
+(|.) ::
+  Lens b c
+  -> Lens a b
+  -> Lens a c
+(|.) =
+  compose
+
+infixr 9 |.
+
+-- |
+--
+-- >>> get identity 3
+-- 3
+--
+-- >>> set identity 3 4
+-- 4
+identity ::
+  Lens a a
+identity =
+  error "todo: identity"
+
+-- |
+--
+-- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
+-- ("abc","def")
+--
+-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl")
+-- (("ghi",3),(4,"jkl"))
+product ::
+  Lens a b
+  -> Lens c d
+  -> Lens (a, c) (b, d)
+product =
+  error "todo: product"
+
+-- | An alias for @product@.
+(***) ::
+  Lens a b
+  -> Lens c d
+  -> Lens (a, c) (b, d)
+(***) =
+  product
+
+infixr 3 ***
+
+-- |
+--
+-- >>> get (choice fstL sndL) (Left ("abc", 7))
+-- "abc"
+--
+-- >>> get (choice fstL sndL) (Right ("abc", 7))
+-- 7
+--
+-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def"
+-- Left ("def",7)
+--
+-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8
+-- Right ("abc",8)
+choice ::
+  Lens a x
+  -> Lens b x
+  -> Lens (Either a b) x
+choice =
+  error "todo: choice"
+
+-- | An alias for @choice@.
+(|||) ::
+  Lens a x
+  -> Lens b x
+  -> Lens (Either a b) x
+(|||) =
+  choice
+
+infixr 2 |||
+
+----
+
+cityL ::
+  Lens Locality String
+cityL =
+  Lens
+    (\(Locality _ t y) c -> Locality c t y)
+    (\(Locality c _ _) -> c)
+
+stateL ::
+  Lens Locality String
+stateL =
+  Lens
+    (\(Locality c _ y) t -> Locality c t y)
+    (\(Locality _ t _) -> t)
+
+countryL ::
+  Lens Locality String
+countryL =
+  Lens
+    (\(Locality c t _) y -> Locality c t y)
+    (\(Locality _ _ y) -> y)
+
+streetL ::
+  Lens Address String
+streetL =
+  Lens
+    (\(Address _ s l) t -> Address t s l)
+    (\(Address t _ _) -> t)
+
+suburbL ::
+  Lens Address String
+suburbL =
+  Lens
+    (\(Address t _ l) s -> Address t s l)
+    (\(Address _ s _) -> s)
+
+localityL ::
+  Lens Address Locality
+localityL =
+  Lens
+    (\(Address t s _) l -> Address t s l)
+    (\(Address _ _ l) -> l)
+
+ageL ::
+  Lens Person Int
+ageL =
+  Lens
+    (\(Person _ n d) a -> Person a n d)
+    (\(Person a _ _) -> a)
+
+nameL ::
+  Lens Person String
+nameL =
+  Lens
+    (\(Person a _ d) n -> Person a n d)
+    (\(Person _ n _) -> n)
+
+addressL ::
+  Lens Person Address
+addressL =
+  Lens
+    (\(Person a n _) d -> Person a n d)
+    (\(Person _ _ d) -> d)
+
+-- |
+--
+-- >>> get (suburbL |. addressL) fred
+-- "Fredville"
+--
+-- >>> get (suburbL |. addressL) mary
+-- "Maryland"
+getSuburb ::
+  Person
+  -> String
+getSuburb =
+  error "todo: getSuburb"
+
+-- |
+--
+-- >>> setStreet fred "Some Other St"
+-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))
+--
+-- >>> setStreet mary "Some Other St"
+-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan"))
+setStreet ::
+  Person
+  -> String
+  -> Person
+setStreet =
+  error "todo: setStreet"
+
+-- |
+--
+-- >>> getAgeAndCountry (fred, maryLocality)
+-- (24,"Maristan")
+--
+-- >>> getAgeAndCountry (mary, fredLocality)
+-- (28,"Fredalia")
+getAgeAndCountry ::
+  (Person, Locality)
+  -> (Int, String)
+getAgeAndCountry =
+  error "todo: getAgeAndCountry"
+
+-- |
+--
+-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality)
+-- (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"))
+--
+-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality)
+-- (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"))
+setCityAndLocality ::
+  (Person, Address) -> (String, Locality) -> (Person, Address)
+setCityAndLocality =
+  error "todo: setCityAndLocality"
+  
+-- |
+--
+-- >>> getSuburbOrCity (Left maryAddress)
+-- "Maryland"
+--
+-- >>> getSuburbOrCity (Right fredLocality)
+-- "Fredmania"
+getSuburbOrCity ::
+  Either Address Locality
+  -> String
+getSuburbOrCity =
+  error "todo: getSuburbOrCity"
+
+-- |
+--
+-- >>> setStreetOrState (Right maryLocality) "Some Other State"
+-- Right (Locality "Mary Mary" "Some Other State" "Maristan")
+--
+-- >>> setStreetOrState (Left fred) "Some Other St"
+-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")))
+setStreetOrState ::
+  Either Person Locality
+  -> String
+  -> Either Person Locality
+setStreetOrState =
+  error "todo: setStreetOrState"
+
+-- |
+--
+-- >>> modifyCityUppercase fred
+-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia"))
+--
+-- >>> modifyCityUppercase mary
+-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan"))
+modifyCityUppercase ::
+  Person
+  -> Person
+modifyCityUppercase =
+  error "todo: modifyCityUppercase"

src/Lets/Lens.hs

@@ -0,0 +1,7 @@
+module Lets.Lens (
+  module L
+) where
+
+import Lets.Lens.Choice as L
+import Lets.Lens.Lens as L
+import Lets.Lens.Profunctor as L

src/Lets/Lens/Choice.hs

@@ -0,0 +1,43 @@
+module Lets.Lens.Choice
+(
+  Choice(..)
+) where
+
+import Lets.Data
+import Lets.Lens.Profunctor
+
+diswap ::
+  Profunctor p =>
+  p (Either a b) (Either c d)
+  -> p (Either b a) (Either d c)
+diswap =
+  let swap = either Right Left 
+  in dimap swap swap
+
+-- | Map on left or right of @Either@. Only one of @left@ or @right@ needs to be
+-- provided.
+class Profunctor p => Choice p where
+  left ::
+    p a b
+    -> p (Either a c) (Either b c)
+  left =
+    diswap . right
+
+  right ::
+    p a b
+    -> p (Either c a) (Either c b)
+  right =
+    diswap . left
+
+instance Choice (->) where
+  left f =
+    either (Left . f) Right
+  right f =
+    either Left (Right . f)
+
+instance Choice Tagged where
+  left (Tagged x) =
+    Tagged (Left x)
+  right (Tagged x) =
+    Tagged (Right x)
+

src/Lets/Lens/Lens.hs

@@ -0,0 +1,788 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Lets.Lens.Lens (
+  fmapT
+, over
+, fmapTAgain
+, Set
+, sets
+, mapped
+, set
+, foldMapT
+, foldMapOf
+, foldMapTAgain
+, Fold
+, folds
+, folded
+, Get
+, get
+, Traversal
+, both
+, traverseLeft
+, traverseRight
+, Traversal'
+, Lens
+, Prism
+, _Left
+, _Right
+, prism
+, _Just
+, _Nothing
+, setP
+, getP
+, Prism'
+, modify
+, (%~)
+, (.~)
+, fmodify
+, (|=)
+, fstL
+, sndL
+, mapL
+, setL
+, compose
+, (|.)
+, identity
+, product
+, (***)
+, choice
+, (|||)
+, Lens'
+, cityL
+, stateL
+, countryL
+, streetL
+, suburbL
+, localityL
+, ageL
+, nameL
+, addressL
+, intAndIntL
+, intAndL
+, getSuburb
+, setStreet
+, getAgeAndCountry
+, setCityAndLocality
+, getSuburbOrCity
+, setStreetOrState
+, modifyCityUppercase
+, modifyIntAndLengthEven
+, traverseLocality
+, intOrIntP
+, intOrP
+, intOrLengthEven
+) where
+
+import Control.Applicative(Applicative(..))
+import Data.Bool(bool)
+import Data.Char(toUpper)
+import Data.Foldable(Foldable(..))
+import Data.Functor((<$>))
+import Data.Map(Map)
+import qualified Data.Map as Map(insert, delete, lookup)
+import Data.Monoid(Monoid(..))
+import qualified Data.Set as Set(Set, insert, delete, member)
+import Data.Traversable(Traversable(..))
+import Lets.Data
+import Lets.Lens.Choice
+import Lets.Lens.Profunctor
+import Prelude hiding (product)
+
+-- $setup
+-- >>> import qualified Data.Map as Map(fromList)
+-- >>> import qualified Data.Set as Set(fromList)
+-- >>> import Data.Char(ord)
+
+-- Let's remind ourselves of Traversable, noting Foldable and Functor.
+--
+-- class (Foldable t, Functor t) => Traversable t where
+--   traverse ::
+--     Applicative f => 
+--     (a -> f b)
+--     -> t a
+--     -> f (t b)
+
+-- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@.
+--
+-- /Reminder:/ fmap :: Functor t => (a -> b) -> t a -> t b
+fmapT ::
+  Traversable t =>
+  (a -> b)
+  -> t a
+  -> t b
+fmapT =
+  error "todo: fmapT"
+
+-- | Let's refactor out the call to @traverse@ as an argument to @fmapT@.
+over :: 
+  ((a -> Identity b) -> s -> Identity t)
+  -> (a -> b)
+  -> s
+  -> t
+over =
+  error "todo: over"
+
+-- | Here is @fmapT@ again, passing @traverse@ to @over@.
+fmapTAgain ::
+  Traversable t =>
+  (a -> b)
+  -> t a
+  -> t b
+fmapTAgain =
+  error "todo: fmapTAgain"
+
+-- | Let's create a type-alias for this type of function.
+type Set s t a b =
+  (a -> Identity b)
+  -> s
+  -> Identity t
+
+-- | Let's write an inverse to @over@ that does the @Identity@ wrapping &
+-- unwrapping.
+sets ::
+  ((a -> b) -> s -> t)
+  -> Set s t a b  
+sets =
+  error "todo: sets"
+
+mapped ::
+  Functor f =>
+  Set (f a) (f b) a b
+mapped =
+  error "todo: mapped"
+
+set ::
+  Set s t a b
+  -> s
+  -> b
+  -> t
+set =
+  error "todo: set"
+
+----
+
+-- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@.
+--
+-- /Reminder:/ foldMap :: (Foldable t, Monoid b) => (a -> b) -> t a -> b
+foldMapT ::
+  (Traversable t, Monoid b) =>
+  (a -> b)
+  -> t a
+  -> b
+foldMapT =
+  error "todo: foldMapT"
+
+-- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@.
+foldMapOf ::
+  ((a -> Const r b) -> s -> Const r t)
+  -> (a -> r)
+  -> s
+  -> r
+foldMapOf =
+  error "todo: foldMapOf"
+
+-- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@.
+foldMapTAgain ::
+  (Traversable t, Monoid b) =>
+  (a -> b)
+  -> t a
+  -> b
+foldMapTAgain =
+  error "todo: foldMapTAgain"
+
+-- | Let's create a type-alias for this type of function.
+type Fold s t a b =
+  forall r.
+  Monoid r =>
+  (a -> Const r b)
+  -> s
+  -> Const r t
+
+-- | Let's write an inverse to @foldMapOf@ that does the @Const@ wrapping &
+-- unwrapping.
+folds ::
+  ((a -> b) -> s -> t)
+  -> (a -> Const b a)
+  -> s
+  -> Const t s
+folds =
+  error "todo: folds"
+
+folded ::
+  Foldable f =>
+  Fold (f a) (f a) a a
+folded =
+  error "todo: folded"
+
+----
+
+-- | @Get@ is like @Fold@, but without the @Monoid@ constraint.
+type Get r s a =
+  (a -> Const r a)
+  -> s
+  -> Const r s
+
+get ::
+  Get a s a
+  -> s
+  -> a
+get =
+  error "todo: get"
+
+----
+
+-- | Let's generalise @Identity@ and @Const r@ to any @Applicative@ instance.
+type Traversal s t a b =
+  forall f.
+  Applicative f =>
+  (a -> f b)
+  -> s
+  -> f t
+
+-- | Traverse both sides of a pair.
+both ::
+  Traversal (a, a) (b, b) a b
+both =
+  error "todo: both"
+
+-- | Traverse the left side of @Either@.
+traverseLeft ::
+  Traversal (Either a x) (Either b x) a b
+traverseLeft =
+  error "todo: traverseLeft"
+
+-- | Traverse the right side of @Either@.
+traverseRight ::
+  Traversal (Either x a) (Either x b) a b
+traverseRight =
+  error "todo: traverseRight"
+
+type Traversal' a b =
+  Traversal a a b b
+
+----
+
+-- | @Const r@ is @Applicative@, if @Monoid r@, however, without the @Monoid@
+-- constraint (as in @Get@), the only shared abstraction between @Identity@ and
+-- @Const r@ is @Functor@.
+--
+-- Consequently, we arrive at our lens derivation:
+type Lens s t a b =
+  forall f.
+  Functor f =>
+  (a -> f b)
+  -> s
+  -> f t
+
+----
+
+-- | A prism is a less specific type of traversal.
+type Prism s t a b =
+  forall p f.
+  (Choice p, Applicative f) =>
+  p a (f b)
+  -> p s (f t)
+
+_Left ::
+  Prism (Either a x) (Either b x) a b
+_Left =
+  error "todo: _Left"
+
+_Right ::
+  Prism (Either x a) (Either x b) a b 
+_Right =
+  error "todo: _Right"
+
+prism ::
+  (b -> t)
+  -> (s -> Either t a)
+  -> Prism s t a b
+prism =
+  error "todo: prism"
+
+_Just ::
+  Prism (Maybe a) (Maybe b) a b
+_Just =
+  error "todo: _Just"
+
+_Nothing ::
+  Prism (Maybe a) (Maybe a) () ()
+_Nothing =
+  error "todo: _Nothing"
+
+setP ::
+  Prism s t a b
+  -> s
+  -> Either t a
+setP =
+  error "todo: setP"
+
+getP ::
+  Prism s t a b
+  -> b
+  -> t
+getP =
+  error "todo: getP"
+
+type Prism' a b =
+  Prism a a b b
+
+----
+
+-- |
+--
+-- >>> modify fstL (+1) (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> modify sndL (+1) ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y)
+modify ::
+  Lens s t a b
+  -> (a -> b)
+  -> s
+  -> t
+modify =
+  error "todo: modify"
+
+-- | An alias for @modify@.
+(%~) ::
+  Lens s t a b
+  -> (a -> b)
+  -> s
+  -> t
+(%~) =
+  modify
+
+infixr 4 %~
+
+-- |
+--
+-- >>> fstL .~ 1 $ (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> sndL .~ 1 $ ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y))
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y))
+(.~) ::
+  Lens s t a b
+  -> b
+  -> s
+  -> t
+(.~) =
+  error "todo: (.~)"
+
+infixl 5 .~
+
+-- |
+--
+-- >>> fmodify fstL (+) (5 :: Int, "abc") 8
+-- (13,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc")
+-- Just (20,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc")
+-- Nothing
+fmodify ::
+  Functor f =>
+  Lens s t a b
+  -> (a -> f b)
+  -> s
+  -> f t 
+fmodify =
+  error "todo: fmodify"
+
+-- |
+--
+-- >>> fstL |= Just 3 $ (7, "abc")
+-- Just (3,"abc")
+--
+-- >>> (fstL |= (+1) $ (3, "abc")) 17
+-- (18,"abc")
+(|=) ::
+  Functor f =>
+  Lens s t a b
+  -> f b
+  -> s
+  -> f t
+(|=) =
+  error "todo: (|=)"
+
+infixl 5 |=
+
+-- |
+--
+-- >>> modify fstL (*10) (3, "abc")
+-- (30,"abc")
+fstL ::
+  Lens (a, x) (b, x) a b
+fstL =
+  error "todo: fstL"
+
+-- |
+--
+-- >>> modify sndL (++ "def") (13, "abc")
+-- (13,"abcdef")
+sndL ::
+  Lens (x, a) (x, b) a b
+sndL =
+  error "todo: sndL"
+
+-- |
+--
+-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Just 'c'
+--
+-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Nothing
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')]
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
+mapL ::
+  Ord k =>
+  k
+  -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v)
+mapL =
+  error "todo: mapL"
+
+-- |
+--
+-- >>> get (setL 3) (Set.fromList [1..5])
+-- True
+--
+-- >>> get (setL 33) (Set.fromList [1..5])
+-- False
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5]
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) False
+-- fromList [1,2,4,5]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5,33]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) False
+-- fromList [1,2,3,4,5]
+setL ::
+  Ord k =>
+  k
+  -> Lens (Set.Set k) (Set.Set k) Bool Bool
+setL =
+  error "todo: setL"
+
+-- |
+--
+-- >>> get (compose fstL sndL) ("abc", (7, "def"))
+-- 7
+--
+-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8
+-- ("abc",(8,"def"))
+compose ::
+  Lens s t a b
+  -> Lens q r s t
+  -> Lens q r a b
+compose =
+  error "todo: compose"
+
+-- | An alias for @compose@.
+(|.) ::
+  Lens s t a b
+  -> Lens q r s t
+  -> Lens q r a b
+(|.) =
+  compose
+
+infixr 9 |.
+
+-- |
+--
+-- >>> get identity 3
+-- 3
+--
+-- >>> set identity 3 4
+-- 4
+identity ::
+  Lens a b a b
+identity =
+  error "todo: identity"
+
+-- |
+--
+-- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
+-- ("abc","def")
+--
+-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl")
+-- (("ghi",3),(4,"jkl"))
+product ::
+  Lens s t a b
+  -> Lens q r c d
+  -> Lens (s, q) (t, r) (a, c) (b, d)
+product =
+  error "todo: product"
+
+-- | An alias for @product@.
+(***) ::
+  Lens s t a b
+  -> Lens q r c d
+  -> Lens (s, q) (t, r) (a, c) (b, d)
+(***) =
+  product
+
+infixr 3 ***
+
+-- |
+--
+-- >>> get (choice fstL sndL) (Left ("abc", 7))
+-- "abc"
+--
+-- >>> get (choice fstL sndL) (Right ("abc", 7))
+-- 7
+--
+-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def"
+-- Left ("def",7)
+--
+-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8
+-- Right ("abc",8)
+choice ::
+  Lens s t a b
+  -> Lens q r a b
+  -> Lens (Either s q) (Either t r) a b
+choice =
+  error "todo: choice"
+
+-- | An alias for @choice@.
+(|||) ::
+  Lens s t a b
+  -> Lens q r a b
+  -> Lens (Either s q) (Either t r) a b
+(|||) =
+  choice
+
+infixr 2 |||
+
+----
+
+type Lens' a b =
+  Lens a a b b
+
+cityL ::
+  Lens' Locality String
+cityL p (Locality c t y) =
+  fmap (\c' -> Locality c' t y) (p c)
+
+stateL ::
+  Lens' Locality String
+stateL p (Locality c t y) =
+  fmap (\t' -> Locality c t' y) (p t)
+
+countryL ::
+  Lens' Locality String
+countryL p (Locality c t y) =
+  fmap (\y' -> Locality c t y') (p y)
+
+streetL ::
+  Lens' Address String
+streetL p (Address t s l) =
+  fmap (\t' -> Address t' s l) (p t)
+
+suburbL ::
+  Lens' Address String
+suburbL p (Address t s l) =
+  fmap (\s' -> Address t s' l) (p s)
+
+localityL ::
+  Lens' Address Locality
+localityL p (Address t s l) =
+  fmap (\l' -> Address t s l') (p l)
+
+ageL ::
+  Lens' Person Int
+ageL p (Person a n d) =
+  fmap (\a' -> Person a' n d) (p a)
+
+nameL ::
+  Lens' Person String
+nameL p (Person a n d) =
+  fmap (\n' -> Person a n' d) (p n)
+
+addressL ::
+  Lens' Person Address
+addressL p (Person a n d) =
+  fmap (\d' -> Person a n d') (p d)
+
+intAndIntL ::
+  Lens' (IntAnd a) Int
+intAndIntL p (IntAnd n a) =
+  fmap (\n' -> IntAnd n' a) (p n)
+
+-- lens for polymorphic update
+intAndL ::
+  Lens (IntAnd a) (IntAnd b) a b
+intAndL p (IntAnd n a) =
+  fmap (\a' -> IntAnd n a') (p a)
+
+-- |
+--
+-- >>> get (suburbL |. addressL) fred
+-- "Fredville"
+--
+-- >>> get (suburbL |. addressL) mary
+-- "Maryland"
+getSuburb ::
+  Person
+  -> String
+getSuburb =
+  error "todo: getSuburb"
+
+-- |
+--
+-- >>> setStreet fred "Some Other St"
+-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))
+--
+-- >>> setStreet mary "Some Other St"
+-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan"))
+setStreet ::
+  Person
+  -> String
+  -> Person
+setStreet =
+  error "todo: setStreet"
+
+-- |
+--
+-- >>> getAgeAndCountry (fred, maryLocality)
+-- (24,"Maristan")
+--
+-- >>> getAgeAndCountry (mary, fredLocality)
+-- (28,"Fredalia")
+getAgeAndCountry ::
+  (Person, Locality)
+  -> (Int, String)
+getAgeAndCountry =
+  error "todo: getAgeAndCountry"
+
+-- |
+--
+-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality)
+-- (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"))
+--
+-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality)
+-- (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"))
+setCityAndLocality ::
+  (Person, Address) -> (String, Locality) -> (Person, Address)
+setCityAndLocality =
+  error "todo: setCityAndLocality"
+  
+-- |
+--
+-- >>> getSuburbOrCity (Left maryAddress)
+-- "Maryland"
+--
+-- >>> getSuburbOrCity (Right fredLocality)
+-- "Fredmania"
+getSuburbOrCity ::
+  Either Address Locality
+  -> String
+getSuburbOrCity =
+  error "todo: getSuburbOrCity"
+
+-- |
+--
+-- >>> setStreetOrState (Right maryLocality) "Some Other State"
+-- Right (Locality "Mary Mary" "Some Other State" "Maristan")
+--
+-- >>> setStreetOrState (Left fred) "Some Other St"
+-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")))
+setStreetOrState ::
+  Either Person Locality
+  -> String
+  -> Either Person Locality
+setStreetOrState =
+  error "todo: setStreetOrState"
+
+-- |
+--
+-- >>> modifyCityUppercase fred
+-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia"))
+--
+-- >>> modifyCityUppercase mary
+-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan"))
+modifyCityUppercase ::
+  Person
+  -> Person
+modifyCityUppercase =
+  error "todo: modifyCityUppercase"
+
+-- |
+--
+-- >>> modifyIntAndLengthEven (IntAnd 10 "abc")
+-- IntAnd 10 False
+--
+-- >>> modifyIntAndLengthEven (IntAnd 10 "abcd")
+-- IntAnd 10 True
+modifyIntAndLengthEven ::
+  IntAnd [a]
+  -> IntAnd Bool
+modifyIntAndLengthEven =
+  error "todo: modifyIntAndLengthEven"
+
+----
+
+-- |
+--
+-- >>> over traverseLocality (map toUpper) (Locality "abc" "def" "ghi")
+-- Locality "ABC" "DEF" "GHI"
+traverseLocality ::
+  Traversal' Locality String
+traverseLocality =
+  error "todo: traverseLocality"
+
+-- |
+--
+-- >>> over intOrIntP (*10) (IntOrIs 3)
+-- IntOrIs 30
+--
+-- >>> over intOrIntP (*10) (IntOrIsNot "abc")
+-- IntOrIsNot "abc"
+intOrIntP ::
+  Prism' (IntOr a) Int
+intOrIntP =
+  error "todo: intOrIntP"
+
+intOrP ::
+  Prism (IntOr a) (IntOr b) a b
+intOrP =
+  error "todo: intOrP"
+
+-- |
+--
+-- >> over intOrP (even . length) (IntOrIsNot "abc")
+-- IntOrIsNot False
+--
+-- >>> over intOrP (even . length) (IntOrIsNot "abcd")
+-- IntOrIsNot True
+--
+-- >>> over intOrP (even . length) (IntOrIs 10)
+-- IntOrIs 10
+intOrLengthEven ::
+  IntOr [a]
+  -> IntOr Bool
+intOrLengthEven =
+  error "todo: intOrLengthEven"

src/Lets/Lens/Profunctor.hs

@@ -0,0 +1,22 @@
+module Lets.Lens.Profunctor
+(
+  Profunctor(dimap)
+) where
+
+import Lets.Data
+
+-- | A profunctor is a binary functor, with the first argument in contravariant
+-- (negative) position and the second argument in covariant (positive) position.
+class Profunctor p where
+  dimap ::
+    (b -> a)
+    -> (c -> d)
+    -> p a c
+    -> p b d
+
+instance Profunctor (->) where
+  dimap f g = \h -> g . h . f
+
+instance Profunctor Tagged where
+  dimap _ g (Tagged x) =
+    Tagged (g x)

src/Lets/OpticPolyLens.hs

@@ -0,0 +1,546 @@
+{-# LANGUAGE RankNTypes #-}
+
+module Lets.OpticPolyLens (
+  Lens(..)
+, getsetLaw
+, setgetLaw
+, setsetLaw
+, get
+, set
+, modify
+, (%~)
+, fmodify
+, (|=)
+, fstL
+, sndL
+, mapL
+, setL
+, compose
+, (|.)
+, identity
+, product
+, (***)
+, choice
+, (|||)
+, cityL
+, countryL
+, streetL
+, suburbL
+, localityL
+, ageL
+, nameL
+, addressL
+, intAndIntL
+, intAndL
+, getSuburb
+, setStreet
+, getAgeAndCountry
+, setCityAndLocality
+, getSuburbOrCity
+, setStreetOrState
+, modifyCityUppercase
+, modifyIntandLengthEven
+) where
+
+import Data.Bool(bool)
+import Data.Char(toUpper)
+import Data.Map(Map)
+import qualified Data.Map as Map(insert, delete, lookup)
+import Data.Set(Set)
+import qualified Data.Set as Set(insert, delete, member)
+import Lets.Data
+import Prelude hiding (product)
+
+-- $setup
+-- >>> import qualified Data.Map as Map(fromList)
+-- >>> import qualified Data.Set as Set(fromList)
+-- >>> import Data.Char(ord)
+
+data Lens s t a b =
+  Lens
+    (forall f. Functor f => (a -> f b) -> s -> f t)
+
+get ::
+  Lens s t a b
+  -> s
+  -> a
+get (Lens r) =
+  getConst . r Const
+
+set ::
+  Lens s t a b
+  -> s
+  -> b
+  -> t
+set (Lens r) a b =
+  getIdentity (r (const (Identity b)) a)
+
+-- | The get/set law of lenses. This function should always return @True@.
+getsetLaw ::
+  Eq s =>
+  Lens s s a a
+  -> s
+  -> Bool
+getsetLaw l =
+  \a -> set l a (get l a) == a
+
+-- | The set/get law of lenses. This function should always return @True@.
+setgetLaw ::
+  Eq a =>
+  Lens s s a a
+  -> s
+  -> a
+  -> Bool
+setgetLaw l a b =
+  get l (set l a b) == b
+
+-- | The set/set law of lenses. This function should always return @True@.
+setsetLaw ::
+  Eq s =>
+  Lens s s a b
+  -> s
+  -> b
+  -> b
+  -> Bool 
+setsetLaw l a b1 b2 =
+  set l (set l a b1) b2 == set l a b2
+
+----
+
+-- |
+--
+-- >>> modify fstL (+1) (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> modify sndL (+1) ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y)
+modify ::
+  Lens s t a b
+  -> (a -> b)
+  -> s
+  -> t
+modify =
+  error "todo: modify"
+
+-- | An alias for @modify@.
+(%~) ::
+  Lens s t a b
+  -> (a -> b)
+  -> s
+  -> t
+(%~) =
+  modify
+
+infixr 4 %~
+
+-- |
+--
+-- >>> fstL .~ 1 $ (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> sndL .~ 1 $ ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y))
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y))
+(.~) ::
+  Lens s t a b
+  -> b
+  -> s
+  -> t
+(.~) =
+  error "todo: (.~)"
+
+infixl 5 .~
+
+-- |
+--
+-- >>> fmodify fstL (+) (5 :: Int, "abc") 8
+-- (13,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc")
+-- Just (20,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc")
+-- Nothing
+fmodify ::
+  Functor f =>
+  Lens s t a b
+  -> (a -> f b)
+  -> s
+  -> f t 
+fmodify =
+  error "todo: fmodify"
+
+-- |
+--
+-- >>> fstL |= Just 3 $ (7, "abc")
+-- Just (3,"abc")
+--
+-- >>> (fstL |= (+1) $ (3, "abc")) 17
+-- (18,"abc")
+(|=) ::
+  Functor f =>
+  Lens s t a b
+  -> f b
+  -> s
+  -> f t
+(|=) =
+  error "todo: (|=)"
+
+infixl 5 |=
+
+-- |
+--
+-- >>> modify fstL (*10) (3, "abc")
+-- (30,"abc")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
+fstL ::
+  Lens (a, x) (b, x) a b
+fstL =
+  error "todo: fstL"
+
+-- |
+--
+-- >>> modify sndL (++ "def") (13, "abc")
+-- (13,"abcdef")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
+sndL ::
+  Lens (x, a) (x, b) a b
+sndL =
+  error "todo: sndL"
+
+-- |
+--
+-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Just 'c'
+--
+-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Nothing
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')]
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
+mapL ::
+  Ord k =>
+  k
+  -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v)
+mapL =
+  error "todo: mapL"
+
+-- |
+--
+-- >>> get (setL 3) (Set.fromList [1..5])
+-- True
+--
+-- >>> get (setL 33) (Set.fromList [1..5])
+-- False
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5]
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) False
+-- fromList [1,2,4,5]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5,33]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) False
+-- fromList [1,2,3,4,5]
+setL ::
+  Ord k =>
+  k
+  -> Lens (Set k) (Set k) Bool Bool
+setL =
+  error "todo: setL"
+
+-- |
+--
+-- >>> get (compose fstL sndL) ("abc", (7, "def"))
+-- 7
+--
+-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8
+-- ("abc",(8,"def"))
+compose ::
+  Lens s t a b
+  -> Lens q r s t
+  -> Lens q r a b
+compose =
+  error "todo: compose"
+
+-- | An alias for @compose@.
+(|.) ::
+  Lens s t a b
+  -> Lens q r s t
+  -> Lens q r a b
+(|.) =
+  compose
+
+infixr 9 |.
+
+-- |
+--
+-- >>> get identity 3
+-- 3
+--
+-- >>> set identity 3 4
+-- 4
+identity ::
+  Lens a b a b
+identity =
+  error "todo: identity"
+
+-- |
+--
+-- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
+-- ("abc","def")
+--
+-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl")
+-- (("ghi",3),(4,"jkl"))
+product ::
+  Lens s t a b
+  -> Lens q r c d
+  -> Lens (s, q) (t, r) (a, c) (b, d)
+product =
+  error "todo: product"
+
+-- | An alias for @product@.
+(***) ::
+  Lens s t a b
+  -> Lens q r c d
+  -> Lens (s, q) (t, r) (a, c) (b, d)
+(***) =
+  product
+
+infixr 3 ***
+
+-- |
+--
+-- >>> get (choice fstL sndL) (Left ("abc", 7))
+-- "abc"
+--
+-- >>> get (choice fstL sndL) (Right ("abc", 7))
+-- 7
+--
+-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def"
+-- Left ("def",7)
+--
+-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8
+-- Right ("abc",8)
+choice ::
+  Lens s t a b
+  -> Lens q r a b
+  -> Lens (Either s q) (Either t r) a b
+choice =
+  error "todo: choice"
+
+-- | An alias for @choice@.
+(|||) ::
+  Lens s t a b
+  -> Lens q r a b
+  -> Lens (Either s q) (Either t r) a b
+(|||) =
+  choice
+
+infixr 2 |||
+
+----
+
+type Lens' a b =
+  Lens a a b b
+
+cityL ::
+  Lens' Locality String
+cityL =
+  Lens
+    (\p (Locality c t y) -> fmap (\c' -> Locality c' t y) (p c))
+
+stateL ::
+  Lens' Locality String
+stateL =
+  Lens
+    (\p (Locality c t y) -> fmap (\t' -> Locality c t' y) (p t))
+
+countryL ::
+  Lens' Locality String
+countryL =
+  Lens
+    (\p (Locality c t y) -> fmap (\y' -> Locality c t y') (p y))
+
+streetL ::
+  Lens' Address String
+streetL =
+  Lens
+    (\p (Address t s l) -> fmap (\t' -> Address t' s l) (p t))
+
+suburbL ::
+  Lens' Address String
+suburbL =
+  Lens
+    (\p (Address t s l) -> fmap (\s' -> Address t s' l) (p s))
+
+localityL ::
+  Lens' Address Locality
+localityL =
+  Lens
+    (\p (Address t s l) -> fmap (\l' -> Address t s l') (p l))
+
+ageL ::
+  Lens' Person Int
+ageL =
+  Lens
+    (\p (Person a n d) -> fmap (\a' -> Person a' n d) (p a))
+
+nameL ::
+  Lens' Person String
+nameL =
+  Lens
+    (\p (Person a n d) -> fmap (\n' -> Person a n' d) (p n))
+
+addressL ::
+  Lens' Person Address
+addressL =
+  Lens
+    (\p (Person a n d) -> fmap (\d' -> Person a n d') (p d))
+
+intAndIntL ::
+  Lens' (IntAnd a) Int
+intAndIntL =
+  Lens
+    (\p (IntAnd n a) -> fmap (\n' -> IntAnd n' a) (p n))
+
+-- lens for polymorphic update
+intAndL ::
+  Lens (IntAnd a) (IntAnd b) a b
+intAndL =
+  Lens
+    (\p (IntAnd n a) -> fmap (\a' -> IntAnd n a') (p a))
+
+-- |
+--
+-- >>> get (suburbL |. addressL) fred
+-- "Fredville"
+--
+-- >>> get (suburbL |. addressL) mary
+-- "Maryland"
+getSuburb ::
+  Person
+  -> String
+getSuburb =
+  error "todo: getSuburb"
+
+
+-- |
+--
+-- >>> setStreet fred "Some Other St"
+-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))
+--
+-- >>> setStreet mary "Some Other St"
+-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan"))
+setStreet ::
+  Person
+  -> String
+  -> Person
+setStreet =
+  error "todo: setStreet"
+
+-- |
+--
+-- >>> getAgeAndCountry (fred, maryLocality)
+-- (24,"Maristan")
+--
+-- >>> getAgeAndCountry (mary, fredLocality)
+-- (28,"Fredalia")
+getAgeAndCountry ::
+  (Person, Locality)
+  -> (Int, String)
+getAgeAndCountry =
+  error "todo: getAgeAndCountry"
+
+-- |
+--
+-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality)
+-- (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"))
+--
+-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality)
+-- (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"))
+setCityAndLocality ::
+  (Person, Address) -> (String, Locality) -> (Person, Address)
+setCityAndLocality =
+  error "todo: setCityAndLocality"
+  
+-- |
+--
+-- >>> getSuburbOrCity (Left maryAddress)
+-- "Maryland"
+--
+-- >>> getSuburbOrCity (Right fredLocality)
+-- "Fredmania"
+getSuburbOrCity ::
+  Either Address Locality
+  -> String
+getSuburbOrCity =
+  get (suburbL ||| cityL)
+
+-- |
+--
+-- >>> setStreetOrState (Right maryLocality) "Some Other State"
+-- Right (Locality "Mary Mary" "Some Other State" "Maristan")
+--
+-- >>> setStreetOrState (Left fred) "Some Other St"
+-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")))
+setStreetOrState ::
+  Either Person Locality
+  -> String
+  -> Either Person Locality
+setStreetOrState =
+  set (streetL |. addressL ||| stateL)
+
+-- |
+--
+-- >>> modifyCityUppercase fred
+-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia"))
+--
+-- >>> modifyCityUppercase mary
+-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan"))
+modifyCityUppercase ::
+  Person
+  -> Person
+modifyCityUppercase =
+  cityL |. localityL |. addressL %~ map toUpper
+
+-- |
+--
+-- >>> modify intAndL (even . length) (IntAnd 10 "abc")
+-- IntAnd 10 False
+--
+-- >>> modify intAndL (even . length) (IntAnd 10 "abcd")
+-- IntAnd 10 True
+modifyIntandLengthEven ::
+  IntAnd [a]
+  -> IntAnd Bool
+modifyIntandLengthEven =
+  intAndL %~ even . length

src/Lets/StoreLens.hs

@@ -0,0 +1,592 @@
+module Lets.StoreLens (
+  Store(..)
+, setS
+, getS
+, mapS
+, duplicateS
+, extendS
+, extractS
+, Lens(..)
+, getsetLaw
+, setgetLaw
+, setsetLaw
+, get
+, set
+, modify
+, (%~)
+, fmodify
+, (|=)
+, fstL
+, sndL
+, mapL
+, setL
+, compose
+, (|.)
+, identity
+, product
+, (***)
+, choice
+, (|||)
+, cityL
+, countryL
+, streetL
+, suburbL
+, localityL
+, ageL
+, nameL
+, addressL
+, getSuburb
+, setStreet
+, getAgeAndCountry
+, setCityAndLocality
+, getSuburbOrCity
+, setStreetOrState
+, modifyCityUppercase
+) where
+
+import Control.Applicative((<*>))
+import Data.Bool(bool)
+import Data.Char(toUpper)
+import Data.Functor((<$>))
+import Data.Map(Map)
+import qualified Data.Map as Map(insert, delete, lookup)
+import Data.Set(Set)
+import qualified Data.Set as Set(insert, delete, member)
+import Lets.Data
+import Prelude hiding (product)
+
+-- $setup
+-- >>> import qualified Data.Map as Map(fromList)
+-- >>> import qualified Data.Set as Set(fromList)
+-- >>> import Data.Char(ord)
+
+setS ::
+  Store s a
+  -> s
+  -> a
+setS (Store s _) =
+  s
+
+getS ::
+  Store s a
+  -> s
+getS (Store _ g) =
+  g
+
+mapS ::
+  (a -> b)
+  -> Store s a
+  -> Store s b
+mapS =
+  error "todo: mapS"
+
+duplicateS ::
+  Store s a
+  -> Store s (Store s a)
+duplicateS =
+  error "todo: duplicateS"
+
+extendS ::
+  (Store s a -> b)
+  -> Store s a
+  -> Store s b
+extendS =
+  error "todo: extendS"
+
+extractS ::
+  Store s a
+  -> a
+extractS =
+  error "todo: extractS"
+
+----
+
+data Lens a b =
+  Lens
+    (a -> Store b a)
+
+-- |
+--
+-- >>> get fstL (0 :: Int, "abc")
+-- 0
+--
+-- >>> get sndL ("abc", 0 :: Int)
+-- 0
+--
+-- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x
+--
+-- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y
+get ::
+  Lens a b
+  -> a
+  -> b
+get (Lens r) =
+  getS . r
+
+-- |
+--
+-- >>> set fstL (0 :: Int, "abc") 1
+-- (1,"abc")
+--
+-- >>> set sndL ("abc", 0 :: Int) 1
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y)
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z)
+set ::
+  Lens a b
+  -> a 
+  -> b
+  -> a
+set (Lens r) =
+  setS . r
+
+-- | The get/set law of lenses. This function should always return @True@.
+getsetLaw ::
+  Eq a =>
+  Lens a b
+  -> a
+  -> Bool
+getsetLaw l =
+  \a -> set l a (get l a) == a
+  
+-- | The set/get law of lenses. This function should always return @True@.
+setgetLaw ::
+  Eq b =>
+  Lens a b
+  -> a
+  -> b
+  -> Bool
+setgetLaw l a b =
+  get l (set l a b) == b
+
+-- | The set/set law of lenses. This function should always return @True@.
+setsetLaw ::
+  Eq a =>
+  Lens a b
+  -> a
+  -> b
+  -> b
+  -> Bool
+setsetLaw l a b1 b2 =
+  set l (set l a b1) b2 == set l a b2
+
+----
+
+-- |
+--
+-- >>> modify fstL (+1) (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> modify sndL (+1) ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y)
+modify ::
+  Lens a b
+  -> (b -> b)
+  -> a
+  -> a
+modify =
+  error "todo: modify"
+
+-- | An alias for @modify@.
+(%~) ::
+  Lens a b
+  -> (b -> b)
+  -> a
+  -> a
+(%~) =
+  modify
+
+infixr 4 %~
+
+-- |
+--
+-- >>> fstL .~ 1 $ (0 :: Int, "abc")
+-- (1,"abc")
+--
+-- >>> sndL .~ 1 $ ("abc", 0 :: Int)
+-- ("abc",1)
+--
+-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y))
+--
+-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y))
+(.~) ::
+  Lens a b
+  -> b
+  -> a
+  -> a
+(.~) =
+  error "todo: (.~)"
+
+infixl 5 .~
+
+-- |
+--
+-- >>> fmodify fstL (+) (5 :: Int, "abc") 8
+-- (13,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc")
+-- Just (20,"abc")
+--
+-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc")
+-- Nothing
+fmodify ::
+  Functor f =>
+  Lens a b
+  -> (b -> f b)
+  -> a
+  -> f a
+fmodify =
+  error "todo: fmodify"
+  
+-- |
+--
+-- >>> fstL |= Just 3 $ (7, "abc")
+-- Just (3,"abc")
+--
+-- >>> (fstL |= (+1) $ (3, "abc")) 17
+-- (18,"abc")
+(|=) ::
+  Functor f =>
+  Lens a b
+  -> f b
+  -> a
+  -> f a
+(|=) =
+  error "todo: (|=)"
+
+infixl 5 |=
+
+-- |
+--
+-- >>> modify fstL (*10) (3, "abc")
+-- (30,"abc")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
+fstL ::
+  Lens (x, y) x
+fstL =
+  error "todo: fstL"
+
+-- |
+--
+-- >>> modify sndL (++ "def") (13, "abc")
+-- (13,"abcdef")
+--
+-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y)
+--
+-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z
+--
+-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
+sndL ::
+  Lens (x, y) y
+sndL =
+  error "todo: sndL"
+
+-- |
+--
+-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Just 'c'
+--
+-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d']))
+-- Nothing
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X')
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')]
+--
+-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(4,'d')]
+--
+-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing
+-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
+mapL ::
+  Ord k =>
+  k
+  -> Lens (Map k v) (Maybe v)
+mapL =
+  error "todo: mapL"
+
+-- |
+--
+-- >>> get (setL 3) (Set.fromList [1..5])
+-- True
+--
+-- >>> get (setL 33) (Set.fromList [1..5])
+-- False
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5]
+--
+-- >>> set (setL 3) (Set.fromList [1..5]) False
+-- fromList [1,2,4,5]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) True
+-- fromList [1,2,3,4,5,33]
+--
+-- >>> set (setL 33) (Set.fromList [1..5]) False
+-- fromList [1,2,3,4,5]
+setL ::
+  Ord k =>
+  k
+  -> Lens (Set k) Bool
+setL =
+  error "todo: setL"
+
+-- |
+--
+-- >>> get (compose fstL sndL) ("abc", (7, "def"))
+-- 7
+--
+-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8
+-- ("abc",(8,"def"))
+compose ::
+  Lens b c
+  -> Lens a b
+  -> Lens a c
+compose =
+  error "todo: compose"
+
+-- | An alias for @compose@.
+(|.) ::
+  Lens b c
+  -> Lens a b
+  -> Lens a c
+(|.) =
+  compose
+
+infixr 9 |.
+
+-- |
+--
+-- >>> get identity 3
+-- 3
+--
+-- >>> set identity 3 4
+-- 4
+identity ::
+  Lens a a
+identity =
+  error "todo: identity"
+    
+-- |
+--
+-- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
+-- ("abc","def")
+--
+-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl")
+-- (("ghi",3),(4,"jkl"))
+product ::
+  Lens a b
+  -> Lens c d
+  -> Lens (a, c) (b, d)
+product =
+  error "todo: product"
+
+-- | An alias for @product@.
+(***) ::
+  Lens a b
+  -> Lens c d
+  -> Lens (a, c) (b, d)
+(***) =
+  product
+
+infixr 3 ***
+
+-- |
+--
+-- >>> get (choice fstL sndL) (Left ("abc", 7))
+-- "abc"
+--
+-- >>> get (choice fstL sndL) (Right ("abc", 7))
+-- 7
+--
+-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def"
+-- Left ("def",7)
+--
+-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8
+-- Right ("abc",8)
+choice ::
+  Lens a x
+  -> Lens b x
+  -> Lens (Either a b) x
+choice =
+  error "todo: choice"
+
+-- | An alias for @choice@.
+(|||) ::
+  Lens a x
+  -> Lens b x
+  -> Lens (Either a b) x
+(|||) =
+  choice
+
+infixr 2 |||
+
+----
+
+cityL ::
+  Lens Locality String
+cityL =
+  Lens
+    (\(Locality c t y) ->
+      Store (\c' -> Locality c' t y) c)
+
+stateL ::
+  Lens Locality String
+stateL =
+  Lens
+    (\(Locality c t y) ->
+      Store (\t' -> Locality c t' y) t)
+
+countryL ::
+  Lens Locality String
+countryL =
+  Lens
+    (\(Locality c t y) ->
+      Store (\y' -> Locality c t y') y)
+
+streetL ::
+  Lens Address String
+streetL =
+  Lens
+    (\(Address t s l) ->
+      Store (\t' -> Address t' s l) t)
+
+suburbL ::
+  Lens Address String
+suburbL =
+  Lens
+    (\(Address t s l) ->
+      Store (\s' -> Address t s' l) s)
+
+localityL ::
+  Lens Address Locality
+localityL =
+  Lens
+    (\(Address t s l) ->
+      Store (\l' -> Address t s l') l)
+
+ageL ::
+  Lens Person Int
+ageL =
+  Lens
+    (\(Person a n d) ->
+      Store (\a' -> Person a' n d) a)
+
+nameL ::
+  Lens Person String
+nameL =
+  Lens
+    (\(Person a n d) ->
+      Store (\n' -> Person a n' d) n)
+
+addressL ::
+  Lens Person Address
+addressL =
+  Lens
+    (\(Person a n d) ->
+    Store (\d' -> Person a n d') d)
+
+-- |
+--
+-- >>> get (suburbL |. addressL) fred
+-- "Fredville"
+--
+-- >>> get (suburbL |. addressL) mary
+-- "Maryland"
+getSuburb ::
+  Person
+  -> String
+getSuburb =
+  error "todo: getSuburb"
+
+-- |
+--
+-- >>> setStreet fred "Some Other St"
+-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))
+--
+-- >>> setStreet mary "Some Other St"
+-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan"))
+setStreet ::
+  Person
+  -> String
+  -> Person
+setStreet =
+  error "todo: setStreet"
+
+-- |
+--
+-- >>> getAgeAndCountry (fred, maryLocality)
+-- (24,"Maristan")
+--
+-- >>> getAgeAndCountry (mary, fredLocality)
+-- (28,"Fredalia")
+getAgeAndCountry ::
+  (Person, Locality)
+  -> (Int, String)
+getAgeAndCountry =
+  error "todo: getAgeAndCountry"
+
+-- |
+--
+-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality)
+-- (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"))
+--
+-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality)
+-- (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"))
+setCityAndLocality ::
+  (Person, Address) -> (String, Locality) -> (Person, Address)
+setCityAndLocality =
+  error "todo: setCityAndLocality"
+  
+-- |
+--
+-- >>> getSuburbOrCity (Left maryAddress)
+-- "Maryland"
+--
+-- >>> getSuburbOrCity (Right fredLocality)
+-- "Fredmania"
+getSuburbOrCity ::
+  Either Address Locality
+  -> String
+getSuburbOrCity =
+  error "todo: getSuburbOrCity"
+
+-- |
+--
+-- >>> setStreetOrState (Right maryLocality) "Some Other State"
+-- Right (Locality "Mary Mary" "Some Other State" "Maristan")
+--
+-- >>> setStreetOrState (Left fred) "Some Other St"
+-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")))
+setStreetOrState ::
+  Either Person Locality
+  -> String
+  -> Either Person Locality
+setStreetOrState =
+  error "todo: setStreetOrState"
+
+-- |
+--
+-- >>> modifyCityUppercase fred
+-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia"))
+--
+-- >>> modifyCityUppercase mary
+-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan"))
+modifyCityUppercase ::
+  Person
+  -> Person
+modifyCityUppercase =
+  error "todo: modifyCityUppercase"