src: Lets: StoreLens: Implement store lens

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>

src/Lets/StoreLens.hs

@@ -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 =
+mapS f (Store sToa s) = Store (\ss -> f (sToa ss)) s
-  error "todo: mapS"
 
 duplicateS ::
   Store s a
   -> Store s (Store s a)
-duplicateS =
+duplicateS (Store sToa a) = Store (\s -> Store sToa s) a
-  error "todo: duplicateS"
 
 extendS ::
   (Store s a -> b)
   -> Store s a
   -> Store s b
-extendS =
+extendS f = mapS f . duplicateS
-  error "todo: extendS"
 
 extractS ::
   Store s a
   -> a
-extractS =
+extractS = \(Store sToa s) -> sToa s
-  error "todo: extractS"
 
 ----
 
@@ -193,8 +189,7 @@ modify ::
   -> (b -> b)
   -> a
   -> a
-modify =
+modify (Lens f) bTob a = let Store s g = f a in s (bTob g)
-  error "todo: modify"
 
 -- | An alias for @modify@.
 (%~) ::
@@ -223,8 +218,7 @@ infixr 4 %~
   -> b
   -> a
   -> a
-(.~) =
+(.~) = \(Lens f) -> \v -> \a -> let Store s g = f a in s v
-  error "todo: (.~)"
 
 infixl 5 .~
 
@@ -244,8 +238,7 @@ fmodify ::
   -> (b -> f b)
   -> a
   -> f a
-fmodify =
+fmodify (Lens f) bTofb a = let Store s g = f a in s <$> bTofb g
-  error "todo: fmodify"
 
 -- |
 --
@@ -260,8 +253,7 @@ fmodify =
   -> f b
   -> a
   -> f a
-(|=) =
+(|=) (Lens f) fb a = let Store s g = f a in s <$> fb
-  error "todo: (|=)"
 
 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 =
+fstL = Lens (\(x, y) -> Store (\x' -> (x', y)) x)
-  error "todo: fstL"
 
 -- |
 --
@@ -292,8 +283,7 @@ fstL =
 -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
 sndL ::
   Lens (x, y) y
-sndL =
+sndL = Lens (\(x, y) -> Store (\y' -> (x, y')) y)
-  error "todo: sndL"
 
 -- |
 --
@@ -318,8 +308,10 @@ mapL ::
   Ord k =>
   k
   -> Lens (Map k v) (Maybe v)
-mapL =
+mapL k = Lens (\mkv -> Store (\mv -> case mv of
-  error "todo: mapL"
+                                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 =
+setL k = Lens (\sk -> Store (\bool -> case bool of
-  error "todo: setL"
+                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 =
+compose = \(Lens f) -> \(Lens g) ->
-  error "todo: compose"
+    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,8 +376,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a a
-identity =
+identity = Lens (\a -> Store (\a' -> a') a)
-  error "todo: identity"
 
 -- |
 --
@@ -394,8 +389,10 @@ product ::
   Lens a b
   -> Lens c d
   -> Lens (a, c) (b, d)
-product =
+product (Lens f) (Lens g) =
-  error "todo: product"
+    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 =
+choice (Lens ax) (Lens bx) =
-  error "todo: choice"
+    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 =
+getSuburb = get $ (compose suburbL addressL)
-  error "todo: getSuburb"
 
 -- |
 --
@@ -526,8 +524,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
+setStreet = set $ (compose streetL addressL)
-  error "todo: setStreet"
 
 -- |
 --
@@ -539,8 +536,9 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
+getAgeAndCountry (person, locality) = (get ageL person,
-  error "todo: getAgeAndCountry"
+                                       get countryL locality)
+
 
 -- |
 --
@@ -551,8 +549,10 @@ 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 =
+setCityAndLocality (person, address) (city, locality) =
-  error "todo: setCityAndLocality"
+  (set (cityL |. localityL |. addressL) person city,
+   set localityL address locality)
+
 
 -- |
 --
@@ -564,8 +564,10 @@ setCityAndLocality =
 getSuburbOrCity ::
   Either Address Locality
   -> String
-getSuburbOrCity =
+getSuburbOrCity = \soc -> case soc of
-  error "todo: getSuburbOrCity"
+                            Left address -> get suburbL address
+                            Right locality -> get cityL locality
+
 
 -- |
 --
@@ -578,8 +580,9 @@ setStreetOrState ::
   Either Person Locality
   -> String
   -> Either Person Locality
-setStreetOrState =
+setStreetOrState = \sos -> \ipsos -> case sos of
-  error "todo: setStreetOrState"
+  Left person -> Left $ set (streetL |. addressL) person ipsos
+  Right locality -> Right $ set stateL locality ipsos
 
 -- |
 --
@@ -591,5 +594,4 @@ setStreetOrState =
 modifyCityUppercase ::
   Person
   -> Person
-modifyCityUppercase =
+modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper
-  error "todo: modifyCityUppercase"