src: Lets: OpticPolyLens: Implement optic poly lens

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

src/Lets/OpticPolyLens.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
 
 module Lets.OpticPolyLens (
   Lens(..)
@@ -43,9 +44,10 @@ module Lets.OpticPolyLens (
 , modifyIntandLengthEven
 ) where
 
-import Data.Char(toUpper)
+import Data.Bool(bool)
+import Data.Char(toUpper, ord)
 import Data.Map(Map)
-import qualified Data.Map as Map(insert, delete, lookup)
+import qualified Data.Map as Map(insert, delete, lookup, fromList, alterF)
 import Data.Set(Set)
 import qualified Data.Set as Set(insert, delete, member)
 import Lets.Data(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address))
@@ -125,8 +127,9 @@ modify ::
   -> (a -> b)
   -> s
   -> t
-modify =
+modify (Lens r) f s = let idf = Identity . f in
-  error "todo: modify"
+                        let ridf = r idf in
+                          let sidt = ridf s in getIdentity sidt
 
 -- | An alias for @modify@.
 (%~) ::
@@ -155,8 +158,10 @@ infixr 4 %~
   -> b
   -> s
   -> t
-(.~) =
+-- modify :: Lens s t a b -> (a -> b) -> s -> t
-  error "todo: (.~)"
+-- modify (Lens r) f s = let idf = Identity . f in
+--                           let ridf = r idf in (getIdentity . ridf) s
+(.~) (Lens stab) b s = getIdentity (stab (\_ -> Identity b) s)
 
 infixl 5 .~
 
@@ -176,8 +181,7 @@ fmodify ::
   -> (a -> f b)
   -> s
   -> f t 
-fmodify =
+fmodify (Lens stab) aTofb s = stab aTofb s
-  error "todo: fmodify"
 
 -- |
 --
@@ -192,8 +196,7 @@ fmodify =
   -> f b
   -> s
   -> f t
-(|=) =
+(|=) (Lens l) fb s = (l (\_ -> fb) s)
-  error "todo: (|=)"
 
 infixl 5 |=
 
@@ -209,8 +212,7 @@ infixl 5 |=
 -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
 fstL ::
   Lens (a, x) (b, x) a b
-fstL =
+fstL = Lens (\f -> \(a, x) -> let fb = f a in (, x) <$> fb)
-  error "todo: fstL"
 
 -- |
 --
@@ -224,8 +226,7 @@ fstL =
 -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
 sndL ::
   Lens (x, a) (x, b) a b
-sndL =
+sndL = Lens (\f -> \(x, a) -> let fb = f a in (x ,) <$> fb)
-  error "todo: sndL"
 
 -- |
 --
@@ -250,8 +251,7 @@ mapL ::
   Ord k =>
   k
   -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v)
-mapL =
+mapL k = Lens (\f -> \mkv -> Map.alterF f k mkv)
-  error "todo: mapL"
 
 -- |
 --
@@ -276,8 +276,8 @@ setL ::
   Ord k =>
   k
   -> Lens (Set k) (Set k) Bool Bool
-setL =
+setL k = Lens (\f -> \sk -> (\b -> bool (Set.delete k sk) (Set.insert k sk) b)
-  error "todo: setL"
+                            <$> (f $ Set.member k sk))
 
 -- |
 --
@@ -290,8 +290,7 @@ compose ::
   Lens s t a b
   -> Lens q r s t
   -> Lens q r a b
-compose =
+compose (Lens r) (Lens g) = Lens $ g . r
-  error "todo: compose"
 
 -- | An alias for @compose@.
 (|.) ::
@@ -312,8 +311,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a b a b
-identity =
+identity = Lens (\f -> \a -> f a)
-  error "todo: identity"
 
 -- |
 --
@@ -356,8 +354,9 @@ choice ::
   Lens s t a b
   -> Lens q r a b
   -> Lens (Either s q) (Either t r) a b
-choice =
+choice (Lens l) (Lens g) = Lens (\f -> \esq -> case esq of
-  error "todo: choice"
+                                                 Left s -> Left <$> l f s
+                                                 Right q -> Right <$> g f q)
 
 -- | An alias for @choice@.
 (|||) ::
@@ -451,9 +450,7 @@ intAndL =
 getSuburb ::
   Person
   -> String
-getSuburb =
+getSuburb = get $ (compose suburbL addressL)
-  error "todo: getSuburb"
-
 
 -- |
 --
@@ -466,8 +463,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
+setStreet = set $ (compose streetL addressL)
-  error "todo: setStreet"
 
 -- |
 --
@@ -479,8 +475,8 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
+getAgeAndCountry (person, locality) = (get ageL person,
-  error "todo: getAgeAndCountry"
+                                       get countryL locality)
 
 -- |
 --
@@ -491,8 +487,9 @@ 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)
   
 -- |
 --