Lens: Finish the exercises based on Profunctors
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
This commit is contained in:
parent
7b37e979fe
commit
b1603f17ce
2 changed files with 52 additions and 59 deletions
107
src/Lets/Lens.hs
107
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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue