From 77da1bf37b87bff7d10a8de49c5d69a25837ef4b Mon Sep 17 00:00:00 2001 From: Tony Morris Date: Wed, 22 Apr 2015 13:14:38 +1000 Subject: [PATCH] Initial set of exercises, no answers --- .ghci | 2 - README.markdown | 66 +++ lets-lens.cabal | 13 +- src/Lets.hs | 9 +- src/Lets/Data.hs | 180 ++++++++ src/Lets/GetSetLens.hs | 544 +++++++++++++++++++++++++ src/Lets/Lens.hs | 7 + src/Lets/Lens/Choice.hs | 43 ++ src/Lets/Lens/Lens.hs | 788 ++++++++++++++++++++++++++++++++++++ src/Lets/Lens/Profunctor.hs | 22 + src/Lets/OpticPolyLens.hs | 546 +++++++++++++++++++++++++ src/Lets/StoreLens.hs | 592 +++++++++++++++++++++++++++ 12 files changed, 2804 insertions(+), 8 deletions(-) create mode 100644 src/Lets/Data.hs create mode 100644 src/Lets/GetSetLens.hs create mode 100644 src/Lets/Lens.hs create mode 100644 src/Lets/Lens/Choice.hs create mode 100644 src/Lets/Lens/Lens.hs create mode 100644 src/Lets/Lens/Profunctor.hs create mode 100644 src/Lets/OpticPolyLens.hs create mode 100644 src/Lets/StoreLens.hs diff --git a/.ghci b/.ghci index 8bf1801..38f753b 100644 --- a/.ghci +++ b/.ghci @@ -6,7 +6,5 @@ :set -fno-warn-unused-do-bind :set -fno-warn-unused-imports :set -fno-warn-type-defaults -:set -XNoImplicitPrelude :set -XScopedTypeVariables :set -XOverloadedStrings -:set -XRebindableSyntax diff --git a/README.markdown b/README.markdown index ec63ddd..8d68dda 100644 --- a/README.markdown +++ b/README.markdown @@ -1 +1,67 @@ # Let's Lens + +![NICTA](http://i.imgur.com/sMXB9XB.jpg) + + +### Abstract + +Let's Lens presents a series of exercises, in a similar format to +[the NICTA functional programming course material](http://github.com/NICTA/course). +The subject of the exercises is around the concept of lenses, initially proposed +by Foster et al., to solve the view-update problem of relational databases. + +The theories around lenses have been advanced significantly in recent years, +resulting in a library, implemented in Haskell, called `lens`. + +http://hackage.haskell.org/package/lens + +The exercises take into account various possible goals. For example, if you wish +to study the history of lenses, then build up to the most recent theories, it is +best to start at the `Lets.GetSetLens` module. If you wish to derive the +structure of lenses from first principles, then derive the more modern theories, +start at the `Lets.Lens.Lens` module. + +---- + +### Exercise modules + +##### `Lets.GetSetLens` + +This module presents a series of exercises, representing lenses as a traditional +pair of "`get` and `set`" functions. This representation may be beneficial as it +easily appeals to an intuition of "what a lens is", however, it is outdated. + +These exercises are useful to gain an initial understanding of the problems that +lenses solve, as well as to gain an insight into the history of lenses and how +the theories have developed over time. + +##### `Lets.StoreLens` + +This series of exercises is similar to `Lets.GetSetLens`, however, using a +slightly altered representation of a lens, based on the `Store` comonad, which +fuses the typical `get` and `set` operations into a data structure. This +representation is described in detail in +*Morris, Tony. "Asymmetric Lenses in Scala." (2012).* + +##### `Lets.OpticPolyLens` + +This series of exercises introduces a new representation of lenses, first +described by Twan van Laarhoven. This representation also introduces a +generalisation of lenses to permit *polymorphic update* of structures. + +##### `Lets.Lens.Lens` + +This series of exercises starts at first principles to derive the concept of a +lens, as it was first described by Twan van Laarhoven. The derivation then goes +on to described other structures to solve various practical problems such as +*multi-update* and *partial update*. + +This representation presents a generalisation, permitting *polymorphic update* +over structures. After lenses are derived, further concepts are introduced, such +as `Fold`s, `Traversal`s and `Prism`s. + +---- + +### Credits + +* Edward Kmett on the [derivation of lenses](https://github.com/ekmett/lens/wiki/Derivation) diff --git a/lets-lens.cabal b/lets-lens.cabal index 0053e25..3c83dec 100644 --- a/lets-lens.cabal +++ b/lets-lens.cabal @@ -36,14 +36,17 @@ library -fno-warn-unused-imports -fno-warn-type-defaults - default-extensions: NoImplicitPrelude - ScopedTypeVariables - InstanceSigs - RebindableSyntax - hs-source-dirs: src exposed-modules: Lets + Lets.Data + Lets.GetSetLens + Lets.Lens + Lets.Lens.Choice + Lets.Lens.Lens + Lets.Lens.Profunctor + Lets.OpticPolyLens + Lets.StoreLens test-suite doctests type: diff --git a/src/Lets.hs b/src/Lets.hs index 6a91527..ea0e397 100644 --- a/src/Lets.hs +++ b/src/Lets.hs @@ -1,2 +1,9 @@ -module Lets where +module Lets ( + module L +) where +import Lets.Data as L +import Lets.GetSetLens as L() +import Lets.Lens as L() +import Lets.OpticPolyLens as L() +import Lets.StoreLens as L() diff --git a/src/Lets/Data.hs b/src/Lets/Data.hs new file mode 100644 index 0000000..81e76ee --- /dev/null +++ b/src/Lets/Data.hs @@ -0,0 +1,180 @@ +module Lets.Data ( + Locality(..) +, Address(..) +, Person(..) +, IntAnd(..) +, IntOr(..) +, fredLocality +, fredAddress +, fred +, maryLocality +, maryAddress +, mary +, Store(..) +, Const (..) +, Tagged(..) +, Identity(..) +, AlongsideLeft(..) +, AlongsideRight(..) +) where + +import Control.Applicative(Applicative(..)) +import Data.Monoid(Monoid(..)) + +data Locality = + Locality + String -- city + String -- state + String -- country + deriving (Eq, Show) + +data Address = + Address + String -- street + String -- suburb + Locality + deriving (Eq, Show) + +data Person = + Person + Int -- age + String -- name + Address -- address + deriving (Eq, Show) + +data IntAnd a = + IntAnd + Int + a + deriving (Eq, Show) + +data IntOr a = + IntOrIs Int + | IntOrIsNot a + deriving (Eq, Show) + +fredLocality :: + Locality +fredLocality = + Locality + "Fredmania" + "New South Fred" + "Fredalia" + +fredAddress :: + Address +fredAddress = + Address + "15 Fred St" + "Fredville" + fredLocality + +fred :: + Person +fred = + Person + 24 + "Fred" + fredAddress + +maryLocality :: + Locality +maryLocality = + Locality + "Mary Mary" + "Western Mary" + "Maristan" + +maryAddress :: + Address +maryAddress = + Address + "83 Mary Ln" + "Maryland" + maryLocality + +mary :: + Person +mary = + Person + 28 + "Mary" + maryAddress + +---- + +data Store s a = + Store + (s -> a) + s + +data Const a b = + Const { + getConst :: + a + } + deriving (Eq, Show) + +instance Functor (Const a) where + fmap _ (Const a) = + Const a + +instance Monoid a => Applicative (Const a) where + pure _ = + Const mempty + Const f <*> Const a = + Const (f `mappend` a) + +data Tagged a b = + Tagged { + getTagged :: + b + } + deriving (Eq, Show) + +instance Functor (Tagged a) where + fmap f (Tagged b) = + Tagged (f b) + +instance Applicative (Tagged a) where + pure = + Tagged + Tagged f <*> Tagged a = + Tagged (f a) + +data Identity a = + Identity { + getIdentity :: + a + } + deriving (Eq, Show) + +instance Functor Identity where + fmap f (Identity a) = + Identity (f a) + +instance Applicative Identity where + pure = + Identity + Identity f <*> Identity a = + Identity (f a) + +data AlongsideLeft f b a = + AlongsideLeft { + getAlongsideLeft :: + f (a, b) + } + +instance Functor f => Functor (AlongsideLeft f b) where + fmap f (AlongsideLeft x) = + AlongsideLeft (fmap (\(a, b) -> (f a, b)) x) + +data AlongsideRight f a b = + AlongsideRight { + getAlongsideRight :: + f (a, b) + } + +instance Functor f => Functor (AlongsideRight f a) where + fmap f (AlongsideRight x) = + AlongsideRight (fmap (\(a, b) -> (a, f b)) x) diff --git a/src/Lets/GetSetLens.hs b/src/Lets/GetSetLens.hs new file mode 100644 index 0000000..ec5e29d --- /dev/null +++ b/src/Lets/GetSetLens.hs @@ -0,0 +1,544 @@ +module Lets.GetSetLens ( + Lens(..) +, getsetLaw +, setgetLaw +, setsetLaw +, get +, set +, modify +, (%~) +, fmodify +, (|=) +, fstL +, sndL +, mapL +, setL +, compose +, (|.) +, identity +, product +, (***) +, choice +, (|||) +, cityL +, countryL +, streetL +, suburbL +, localityL +, ageL +, nameL +, addressL +, getSuburb +, setStreet +, getAgeAndCountry +, setCityAndLocality +, getSuburbOrCity +, setStreetOrState +, modifyCityUppercase +) where + +import Control.Applicative((<*>)) +import Data.Bool(bool) +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) +import Lets.Data +import Prelude hiding (product) + +-- $setup +-- >>> import qualified Data.Map as Map(fromList) +-- >>> import qualified Data.Set as Set(fromList) +-- >>> import Data.Char(ord) + +data Lens a b = + Lens + (a -> b -> a) + (a -> b) + +-- | +-- +-- >>> get fstL (0 :: Int, "abc") +-- 0 +-- +-- >>> get sndL ("abc", 0 :: Int) +-- 0 +-- +-- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x +-- +-- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y +get :: + Lens a b + -> a + -> b +get (Lens _ g) = + g + +-- | +-- +-- >>> set fstL (0 :: Int, "abc") 1 +-- (1,"abc") +-- +-- >>> set sndL ("abc", 0 :: Int) 1 +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) +set :: + Lens a b + -> a + -> b + -> a +set (Lens s _) a = + s a + +-- | The get/set law of lenses. This function should always return @True@. +getsetLaw :: + Eq a => + Lens a b + -> a + -> Bool +getsetLaw l = + \a -> set l a (get l a) == a + +-- | The set/get law of lenses. This function should always return @True@. +setgetLaw :: + Eq b => + Lens a b + -> a + -> b + -> Bool +setgetLaw l a b = + get l (set l a b) == b + +-- | The set/set law of lenses. This function should always return @True@. +setsetLaw :: + Eq a => + Lens a b + -> a + -> b + -> b + -> Bool +setsetLaw l a b1 b2 = + set l (set l a b1) b2 == set l a b2 + +---- + +-- | +-- +-- >>> modify fstL (+1) (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> modify sndL (+1) ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) +modify :: + Lens a b + -> (b -> b) + -> a + -> a +modify = + error "todo: modify" + +-- | An alias for @modify@. +(%~) :: + Lens a b + -> (b -> b) + -> a + -> a +(%~) = + modify + +infixr 4 %~ + +-- | +-- +-- >>> fstL .~ 1 $ (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> sndL .~ 1 $ ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) +(.~) :: + Lens a b + -> b + -> a + -> a +(.~) = + error "todo: (.~)" + +infixl 5 .~ + +-- | +-- +-- >>> fmodify fstL (+) (5 :: Int, "abc") 8 +-- (13,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") +-- Just (20,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") +-- Nothing +fmodify :: + Functor f => + Lens a b + -> (b -> f b) + -> a + -> f a +fmodify = + error "todo: fmodify" + +-- | +-- +-- >>> fstL |= Just 3 $ (7, "abc") +-- Just (3,"abc") +-- +-- >>> (fstL |= (+1) $ (3, "abc")) 17 +-- (18,"abc") +(|=) :: + Functor f => + Lens a b + -> f b + -> a + -> f a +(|=) = + error "todo: (|=)" + +infixl 5 |= + +-- | +-- +-- >>> modify fstL (*10) (3, "abc") +-- (30,"abc") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z +fstL :: + Lens (x, y) x +fstL = + error "todo: fstL" + +-- | +-- +-- >>> modify sndL (++ "def") (13, "abc") +-- (13,"abcdef") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z +sndL :: + Lens (x, y) y +sndL = + error "todo: sndL" + +-- | +-- +-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Just 'c' +-- +-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Nothing +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] +mapL :: + Ord k => + k + -> Lens (Map k v) (Maybe v) +mapL = + error "todo: mapL" + +-- | +-- +-- >>> get (setL 3) (Set.fromList [1..5]) +-- True +-- +-- >>> get (setL 33) (Set.fromList [1..5]) +-- False +-- +-- >>> set (setL 3) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5] +-- +-- >>> set (setL 3) (Set.fromList [1..5]) False +-- fromList [1,2,4,5] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5,33] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) False +-- fromList [1,2,3,4,5] +setL :: + Ord k => + k + -> Lens (Set k) Bool +setL = + error "todo: setL" + +-- | +-- +-- >>> get (compose fstL sndL) ("abc", (7, "def")) +-- 7 +-- +-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 +-- ("abc",(8,"def")) +compose :: + Lens b c + -> Lens a b + -> Lens a c +compose = + error "todo: compose" + +-- | An alias for @compose@. +(|.) :: + Lens b c + -> Lens a b + -> Lens a c +(|.) = + compose + +infixr 9 |. + +-- | +-- +-- >>> get identity 3 +-- 3 +-- +-- >>> set identity 3 4 +-- 4 +identity :: + Lens a a +identity = + error "todo: identity" + +-- | +-- +-- >>> get (product fstL sndL) (("abc", 3), (4, "def")) +-- ("abc","def") +-- +-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") +-- (("ghi",3),(4,"jkl")) +product :: + Lens a b + -> Lens c d + -> Lens (a, c) (b, d) +product = + error "todo: product" + +-- | An alias for @product@. +(***) :: + Lens a b + -> Lens c d + -> Lens (a, c) (b, d) +(***) = + product + +infixr 3 *** + +-- | +-- +-- >>> get (choice fstL sndL) (Left ("abc", 7)) +-- "abc" +-- +-- >>> get (choice fstL sndL) (Right ("abc", 7)) +-- 7 +-- +-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" +-- Left ("def",7) +-- +-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 +-- Right ("abc",8) +choice :: + Lens a x + -> Lens b x + -> Lens (Either a b) x +choice = + error "todo: choice" + +-- | An alias for @choice@. +(|||) :: + Lens a x + -> Lens b x + -> Lens (Either a b) x +(|||) = + choice + +infixr 2 ||| + +---- + +cityL :: + Lens Locality String +cityL = + Lens + (\(Locality _ t y) c -> Locality c t y) + (\(Locality c _ _) -> c) + +stateL :: + Lens Locality String +stateL = + Lens + (\(Locality c _ y) t -> Locality c t y) + (\(Locality _ t _) -> t) + +countryL :: + Lens Locality String +countryL = + Lens + (\(Locality c t _) y -> Locality c t y) + (\(Locality _ _ y) -> y) + +streetL :: + Lens Address String +streetL = + Lens + (\(Address _ s l) t -> Address t s l) + (\(Address t _ _) -> t) + +suburbL :: + Lens Address String +suburbL = + Lens + (\(Address t _ l) s -> Address t s l) + (\(Address _ s _) -> s) + +localityL :: + Lens Address Locality +localityL = + Lens + (\(Address t s _) l -> Address t s l) + (\(Address _ _ l) -> l) + +ageL :: + Lens Person Int +ageL = + Lens + (\(Person _ n d) a -> Person a n d) + (\(Person a _ _) -> a) + +nameL :: + Lens Person String +nameL = + Lens + (\(Person a _ d) n -> Person a n d) + (\(Person _ n _) -> n) + +addressL :: + Lens Person Address +addressL = + Lens + (\(Person a n _) d -> Person a n d) + (\(Person _ _ d) -> d) + +-- | +-- +-- >>> get (suburbL |. addressL) fred +-- "Fredville" +-- +-- >>> get (suburbL |. addressL) mary +-- "Maryland" +getSuburb :: + Person + -> String +getSuburb = + error "todo: getSuburb" + +-- | +-- +-- >>> setStreet fred "Some Other St" +-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setStreet mary "Some Other St" +-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) +setStreet :: + Person + -> String + -> Person +setStreet = + error "todo: setStreet" + +-- | +-- +-- >>> getAgeAndCountry (fred, maryLocality) +-- (24,"Maristan") +-- +-- >>> getAgeAndCountry (mary, fredLocality) +-- (28,"Fredalia") +getAgeAndCountry :: + (Person, Locality) + -> (Int, String) +getAgeAndCountry = + error "todo: getAgeAndCountry" + +-- | +-- +-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) +-- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) +-- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) +setCityAndLocality :: + (Person, Address) -> (String, Locality) -> (Person, Address) +setCityAndLocality = + error "todo: setCityAndLocality" + +-- | +-- +-- >>> getSuburbOrCity (Left maryAddress) +-- "Maryland" +-- +-- >>> getSuburbOrCity (Right fredLocality) +-- "Fredmania" +getSuburbOrCity :: + Either Address Locality + -> String +getSuburbOrCity = + error "todo: getSuburbOrCity" + +-- | +-- +-- >>> setStreetOrState (Right maryLocality) "Some Other State" +-- Right (Locality "Mary Mary" "Some Other State" "Maristan") +-- +-- >>> setStreetOrState (Left fred) "Some Other St" +-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) +setStreetOrState :: + Either Person Locality + -> String + -> Either Person Locality +setStreetOrState = + error "todo: setStreetOrState" + +-- | +-- +-- >>> modifyCityUppercase fred +-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) +-- +-- >>> modifyCityUppercase mary +-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) +modifyCityUppercase :: + Person + -> Person +modifyCityUppercase = + error "todo: modifyCityUppercase" diff --git a/src/Lets/Lens.hs b/src/Lets/Lens.hs new file mode 100644 index 0000000..daa878c --- /dev/null +++ b/src/Lets/Lens.hs @@ -0,0 +1,7 @@ +module Lets.Lens ( + module L +) where + +import Lets.Lens.Choice as L +import Lets.Lens.Lens as L +import Lets.Lens.Profunctor as L diff --git a/src/Lets/Lens/Choice.hs b/src/Lets/Lens/Choice.hs new file mode 100644 index 0000000..6d86080 --- /dev/null +++ b/src/Lets/Lens/Choice.hs @@ -0,0 +1,43 @@ +module Lets.Lens.Choice +( + Choice(..) +) where + +import Lets.Data +import Lets.Lens.Profunctor + +diswap :: + Profunctor p => + p (Either a b) (Either c d) + -> p (Either b a) (Either d c) +diswap = + let swap = either Right Left + in dimap swap swap + +-- | Map on left or right of @Either@. Only one of @left@ or @right@ needs to be +-- provided. +class Profunctor p => Choice p where + left :: + p a b + -> p (Either a c) (Either b c) + left = + diswap . right + + right :: + p a b + -> p (Either c a) (Either c b) + right = + diswap . left + +instance Choice (->) where + left f = + either (Left . f) Right + right f = + either Left (Right . f) + +instance Choice Tagged where + left (Tagged x) = + Tagged (Left x) + right (Tagged x) = + Tagged (Right x) + diff --git a/src/Lets/Lens/Lens.hs b/src/Lets/Lens/Lens.hs new file mode 100644 index 0000000..5b614e2 --- /dev/null +++ b/src/Lets/Lens/Lens.hs @@ -0,0 +1,788 @@ +{-# LANGUAGE RankNTypes #-} + +module Lets.Lens.Lens ( + fmapT +, over +, fmapTAgain +, Set +, sets +, mapped +, set +, foldMapT +, foldMapOf +, foldMapTAgain +, Fold +, folds +, folded +, Get +, get +, Traversal +, both +, traverseLeft +, traverseRight +, Traversal' +, Lens +, Prism +, _Left +, _Right +, prism +, _Just +, _Nothing +, setP +, getP +, Prism' +, modify +, (%~) +, (.~) +, fmodify +, (|=) +, fstL +, sndL +, mapL +, setL +, compose +, (|.) +, identity +, product +, (***) +, choice +, (|||) +, Lens' +, cityL +, stateL +, countryL +, streetL +, suburbL +, localityL +, ageL +, nameL +, addressL +, intAndIntL +, intAndL +, getSuburb +, setStreet +, getAgeAndCountry +, setCityAndLocality +, getSuburbOrCity +, setStreetOrState +, modifyCityUppercase +, modifyIntAndLengthEven +, traverseLocality +, intOrIntP +, intOrP +, intOrLengthEven +) where + +import Control.Applicative(Applicative(..)) +import Data.Bool(bool) +import Data.Char(toUpper) +import Data.Foldable(Foldable(..)) +import Data.Functor((<$>)) +import Data.Map(Map) +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(..)) +import Lets.Data +import Lets.Lens.Choice +import Lets.Lens.Profunctor +import Prelude hiding (product) + +-- $setup +-- >>> import qualified Data.Map as Map(fromList) +-- >>> import qualified Data.Set as Set(fromList) +-- >>> import Data.Char(ord) + +-- Let's remind ourselves of Traversable, noting Foldable and Functor. +-- +-- class (Foldable t, Functor t) => Traversable t where +-- traverse :: +-- Applicative f => +-- (a -> f b) +-- -> t a +-- -> f (t b) + +-- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. +-- +-- /Reminder:/ fmap :: Functor t => (a -> b) -> t a -> t b +fmapT :: + Traversable t => + (a -> b) + -> t a + -> t b +fmapT = + error "todo: fmapT" + +-- | Let's refactor out the call to @traverse@ as an argument to @fmapT@. +over :: + ((a -> Identity b) -> s -> Identity t) + -> (a -> b) + -> s + -> t +over = + error "todo: over" + +-- | Here is @fmapT@ again, passing @traverse@ to @over@. +fmapTAgain :: + Traversable t => + (a -> b) + -> t a + -> t b +fmapTAgain = + error "todo: fmapTAgain" + +-- | Let's create a type-alias for this type of function. +type Set s t a b = + (a -> Identity b) + -> s + -> Identity t + +-- | Let's write an inverse to @over@ that does the @Identity@ wrapping & +-- unwrapping. +sets :: + ((a -> b) -> s -> t) + -> Set s t a b +sets = + error "todo: sets" + +mapped :: + Functor f => + Set (f a) (f b) a b +mapped = + error "todo: mapped" + +set :: + Set s t a b + -> s + -> b + -> t +set = + error "todo: set" + +---- + +-- | Observe that @fmap@ can be recovered from @traverse@ using @Identity@. +-- +-- /Reminder:/ foldMap :: (Foldable t, Monoid b) => (a -> b) -> t a -> b +foldMapT :: + (Traversable t, Monoid b) => + (a -> b) + -> t a + -> b +foldMapT = + error "todo: foldMapT" + +-- | Let's refactor out the call to @traverse@ as an argument to @foldMapT@. +foldMapOf :: + ((a -> Const r b) -> s -> Const r t) + -> (a -> r) + -> s + -> r +foldMapOf = + error "todo: foldMapOf" + +-- | Here is @foldMapT@ again, passing @traverse@ to @foldMapOf@. +foldMapTAgain :: + (Traversable t, Monoid b) => + (a -> b) + -> t a + -> b +foldMapTAgain = + error "todo: foldMapTAgain" + +-- | Let's create a type-alias for this type of function. +type Fold s t a b = + forall r. + Monoid r => + (a -> Const r b) + -> s + -> Const r t + +-- | Let's write an inverse to @foldMapOf@ that does the @Const@ wrapping & +-- unwrapping. +folds :: + ((a -> b) -> s -> t) + -> (a -> Const b a) + -> s + -> Const t s +folds = + error "todo: folds" + +folded :: + Foldable f => + Fold (f a) (f a) a a +folded = + error "todo: folded" + +---- + +-- | @Get@ is like @Fold@, but without the @Monoid@ constraint. +type Get r s a = + (a -> Const r a) + -> s + -> Const r s + +get :: + Get a s a + -> s + -> a +get = + error "todo: get" + +---- + +-- | Let's generalise @Identity@ and @Const r@ to any @Applicative@ instance. +type Traversal s t a b = + forall f. + Applicative f => + (a -> f b) + -> s + -> f t + +-- | Traverse both sides of a pair. +both :: + Traversal (a, a) (b, b) a b +both = + error "todo: both" + +-- | Traverse the left side of @Either@. +traverseLeft :: + Traversal (Either a x) (Either b x) a b +traverseLeft = + error "todo: traverseLeft" + +-- | Traverse the right side of @Either@. +traverseRight :: + Traversal (Either x a) (Either x b) a b +traverseRight = + error "todo: traverseRight" + +type Traversal' a b = + Traversal a a b b + +---- + +-- | @Const r@ is @Applicative@, if @Monoid r@, however, without the @Monoid@ +-- constraint (as in @Get@), the only shared abstraction between @Identity@ and +-- @Const r@ is @Functor@. +-- +-- Consequently, we arrive at our lens derivation: +type Lens s t a b = + forall f. + Functor f => + (a -> f b) + -> s + -> f t + +---- + +-- | A prism is a less specific type of traversal. +type Prism s t a b = + forall p f. + (Choice p, Applicative f) => + p a (f b) + -> p s (f t) + +_Left :: + Prism (Either a x) (Either b x) a b +_Left = + error "todo: _Left" + +_Right :: + 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 = + error "todo: prism" + +_Just :: + Prism (Maybe a) (Maybe b) a b +_Just = + error "todo: _Just" + +_Nothing :: + Prism (Maybe a) (Maybe a) () () +_Nothing = + error "todo: _Nothing" + +setP :: + Prism s t a b + -> s + -> Either t a +setP = + error "todo: setP" + +getP :: + Prism s t a b + -> b + -> t +getP = + error "todo: getP" + +type Prism' a b = + Prism a a b b + +---- + +-- | +-- +-- >>> modify fstL (+1) (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> modify sndL (+1) ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) +modify :: + Lens s t a b + -> (a -> b) + -> s + -> t +modify = + error "todo: modify" + +-- | An alias for @modify@. +(%~) :: + Lens s t a b + -> (a -> b) + -> s + -> t +(%~) = + modify + +infixr 4 %~ + +-- | +-- +-- >>> fstL .~ 1 $ (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> sndL .~ 1 $ ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) +(.~) :: + Lens s t a b + -> b + -> s + -> t +(.~) = + error "todo: (.~)" + +infixl 5 .~ + +-- | +-- +-- >>> fmodify fstL (+) (5 :: Int, "abc") 8 +-- (13,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") +-- Just (20,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") +-- Nothing +fmodify :: + Functor f => + Lens s t a b + -> (a -> f b) + -> s + -> f t +fmodify = + error "todo: fmodify" + +-- | +-- +-- >>> fstL |= Just 3 $ (7, "abc") +-- Just (3,"abc") +-- +-- >>> (fstL |= (+1) $ (3, "abc")) 17 +-- (18,"abc") +(|=) :: + Functor f => + Lens s t a b + -> f b + -> s + -> f t +(|=) = + error "todo: (|=)" + +infixl 5 |= + +-- | +-- +-- >>> modify fstL (*10) (3, "abc") +-- (30,"abc") +fstL :: + Lens (a, x) (b, x) a b +fstL = + error "todo: fstL" + +-- | +-- +-- >>> modify sndL (++ "def") (13, "abc") +-- (13,"abcdef") +sndL :: + Lens (x, a) (x, b) a b +sndL = + error "todo: sndL" + +-- | +-- +-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Just 'c' +-- +-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Nothing +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] +mapL :: + Ord k => + k + -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) +mapL = + error "todo: mapL" + +-- | +-- +-- >>> get (setL 3) (Set.fromList [1..5]) +-- True +-- +-- >>> get (setL 33) (Set.fromList [1..5]) +-- False +-- +-- >>> set (setL 3) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5] +-- +-- >>> set (setL 3) (Set.fromList [1..5]) False +-- fromList [1,2,4,5] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5,33] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) False +-- fromList [1,2,3,4,5] +setL :: + Ord k => + k + -> Lens (Set.Set k) (Set.Set k) Bool Bool +setL = + error "todo: setL" + +-- | +-- +-- >>> get (compose fstL sndL) ("abc", (7, "def")) +-- 7 +-- +-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 +-- ("abc",(8,"def")) +compose :: + Lens s t a b + -> Lens q r s t + -> Lens q r a b +compose = + error "todo: compose" + +-- | An alias for @compose@. +(|.) :: + Lens s t a b + -> Lens q r s t + -> Lens q r a b +(|.) = + compose + +infixr 9 |. + +-- | +-- +-- >>> get identity 3 +-- 3 +-- +-- >>> set identity 3 4 +-- 4 +identity :: + Lens a b a b +identity = + error "todo: identity" + +-- | +-- +-- >>> get (product fstL sndL) (("abc", 3), (4, "def")) +-- ("abc","def") +-- +-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") +-- (("ghi",3),(4,"jkl")) +product :: + Lens s t a b + -> Lens q r c d + -> Lens (s, q) (t, r) (a, c) (b, d) +product = + error "todo: product" + +-- | An alias for @product@. +(***) :: + Lens s t a b + -> Lens q r c d + -> Lens (s, q) (t, r) (a, c) (b, d) +(***) = + product + +infixr 3 *** + +-- | +-- +-- >>> get (choice fstL sndL) (Left ("abc", 7)) +-- "abc" +-- +-- >>> get (choice fstL sndL) (Right ("abc", 7)) +-- 7 +-- +-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" +-- Left ("def",7) +-- +-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 +-- Right ("abc",8) +choice :: + Lens s t a b + -> Lens q r a b + -> Lens (Either s q) (Either t r) a b +choice = + error "todo: choice" + +-- | An alias for @choice@. +(|||) :: + Lens s t a b + -> Lens q r a b + -> Lens (Either s q) (Either t r) a b +(|||) = + choice + +infixr 2 ||| + +---- + +type Lens' a b = + Lens a a b b + +cityL :: + Lens' Locality String +cityL p (Locality c t y) = + fmap (\c' -> Locality c' t y) (p c) + +stateL :: + Lens' Locality String +stateL p (Locality c t y) = + fmap (\t' -> Locality c t' y) (p t) + +countryL :: + Lens' Locality String +countryL p (Locality c t y) = + fmap (\y' -> Locality c t y') (p y) + +streetL :: + Lens' Address String +streetL p (Address t s l) = + fmap (\t' -> Address t' s l) (p t) + +suburbL :: + Lens' Address String +suburbL p (Address t s l) = + fmap (\s' -> Address t s' l) (p s) + +localityL :: + Lens' Address Locality +localityL p (Address t s l) = + fmap (\l' -> Address t s l') (p l) + +ageL :: + Lens' Person Int +ageL p (Person a n d) = + fmap (\a' -> Person a' n d) (p a) + +nameL :: + Lens' Person String +nameL p (Person a n d) = + fmap (\n' -> Person a n' d) (p n) + +addressL :: + Lens' Person Address +addressL p (Person a n d) = + fmap (\d' -> Person a n d') (p d) + +intAndIntL :: + Lens' (IntAnd a) Int +intAndIntL p (IntAnd n a) = + fmap (\n' -> IntAnd n' a) (p n) + +-- lens for polymorphic update +intAndL :: + Lens (IntAnd a) (IntAnd b) a b +intAndL p (IntAnd n a) = + fmap (\a' -> IntAnd n a') (p a) + +-- | +-- +-- >>> get (suburbL |. addressL) fred +-- "Fredville" +-- +-- >>> get (suburbL |. addressL) mary +-- "Maryland" +getSuburb :: + Person + -> String +getSuburb = + error "todo: getSuburb" + +-- | +-- +-- >>> setStreet fred "Some Other St" +-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setStreet mary "Some Other St" +-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) +setStreet :: + Person + -> String + -> Person +setStreet = + error "todo: setStreet" + +-- | +-- +-- >>> getAgeAndCountry (fred, maryLocality) +-- (24,"Maristan") +-- +-- >>> getAgeAndCountry (mary, fredLocality) +-- (28,"Fredalia") +getAgeAndCountry :: + (Person, Locality) + -> (Int, String) +getAgeAndCountry = + error "todo: getAgeAndCountry" + +-- | +-- +-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) +-- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) +-- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) +setCityAndLocality :: + (Person, Address) -> (String, Locality) -> (Person, Address) +setCityAndLocality = + error "todo: setCityAndLocality" + +-- | +-- +-- >>> getSuburbOrCity (Left maryAddress) +-- "Maryland" +-- +-- >>> getSuburbOrCity (Right fredLocality) +-- "Fredmania" +getSuburbOrCity :: + Either Address Locality + -> String +getSuburbOrCity = + error "todo: getSuburbOrCity" + +-- | +-- +-- >>> setStreetOrState (Right maryLocality) "Some Other State" +-- Right (Locality "Mary Mary" "Some Other State" "Maristan") +-- +-- >>> setStreetOrState (Left fred) "Some Other St" +-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) +setStreetOrState :: + Either Person Locality + -> String + -> Either Person Locality +setStreetOrState = + error "todo: setStreetOrState" + +-- | +-- +-- >>> modifyCityUppercase fred +-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) +-- +-- >>> modifyCityUppercase mary +-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) +modifyCityUppercase :: + Person + -> Person +modifyCityUppercase = + error "todo: modifyCityUppercase" + +-- | +-- +-- >>> modifyIntAndLengthEven (IntAnd 10 "abc") +-- IntAnd 10 False +-- +-- >>> modifyIntAndLengthEven (IntAnd 10 "abcd") +-- IntAnd 10 True +modifyIntAndLengthEven :: + IntAnd [a] + -> IntAnd Bool +modifyIntAndLengthEven = + error "todo: modifyIntAndLengthEven" + +---- + +-- | +-- +-- >>> over traverseLocality (map toUpper) (Locality "abc" "def" "ghi") +-- Locality "ABC" "DEF" "GHI" +traverseLocality :: + Traversal' Locality String +traverseLocality = + error "todo: traverseLocality" + +-- | +-- +-- >>> over intOrIntP (*10) (IntOrIs 3) +-- IntOrIs 30 +-- +-- >>> over intOrIntP (*10) (IntOrIsNot "abc") +-- IntOrIsNot "abc" +intOrIntP :: + Prism' (IntOr a) Int +intOrIntP = + error "todo: intOrIntP" + +intOrP :: + Prism (IntOr a) (IntOr b) a b +intOrP = + error "todo: intOrP" + +-- | +-- +-- >> over intOrP (even . length) (IntOrIsNot "abc") +-- IntOrIsNot False +-- +-- >>> over intOrP (even . length) (IntOrIsNot "abcd") +-- IntOrIsNot True +-- +-- >>> over intOrP (even . length) (IntOrIs 10) +-- IntOrIs 10 +intOrLengthEven :: + IntOr [a] + -> IntOr Bool +intOrLengthEven = + error "todo: intOrLengthEven" diff --git a/src/Lets/Lens/Profunctor.hs b/src/Lets/Lens/Profunctor.hs new file mode 100644 index 0000000..c2d4733 --- /dev/null +++ b/src/Lets/Lens/Profunctor.hs @@ -0,0 +1,22 @@ +module Lets.Lens.Profunctor +( + Profunctor(dimap) +) where + +import Lets.Data + +-- | A profunctor is a binary functor, with the first argument in contravariant +-- (negative) position and the second argument in covariant (positive) position. +class Profunctor p where + dimap :: + (b -> a) + -> (c -> d) + -> p a c + -> p b d + +instance Profunctor (->) where + dimap f g = \h -> g . h . f + +instance Profunctor Tagged where + dimap _ g (Tagged x) = + Tagged (g x) diff --git a/src/Lets/OpticPolyLens.hs b/src/Lets/OpticPolyLens.hs new file mode 100644 index 0000000..416deba --- /dev/null +++ b/src/Lets/OpticPolyLens.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE RankNTypes #-} + +module Lets.OpticPolyLens ( + Lens(..) +, getsetLaw +, setgetLaw +, setsetLaw +, get +, set +, modify +, (%~) +, fmodify +, (|=) +, fstL +, sndL +, mapL +, setL +, compose +, (|.) +, identity +, product +, (***) +, choice +, (|||) +, cityL +, countryL +, streetL +, suburbL +, localityL +, ageL +, nameL +, addressL +, intAndIntL +, intAndL +, getSuburb +, setStreet +, getAgeAndCountry +, setCityAndLocality +, getSuburbOrCity +, setStreetOrState +, modifyCityUppercase +, modifyIntandLengthEven +) where + +import Data.Bool(bool) +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) +import Lets.Data +import Prelude hiding (product) + +-- $setup +-- >>> import qualified Data.Map as Map(fromList) +-- >>> import qualified Data.Set as Set(fromList) +-- >>> import Data.Char(ord) + +data Lens s t a b = + Lens + (forall f. Functor f => (a -> f b) -> s -> f t) + +get :: + Lens s t a b + -> s + -> a +get (Lens r) = + getConst . r Const + +set :: + Lens s t a b + -> s + -> b + -> t +set (Lens r) a b = + getIdentity (r (const (Identity b)) a) + +-- | The get/set law of lenses. This function should always return @True@. +getsetLaw :: + Eq s => + Lens s s a a + -> s + -> Bool +getsetLaw l = + \a -> set l a (get l a) == a + +-- | The set/get law of lenses. This function should always return @True@. +setgetLaw :: + Eq a => + Lens s s a a + -> s + -> a + -> Bool +setgetLaw l a b = + get l (set l a b) == b + +-- | The set/set law of lenses. This function should always return @True@. +setsetLaw :: + Eq s => + Lens s s a b + -> s + -> b + -> b + -> Bool +setsetLaw l a b1 b2 = + set l (set l a b1) b2 == set l a b2 + +---- + +-- | +-- +-- >>> modify fstL (+1) (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> modify sndL (+1) ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) +modify :: + Lens s t a b + -> (a -> b) + -> s + -> t +modify = + error "todo: modify" + +-- | An alias for @modify@. +(%~) :: + Lens s t a b + -> (a -> b) + -> s + -> t +(%~) = + modify + +infixr 4 %~ + +-- | +-- +-- >>> fstL .~ 1 $ (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> sndL .~ 1 $ ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) +(.~) :: + Lens s t a b + -> b + -> s + -> t +(.~) = + error "todo: (.~)" + +infixl 5 .~ + +-- | +-- +-- >>> fmodify fstL (+) (5 :: Int, "abc") 8 +-- (13,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") +-- Just (20,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") +-- Nothing +fmodify :: + Functor f => + Lens s t a b + -> (a -> f b) + -> s + -> f t +fmodify = + error "todo: fmodify" + +-- | +-- +-- >>> fstL |= Just 3 $ (7, "abc") +-- Just (3,"abc") +-- +-- >>> (fstL |= (+1) $ (3, "abc")) 17 +-- (18,"abc") +(|=) :: + Functor f => + Lens s t a b + -> f b + -> s + -> f t +(|=) = + error "todo: (|=)" + +infixl 5 |= + +-- | +-- +-- >>> modify fstL (*10) (3, "abc") +-- (30,"abc") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z +fstL :: + Lens (a, x) (b, x) a b +fstL = + error "todo: fstL" + +-- | +-- +-- >>> modify sndL (++ "def") (13, "abc") +-- (13,"abcdef") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z +sndL :: + Lens (x, a) (x, b) a b +sndL = + error "todo: sndL" + +-- | +-- +-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Just 'c' +-- +-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Nothing +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] +mapL :: + Ord k => + k + -> Lens (Map k v) (Map k v) (Maybe v) (Maybe v) +mapL = + error "todo: mapL" + +-- | +-- +-- >>> get (setL 3) (Set.fromList [1..5]) +-- True +-- +-- >>> get (setL 33) (Set.fromList [1..5]) +-- False +-- +-- >>> set (setL 3) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5] +-- +-- >>> set (setL 3) (Set.fromList [1..5]) False +-- fromList [1,2,4,5] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5,33] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) False +-- fromList [1,2,3,4,5] +setL :: + Ord k => + k + -> Lens (Set k) (Set k) Bool Bool +setL = + error "todo: setL" + +-- | +-- +-- >>> get (compose fstL sndL) ("abc", (7, "def")) +-- 7 +-- +-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 +-- ("abc",(8,"def")) +compose :: + Lens s t a b + -> Lens q r s t + -> Lens q r a b +compose = + error "todo: compose" + +-- | An alias for @compose@. +(|.) :: + Lens s t a b + -> Lens q r s t + -> Lens q r a b +(|.) = + compose + +infixr 9 |. + +-- | +-- +-- >>> get identity 3 +-- 3 +-- +-- >>> set identity 3 4 +-- 4 +identity :: + Lens a b a b +identity = + error "todo: identity" + +-- | +-- +-- >>> get (product fstL sndL) (("abc", 3), (4, "def")) +-- ("abc","def") +-- +-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") +-- (("ghi",3),(4,"jkl")) +product :: + Lens s t a b + -> Lens q r c d + -> Lens (s, q) (t, r) (a, c) (b, d) +product = + error "todo: product" + +-- | An alias for @product@. +(***) :: + Lens s t a b + -> Lens q r c d + -> Lens (s, q) (t, r) (a, c) (b, d) +(***) = + product + +infixr 3 *** + +-- | +-- +-- >>> get (choice fstL sndL) (Left ("abc", 7)) +-- "abc" +-- +-- >>> get (choice fstL sndL) (Right ("abc", 7)) +-- 7 +-- +-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" +-- Left ("def",7) +-- +-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 +-- Right ("abc",8) +choice :: + Lens s t a b + -> Lens q r a b + -> Lens (Either s q) (Either t r) a b +choice = + error "todo: choice" + +-- | An alias for @choice@. +(|||) :: + Lens s t a b + -> Lens q r a b + -> Lens (Either s q) (Either t r) a b +(|||) = + choice + +infixr 2 ||| + +---- + +type Lens' a b = + Lens a a b b + +cityL :: + Lens' Locality String +cityL = + Lens + (\p (Locality c t y) -> fmap (\c' -> Locality c' t y) (p c)) + +stateL :: + Lens' Locality String +stateL = + Lens + (\p (Locality c t y) -> fmap (\t' -> Locality c t' y) (p t)) + +countryL :: + Lens' Locality String +countryL = + Lens + (\p (Locality c t y) -> fmap (\y' -> Locality c t y') (p y)) + +streetL :: + Lens' Address String +streetL = + Lens + (\p (Address t s l) -> fmap (\t' -> Address t' s l) (p t)) + +suburbL :: + Lens' Address String +suburbL = + Lens + (\p (Address t s l) -> fmap (\s' -> Address t s' l) (p s)) + +localityL :: + Lens' Address Locality +localityL = + Lens + (\p (Address t s l) -> fmap (\l' -> Address t s l') (p l)) + +ageL :: + Lens' Person Int +ageL = + Lens + (\p (Person a n d) -> fmap (\a' -> Person a' n d) (p a)) + +nameL :: + Lens' Person String +nameL = + Lens + (\p (Person a n d) -> fmap (\n' -> Person a n' d) (p n)) + +addressL :: + Lens' Person Address +addressL = + Lens + (\p (Person a n d) -> fmap (\d' -> Person a n d') (p d)) + +intAndIntL :: + Lens' (IntAnd a) Int +intAndIntL = + Lens + (\p (IntAnd n a) -> fmap (\n' -> IntAnd n' a) (p n)) + +-- lens for polymorphic update +intAndL :: + Lens (IntAnd a) (IntAnd b) a b +intAndL = + Lens + (\p (IntAnd n a) -> fmap (\a' -> IntAnd n a') (p a)) + +-- | +-- +-- >>> get (suburbL |. addressL) fred +-- "Fredville" +-- +-- >>> get (suburbL |. addressL) mary +-- "Maryland" +getSuburb :: + Person + -> String +getSuburb = + error "todo: getSuburb" + + +-- | +-- +-- >>> setStreet fred "Some Other St" +-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setStreet mary "Some Other St" +-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) +setStreet :: + Person + -> String + -> Person +setStreet = + error "todo: setStreet" + +-- | +-- +-- >>> getAgeAndCountry (fred, maryLocality) +-- (24,"Maristan") +-- +-- >>> getAgeAndCountry (mary, fredLocality) +-- (28,"Fredalia") +getAgeAndCountry :: + (Person, Locality) + -> (Int, String) +getAgeAndCountry = + error "todo: getAgeAndCountry" + +-- | +-- +-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) +-- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) +-- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) +setCityAndLocality :: + (Person, Address) -> (String, Locality) -> (Person, Address) +setCityAndLocality = + error "todo: setCityAndLocality" + +-- | +-- +-- >>> getSuburbOrCity (Left maryAddress) +-- "Maryland" +-- +-- >>> getSuburbOrCity (Right fredLocality) +-- "Fredmania" +getSuburbOrCity :: + Either Address Locality + -> String +getSuburbOrCity = + get (suburbL ||| cityL) + +-- | +-- +-- >>> setStreetOrState (Right maryLocality) "Some Other State" +-- Right (Locality "Mary Mary" "Some Other State" "Maristan") +-- +-- >>> setStreetOrState (Left fred) "Some Other St" +-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) +setStreetOrState :: + Either Person Locality + -> String + -> Either Person Locality +setStreetOrState = + set (streetL |. addressL ||| stateL) + +-- | +-- +-- >>> modifyCityUppercase fred +-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) +-- +-- >>> modifyCityUppercase mary +-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) +modifyCityUppercase :: + Person + -> Person +modifyCityUppercase = + cityL |. localityL |. addressL %~ map toUpper + +-- | +-- +-- >>> modify intAndL (even . length) (IntAnd 10 "abc") +-- IntAnd 10 False +-- +-- >>> modify intAndL (even . length) (IntAnd 10 "abcd") +-- IntAnd 10 True +modifyIntandLengthEven :: + IntAnd [a] + -> IntAnd Bool +modifyIntandLengthEven = + intAndL %~ even . length diff --git a/src/Lets/StoreLens.hs b/src/Lets/StoreLens.hs new file mode 100644 index 0000000..91a3822 --- /dev/null +++ b/src/Lets/StoreLens.hs @@ -0,0 +1,592 @@ +module Lets.StoreLens ( + Store(..) +, setS +, getS +, mapS +, duplicateS +, extendS +, extractS +, Lens(..) +, getsetLaw +, setgetLaw +, setsetLaw +, get +, set +, modify +, (%~) +, fmodify +, (|=) +, fstL +, sndL +, mapL +, setL +, compose +, (|.) +, identity +, product +, (***) +, choice +, (|||) +, cityL +, countryL +, streetL +, suburbL +, localityL +, ageL +, nameL +, addressL +, getSuburb +, setStreet +, getAgeAndCountry +, setCityAndLocality +, getSuburbOrCity +, setStreetOrState +, modifyCityUppercase +) where + +import Control.Applicative((<*>)) +import Data.Bool(bool) +import Data.Char(toUpper) +import Data.Functor((<$>)) +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) +import Lets.Data +import Prelude hiding (product) + +-- $setup +-- >>> import qualified Data.Map as Map(fromList) +-- >>> import qualified Data.Set as Set(fromList) +-- >>> import Data.Char(ord) + +setS :: + Store s a + -> s + -> a +setS (Store s _) = + s + +getS :: + Store s a + -> s +getS (Store _ g) = + g + +mapS :: + (a -> b) + -> Store s a + -> Store s b +mapS = + error "todo: mapS" + +duplicateS :: + Store s a + -> Store s (Store s a) +duplicateS = + error "todo: duplicateS" + +extendS :: + (Store s a -> b) + -> Store s a + -> Store s b +extendS = + error "todo: extendS" + +extractS :: + Store s a + -> a +extractS = + error "todo: extractS" + +---- + +data Lens a b = + Lens + (a -> Store b a) + +-- | +-- +-- >>> get fstL (0 :: Int, "abc") +-- 0 +-- +-- >>> get sndL ("abc", 0 :: Int) +-- 0 +-- +-- prop> let types = (x :: Int, y :: String) in get fstL (x, y) == x +-- +-- prop> let types = (x :: Int, y :: String) in get sndL (x, y) == y +get :: + Lens a b + -> a + -> b +get (Lens r) = + getS . r + +-- | +-- +-- >>> set fstL (0 :: Int, "abc") 1 +-- (1,"abc") +-- +-- >>> set sndL ("abc", 0 :: Int) 1 +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (z, y) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (x, z) +set :: + Lens a b + -> a + -> b + -> a +set (Lens r) = + setS . r + +-- | The get/set law of lenses. This function should always return @True@. +getsetLaw :: + Eq a => + Lens a b + -> a + -> Bool +getsetLaw l = + \a -> set l a (get l a) == a + +-- | The set/get law of lenses. This function should always return @True@. +setgetLaw :: + Eq b => + Lens a b + -> a + -> b + -> Bool +setgetLaw l a b = + get l (set l a b) == b + +-- | The set/set law of lenses. This function should always return @True@. +setsetLaw :: + Eq a => + Lens a b + -> a + -> b + -> b + -> Bool +setsetLaw l a b1 b2 = + set l (set l a b1) b2 == set l a b2 + +---- + +-- | +-- +-- >>> modify fstL (+1) (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> modify sndL (+1) ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in modify fstL id (x, y) == (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in modify sndL id (x, y) == (x, y) +modify :: + Lens a b + -> (b -> b) + -> a + -> a +modify = + error "todo: modify" + +-- | An alias for @modify@. +(%~) :: + Lens a b + -> (b -> b) + -> a + -> a +(%~) = + modify + +infixr 4 %~ + +-- | +-- +-- >>> fstL .~ 1 $ (0 :: Int, "abc") +-- (1,"abc") +-- +-- >>> sndL .~ 1 $ ("abc", 0 :: Int) +-- ("abc",1) +-- +-- prop> let types = (x :: Int, y :: String) in set fstL (x, y) z == (fstL .~ z $ (x, y)) +-- +-- prop> let types = (x :: Int, y :: String) in set sndL (x, y) z == (sndL .~ z $ (x, y)) +(.~) :: + Lens a b + -> b + -> a + -> a +(.~) = + error "todo: (.~)" + +infixl 5 .~ + +-- | +-- +-- >>> fmodify fstL (+) (5 :: Int, "abc") 8 +-- (13,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (10, "abc") +-- Just (20,"abc") +-- +-- >>> fmodify fstL (\n -> bool Nothing (Just (n * 2)) (even n)) (11, "abc") +-- Nothing +fmodify :: + Functor f => + Lens a b + -> (b -> f b) + -> a + -> f a +fmodify = + error "todo: fmodify" + +-- | +-- +-- >>> fstL |= Just 3 $ (7, "abc") +-- Just (3,"abc") +-- +-- >>> (fstL |= (+1) $ (3, "abc")) 17 +-- (18,"abc") +(|=) :: + Functor f => + Lens a b + -> f b + -> a + -> f a +(|=) = + error "todo: (|=)" + +infixl 5 |= + +-- | +-- +-- >>> modify fstL (*10) (3, "abc") +-- (30,"abc") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw fstL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw fstL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z +fstL :: + Lens (x, y) x +fstL = + error "todo: fstL" + +-- | +-- +-- >>> modify sndL (++ "def") (13, "abc") +-- (13,"abcdef") +-- +-- prop> let types = (x :: Int, y :: String) in getsetLaw sndL (x, y) +-- +-- prop> let types = (x :: Int, y :: String) in setgetLaw sndL (x, y) z +-- +-- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z +sndL :: + Lens (x, y) y +sndL = + error "todo: sndL" + +-- | +-- +-- >>> get (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Just 'c' +-- +-- >>> get (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) +-- Nothing +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'X'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) (Just 'X') +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(33,'X')] +-- +-- >>> set (mapL 3) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(4,'d')] +-- +-- >>> set (mapL 33) (Map.fromList (map (\c -> (ord c - 96, c)) ['a'..'d'])) Nothing +-- fromList [(1,'a'),(2,'b'),(3,'c'),(4,'d')] +mapL :: + Ord k => + k + -> Lens (Map k v) (Maybe v) +mapL = + error "todo: mapL" + +-- | +-- +-- >>> get (setL 3) (Set.fromList [1..5]) +-- True +-- +-- >>> get (setL 33) (Set.fromList [1..5]) +-- False +-- +-- >>> set (setL 3) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5] +-- +-- >>> set (setL 3) (Set.fromList [1..5]) False +-- fromList [1,2,4,5] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) True +-- fromList [1,2,3,4,5,33] +-- +-- >>> set (setL 33) (Set.fromList [1..5]) False +-- fromList [1,2,3,4,5] +setL :: + Ord k => + k + -> Lens (Set k) Bool +setL = + error "todo: setL" + +-- | +-- +-- >>> get (compose fstL sndL) ("abc", (7, "def")) +-- 7 +-- +-- >>> set (compose fstL sndL) ("abc", (7, "def")) 8 +-- ("abc",(8,"def")) +compose :: + Lens b c + -> Lens a b + -> Lens a c +compose = + error "todo: compose" + +-- | An alias for @compose@. +(|.) :: + Lens b c + -> Lens a b + -> Lens a c +(|.) = + compose + +infixr 9 |. + +-- | +-- +-- >>> get identity 3 +-- 3 +-- +-- >>> set identity 3 4 +-- 4 +identity :: + Lens a a +identity = + error "todo: identity" + +-- | +-- +-- >>> get (product fstL sndL) (("abc", 3), (4, "def")) +-- ("abc","def") +-- +-- >>> set (product fstL sndL) (("abc", 3), (4, "def")) ("ghi", "jkl") +-- (("ghi",3),(4,"jkl")) +product :: + Lens a b + -> Lens c d + -> Lens (a, c) (b, d) +product = + error "todo: product" + +-- | An alias for @product@. +(***) :: + Lens a b + -> Lens c d + -> Lens (a, c) (b, d) +(***) = + product + +infixr 3 *** + +-- | +-- +-- >>> get (choice fstL sndL) (Left ("abc", 7)) +-- "abc" +-- +-- >>> get (choice fstL sndL) (Right ("abc", 7)) +-- 7 +-- +-- >>> set (choice fstL sndL) (Left ("abc", 7)) "def" +-- Left ("def",7) +-- +-- >>> set (choice fstL sndL) (Right ("abc", 7)) 8 +-- Right ("abc",8) +choice :: + Lens a x + -> Lens b x + -> Lens (Either a b) x +choice = + error "todo: choice" + +-- | An alias for @choice@. +(|||) :: + Lens a x + -> Lens b x + -> Lens (Either a b) x +(|||) = + choice + +infixr 2 ||| + +---- + +cityL :: + Lens Locality String +cityL = + Lens + (\(Locality c t y) -> + Store (\c' -> Locality c' t y) c) + +stateL :: + Lens Locality String +stateL = + Lens + (\(Locality c t y) -> + Store (\t' -> Locality c t' y) t) + +countryL :: + Lens Locality String +countryL = + Lens + (\(Locality c t y) -> + Store (\y' -> Locality c t y') y) + +streetL :: + Lens Address String +streetL = + Lens + (\(Address t s l) -> + Store (\t' -> Address t' s l) t) + +suburbL :: + Lens Address String +suburbL = + Lens + (\(Address t s l) -> + Store (\s' -> Address t s' l) s) + +localityL :: + Lens Address Locality +localityL = + Lens + (\(Address t s l) -> + Store (\l' -> Address t s l') l) + +ageL :: + Lens Person Int +ageL = + Lens + (\(Person a n d) -> + Store (\a' -> Person a' n d) a) + +nameL :: + Lens Person String +nameL = + Lens + (\(Person a n d) -> + Store (\n' -> Person a n' d) n) + +addressL :: + Lens Person Address +addressL = + Lens + (\(Person a n d) -> + Store (\d' -> Person a n d') d) + +-- | +-- +-- >>> get (suburbL |. addressL) fred +-- "Fredville" +-- +-- >>> get (suburbL |. addressL) mary +-- "Maryland" +getSuburb :: + Person + -> String +getSuburb = + error "todo: getSuburb" + +-- | +-- +-- >>> setStreet fred "Some Other St" +-- Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setStreet mary "Some Other St" +-- Person 28 "Mary" (Address "Some Other St" "Maryland" (Locality "Mary Mary" "Western Mary" "Maristan")) +setStreet :: + Person + -> String + -> Person +setStreet = + error "todo: setStreet" + +-- | +-- +-- >>> getAgeAndCountry (fred, maryLocality) +-- (24,"Maristan") +-- +-- >>> getAgeAndCountry (mary, fredLocality) +-- (28,"Fredalia") +getAgeAndCountry :: + (Person, Locality) + -> (Int, String) +getAgeAndCountry = + error "todo: getAgeAndCountry" + +-- | +-- +-- >>> setCityAndLocality (fred, maryAddress) ("Some Other City", fredLocality) +-- (Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "Some Other City" "New South Fred" "Fredalia")),Address "83 Mary Ln" "Maryland" (Locality "Fredmania" "New South Fred" "Fredalia")) +-- +-- >>> setCityAndLocality (mary, fredAddress) ("Some Other City", maryLocality) +-- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) +setCityAndLocality :: + (Person, Address) -> (String, Locality) -> (Person, Address) +setCityAndLocality = + error "todo: setCityAndLocality" + +-- | +-- +-- >>> getSuburbOrCity (Left maryAddress) +-- "Maryland" +-- +-- >>> getSuburbOrCity (Right fredLocality) +-- "Fredmania" +getSuburbOrCity :: + Either Address Locality + -> String +getSuburbOrCity = + error "todo: getSuburbOrCity" + +-- | +-- +-- >>> setStreetOrState (Right maryLocality) "Some Other State" +-- Right (Locality "Mary Mary" "Some Other State" "Maristan") +-- +-- >>> setStreetOrState (Left fred) "Some Other St" +-- Left (Person 24 "Fred" (Address "Some Other St" "Fredville" (Locality "Fredmania" "New South Fred" "Fredalia"))) +setStreetOrState :: + Either Person Locality + -> String + -> Either Person Locality +setStreetOrState = + error "todo: setStreetOrState" + +-- | +-- +-- >>> modifyCityUppercase fred +-- Person 24 "Fred" (Address "15 Fred St" "Fredville" (Locality "FREDMANIA" "New South Fred" "Fredalia")) +-- +-- >>> modifyCityUppercase mary +-- Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "MARY MARY" "Western Mary" "Maristan")) +modifyCityUppercase :: + Person + -> Person +modifyCityUppercase = + error "todo: modifyCityUppercase"