Add comments showing CPS and store lens idea

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

.gitignore

@@ -30,3 +30,7 @@ TAGS
 
 *.swp
 
+# STACK
+.stack-work
+stack.yaml.lock
+tags

src/Lets/GetSetLens.hs

@@ -43,7 +43,7 @@ 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 qualified Data.Set as Set(insert, delete, member, fromList)
 import Lets.Data(Person(Person), Locality(Locality), Address(Address))
 import Prelude hiding (product)
 
@@ -144,8 +144,7 @@ modify ::
   -> (b -> b)
   -> a
   -> a
-modify =
-  error "todo: modify"
+modify = \(Lens f g) -> \bTob -> \a -> f a (bTob (g a))
 
 -- | An alias for @modify@.
 (%~) ::
@@ -174,8 +173,7 @@ infixr 4 %~
   -> b
   -> a
   -> a
-(.~) =
-  error "todo: (.~)"
+(.~) = \(Lens f _) -> \b -> \a -> f a b
 
 infixl 5 .~
 
@@ -195,8 +193,7 @@ fmodify ::
   -> (b -> f b)
   -> a
   -> f a
-fmodify =
-  error "todo: fmodify"
+fmodify = \(Lens f g) -> \bTofb -> \a -> (f a) <$> bTofb (g a)
 
 -- |
 --
@@ -211,8 +208,7 @@ fmodify =
   -> f b
   -> a
   -> f a
-(|=) =
-  error "todo: (|=)"
+(|=) = \(Lens f _) -> \fb -> \a -> (f a) <$> fb
 
 infixl 5 |=
 
@@ -228,8 +224,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 (\(_, y) -> \x -> (x, y)) (\(x, _) -> x)
 
 -- |
 --
@@ -243,8 +238,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 -> (x, y)) (\(_, y) -> y)
 
 -- |
 --
@@ -269,8 +263,9 @@ mapL ::
   Ord k =>
   k
   -> Lens (Map k v) (Maybe v)
-mapL =
-  error "todo: mapL"
+-- Did not really understand this, taken from solutions
+mapL k = Lens (maybe . Map.delete k <*> (flip (Map.insert k)))
+         (Map.lookup k)
 
 -- |
 --
@@ -295,8 +290,12 @@ setL ::
   Ord k =>
   k
   -> Lens (Set k) Bool
-setL =
-  error "todo: setL"
+-- Set k -> Bool -> Set k
+-- Set k -> Bool
+setL k = Lens (\sk -> \bool -> case bool of
+                                True -> Set.insert k sk
+                                False -> Set.delete k sk)
+         (\sk -> Set.member k sk)
 
 -- |
 --
@@ -309,8 +308,7 @@ compose ::
   Lens b c
   -> Lens a b
   -> Lens a c
-compose =
-  error "todo: compose"
+compose (Lens f g) (Lens h i) = Lens (\a -> h a . f (i a)) (g . i)
 
 -- | An alias for @compose@.
 (|.) ::
@@ -331,8 +329,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a a
-identity =
-  error "todo: identity"
+identity = Lens (\_ -> \b -> b) (\a -> a)
 
 -- |
 --
@@ -345,8 +342,9 @@ product ::
   Lens a b
   -> Lens c d
   -> Lens (a, c) (b, d)
-product =
-  error "todo: product"
+product (Lens f g) (Lens h i) = Lens
+                                (\(a, c) -> \(b, d) -> (f a b, h c d))
+                                (\(a, c) -> (g a, i c))
 
 -- | An alias for @product@.
 (***) ::
@@ -375,8 +373,13 @@ choice ::
   Lens a x
   -> Lens b x
   -> Lens (Either a b) x
-choice =
-  error "todo: choice"
+choice (Lens f g) (Lens h i) = Lens
+                               (\eab -> \x -> case eab of
+                                   Left a -> Left $ f a x
+                                   Right b -> Right $ h b x)
+                               (\eab -> case eab of
+                                          Left a -> g a
+                                          Right b -> i b)
 
 -- | An alias for @choice@.
 (|||) ::
@@ -463,8 +466,7 @@ addressL =
 getSuburb ::
   Person
   -> String
-getSuburb =
-  error "todo: getSuburb"
+getSuburb = get $ (compose suburbL addressL)
 
 -- |
 --
@@ -477,8 +479,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
-  error "todo: setStreet"
+setStreet = set $ (compose streetL addressL)
 
 -- |
 --
@@ -490,8 +491,8 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
-  error "todo: getAgeAndCountry"
+getAgeAndCountry (person, locality) = (get ageL person,
+                                       get countryL locality)
 
 -- |
 --
@@ -502,8 +503,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)
   
 -- |
 --
