From b1603f17ce6419ab0d0086935d52420f4cda9d19 Mon Sep 17 00:00:00 2001
From: Sanchayan Maity <maitysanchayan@gmail.com>
Date: Sat, 21 Mar 2020 11:47:40 +0530
Subject: [PATCH] Lens: Finish the exercises based on Profunctors

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
---
 src/Lets/Lens.hs          | 107 ++++++++++++++++++--------------------
 src/Lets/OpticPolyLens.hs |   4 +-
 2 files changed, 52 insertions(+), 59 deletions(-)

diff --git a/src/Lets/Lens.hs b/src/Lets/Lens.hs
index a9b84ac..d6c9a0b 100644
--- a/src/Lets/Lens.hs
+++ b/src/Lets/Lens.hs
@@ -78,7 +78,7 @@ import Data.Char(toUpper)
 import Data.Foldable(Foldable(foldMap))
 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, alterF)
 import Data.Monoid(Monoid)
 import qualified Data.Set as Set(Set, insert, delete, member)
 import Data.Traversable(Traversable(traverse))
@@ -274,43 +274,39 @@ type Prism s t a b =
 
 _Left ::
   Prism (Either a x) (Either b x) a b
-_Left = _
+-- _Left h = let rh = right h in dimap (either Right (Left . Right)) (either pure (fmap Left)) rh
+_Left h = let lh = left h in dimap (either Left (Right . Right)) (either (fmap Left) pure) lh
 
 _Right ::
   Prism (Either x a) (Either x b) a b
-_Right =
-  error "todo: _Right"
+_Right h = let rh = right h in dimap (either (Left . Left) Right) (either pure (fmap Right)) rh
 
 prism ::
   (b -> t)
   -> (s -> Either t a)
   -> Prism s t a b
-prism =
-  error "todo: prism"
+prism bToT sToEta pafb = let rh = right pafb in dimap sToEta (either pure (fmap bToT)) rh
 
 _Just ::
   Prism (Maybe a) (Maybe b) a b
-_Just =
-  error "todo: _Just"
+_Just = prism Just (maybe (Left Nothing) Right)
 
 _Nothing ::
   Prism (Maybe a) (Maybe a) () ()
-_Nothing =
-  error "todo: _Nothing"
+_Nothing = prism (\_ -> Nothing) (maybe (Right ()) (Left . Just))
 
 setP ::
   Prism s t a b
   -> s
   -> Either t a
-setP _ _ =
-  error "todo: setP"
+setP p = let pl = p Left in either Right Left . pl
 
 getP ::
   Prism s t a b
   -> b
   -> t
-getP _ _ =
-  error "todo: getP"
+-- Copied :(
+getP p = let pti = p . Tagged . Identity in getIdentity . getTagged . pti
 
 type Prism' a b =
   Prism a a b b
@@ -333,8 +329,7 @@ modify ::
   -> (a -> b)
   -> s
   -> t
-modify _ _ _ =
-  error "todo: modify"
+modify l f = getIdentity . l (Identity . f)
 
 -- | An alias for @modify@.
 (%~) ::
@@ -363,8 +358,7 @@ infixr 4 %~
   -> b
   -> s
   -> t
-(.~) _ _ _ =
-  error "todo: (.~)"
+(.~) l = let ml = modify l in ml . const
 
 infixl 5 .~
 
@@ -384,8 +378,7 @@ fmodify ::
   -> (a -> f b)
   -> s
   -> f t
-fmodify _ _ _ =
-  error "todo: fmodify"
+fmodify l = l
 
 -- |
 --
@@ -400,8 +393,7 @@ fmodify _ _ _ =
   -> f b
   -> s
   -> f t
-(|=) _ _ _ =
-  error "todo: (|=)"
+(|=) l = let fl = fmodify l in fl . const
 
 infixl 5 |=
 
@@ -411,8 +403,7 @@ infixl 5 |=
 -- (30,"abc")
 fstL ::
   Lens (a, x) (b, x) a b
-fstL =
-  error "todo: fstL"
+fstL f (x, y) = let fx = f x in fmap (\x' -> (x', y)) fx
 
 -- |
 --
@@ -420,8 +411,7 @@ fstL =
 -- (13,"abcdef")
 sndL ::
   Lens (x, a) (x, b) a b
-sndL =
-  error "todo: sndL"
+sndL f (x, y) = let fy = f y in fmap (\y' -> (x, y')) fy
 
 -- |
 --
@@ -496,8 +486,7 @@ compose ::
   Lens s t a b
   -> Lens q r s t
   -> Lens q r a b
-compose _ _ =
-  error "todo: compose"
+compose l1 l2 = l2 . l1
 
 -- | An alias for @compose@.
 (|.) ::
@@ -518,8 +507,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a b a b
-identity =
-  error "todo: identity"
+identity = id
 
 -- |
 --
@@ -562,8 +550,9 @@ choice ::
   Lens s t a b
   -> Lens q r a b
   -> Lens (Either s q) (Either t r) a b
