diff --git a/src/Lets/StoreLens.hs b/src/Lets/StoreLens.hs index 1929e6f..4b6e38c 100644 --- a/src/Lets/StoreLens.hs +++ b/src/Lets/StoreLens.hs @@ -47,12 +47,12 @@ module Lets.StoreLens ( ) where import Control.Applicative(Applicative((<*>))) -import Data.Char(toUpper) +import Data.Char(toUpper, ord) import Data.Functor((<$>)) import Data.Map(Map) -import qualified Data.Map as Map(insert, delete, lookup) +import qualified Data.Map as Map(insert, delete, lookup, fromList) import Data.Set(Set) -import qualified Data.Set as Set(insert, delete, member) +import qualified Data.Set as Set(insert, delete, member, fromList) import Lets.Data(Store(Store), Person(Person), Locality(Locality), Address(Address)) import Prelude hiding (product) @@ -80,27 +80,23 @@ mapS :: (a -> b) -> Store s a -> Store s b -mapS = - error "todo: mapS" +mapS f (Store sToa s) = Store (\ss -> f (sToa ss)) s duplicateS :: Store s a -> Store s (Store s a) -duplicateS = - error "todo: duplicateS" +duplicateS (Store sToa a) = Store (\s -> Store sToa s) a extendS :: (Store s a -> b) -> Store s a -> Store s b -extendS = - error "todo: extendS" +extendS f = mapS f . duplicateS extractS :: Store s a -> a -extractS = - error "todo: extractS" +extractS = \(Store sToa s) -> sToa s ---- @@ -193,8 +189,7 @@ modify :: -> (b -> b) -> a -> a -modify = - error "todo: modify" +modify (Lens f) bTob a = let Store s g = f a in s (bTob g) -- | An alias for @modify@. (%~) :: @@ -223,8 +218,7 @@ infixr 4 %~ -> b -> a -> a -(.~) = - error "todo: (.~)" +(.~) = \(Lens f) -> \v -> \a -> let Store s g = f a in s v infixl 5 .~ @@ -244,9 +238,8 @@ fmodify :: -> (b -> f b) -> a -> f a -fmodify = - error "todo: fmodify" - +fmodify (Lens f) bTofb a = let Store s g = f a in s <$> bTofb g + -- | -- -- >>> fstL |= Just 3 $ (7, "abc") @@ -260,8 +253,7 @@ fmodify = -> f b -> a -> f a -(|=) = - error "todo: (|=)" +(|=) (Lens f) fb a = let Store s g = f a in s <$> fb infixl 5 |= @@ -277,8 +269,7 @@ infixl 5 |= -- prop> let types = (x :: Int, y :: String) in setsetLaw fstL (x, y) z fstL :: Lens (x, y) x -fstL = - error "todo: fstL" +fstL = Lens (\(x, y) -> Store (\x' -> (x', y)) x) -- | -- @@ -292,8 +283,7 @@ fstL = -- prop> let types = (x :: Int, y :: String) in setsetLaw sndL (x, y) z sndL :: Lens (x, y) y -sndL = - error "todo: sndL" +sndL = Lens (\(x, y) -> Store (\y' -> (x, y')) y) -- | -- @@ -318,8 +308,10 @@ mapL :: Ord k => k -> Lens (Map k v) (Maybe v) -mapL = - error "todo: mapL" +mapL k = Lens (\mkv -> Store (\mv -> case mv of + Nothing -> Map.delete k mkv + Just a -> Map.insert k a mkv) + (Map.lookup k mkv)) -- | -- @@ -344,8 +336,10 @@ setL :: Ord k => k -> Lens (Set k) Bool -setL = - error "todo: setL" +setL k = Lens (\sk -> Store (\bool -> case bool of + True -> Set.insert k sk + False -> Set.delete k sk) + (Set.member k sk)) -- | -- @@ -358,8 +352,10 @@ compose :: Lens b c -> Lens a b -> Lens a c -compose = - error "todo: compose" +compose = \(Lens f) -> \(Lens g) -> + Lens (\a -> let Store bToa b = g a + in let Store cTob c = f b + in Store (bToa . cTob) c) -- | An alias for @compose@. (|.) :: @@ -380,9 +376,8 @@ infixr 9 |. -- 4 identity :: Lens a a -identity = - error "todo: identity" - +identity = Lens (\a -> Store (\a' -> a') a) + -- | -- -- >>> get (product fstL sndL) (("abc", 3), (4, "def")) @@ -394,8 +389,10 @@ product :: Lens a b -> Lens c d -> Lens (a, c) (b, d) -product = - error "todo: product" +product (Lens f) (Lens g) = + Lens (\(a, c) -> let Store h i = f a + in let Store j k = g c + in Store (\(b, d) -> (h b, j d)) (i, k)) -- | An alias for @product@. (***) :: @@ -424,8 +421,10 @@ choice :: Lens a x -> Lens b x -> Lens (Either a b) x -choice = - error "todo: choice" +choice (Lens ax) (Lens bx) = + Lens (\eab -> case eab of + Left a -> let Store f g = ax a in Store (\x -> Left $ f x) g + Right b -> let Store h i = bx b in Store (\x -> Right $ h x) i) -- | An alias for @choice@. (|||) :: @@ -512,8 +511,7 @@ addressL = getSuburb :: Person -> String -getSuburb = - error "todo: getSuburb" +getSuburb = get $ (compose suburbL addressL) -- | -- @@ -526,8 +524,7 @@ setStreet :: Person -> String -> Person -setStreet = - error "todo: setStreet" +setStreet = set $ (compose streetL addressL) -- | -- @@ -539,8 +536,9 @@ setStreet = getAgeAndCountry :: (Person, Locality) -> (Int, String) -getAgeAndCountry = - error "todo: getAgeAndCountry" +getAgeAndCountry (person, locality) = (get ageL person, + get countryL locality) + -- | -- @@ -551,9 +549,11 @@ getAgeAndCountry = -- (Person 28 "Mary" (Address "83 Mary Ln" "Maryland" (Locality "Some Other City" "Western Mary" "Maristan")),Address "15 Fred St" "Fredville" (Locality "Mary Mary" "Western Mary" "Maristan")) setCityAndLocality :: (Person, Address) -> (String, Locality) -> (Person, Address) -setCityAndLocality = - error "todo: setCityAndLocality" - +setCityAndLocality (person, address) (city, locality) = + (set (cityL |. localityL |. addressL) person city, + set localityL address locality) + + -- | -- -- >>> getSuburbOrCity (Left maryAddress) @@ -564,8 +564,10 @@ setCityAndLocality = getSuburbOrCity :: Either Address Locality -> String -getSuburbOrCity = - error "todo: getSuburbOrCity" +getSuburbOrCity = \soc -> case soc of + Left address -> get suburbL address + Right locality -> get cityL locality + -- | -- @@ -578,8 +580,9 @@ setStreetOrState :: Either Person Locality -> String -> Either Person Locality -setStreetOrState = - error "todo: setStreetOrState" +setStreetOrState = \sos -> \ipsos -> case sos of + Left person -> Left $ set (streetL |. addressL) person ipsos + Right locality -> Right $ set stateL locality ipsos -- | -- @@ -591,5 +594,4 @@ setStreetOrState = modifyCityUppercase :: Person -> Person -modifyCityUppercase = - error "todo: modifyCityUppercase" +modifyCityUppercase = (cityL |. localityL |. addressL) %~ map toUpper