@@ -515,8 +517,9 @@ 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
 
 -- |
 --
@@ -529,8 +532,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
 
 -- |
 --
@@ -542,5 +546,4 @@ setStreetOrState =
 modifyCityUppercase ::
   Person
   -> Person
-modifyCityUppercase =
-  error "todo: modifyCityUppercase"
+modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper

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))
@@ -111,8 +111,7 @@ fmapT ::
   (a -> b)
   -> t a
   -> t b
-fmapT =
-  error "todo: fmapT"
+fmapT f = getIdentity . traverse (Identity . f)
 
 -- | Let's refactor out the call to @traverse@ as an argument to @fmapT@.
 over ::
@@ -120,8 +119,7 @@ over ::
   -> (a -> b)
   -> s
   -> t
-over =
-  error "todo: over"
+over t f = getIdentity . t (Identity . f)
 
 -- | Here is @fmapT@ again, passing @traverse@ to @over@.
 fmapTAgain ::
@@ -129,8 +127,7 @@ fmapTAgain ::
   (a -> b)
   -> t a
   -> t b
-fmapTAgain =
-  error "todo: fmapTAgain"
+fmapTAgain = over traverse
 
 -- | Let's create a type-alias for this type of function.
 type Set s t a b =
@@ -143,22 +140,19 @@ type Set s t a b =
 sets ::
   ((a -> b) -> s -> t)
   -> Set s t a b
-sets =
-  error "todo: sets"
+sets f g = Identity . f (getIdentity . g)
 
 mapped ::
   Functor f =>
   Set (f a) (f b) a b
-mapped =
-  error "todo: mapped"
+mapped f g = Identity (getIdentity . f <$> g)
 
 set ::
   Set s t a b
   -> s
   -> b
   -> t
-set =
-  error "todo: set"
+set f s b = over f (const b) s
 
 ----
 
@@ -170,8 +164,7 @@ foldMapT ::
   (a -> b)
   -> t a
   -> b
-foldMapT =
-  error "todo: foldMapT"
+foldMapT f = getConst . traverse (Const . f)
 
 -- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@.
 foldMapOf ::
@@ -179,8 +172,7 @@ foldMapOf ::
   -> (a -> r)
   -> s
   -> r
-foldMapOf =
-  error "todo: foldMapOf"
+foldMapOf t f = getConst . t (Const . f)
 
 -- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@.
 foldMapTAgain ::
@@ -188,8 +180,7 @@ foldMapTAgain ::
   (a -> b)
   -> t a
   -> b
-foldMapTAgain =
-  error "todo: foldMapTAgain"
+foldMapTAgain = foldMapOf traverse
 
 -- | Let's create a type-alias for this type of function.
 type Fold s t a b =
@@ -206,14 +197,12 @@ folds ::
   -> (a -> Const b a)
   -> s
   -> Const t s
-folds =
-  error "todo: folds"
+folds f g s = let t = (f (getConst . g) s) in Const t
 
 folded ::
   Foldable f =>
   Fold (f a) (f a) a a
-folded =
-  error "todo: folded"
+folded = folds foldMap
 
 ----
 
@@ -227,8 +216,7 @@ get ::
   Get a s a
   -> s
   -> a
-get =
-  error "todo: get"
+get f = getConst . f Const
 
 ----
 
@@ -243,20 +231,20 @@ type Traversal s t a b =
 -- | Traverse both sides of a pair.
 both ::
   Traversal (a, a) (b, b) a b
-both =
-  error "todo: both"
+-- both :: (a -> f b) -> (a , a) -> f (b , b)
+both f (a, b) = (,) <$> f a <*> f b
 
 -- | Traverse the left side of @Either@.
 traverseLeft ::
   Traversal (Either a x) (Either b x) a b
-traverseLeft =
-  error "todo: traverseLeft"
+traverseLeft f (Left a) = Left <$> f a
+traverseLeft _ (Right x) = pure $ Right x
 
 -- | Traverse the right side of @Either@.
 traverseRight ::
   Traversal (Either x a) (Either x b) a b
-traverseRight =
-  error "todo: traverseRight"
+traverseRight _ (Left x) = pure $ Left x
+traverseRight f (Right b) = Right <$> f b
 
 type Traversal' a b =
   Traversal a a b b
@@ -286,44 +274,39 @@ type Prism s t a b =
 
 _Left ::
   Prism (Either a x) (Either b x) a b
-_Left =
-  error "todo: _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
@@ -346,8 +329,7 @@ modify ::
   -> (a -> b)
   -> s
   -> t
-modify _ _ _ =
-  error "todo: modify"
+modify l f = getIdentity . l (Identity . f)
 
 -- | An alias for @modify@.
 (%~) ::