-choice _ _ =
-  error "todo: choice"
+choice l1 l2 = (\f esq -> case esq of
+                  Left s  -> Left <$> (l1 f s)
+                  Right q -> Right <$> (l2 f q))
 
 -- | An alias for @choice@.
 (|||) ::
@@ -646,8 +635,7 @@ intAndL p (IntAnd n a) =
 getSuburb ::
   Person
   -> String
-getSuburb =
-  error "todo: getSuburb"
+getSuburb = get $ (compose suburbL addressL)
 
 -- |
 --
@@ -660,8 +648,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
-  error "todo: setStreet"
+setStreet = set $ (compose streetL addressL)
 
 -- |
 --
@@ -673,8 +660,8 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
-  error "todo: getAgeAndCountry"
+getAgeAndCountry (person, locality) = (get ageL person,
+                                       get countryL locality)
 
 -- |
 --
@@ -685,8 +672,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 =
-  error "todo: setCityAndLocality"
+setCityAndLocality (person, address) (city, locality) =
+  (set (cityL |. localityL |. addressL) person city,
+   set localityL address locality)
 
 -- |
 --
@@ -699,7 +687,7 @@ getSuburbOrCity ::
   Either Address Locality
   -> String
 getSuburbOrCity =
-  error "todo: getSuburbOrCity"
+  get (suburbL ||| cityL)
 
 -- |
 --
@@ -713,7 +701,7 @@ setStreetOrState ::
   -> String
   -> Either Person Locality
 setStreetOrState =
-  error "todo: setStreetOrState"
+  set (streetL |. addressL ||| stateL)
 
 -- |
 --
@@ -726,22 +714,20 @@ modifyCityUppercase ::
   Person
   -> Person
 modifyCityUppercase =
-  error "todo: modifyCityUppercase"
+  cityL |. localityL |. addressL %~ map toUpper
 
 -- |
 --
--- >>> modifyIntAndLengthEven (IntAnd 10 "abc")
+-- >>> modify intAndL (even . length) (IntAnd 10 "abc")
 -- IntAnd 10 False
 --
--- >>> modifyIntAndLengthEven (IntAnd 10 "abcd")
+-- >>> modify intAndL (even . length) (IntAnd 10 "abcd")
 -- IntAnd 10 True
 modifyIntAndLengthEven ::
   IntAnd [a]
   -> IntAnd Bool
 modifyIntAndLengthEven =
-  error "todo: modifyIntAndLengthEven"
-
-----
+  intAndL %~ even . length
 
 -- |
 --
@@ -749,8 +735,8 @@ modifyIntAndLengthEven =
 -- Locality "ABC" "DEF" "GHI"
 traverseLocality ::
   Traversal' Locality String
-traverseLocality =
-  error "todo: traverseLocality"
+traverseLocality f (Locality c t y) =
+  Locality <$> f c <*> f t <*> f y
 
 -- |
 --
@@ -762,25 +748,32 @@ traverseLocality =
 intOrIntP ::
   Prism' (IntOr a) Int
 intOrIntP =
-  error "todo: intOrIntP"
+  prism
+    IntOrIs
+    (\i -> case i of
+            IntOrIs n -> Right n
+            IntOrIsNot a -> Left (IntOrIsNot a))
 
 intOrP ::
   Prism (IntOr a) (IntOr b) a b
 intOrP =
-  error "todo: intOrP"
+  prism
+    IntOrIsNot
+    (\i -> case i of
+            IntOrIs n -> Left (IntOrIs n)
+            IntOrIsNot a -> Right a)
 
 -- |
 --
--- >> intOrLengthEven (IntOrIsNot "abc")
+-- >> over intOrP (even . length) (IntOrIsNot "abc")
 -- IntOrIsNot False
 --
--- >>> intOrLengthEven (IntOrIsNot "abcd")
+-- >>> over intOrP (even . length) (IntOrIsNot "abcd")
 -- IntOrIsNot True
 --
--- >>> intOrLengthEven (IntOrIs 10)
+-- >>> over intOrP (even . length) (IntOrIs 10)
 -- IntOrIs 10
 intOrLengthEven ::
   IntOr [a]
   -> IntOr Bool
-intOrLengthEven =
-  error "todo: intOrLengthEven"
+intOrLengthEven = over intOrP (even . length)
diff --git a/src/Lets/OpticPolyLens.hs b/src/Lets/OpticPolyLens.hs
index e36b81d..43698a2 100644
--- a/src/Lets/OpticPolyLens.hs
+++ b/src/Lets/OpticPolyLens.hs
@@ -64,12 +64,12 @@ data Lens s t a b =
   Lens
     (forall f. Functor f => (a -> f b) -> s -> f t)
 
+-- Const :: forall b . a -> Const a b
 get ::
   Lens s t a b
   -> s
   -> a
-get (Lens r) =
-  getConst . r Const
+get (Lens r) s = let rc = r Const in getConst $ rc s
 
 set ::
   Lens s t a b