Compare commits

..

No commits in common. "4d3bc29f8172ceb9fb5bfb98d6ad800d6b919ce5" and "4c7da139cc3d526a346a86bc6977e6f0ba2d2193" have entirely different histories.

6 changed files with 220 additions and 301 deletions

4
.gitignore vendored
View file

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

View file

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

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

View file

@ -1,5 +1,4 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Lets.OpticPolyLens (
Lens(..)
@ -44,10 +43,9 @@ module Lets.OpticPolyLens (
, modifyIntandLengthEven
) where
import Data.Bool(bool)
import Data.Char(toUpper, ord)
import Data.Char(toUpper)
import Data.Map(Map)
import qualified Data.Map as Map(insert, delete, lookup, fromList, alterF)
import qualified Data.Map as Map(insert, delete, lookup)
import Data.Set(Set)
import qualified Data.Set as Set(insert, delete, member)
import Lets.Data(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address))
@ -64,30 +62,12 @@ data Lens s t a b =
Lens
(forall f. Functor f => (a -> f b) -> s -> f t)
-- Lens s t a b
-- Lens u w s t
-- (s -> f t) -> w -> f w
-- Lens u w s t . Lens s t a b
-- p :: (->)
-- p a b
-- f :: s -> a
-- fcps :: forall r . (a -> r) -> s -> r
-- f ~ fcps id
-- fcps = \c -> c . f
-- (a -> r) . s -> a
-- forall r . (a -> f r) -> s -> f r
-- forall f . Functor f => (a -> f b) -> s -> f t
-- Const :: forall b . a -> Const a b
get ::
Lens s t a b
-> s
-> a
get (Lens r) s = let rc = r Const in getConst $ rc s
get (Lens r) =
getConst . r Const
set ::
Lens s t a b
@ -145,9 +125,8 @@ modify ::
-> (a -> b)
-> s
-> t
modify (Lens r) f s = let idf = Identity . f in
let ridf = r idf in
let sidt = ridf s in getIdentity sidt
modify =
error "todo: modify"
-- | An alias for @modify@.
(%~) ::
@ -176,10 +155,8 @@ infixr 4 %~
-> b
-> s
-> t
-- modify :: Lens s t a b -> (a -> b) -> s -> t
-- modify (Lens r) f s = let idf = Identity . f in
-- let ridf = r idf in (getIdentity . ridf) s
(.~) (Lens stab) b s = getIdentity (stab (\_ -> Identity b) s)
(.~) =
error "todo: (.~)"
infixl 5 .~
@ -199,7 +176,8 @@ fmodify ::
-> (a -> f b)
-> s
-> f t
fmodify (Lens stab) aTofb s = stab aTofb s
fmodify =
error "todo: fmodify"
-- |
--
@ -214,7 +192,8 @@ fmodify (Lens stab) aTofb s = stab aTofb s
-> f b
-> s
-> f t
(|=) (Lens l) fb s = (l (\_ -> fb) s)
(|=) =
error "todo: (|=)"
infixl 5 |=
@ -230,7 +209,8 @@ infixl 5 |=
-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z
fstL ::
Lens (a, x) (b, x) a b
fstL = Lens (\f -> \(a, x) -> let fb = f a in (, x) <$> fb)
fstL =
error "todo: fstL"
-- |
--
@ -244,7 +224,8 @@ fstL = Lens (\f -> \(a, x) -> let fb = f a in (, x) <$> fb)
-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z
sndL ::
Lens (x, a) (x, b) a b
sndL = Lens (\f -> \(x, a) -> let fb = f a in (x ,) <$> fb)
sndL =
error "todo: sndL"
-- |
--
@ -269,7 +250,8 @@ mapL ::
Ord k =>
k
-> Lens (Map k v) (Map k v) (Maybe v) (Maybe v)
mapL k = Lens (\f -> \mkv -> Map.alterF f k mkv)
mapL =
error "todo: mapL"
-- |
--
@ -294,8 +276,8 @@ setL ::
Ord k =>
k
-> Lens (Set k) (Set k) Bool Bool
setL k = Lens (\f -> \sk -> (\b -> bool (Set.delete k sk) (Set.insert k sk) b)
<$> (f $ Set.member k sk))
setL =
error "todo: setL"
-- |
--
@ -308,7 +290,8 @@ compose ::
Lens s t a b
-> Lens q r s t
-> Lens q r a b
compose (Lens r) (Lens g) = Lens $ g . r
compose =
error "todo: compose"
-- | An alias for @compose@.
(|.) ::
@ -329,7 +312,8 @@ infixr 9 |.
-- 4
identity ::
Lens a b a b
identity = Lens (\f -> \a -> f a)
identity =
error "todo: identity"
-- |
--
@ -372,9 +356,8 @@ choice ::
Lens s t a b
-> Lens q r a b
-> Lens (Either s q) (Either t r) a b
choice (Lens l) (Lens g) = Lens (\f -> \esq -> case esq of
Left s -> Left <$> l f s
Right q -> Right <$> g f q)
choice =
error "todo: choice"
-- | An alias for @choice@.
(|||) ::
@ -468,7 +451,9 @@ intAndL =
getSuburb ::
Person
-> String
getSuburb = get $ (compose suburbL addressL)
getSuburb =
error "todo: getSuburb"
-- |
--
@ -481,7 +466,8 @@ setStreet ::
Person
-> String
-> Person
setStreet = set $ (compose streetL addressL)
setStreet =
error "todo: setStreet"
-- |
--
@ -493,8 +479,8 @@ setStreet = set $ (compose streetL addressL)
getAgeAndCountry ::
(Person, Locality)
-> (Int, String)
getAgeAndCountry (person, locality) = (get ageL person,
get countryL locality)
getAgeAndCountry =
error "todo: getAgeAndCountry"
-- |
--
@ -505,9 +491,8 @@ getAgeAndCountry (person, locality) = (get ageL person,
-- (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 (person, address) (city, locality) =
(set (cityL |. localityL |. addressL) person city,
set localityL address locality)
setCityAndLocality =
error "todo: setCityAndLocality"
-- |
--

View file

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

View file

@ -1,66 +0,0 @@
# 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