sanchayanmaity/lets-lens
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Initial set of exercises, no answers

Browse source
This commit is contained in:
Tony Morris 2015-04-22 13:14:38 +10:00
parent 825eb48997
commit 77da1bf37b
12 changed files with 2804 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
.ghci
View file

@ -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

66
README.markdown
View file

@ -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)

13
lets-lens.cabal
View file

@ -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:

9
src/Lets.hs
View file

@ -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
View 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
View 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
View 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
View 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
View 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 ::
IntOr [a]
-> IntOr Bool
intOrLengthEven =
error "todo: intOrLengthEven"

22
src/Lets/Lens/Profunctor.hs Normal file
View file

@ -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)

546
src/Lets/OpticPolyLens.hs Normal file
View file

@ -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

592
src/Lets/StoreLens.hs Normal file
View file

@ -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"