src: Lets: StoreLens: Implement store lens
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
parent
5186970bb8
commit
246f6b1302
1 changed files with 54 additions and 52 deletions
|
|
@ -47,12 +47,12 @@ module Lets.StoreLens (
|
|||
) where
|
||||
|
||||
import Control.Applicative(Applicative((<*>)))
|
||||
import Data.Char(toUpper)
|
||||
import Data.Char(toUpper, ord)
|
||||
import Data.Functor((<$>))
|
||||
import Data.Map(Map)
|
||||
import qualified Data.Map as Map(insert, delete, lookup)
|
||||
import qualified Data.Map as Map(insert, delete, lookup, fromList)
|
||||
import Data.Set(Set)
|
||||
import qualified Data.Set as Set(insert, delete, member)
|
||||
import qualified Data.Set as Set(insert, delete, member, fromList)
|
||||
import Lets.Data(Store(Store), Person(Person), Locality(Locality), Address(Address))
|
||||
import Prelude hiding (product)
|
||||
|
||||
|
|
@ -80,27 +80,23 @@ mapS ::
|
|||
(a -> b)
|
||||
-> Store s a
|
||||
-> Store s b
|
||||
mapS =
|
||||
error "todo: mapS"
|
||||
mapS f (Store sToa s) = Store (\ss -> f (sToa ss)) s
|
||||
|
||||
duplicateS ::
|
||||
Store s a
|
||||
-> Store s (Store s a)
|
||||
duplicateS =
|
||||
error "todo: duplicateS"
|
||||
duplicateS (Store sToa a) = Store (\s -> Store sToa s) a
|
||||
|
||||
extendS ::
|
||||
(Store s a -> b)
|
||||
-> Store s a
|
||||
-> Store s b
|
||||
extendS =
|
||||
error "todo: extendS"
|
||||
extendS f = mapS f . duplicateS
|
||||
|
||||
extractS ::
|
||||
Store s a
|
||||
-> a
|
||||
extractS =
|
||||
error "todo: extractS"
|
||||
extractS = \(Store sToa s) -> sToa s
|
||||
|
||||
----
|
||||
|
||||
|
|
@ -193,8 +189,7 @@ modify ::
|
|||
-> (b -> b)
|
||||
-> a
|
||||
-> a
|
||||
modify =
|
||||
error "todo: modify"
|
||||
modify (Lens f) bTob a = let Store s g = f a in s (bTob g)
|
||||
|
||||
-- | An alias for @modify@.
|
||||
(%~) ::
|
||||
|
|
@ -223,8 +218,7 @@ infixr 4 %~
|
|||
-> b
|
||||
-> a
|
||||
-> a
|
||||
(.~) =
|
||||
error "todo: (.~)"
|
||||
(.~) = \(Lens f) -> \v -> \a -> let Store s g = f a in s v
|
||||
|
||||
infixl 5 .~
|
||||
|
||||
|
|
@ -244,9 +238,8 @@ fmodify ::
|
|||
-> (b -> f b)
|
||||
-> a
|
||||
-> f a
|
||||
fmodify =
|
||||
error "todo: fmodify"
|
||||
|
||||
fmodify (Lens f) bTofb a = let Store s g = f a in s <$> bTofb g
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> fstL |= Just 3 $ (7, "abc")
|
||||
|
|
@ -260,8 +253,7 @@ fmodify =
|
|||
-> f b
|
||||
-> a
|
||||
-> f a
|
||||
(|=) =
|
||||
error "todo: (|=)"
|
||||
(|=) (Lens f) fb a = let Store s g = f a in s <$> fb
|
||||
|
||||
infixl 5 |=
|
||||
|
||||
|
|
@ -277,8 +269,7 @@ infixl 5 |=
|
|||
-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
|
||||
fstL ::
|
||||
Lens (x, y) x
|
||||
fstL =
|
||||
error "todo: fstL"
|
||||
fstL = Lens (\(x, y) -> Store (\x' -> (x', y)) x)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -292,8 +283,7 @@ fstL =
|
|||
-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
|
||||
sndL ::
|
||||
Lens (x, y) y
|
||||
sndL =
|
||||
error "todo: sndL"
|
||||
sndL = Lens (\(x, y) -> Store (\y' -> (x, y')) y)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -318,8 +308,10 @@ mapL ::
|
|||
Ord k =>
|
||||
k
|
||||
-> Lens (Map k v) (Maybe v)
|
||||
mapL =
|
||||
error "todo: mapL"
|
||||
mapL k = Lens (\mkv -> Store (\mv -> case mv of
|
||||
Nothing -> Map.delete k mkv
|
||||
Just a -> Map.insert k a mkv)
|
||||
(Map.lookup k mkv))
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -344,8 +336,10 @@ setL ::
|
|||
Ord k =>
|
||||
k
|
||||
-> Lens (Set k) Bool
|
||||
setL =
|
||||
error "todo: setL"
|
||||
setL k = Lens (\sk -> Store (\bool -> case bool of
|
||||
True -> Set.insert k sk
|
||||
False -> Set.delete k sk)
|
||||
(Set.member k sk))
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -358,8 +352,10 @@ compose ::
|
|||
Lens b c
|
||||
-> Lens a b
|
||||
-> Lens a c
|
||||
compose =
|
||||
error "todo: compose"
|
||||
compose = \(Lens f) -> \(Lens g) ->
|
||||
Lens (\a -> let Store bToa b = g a
|
||||
in let Store cTob c = f b
|
||||
in Store (bToa . cTob) c)
|
||||
|
||||
-- | An alias for @compose@.
|
||||
(|.) ::
|
||||
|
|
@ -380,9 +376,8 @@ infixr 9 |.
|
|||
-- 4
|
||||
identity ::
|
||||
Lens a a
|
||||
identity =
|
||||
error "todo: identity"
|
||||
|
||||
identity = Lens (\a -> Store (\a' -> a') a)
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
|
||||
|
|
@ -394,8 +389,10 @@ product ::
|
|||
Lens a b
|
||||
-> Lens c d
|
||||
-> Lens (a, c) (b, d)
|
||||
product =
|
||||
error "todo: product"
|
||||
product (Lens f) (Lens g) =
|
||||
Lens (\(a, c) -> let Store h i = f a
|
||||
in let Store j k = g c
|
||||
in Store (\(b, d) -> (h b, j d)) (i, k))
|
||||
|
||||
-- | An alias for @product@.
|
||||
(***) ::
|
||||
|
|
@ -424,8 +421,10 @@ choice ::
|
|||
Lens a x
|
||||
-> Lens b x
|
||||
-> Lens (Either a b) x
|
||||
choice =
|
||||
error "todo: choice"
|
||||
choice (Lens ax) (Lens bx) =
|
||||
Lens (\eab -> case eab of
|
||||
Left a -> let Store f g = ax a in Store (\x -> Left $ f x) g
|
||||
Right b -> let Store h i = bx b in Store (\x -> Right $ h x) i)
|
||||
|
||||
-- | An alias for @choice@.
|
||||
(|||) ::
|
||||
|
|
@ -512,8 +511,7 @@ addressL =
|
|||
getSuburb ::
|
||||
Person
|
||||
-> String
|
||||
getSuburb =
|
||||
error "todo: getSuburb"
|
||||
getSuburb = get $ (compose suburbL addressL)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -526,8 +524,7 @@ setStreet ::
|
|||
Person
|
||||
-> String
|
||||
-> Person
|
||||
setStreet =
|
||||
error "todo: setStreet"
|
||||
setStreet = set $ (compose streetL addressL)
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -539,8 +536,9 @@ setStreet =
|
|||
getAgeAndCountry ::
|
||||
(Person, Locality)
|
||||
-> (Int, String)
|
||||
getAgeAndCountry =
|
||||
error "todo: getAgeAndCountry"
|
||||
getAgeAndCountry (person, locality) = (get ageL person,
|
||||
get countryL locality)
|
||||
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -551,9 +549,11 @@ getAgeAndCountry =
|
|||
-- (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"
|
||||
|
||||
setCityAndLocality (person, address) (city, locality) =
|
||||
(set (cityL |. localityL |. addressL) person city,
|
||||
set localityL address locality)
|
||||
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> getSuburbOrCity (Left maryAddress)
|
||||
|
|
@ -564,8 +564,10 @@ setCityAndLocality =
|
|||
getSuburbOrCity ::
|
||||
Either Address Locality
|
||||
-> String
|
||||
getSuburbOrCity =
|
||||
error "todo: getSuburbOrCity"
|
||||
getSuburbOrCity = \soc -> case soc of
|
||||
Left address -> get suburbL address
|
||||
Right locality -> get cityL locality
|
||||
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -578,8 +580,9 @@ setStreetOrState ::
|
|||
Either Person Locality
|
||||
-> String
|
||||
-> Either Person Locality
|
||||
setStreetOrState =
|
||||
error "todo: setStreetOrState"
|
||||
setStreetOrState = \sos -> \ipsos -> case sos of
|
||||
Left person -> Left $ set (streetL |. addressL) person ipsos
|
||||
Right locality -> Right $ set stateL locality ipsos
|
||||
|
||||
-- |
|
||||
--
|
||||
|
|
@ -591,5 +594,4 @@ setStreetOrState =
|
|||
modifyCityUppercase ::
|
||||
Person
|
||||
-> Person
|
||||
modifyCityUppercase =
|
||||
error "todo: modifyCityUppercase"
|
||||
modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper
|
||||
|
|
|
|||
Loading…
Reference in a new issue