@@ -376,8 +358,7 @@ infixr 4 %~
   -> b
   -> s
   -> t
-(.~) _ _ _ =
-  error "todo: (.~)"
+(.~) l = let ml = modify l in ml . const
 
 infixl 5 .~
 
@@ -397,8 +378,7 @@ fmodify ::
   -> (a -> f b)
   -> s
   -> f t
-fmodify _ _ _ =
-  error "todo: fmodify"
+fmodify l = l
 
 -- |
 --
@@ -413,8 +393,7 @@ fmodify _ _ _ =
   -> f b
   -> s
   -> f t
-(|=) _ _ _ =
-  error "todo: (|=)"
+(|=) l = let fl = fmodify l in fl . const
 
 infixl 5 |=
 
@@ -424,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
 
 -- |
 --
@@ -433,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
 
 -- |
 --
@@ -509,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@.
 (|.) ::
@@ -531,8 +507,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a b a b
-identity =
-  error "todo: identity"
+identity = id
 
 -- |
 --
@@ -575,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@.
 (|||) ::
@@ -659,8 +635,7 @@ intAndL p (IntAnd n a) =
 getSuburb ::
   Person
   -> String
-getSuburb =
-  error "todo: getSuburb"
+getSuburb = get $ (compose suburbL addressL)
 
 -- |
 --
@@ -673,8 +648,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
-  error "todo: setStreet"
+setStreet = set $ (compose streetL addressL)
 
 -- |
 --
@@ -686,8 +660,8 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
-  error "todo: getAgeAndCountry"
+getAgeAndCountry (person, locality) = (get ageL person,
+                                       get countryL locality)
 
 -- |
 --
@@ -698,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)
 
 -- |
 --
@@ -712,7 +687,7 @@ getSuburbOrCity ::
   Either Address Locality
   -> String
 getSuburbOrCity =
-  error "todo: getSuburbOrCity"
+  get (suburbL ||| cityL)
 
 -- |
 --
@@ -726,7 +701,7 @@ setStreetOrState ::
   -> String
   -> Either Person Locality
 setStreetOrState =
-  error "todo: setStreetOrState"
+  set (streetL |. addressL ||| stateL)
 
 -- |
 --
@@ -739,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
 
 -- |
 --
@@ -762,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
 
 -- |
 --
@@ -775,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)

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))
@@ -62,12 +64,30 @@ data Lens s t a b =
   Lens
     (forall f. Functor f => (a -> f b) -> s -> f t)
 
+-- Lens s t a b
+
+-- Lens u w s t
+--   (s -> f t) -> w -> f w
+
+-- Lens u w s t . Lens s t a b
+
+-- p :: (->)
+-- p a b
+
+-- f :: s -> a
+-- fcps :: forall r . (a -> r) -> s -> r
+-- f ~ fcps id
+-- fcps = \c -> c . f
+--              (a -> r) . s -> a
+-- forall r . (a -> f r) -> s -> f r
+-- 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
@@ -125,8 +145,9 @@ modify ::
   -> (a -> b)
   -> s
   -> t
-modify =
-  error "todo: modify"
+modify (Lens r) f s = let idf = Identity . f in
+                        let ridf = r idf in
+                          let sidt = ridf s in getIdentity sidt
 
 -- | An alias for @modify@.
 (%~) ::
@@ -155,8 +176,10 @@ infixr 4 %~
   -> b
   -> s
   -> t
-(.~) =
-  error "todo: (.~)"
+-- modify :: Lens s t a b -> (a -> b) -> s -> t
+-- 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 +199,7 @@ fmodify ::
   -> (a -> f b)
   -> s
   -> f t 
-fmodify =
-  error "todo: fmodify"
+fmodify (Lens stab) aTofb s = stab aTofb s
 
 -- |
 --
@@ -192,8 +214,7 @@ fmodify =
   -> f b
   -> s
   -> f t
-(|=) =
-  error "todo: (|=)"
+(|=) (Lens l) fb s = (l (\_ -> fb) s)
 
 infixl 5 |=
 
@@ -209,8 +230,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 =
-  error "todo: fstL"
+fstL = Lens (\f -> \(a, x) -> let fb = f a in (, x) <$> fb)
 
 -- |
 --
@@ -224,8 +244,7 @@ fstL =
 -- 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"
+sndL = Lens (\f -> \(x, a) -> let fb = f a in (x ,) <$> fb)
 
 -- |
 --
@@ -250,8 +269,7 @@ mapL ::
   Ord k =>
   k
   -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v)
-mapL =
-  error "todo: mapL"
+mapL k = Lens (\f -> \mkv -> Map.alterF f k mkv)
 
 -- |
 --
@@ -276,8 +294,8 @@ setL ::
   Ord k =>
   k
   -> Lens (Set k) (Set k) Bool Bool
