Repository: data61/lets-lens Branch: master Commit: 69555cd462e3 Files: 19 Total size: 59.7 KB Directory structure: gitextract_x_dmflpo/ ├── .ghci ├── .gitignore ├── LICENCE ├── README.markdown ├── Setup.hs ├── changelog ├── default.nix ├── lets-lens.cabal ├── lets-lens.nix ├── shell.nix ├── src/ │ ├── Lets/ │ │ ├── Choice.hs │ │ ├── Data.hs │ │ ├── GetSetLens.hs │ │ ├── Lens.hs │ │ ├── OpticPolyLens.hs │ │ ├── Profunctor.hs │ │ └── StoreLens.hs │ └── Lets.hs └── test/ └── doctests.hs ================================================ FILE CONTENTS ================================================ ================================================ FILE: .ghci ================================================ :set -isrc :l src/Lets.hs :set prompt ">> " :set -Wall :set -fno-warn-unused-binds :set -fno-warn-unused-do-bind :set -fno-warn-unused-imports :set -fno-warn-type-defaults :set -XScopedTypeVariables :set -XOverloadedStrings ================================================ FILE: .gitignore ================================================ *~ *#* # CABAL /dist /dist-newstyle /cabal-dev /.cabal-sandbox /cabal.sandbox.config .ghc.environment.* # Haskell Program Coverage /.hpc # Leksah *.lkshs # Intellij IDEA /.idea # darcs /_darcs # ctags TAGS # sbt /project /target *.swp ================================================ FILE: LICENCE ================================================ Copyright 2012-2015 National ICT Australia Limited All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ================================================ FILE: README.markdown ================================================ # Let's Lens ![System-F](https://logo.systemf.com.au/systemf-450x450.png) Let's Lens presents a series of exercises, in a similar format to [the Data61 functional programming course material](http://github.com/data61/fp-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` module. Exercises can be recognised by filling in a function body that has a placeholder of `error "todo: "`. ---- ### 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` 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) ================================================ FILE: Setup.hs ================================================ import Distribution.Simple main = defaultMain ================================================ FILE: changelog ================================================ 0.0.1 Init ================================================ FILE: default.nix ================================================ { nixpkgs ? import {}, compiler ? "default" }: let inherit (nixpkgs) pkgs; haskellPackages = if compiler == "default" then pkgs.haskellPackages else pkgs.haskell.packages.${compiler}; tasty-hedgehog-github = pkgs.callPackage (pkgs.fetchFromGitHub { owner = "qfpl"; repo = "tasty-hedgehog"; rev = "5da389f5534943b430300a213c5ffb5d0e13459e"; sha256 = "04pmr9q70gakd327sywpxr7qp8jnl3b0y2sqxxxcj6zj2q45q38m"; }) {}; modifiedHaskellPackages = haskellPackages.override { overrides = self: super: { tasty-hedgehog = if super ? tasty-hedgehog then super.tasty-hedgehog else tasty-hedgehog-github; }; }; lets-lens = modifiedHaskellPackages.callPackage ./lets-lens.nix {}; in lets-lens ================================================ FILE: lets-lens.cabal ================================================ name: lets-lens version: 0.0.1 license: BSD3 license-file: LICENCE author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> copyright: Copyright (C) 2015-2016 National ICT Australia Limited, Copyright (c) 2017-2018, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230. synopsis: Source code for exercises on the lens concept category: Education description: Source code for exercises on the lens concept homepage: https://github.com/data61/lets-lens bug-reports: https://github.com/data61/lets-lens/issues cabal-version: >= 1.10 build-type: Simple extra-source-files: changelog source-repository head type: git location: git@github.com:data61/lets-lens.git flag small_base description: Choose the new, split-up base package. library default-language: Haskell2010 build-depends: base >= 4.8 && < 5 , containers >= 0.4.0.0 ghc-options: -Wall -fno-warn-unused-binds -fno-warn-unused-do-bind -fno-warn-unused-imports -fno-warn-type-defaults hs-source-dirs: src exposed-modules: Lets Lets.Choice Lets.Data Lets.GetSetLens Lets.Lens Lets.OpticPolyLens Lets.Profunctor Lets.StoreLens test-suite doctests type: exitcode-stdio-1.0 main-is: doctests.hs default-language: Haskell2010 build-depends: base < 5 && >= 3 , doctest >= 0.9.7 , filepath >= 1.3 , directory >= 1.1 , QuickCheck >= 2.0 , template-haskell >= 2.8 ghc-options: -Wall -threaded hs-source-dirs: test ================================================ FILE: lets-lens.nix ================================================ { mkDerivation, base, containers, directory, doctest, filepath , QuickCheck, stdenv, template-haskell }: mkDerivation { pname = "lets-lens"; version = "0.0.1"; src = ./.; libraryHaskellDepends = [ base containers ]; testHaskellDepends = [ base directory doctest filepath QuickCheck template-haskell ]; homepage = "https://github.com/data61/lets-lens"; description = "Source code for exercises on the lens concept"; license = stdenv.lib.licenses.bsd3; } ================================================ FILE: shell.nix ================================================ { nixpkgs ? import {}, compiler ? "default" }: let inherit (nixpkgs) pkgs; drv = import ./default.nix { inherit nixpkgs compiler; }; drvWithTools = pkgs.haskell.lib.addBuildDepends drv [ pkgs.cabal-install ]; in if pkgs.lib.inNixShell then drvWithTools.env else drvWithTools ================================================ FILE: src/Lets/Choice.hs ================================================ module Lets.Choice ( Choice(..) ) where import Lets.Data import Lets.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) ================================================ FILE: src/Lets/Data.hs ================================================ 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) ================================================ FILE: src/Lets/GetSetLens.hs ================================================ 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(Applicative((<*>))) 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(Person(Person), Locality(Locality), Address(Address)) import Prelude hiding (product) -- $setup -- >>> import qualified Data.Map as Map(fromList) -- >>> import qualified Data.Set as Set(fromList) -- >>> import Data.Bool(bool) -- >>> import Data.Char(ord) -- >>> import Lets.Data 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) -- | -- -- >>> getSuburb fred -- "Fredville" -- -- >>> getSuburb 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" ================================================ FILE: src/Lets/Lens.hs ================================================ {-# LANGUAGE RankNTypes #-} module Lets.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((<*>), pure)) import Data.Char(toUpper) import Data.Foldable(Foldable(foldMap)) import Data.Functor((<$>)) import Data.Map(Map) import qualified Data.Map as Map(insert, delete, lookup) import Data.Monoid(Monoid) import qualified Data.Set as Set(Set, insert, delete, member) import Data.Traversable(Traversable(traverse)) import Lets.Data(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), Tagged(Tagged, getTagged), IntOr(IntOrIs, IntOrIsNot), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address)) import Lets.Choice(Choice(left, right)) import Lets.Profunctor(Profunctor(dimap)) import Prelude hiding (product) -- $setup -- >>> import qualified Data.Map as Map(fromList) -- >>> import qualified Data.Set as Set(fromList) -- >>> import Data.Bool(bool) -- >>> import Data.Char(ord) -- >>> import Lets.Data -- 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 @foldMap@ can be recovered from @traverse@ using @Const@. -- -- /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" -- | -- -- To work on `Map k a`: -- Map.lookup :: Ord k => k -> Map k a -> Maybe a -- Map.insert :: Ord k => k -> a -> Map k a -> Map k a -- Map.delete :: Ord k => k -> Map k a -> Map k a -- -- >>> 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" -- | -- -- To work on `Set a`: -- Set.insert :: Ord a => a -> Set a -> Set a -- Set.member :: Ord a => a -> Set a -> Bool -- Set.delete :: Ord a => a -> Set a -> Set a -- -- >>> 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) -- | -- -- >>> getSuburb fred -- "Fredville" -- -- >>> getSuburb 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" -- | -- -- >> intOrLengthEven (IntOrIsNot "abc") -- IntOrIsNot False -- -- >>> intOrLengthEven (IntOrIsNot "abcd") -- IntOrIsNot True -- -- >>> intOrLengthEven (IntOrIs 10) -- IntOrIs 10 intOrLengthEven :: IntOr [a] -> IntOr Bool intOrLengthEven = error "todo: intOrLengthEven" ================================================ FILE: src/Lets/OpticPolyLens.hs ================================================ {-# 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.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(AlongsideLeft(AlongsideLeft, getAlongsideLeft), AlongsideRight(AlongsideRight, getAlongsideRight), Identity(Identity, getIdentity), Const(Const, getConst), IntAnd(IntAnd), Person(Person), Locality(Locality), Address(Address)) import Prelude hiding (product) -- $setup -- >>> import qualified Data.Map as Map(fromList) -- >>> import qualified Data.Set as Set(fromList) -- >>> import Data.Bool(bool) -- >>> import Data.Char(ord) -- >>> import Lets.Data 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)) -- | -- -- >>> getSuburb fred -- "Fredville" -- -- >>> getSuburb 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 ================================================ FILE: src/Lets/Profunctor.hs ================================================ module Lets.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) ================================================ FILE: src/Lets/StoreLens.hs ================================================ 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 , stateL , countryL , streetL , suburbL , localityL , ageL , nameL , addressL , getSuburb , setStreet , getAgeAndCountry , setCityAndLocality , getSuburbOrCity , setStreetOrState , modifyCityUppercase ) where import Control.Applicative(Applicative((<*>))) 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(Store(Store), Person(Person), Locality(Locality), Address(Address)) import Prelude hiding (product) -- $setup -- >>> import qualified Data.Map as Map(fromList) -- >>> import qualified Data.Set as Set(fromList) -- >>> import Data.Bool(bool) -- >>> import Data.Char(ord) -- >>> import Lets.Data 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) -- | -- -- >>> getSuburb fred -- "Fredville" -- -- >>> getSuburb 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" ================================================ FILE: src/Lets.hs ================================================ 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() ================================================ FILE: test/doctests.hs ================================================ import Test.DocTest main :: IO () main = doctest [ "-isrc" , "src/Lets/GetSetLens.hs" , "src/Lets/Lens.hs" , "src/Lets/OpticPolyLens.hs" , "src/Lets/StoreLens.hs" ]