Compare commits

..

10 commits

Author SHA1 Message Date
Sanchayan Maity 4d3bc29f81 Add comments showing CPS and store lens idea
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2020-03-22 19:44:17 +05:30
Sanchayan Maity b1603f17ce Lens: Finish the exercises based on Profunctors
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2020-03-21 11:47:40 +05:30
Sanchayan Maity 7b37e979fe stack.yaml: Update stack lts
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-11-19 18:52:49 +05:30
Sanchayan Maity dd741ff696 Ignore tags file
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-08-28 00:34:08 +05:30
Sanchayan Maity 9c83801470 Lens.hs: Complete the easier part of this Lens exercise
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-08-27 20:37:20 +05:30
Sanchayan Maity b0f7bf2c06 Add stack support
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-08-19 22:14:01 +05:30
Sanchayan Maity 7c8a2f87bb src: Lets: OpticPolyLens: Implement optic poly lens
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-02-26 22:56:40 +05:30
Sanchayan Maity 246f6b1302 src: Lets: StoreLens: Implement store lens
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-02-13 16:33:25 +05:30
Sanchayan Maity 5186970bb8 src: Lets: GetSetLens: Implement the examples
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-02-10 19:31:13 +05:30
Sanchayan Maity 1b68f0617f src: Lets: GetSetLens: Implement basic lens operators
Signed-off-by: Sanchayan Maity <maitysanchayan@gmail.com>
2019-02-08 23:58:38 +05:30
6 changed files with 301 additions and 220 deletions

4
.gitignore vendored
View file

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

View file

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

View file

