sanchayanmaity/lets-lens
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Compare commits

base: sanchayanmaity:lens_practice
Branches Tags
sanchayanmaity:lens_practice
sanchayanmaity:master
..
compare: sanchayanmaity:master
Branches Tags
sanchayanmaity:lens_practice
sanchayanmaity:master

No commits in common. "lens_practice" and "master" have entirely different histories.
lens_pract ... master

6 changed files with 220 additions and 301 deletions
Show stats Expand all files Collapse all files

4
.gitignore vendored
View file

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

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

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

85
src/Lets/OpticPolyLens.hs
View file

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

117
src/Lets/StoreLens.hs
View file

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

66
stack.yaml
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