-setL =
-  error "todo: setL"
+setL k = Lens (\f -> \sk -> (\b -> bool (Set.delete k sk) (Set.insert k sk) b)
+                            <$> (f $ Set.member k sk))
 
 -- |
 --
@@ -290,8 +308,7 @@ compose ::
   Lens s t a b
   -> Lens q r s t
   -> Lens q r a b
-compose =
-  error "todo: compose"
+compose (Lens r) (Lens g) = Lens $ g . r
 
 -- | An alias for @compose@.
 (|.) ::
@@ -312,8 +329,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a b a b
-identity =
-  error "todo: identity"
+identity = Lens (\f -> \a -> f a)
 
 -- |
 --
@@ -356,8 +372,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 (Lens l) (Lens g) = Lens (\f -> \esq -> case esq of
+                                                 Left s -> Left <$> l f s
+                                                 Right q -> Right <$> g f q)
 
 -- | An alias for @choice@.
 (|||) ::
@@ -451,9 +468,7 @@ intAndL =
 getSuburb ::
   Person
   -> String
-getSuburb =
-  error "todo: getSuburb"
-
+getSuburb = get $ (compose suburbL addressL)
 
 -- |
 --
@@ -466,8 +481,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
-  error "todo: setStreet"
+setStreet = set $ (compose streetL addressL)
 
 -- |
 --
@@ -479,8 +493,8 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
-  error "todo: getAgeAndCountry"
+getAgeAndCountry (person, locality) = (get ageL person,
+                                       get countryL locality)
 
 -- |
 --
@@ -491,8 +505,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)
   
 -- |
 --

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,30 +80,37 @@ 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
 
 ----
 
+-- data Lens a b =
+--   Lens
+--     (a -> b -> a)
+--     (a -> b)
+-- data Store s a = Store (s -> a) s
+
+-- a -> Store b a
+-- a -> Store (b -> a) b
+-- Drop the Store wrapper
+-- a -> b -> a
+-- a -> b
 data Lens a b =
   Lens
     (a -> Store b a)
@@ -193,8 +200,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 +229,7 @@ infixr 4 %~
   -> b
   -> a
   -> a
-(.~) =
-  error "todo: (.~)"
+(.~) = \(Lens f) -> \v -> \a -> let Store s g = f a in s v
 
 infixl 5 .~
 
@@ -244,8 +249,7 @@ 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
 
 -- |
 --
@@ -260,8 +264,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 +280,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 +294,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 +319,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 +347,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 +363,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,8 +387,7 @@ infixr 9 |.
 -- 4
 identity ::
   Lens a a
-identity =
-  error "todo: identity"
+identity = Lens (\a -> Store (\a' -> a') a)
 
 -- |
 --
@@ -394,8 +400,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 +432,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 +522,7 @@ addressL =
 getSuburb ::
   Person
   -> String
-getSuburb =
-  error "todo: getSuburb"
+getSuburb = get $ (compose suburbL addressL)
 
 -- |
 --
@@ -526,8 +535,7 @@ setStreet ::
   Person
   -> String
   -> Person
-setStreet =
-  error "todo: setStreet"
+setStreet = set $ (compose streetL addressL)
 
 -- |
 --
@@ -539,8 +547,9 @@ setStreet =
 getAgeAndCountry ::
   (Person, Locality)
   -> (Int, String)
-getAgeAndCountry =
-  error "todo: getAgeAndCountry"
+getAgeAndCountry (person, locality) = (get ageL person,
+                                       get countryL locality)
+
 
 -- |
 --
@@ -551,8 +560,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 =
-  error "todo: setCityAndLocality"
+setCityAndLocality (person, address) (city, locality) =
+  (set (cityL |. localityL |. addressL) person city,
+   set localityL address locality)
+
 
 -- |
 --
@@ -564,8 +575,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 +591,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 +605,4 @@ setStreetOrState =
 modifyCityUppercase ::
   Person
   -> Person
-modifyCityUppercase =
-  error "todo: modifyCityUppercase"
+modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper

stack.yaml

@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+#
+# The location of a snapshot can be provided as a file or url. Stack assumes
+# a snapshot provided as a file might change, whereas a url resource does not.
+#
+# resolver: ./custom-snapshot.yaml
+# resolver: https://example.com/snapshots/2018-01-01.yaml
+resolver: lts-14.12
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+#   subdirs:
+#   - auto-update
+#   - wai
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver.
+# These entries can reference officially published versions as well as
+# forks / in-progress versions pinned to a git hash. For example:
+#
+# extra-deps:
+# - acme-missiles-0.3
+# - git: https://github.com/commercialhaskell/stack.git
+#   commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=2.1"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor