Lens: Finish the exercises based on Profunctors

Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
Sanchayan Maity 2020-03-21 11:47:40 +05:30
parent 7b37e979fe
commit b1603f17ce
2 changed files with 52 additions and 59 deletions

View file

@ -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)

View file

@ -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