@ -78,7 +78,7 @@ import Data.Char(toUpper)
import Data.Foldable(Foldable(foldMap)) import Data.Foldable(Foldable(foldMap))
import Data.Functor((<$>)) import Data.Functor((<$>))
import Data.Map(Map) 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 Data.Monoid(Monoid)
import qualified Data.Set as Set(Set, insert, delete, member) import qualified Data.Set as Set(Set, insert, delete, member)
import Data.Traversable(Traversable(traverse)) import Data.Traversable(Traversable(traverse))
@ -98,7 +98,7 @@ import Prelude hiding (product)
-- --
-- class (Foldable t, Functor t) => Traversable t where -- class (Foldable t, Functor t) => Traversable t where
-- traverse :: -- traverse ::
-- Applicative f => -- Applicative f =>
-- (a -> f b) -- (a -> f b)
-- -> t a -- -> t a
-- -> f (t b) -- -> f (t b)
@ -111,17 +111,15 @@ fmapT ::
(a -> b) (a -> b)
-> t a -> t a
-> t b -> t b
fmapT = fmapT f = getIdentity . traverse (Identity . f)
error "todo: fmapT"
-- | Let's refactor out the call to @traverse@ as an argument to @fmapT@. -- | Let's refactor out the call to @traverse@ as an argument to @fmapT@.
over :: over ::
((a -> Identity b) -> s -> Identity t) ((a -> Identity b) -> s -> Identity t)
-> (a -> b) -> (a -> b)
-> s -> s
-> t -> t
over = over t f = getIdentity . t (Identity . f)
error "todo: over"
-- | Here is @fmapT@ again, passing @traverse@ to @over@. -- | Here is @fmapT@ again, passing @traverse@ to @over@.
fmapTAgain :: fmapTAgain ::
@ -129,8 +127,7 @@ fmapTAgain ::
(a -> b) (a -> b)
-> t a -> t a
-> t b -> t b
fmapTAgain = fmapTAgain = over traverse
error "todo: fmapTAgain"
-- | Let's create a type-alias for this type of function. -- | Let's create a type-alias for this type of function.
type Set s t a b = type Set s t a b =
@ -142,23 +139,20 @@ type Set s t a b =
-- unwrapping. -- unwrapping.
sets :: sets ::
((a -> b) -> s -> t) ((a -> b) -> s -> t)
-> Set s t a b -> Set s t a b
sets = sets f g = Identity . f (getIdentity . g)
error "todo: sets"
mapped :: mapped ::
Functor f => Functor f =>
Set (f a) (f b) a b Set (f a) (f b) a b
mapped = mapped f g = Identity (getIdentity . f <$> g)
error "todo: mapped"
set :: set ::
Set s t a b Set s t a b
-> s -> s
-> b -> b
-> t -> t
set = set f s b = over f (const b) s
error "todo: set"
---- ----
@ -170,8 +164,7 @@ foldMapT ::
(a -> b) (a -> b)
-> t a -> t a
-> b -> b
foldMapT = foldMapT f = getConst . traverse (Const . f)
error "todo: foldMapT"
-- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@. -- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@.
foldMapOf :: foldMapOf ::
@ -179,8 +172,7 @@ foldMapOf ::
-> (a -> r) -> (a -> r)
-> s -> s
-> r -> r
foldMapOf = foldMapOf t f = getConst . t (Const . f)
error "todo: foldMapOf"
-- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@. -- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@.
foldMapTAgain :: foldMapTAgain ::
@ -188,8 +180,7 @@ foldMapTAgain ::
(a -> b) (a -> b)
-> t a -> t a
-> b -> b
foldMapTAgain = foldMapTAgain = foldMapOf traverse
error "todo: foldMapTAgain"
-- | Let's create a type-alias for this type of function. -- | Let's create a type-alias for this type of function.
type Fold s t a b = type Fold s t a b =
@ -206,14 +197,12 @@ folds ::
-> (a -> Const b a) -> (a -> Const b a)
-> s -> s
-> Const t s -> Const t s
folds = folds f g s = let t = (f (getConst . g) s) in Const t
error "todo: folds"
folded :: folded ::
Foldable f => Foldable f =>
Fold (f a) (f a) a a Fold (f a) (f a) a a
folded = folded = folds foldMap
error "todo: folded"
---- ----
@ -227,8 +216,7 @@ get ::
Get a s a Get a s a
-> s -> s
-> a -> a
get = get f = getConst . f Const
error "todo: get"
---- ----
@ -243,20 +231,20 @@ type Traversal s t a b =
-- | Traverse both sides of a pair. -- | Traverse both sides of a pair.
both :: both ::
Traversal (a, a) (b, b) a b Traversal (a, a) (b, b) a b
both = -- both :: (a -> f b) -> (a , a) -> f (b , b)
error "todo: both" both f (a, b) = (,) <$> f a <*> f b
-- | Traverse the left side of @Either@. -- | Traverse the left side of @Either@.
traverseLeft :: traverseLeft ::
Traversal (Either a x) (Either b x) a b Traversal (Either a x) (Either b x) a b
traverseLeft = traverseLeft f (Left a) = Left <$> f a
error "todo: traverseLeft" traverseLeft _ (Right x) = pure $ Right x
-- | Traverse the right side of @Either@. -- | Traverse the right side of @Either@.
traverseRight :: traverseRight ::
Traversal (Either x a) (Either x b) a b Traversal (Either x a) (Either x b) a b
traverseRight = traverseRight _ (Left x) = pure $ Left x
error "todo: traverseRight" traverseRight f (Right b) = Right <$> f b
type Traversal' a b = type Traversal' a b =
Traversal a a b b Traversal a a b b
@ -286,44 +274,39 @@ type Prism s t a b =
_Left :: _Left ::
Prism (Either a x) (Either b x) a b 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
error "todo: _Left" _Left h = let lh = left h in dimap (either Left (Right . Right)) (either (fmap Left) pure) lh
_Right :: _Right ::
Prism (Either x a) (Either x b) a b Prism (Either x a) (Either x b) a b
_Right = _Right h = let rh = right h in dimap (either (Left . Left) Right) (either pure (fmap Right)) rh
error "todo: _Right"
prism :: prism ::
(b -> t) (b -> t)
-> (s -> Either t a) -> (s -> Either t a)
-> Prism s t a b -> Prism s t a b
prism = prism bToT sToEta pafb = let rh = right pafb in dimap sToEta (either pure (fmap bToT)) rh
error "todo: prism"
_Just :: _Just ::
Prism (Maybe a) (Maybe b) a b Prism (Maybe a) (Maybe b) a b
_Just = _Just = prism Just (maybe (Left Nothing) Right)
error "todo: _Just"
_Nothing :: _Nothing ::
Prism (Maybe a) (Maybe a) () () Prism (Maybe a) (Maybe a) () ()
_Nothing = _Nothing = prism (\_ -> Nothing) (maybe (Right ()) (Left . Just))
error "todo: _Nothing"
setP :: setP ::
Prism s t a b Prism s t a b
-> s -> s
-> Either t a -> Either t a
setP _ _ = setP p = let pl = p Left in either Right Left . pl
error "todo: setP"
getP :: getP ::
Prism s t a b Prism s t a b
-> b -> b
-> t -> t
getP _ _ = -- Copied :(
error "todo: getP" getP p = let pti = p . Tagged . Identity in getIdentity . getTagged . pti
type Prism' a b = type Prism' a b =
Prism a a b b Prism a a b b
@ -346,8 +329,7 @@ modify ::
-> (a -> b) -> (a -> b)
-> s -> s
-> t -> t
modify _ _ _ = modify l f = getIdentity . l (Identity . f)
error "todo: modify"
-- | An alias for @modify@. -- | An alias for @modify@.
(%~) :: (%~) ::
@ -376,8 +358,7 @@ infixr 4 %~
-> b -> b
-> s -> s
-> t -> t
(.~) _ _ _ = (.~) l = let ml = modify l in ml . const
error "todo: (.~)"
infixl 5 .~ infixl 5 .~
@ -396,9 +377,8 @@ fmodify ::
Lens s t a b Lens s t a b
-> (a -> f b) -> (a -> f b)
-> s -> s
-> f t -> f t
fmodify _ _ _ = fmodify l = l
error "todo: fmodify"
-- | -- |
-- --
@ -413,8 +393,7 @@ fmodify _ _ _ =
-> f b -> f b
-> s -> s
-> f t -> f t
(|=) _ _ _ = (|=) l = let fl = fmodify l in fl . const
error "todo: (|=)"
infixl 5 |= infixl 5 |=
@ -424,8 +403,7 @@ infixl 5 |=
-- (30,"abc") -- (30,"abc")
fstL :: fstL ::
Lens (a, x) (b, x) a b Lens (a, x) (b, x) a b
fstL = fstL f (x, y) = let fx = f x in fmap (\x' -> (x', y)) fx
error "todo: fstL"
-- | -- |
-- --
@ -433,8 +411,7 @@ fstL =
-- (13,"abcdef") -- (13,"abcdef")
sndL :: sndL ::
Lens (x, a) (x, b) a b Lens (x, a) (x, b) a b
sndL = sndL f (x, y) = let fy = f y in fmap (\y' -> (x, y')) fy
error "todo: sndL"
-- | -- |
-- --
@ -509,8 +486,7 @@ compose ::
Lens s t a b Lens s t a b
-> Lens q r s t -> Lens q r s t
-> Lens q r a b -> Lens q r a b
compose _ _ = compose l1 l2 = l2 . l1
error "todo: compose"
-- | An alias for @compose@. -- | An alias for @compose@.
(|.) :: (|.) ::
@ -531,8 +507,7 @@ infixr 9 |.
-- 4 -- 4
identity :: identity ::
Lens a b a b Lens a b a b
identity = identity = id
error "todo: identity"
-- | -- |
-- --
@ -575,8 +550,9 @@ choice ::
Lens s t a b Lens s t a b
-> Lens q r a b -> Lens q r a b
-> Lens (Either s q) (Either t r) a b -> Lens (Either s q) (Either t r) a b
choice _ _ = choice l1 l2 = (\f esq -> case esq of
error "todo: choice" Left s -> Left <$> (l1 f s)
Right q -> Right <$> (l2 f q))
-- | An alias for @choice@. -- | An alias for @choice@.
(|||) :: (|||) ::
@ -659,8 +635,7 @@ intAndL p (IntAnd n a) =
getSuburb :: getSuburb ::
Person Person
-> String -> String
getSuburb = getSuburb = get $ (compose suburbL addressL)
error "todo: getSuburb"
-- | -- |
-- --
@ -673,8 +648,7 @@ setStreet ::
Person Person
-> String -> String
-> Person -> Person
setStreet = setStreet = set $ (compose streetL addressL)
error "todo: setStreet"
-- | -- |
-- --
@ -686,8 +660,8 @@ setStreet =
getAgeAndCountry :: getAgeAndCountry ::
(Person, Locality) (Person, Locality)
-> (Int, String) -> (Int, String)
getAgeAndCountry = getAgeAndCountry (person, locality) = (get ageL person,
error "todo: getAgeAndCountry" get countryL locality)
-- | -- |
-- --
@ -698,9 +672,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")) -- (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 :: setCityAndLocality ::
(Person, Address) -> (String, Locality) -> (Person, Address) (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)
-- | -- |
-- --
-- >>> getSuburbOrCity (Left maryAddress) -- >>> getSuburbOrCity (Left maryAddress)
@ -712,7 +687,7 @@ getSuburbOrCity ::
Either Address Locality Either Address Locality
-> String -> String
getSuburbOrCity = getSuburbOrCity =
error "todo: getSuburbOrCity" get (suburbL ||| cityL)
-- | -- |
-- --
@ -726,7 +701,7 @@ setStreetOrState ::
-> String -> String
-> Either Person Locality -> Either Person Locality
setStreetOrState = setStreetOrState =
error "todo: setStreetOrState" set (streetL |. addressL ||| stateL)
-- | -- |
-- --
@ -739,22 +714,20 @@ modifyCityUppercase ::
Person Person
-> Person -> Person
modifyCityUppercase = modifyCityUppercase =
error "todo: modifyCityUppercase" cityL |. localityL |. addressL %~ map toUpper
-- | -- |
-- --
-- >>> modifyIntAndLengthEven (IntAnd 10 "abc") -- >>> modify intAndL (even . length) (IntAnd 10 "abc")
-- IntAnd 10 False -- IntAnd 10 False
-- --
-- >>> modifyIntAndLengthEven (IntAnd 10 "abcd") -- >>> modify intAndL (even . length) (IntAnd 10 "abcd")
-- IntAnd 10 True -- IntAnd 10 True
modifyIntAndLengthEven :: modifyIntAndLengthEven ::
IntAnd [a] IntAnd [a]
-> IntAnd Bool -> IntAnd Bool
modifyIntAndLengthEven = modifyIntAndLengthEven =
error "todo: modifyIntAndLengthEven" intAndL %~ even . length
----
-- | -- |
-- --
@ -762,8 +735,8 @@ modifyIntAndLengthEven =
-- Locality "ABC" "DEF" "GHI" -- Locality "ABC" "DEF" "GHI"
traverseLocality :: traverseLocality ::
Traversal' Locality String Traversal' Locality String
traverseLocality = traverseLocality f (Locality c t y) =
error "todo: traverseLocality" Locality <$> f c <*> f t <*> f y
-- | -- |
-- --
@ -775,25 +748,32 @@ traverseLocality =
intOrIntP :: intOrIntP ::
Prism' (IntOr a) Int Prism' (IntOr a) Int
intOrIntP = intOrIntP =
error "todo: intOrIntP" prism
IntOrIs
(\i -> case i of
IntOrIs n -> Right n
IntOrIsNot a -> Left (IntOrIsNot a))
intOrP :: intOrP ::
Prism (IntOr a) (IntOr b) a b Prism (IntOr a) (IntOr b) a b
intOrP = 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 -- IntOrIsNot False
-- --
-- >>> intOrLengthEven (IntOrIsNot "abcd") -- >>> over intOrP (even . length) (IntOrIsNot "abcd")
-- IntOrIsNot True -- IntOrIsNot True
-- --
-- >>> intOrLengthEven (IntOrIs 10) -- >>> over intOrP (even . length) (IntOrIs 10)
-- IntOrIs 10 -- IntOrIs 10
intOrLengthEven :: intOrLengthEven ::
IntOr [a] IntOr [a]
-> IntOr Bool -> IntOr Bool
intOrLengthEven = intOrLengthEven = over intOrP (even . length)
error "todo: intOrLengthEven"

