Compare commits
10 commits
master
...
lens_pract
Author | SHA1 | Date | |
---|---|---|---|
4d3bc29f81 | |||
b1603f17ce | |||
7b37e979fe | |||
dd741ff696 | |||
9c83801470 | |||
b0f7bf2c06 | |||
7c8a2f87bb | |||
246f6b1302 | |||
5186970bb8 | |||
1b68f0617f |
6 changed files with 301 additions and 220 deletions
4
.gitignore
vendored
4
.gitignore
vendored
|
@ -30,3 +30,7 @@ TAGS
|
||||||
|
|
||||||
*.swp
|
*.swp
|
||||||
|
|
||||||
|
# STACK
|
||||||
|
.stack-work
|
||||||
|
stack.yaml.lock
|
||||||
|
tags
|
||||||
|
|
|
@ -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"
|
|
||||||
|
|
156
src/Lets/Lens.hs
156
src/Lets/Lens.hs
|
@ -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))
|
||||||
|
@ -111,8 +111,7 @@ 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 ::
|
||||||
|
@ -120,8 +119,7 @@ over ::
|
||||||
-> (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 =
|
||||||
|
@ -143,22 +140,19 @@ type Set s t a b =
|
||||||
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 .~
|
||||||
|
|
||||||
|
@ -397,8 +378,7 @@ fmodify ::
|
||||||
-> (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,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"))
|
-- (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)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
@ -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"
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
|
|
@ -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,8 +249,7 @@ 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"
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
@ -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,8 +387,7 @@ infixr 9 |.
|
||||||
-- 4
|
-- 4
|
||||||
identity ::
|
identity ::
|
||||||
Lens a a
|
Lens a a
|
||||||
identity =
|
identity = Lens (\a -> Store (\a' -> a') a)
|
||||||
error "todo: identity"
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
@ -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,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"))
|
-- (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)
|
||||||
|
|
||||||
|
|
||||||
-- |
|
-- |
|
||||||
--
|
--
|
||||||
|
@ -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
66
stack.yaml
Normal 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
|
Loading…
Reference in a new issue