Initial set of exercises, no answers
This commit is contained in:
parent
825eb48997
commit
77da1bf37b
12 changed files with 2804 additions and 8 deletions
2
.ghci
2
.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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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()
|
||||
|
|
180
src/Lets/Data.hs
Normal file
180
src/Lets/Data.hs
Normal file
|
@ -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)
|
544
src/Lets/GetSetLens.hs
Normal file
544
src/Lets/GetSetLens.hs
Normal file
|
@ -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"
|
7
src/Lets/Lens.hs
Normal file
7
src/Lets/Lens.hs
Normal file
|
@ -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
|
43
src/Lets/Lens/Choice.hs
Normal file
43
src/Lets/Lens/Choice.hs
Normal file
|
@ -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)
|
||||
|
788
src/Lets/Lens/Lens.hs
Normal file
788
src/Lets/Lens/Lens.hs
Normal file
|
@ -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 ::
|
||||