View file

@ -1,4 +1,5 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Lets.OpticPolyLens ( module Lets.OpticPolyLens (
Lens(..) Lens(..)
@ -43,9 +44,10 @@ module Lets.OpticPolyLens (
, modifyIntandLengthEven , modifyIntandLengthEven
) where ) where
import Data.Char(toUpper) import Data.Bool(bool)
import Data.Char(toUpper, ord)
import Data.Map(Map) 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 Data.Set(Set)
import qualified Data.Set as Set(insert, delete, member) 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)) 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 Lens
(forall f. Functor f => (a -> f b) -> s -> f t) (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 :: get ::
Lens s t a b Lens s t a b
-> s -> s
-> a -> a
get (Lens r) = get (Lens r) s = let rc = r Const in getConst $ rc s
getConst . r Const
set :: set ::
Lens s t a b Lens s t a b
@ -125,8 +145,9 @@ modify ::
-> (a -> b) -> (a -> b)
-> s -> s
-> t -> 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@. -- | An alias for @modify@.
(%~) :: (%~) ::
@ -155,8 +176,10 @@ infixr 4 %~
-> b -> b
-> s -> s
-> t -> 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 .~ infixl 5 .~
@ -176,8 +199,7 @@ fmodify ::
-> (a -> f b) -> (a -> f b)
-> s -> s
-> f t -> f t
fmodify = fmodify (Lens stab) aTofb s = stab aTofb s
error "todo: fmodify"
-- | -- |
-- --
@ -192,8 +214,7 @@ fmodify =
-> f b -> f b
-> s -> s
-> f t -> f t
(|=) = (|=) (Lens l) fb s = (l (\_ -> fb) s)
error "todo: (|=)"
infixl 5 |= infixl 5 |=
@ -209,8 +230,7 @@ infixl 5 |=
-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
fstL :: fstL ::
Lens (a, x) (b, x) a b 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 +244,7 @@ fstL =
-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
sndL :: sndL ::
Lens (x, a) (x, b) a b 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 +269,7 @@ mapL ::
Ord k => Ord k =>
k k
-> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) -> 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 +294,8 @@ setL ::
Ord k => Ord k =>
k k
-> Lens (Set k) (Set k) Bool Bool -> 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 +308,7 @@ compose ::
Lens s t a b Lens s t a b
-> Lens q r s t -> Lens q r s t
-> Lens q r a b -> Lens q r a b
compose = compose (Lens r) (Lens g) = Lens $ g . r
error "todo: compose"
-- | An alias for @compose@. -- | An alias for @compose@.
(|.) :: (|.) ::
@ -312,8 +329,7 @@ infixr 9 |.
-- 4 -- 4
identity :: identity ::
Lens a b a b Lens a b a b
identity = identity = Lens (\f -> \a -> f a)
error "todo: identity"
-- | -- |
-- --
@ -356,8 +372,9 @@ choice ::
Lens s t a b Lens s t a b
-> Lens q r a b -> Lens q r a b
-> Lens (Either s q) (Either t 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@. -- | An alias for @choice@.
(|||) :: (|||) ::
@ -451,9 +468,7 @@ intAndL =
getSuburb :: getSuburb ::
Person Person
-> String -> String
getSuburb = getSuburb = get $ (compose suburbL addressL)
error "todo: getSuburb"
-- | -- |
-- --
@ -466,8 +481,7 @@ setStreet ::
Person Person
-> String -> String
-> Person -> Person
setStreet = setStreet = set $ (compose streetL addressL)
error "todo: setStreet"
-- | -- |
-- --
@ -479,8 +493,8 @@ setStreet =
getAgeAndCountry :: getAgeAndCountry ::
(Person, Locality) (Person, Locality)
-> (Int, String) -> (Int, String)
getAgeAndCountry = getAgeAndCountry (person, locality) = (get ageL person,
error "todo: getAgeAndCountry" 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")) -- (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 :: setCityAndLocality ::
(Person, Address) -> (String, Locality) -> (Person, Address) (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)
-- | -- |
-- --

View file

@ -47,12 +47,12 @@ module Lets.StoreLens (
) where ) where
import Control.Applicative(Applicative((<*>))) import Control.Applicative(Applicative((<*>)))
import Data.Char(toUpper) import Data.Char(toUpper, ord)
import Data.Functor((<$>)) import Data.Functor((<$>))
import Data.Map(Map) 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 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 Lets.Data(Store(Store), Person(Person), Locality(Locality), Address(Address))
import Prelude hiding (product) import Prelude hiding (product)
@ -80,30 +80,37 @@ mapS ::
(a -> b) (a -> b)
-> Store s a -> Store s a
-> Store s b -> Store s b
mapS = mapS f (Store sToa s) = Store (\ss -> f (sToa ss)) s
error "todo: mapS"
duplicateS :: duplicateS ::
Store s a Store s a
-> Store s (Store s a) -> Store s (Store s a)
duplicateS = duplicateS (Store sToa a) = Store (\s -> Store sToa s) a
error "todo: duplicateS"
extendS :: extendS ::
(Store s a -> b) (Store s a -> b)
-> Store s a -> Store s a
-> Store s b -> Store s b
extendS = extendS f = mapS f . duplicateS
error "todo: extendS"
extractS :: extractS ::
Store s a Store s a
-> a -> a
extractS = extractS = \(Store sToa s) -> sToa s
error "todo: extractS"
---- ----
-- 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 = data Lens a b =
Lens Lens
(a -> Store b a) (a -> Store b a)
@ -193,8 +200,7 @@ modify ::
-> (b -> b) -> (b -> b)
-> a -> a
-> a -> a
modify = modify (Lens f) bTob a = let Store s g = f a in s (bTob g)
error "todo: modify"
-- | An alias for @modify@. -- | An alias for @modify@.
(%~) :: (%~) ::
@ -223,8 +229,7 @@ infixr 4 %~
-> b -> b
-> a -> a
-> a -> a
(.~) = (.~) = \(Lens f) -> \v -> \a -> let Store s g = f a in s v
error "todo: (.~)"
infixl 5 .~ infixl 5 .~
@ -244,9 +249,8 @@ fmodify ::
-> (b -> f b) -> (b -> f b)
-> a -> a
-> f a -> f a
fmodify = fmodify (Lens f) bTofb a = let Store s g = f a in s <$> bTofb g
error "todo: fmodify"
-- | -- |
-- --
-- >>> fstL |= Just 3 $ (7, "abc") -- >>> fstL |= Just 3 $ (7, "abc")
@ -260,8 +264,7 @@ fmodify =
-> f b -> f b
-> a -> a
-> f a -> f a
(|=) = (|=) (Lens f) fb a = let Store s g = f a in s <$> fb
error "todo: (|=)"
infixl 5 |= infixl 5 |=
@ -277,8 +280,7 @@ infixl 5 |=
-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
fstL :: fstL ::
Lens (x, y) x Lens (x, y) x
fstL = fstL = Lens (\(x, y) -> Store (\x' -> (x', y)) x)
error "todo: fstL"
-- | -- |
-- --
@ -292,8 +294,7 @@ fstL =
-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
sndL :: sndL ::
Lens (x, y) y Lens (x, y) y
sndL = sndL = Lens (\(x, y) -> Store (\y' -> (x, y')) y)
error "todo: sndL"
-- | -- |
-- --
@ -318,8 +319,10 @@ mapL ::
Ord k => Ord k =>
k k
-> Lens (Map k v) (Maybe v) -> Lens (Map k v) (Maybe v)
mapL = mapL k = Lens (\mkv -> Store (\mv -> case mv of
error "todo: mapL" Nothing -> Map.delete k mkv
Just a -> Map.insert k a mkv)
(Map.lookup k mkv))
-- | -- |
-- --
@ -344,8 +347,10 @@ setL ::
Ord k => Ord k =>
k k
-> Lens (Set k) Bool -> Lens (Set k) Bool
setL = setL k = Lens (\sk -> Store (\bool -> case bool of
error "todo: setL" True -> Set.insert k sk
False -> Set.delete k sk)
(Set.member k sk))
-- | -- |
-- --
@ -358,8 +363,10 @@ compose ::
Lens b c Lens b c
-> Lens a b -> Lens a b
-> Lens a c -> Lens a c
compose = compose = \(Lens f) -> \(Lens g) ->
error "todo: compose" Lens (\a -> let Store bToa b = g a
in let Store cTob c = f b
in Store (bToa . cTob) c)
-- | An alias for @compose@. -- | An alias for @compose@.
(|.) :: (|.) ::
@ -380,9 +387,8 @@ infixr 9 |.
-- 4 -- 4
identity :: identity ::
Lens a a Lens a a
identity = identity = Lens (\a -> Store (\a' -> a') a)
error "todo: identity"
-- | -- |
-- --
-- >>> get (product fstL sndL) (("abc", 3), (4, "def")) -- >>> get (product fstL sndL) (("abc", 3), (4, "def"))
@ -394,8 +400,10 @@ product ::
Lens a b Lens a b
-> Lens c d -> Lens c d
-> Lens (a, c) (b, d) -> Lens (a, c) (b, d)
product = product (Lens f) (Lens g) =
error "todo: product" 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@. -- | An alias for @product@.
(***) :: (***) ::
@ -424,8 +432,10 @@ choice ::
Lens a x Lens a x
-> Lens b x -> Lens b x
-> Lens (Either a b) x -> Lens (Either a b) x
choice = choice (Lens ax) (Lens bx) =
error "todo: choice" 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@. -- | An alias for @choice@.
(|||) :: (|||) ::
@ -512,8 +522,7 @@ addressL =
getSuburb :: getSuburb ::
Person Person
-> String -> String
getSuburb = getSuburb = get $ (compose suburbL addressL)
error "todo: getSuburb"
-- | -- |
-- --
@ -526,8 +535,7 @@ setStreet ::
Person Person
-> String -> String
-> Person -> Person
setStreet = setStreet = set $ (compose streetL addressL)
error "todo: setStreet"
-- | -- |
-- --
@ -539,8 +547,9 @@ setStreet =
getAgeAndCountry :: getAgeAndCountry ::
(Person, Locality) (Person, Locality)
-> (Int, String) -> (Int, String)
getAgeAndCountry = getAgeAndCountry (person, locality) = (get ageL person,
error "todo: getAgeAndCountry" get countryL locality)
-- | -- |
-- --
@ -551,9 +560,11 @@ 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")) -- (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 :: setCityAndLocality ::
(Person, Address) -> (String, Locality) -> (Person, Address) (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)
-- | -- |
-- --
-- >>> getSuburbOrCity (Left maryAddress) -- >>> getSuburbOrCity (Left maryAddress)
@ -564,8 +575,10 @@ setCityAndLocality =
getSuburbOrCity :: getSuburbOrCity ::
Either Address Locality Either Address Locality
-> String -> String
getSuburbOrCity = getSuburbOrCity = \soc -> case soc of
error "todo: getSuburbOrCity" Left address -> get suburbL address
Right locality -> get cityL locality
-- | -- |
-- --
@ -578,8 +591,9 @@ setStreetOrState ::
Either Person Locality Either Person Locality
-> String -> String
-> Either Person Locality -> Either Person Locality
setStreetOrState = setStreetOrState = \sos -> \ipsos -> case sos of
error "todo: setStreetOrState" Left person -> Left $ set (streetL |. addressL) person ipsos
Right locality -> Right $ set stateL locality ipsos
-- | -- |
-- --
@ -591,5 +605,4 @@ setStreetOrState =
modifyCityUppercase :: modifyCityUppercase ::
Person Person
-> Person -> Person
modifyCityUppercase = modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper
error "todo: modifyCityUppercase"

66
stack.yaml Normal file
View file

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