From 46b64df0373c3fb796f31e0b571e8b5e90222db0 Mon Sep 17 00:00:00 2001 From: Peter Minten Date: Sun, 28 Jun 2015 12:55:53 +0200 Subject: [PATCH] Add lens-person exercise This is a relatively easy exercise to play around with basic lenses. --- _test/bootstrap.sh | 3 +- config.json | 1 + lens-person/Person.hs | 45 +++++++++++++++++++++++ lens-person/example.hs | 64 +++++++++++++++++++++++++++++++++ lens-person/lens-person_test.hs | 59 ++++++++++++++++++++++++++++++ 5 files changed, 171 insertions(+), 1 deletion(-) create mode 100644 lens-person/Person.hs create mode 100644 lens-person/example.hs create mode 100644 lens-person/lens-person_test.hs diff --git a/_test/bootstrap.sh b/_test/bootstrap.sh index ad112de2f..da7fc4f40 100755 --- a/_test/bootstrap.sh +++ b/_test/bootstrap.sh @@ -23,4 +23,5 @@ cabal install \ vector \ parallel \ stm \ - old-locale + old-locale \ + lens diff --git a/config.json b/config.json index f38bc0758..c20ca9562 100644 --- a/config.json +++ b/config.json @@ -72,6 +72,7 @@ "go-counting", "zipper", "forth", + "lens-person", "pov" ], "deprecated": [ diff --git a/lens-person/Person.hs b/lens-person/Person.hs new file mode 100644 index 000000000..4ce89f233 --- /dev/null +++ b/lens-person/Person.hs @@ -0,0 +1,45 @@ +module Person where + +import Data.Time.Calendar + +data Person = Person { + _name :: Name, + _born :: Born, + _address :: Address + } + +data Name = Name { + _foreNames :: String, -- Space separated + _surName :: String + } + +data Born = Born { + _bornAt :: Address, + _bornOn :: Day + } + +data Address = Address { + _street :: String, + _houseNumber :: Int, + _place :: String, -- Village / city + _country :: String + } + +-- Valid values of Gregorian are those for which 'Data.Time.Calendar.fromGregorianValid' +-- returns Just. +data Gregorian = Gregorian { + _year :: Integer, + _month :: Int, + _day :: Int + } + +-- Implement these. + +bornStreet :: Born -> String + +setCurrentStreet :: String -> Person -> Person + +setBirthMonth :: Int -> Person -> Person + +-- | Transform both birth and current street names. +renameStreets :: (String -> String) -> Person -> Person diff --git a/lens-person/example.hs b/lens-person/example.hs new file mode 100644 index 000000000..9a6aee598 --- /dev/null +++ b/lens-person/example.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Person where + +import Control.Lens +import Data.Time.Calendar + +data Person = Person { + _name :: Name, + _born :: Born, + _address :: Address + } + +data Name = Name { + _foreNames :: String, -- Space separated + _surName :: String + } + +data Born = Born { + _bornAt :: Address, + _bornOn :: Day + } + +data Address = Address { + _street :: String, + _houseNumber :: Int, + _place :: String, -- Village / city + _country :: String + } + +-- Valid values of Gregorian are those for which 'Data.Time.Calendar.fromGregorianValid' +-- returns Just. +data Gregorian = Gregorian { + _year :: Integer, + _month :: Int, + _day :: Int + } + +makeLenses ''Person +makeLenses ''Name +makeLenses ''Born +makeLenses ''Address +makeLenses ''Gregorian + +gregorianDay :: Iso' Gregorian Day +gregorianDay = iso toDay fromDay + where + toDay (Gregorian y m d) = fromGregorian y m d + fromDay d' = let (y, m, d) = toGregorian d' in Gregorian y m d + +bornStreet :: Born -> String +bornStreet = view (bornAt . street) + +setCurrentStreet :: String -> Person -> Person +setCurrentStreet = set (address . street) + +setBirthMonth :: Int -> Person -> Person +setBirthMonth = set (born . bornOn . from gregorianDay . month) + +renameStreets :: (String -> String) -> Person -> Person +renameStreets f = over birthStreet f . over currentStreet f + where + birthStreet = born . bornAt . street + currentStreet = address . street diff --git a/lens-person/lens-person_test.hs b/lens-person/lens-person_test.hs new file mode 100644 index 000000000..b1bd0beea --- /dev/null +++ b/lens-person/lens-person_test.hs @@ -0,0 +1,59 @@ +import Data.Char (toUpper) +import Data.Time.Calendar (fromGregorian) +import System.Exit (ExitCode (..), exitWith) +import Test.HUnit (Assertion, Counts (..), Test (..), + runTestTT, (@=?)) + +import Person (Address (..), Born (..), + Name (..), Person (..), bornStreet, + renameStreets, setBirthMonth, + setCurrentStreet) + +testCase :: String -> Assertion -> Test +testCase label assertion = TestLabel label (TestCase assertion) + +exitProperly :: IO Counts -> IO () +exitProperly m = do + counts <- m + exitWith $ if failures counts /= 0 || errors counts /= 0 then ExitFailure 1 else ExitSuccess + +main :: IO () +main = exitProperly $ runTestTT $ TestList + [ TestList personTests ] + +testPerson :: Person +testPerson = Person { + _name = Name { + _foreNames = "Jane Joanna", + _surName = "Doe" + }, + _born = Born { + _bornAt = Address { + _street = "Longway", + _houseNumber = 1024, + _place = "Springfield", + _country = "United States" + }, + _bornOn = fromGregorian 1984 4 12 + }, + _address = Address { + _street = "Shortlane", + _houseNumber = 2, + _place = "Fallmeadow", + _country = "Canada" + } + } + +personTests :: [Test] +personTests = + [ testCase "bornStreet" $ + "Longway" @=? bornStreet (_born testPerson), + testCase "setCurrentStreet" $ + "Middleroad" @=? (_street . _address) (setCurrentStreet "Middleroad" testPerson), + testCase "setBirthMonth" $ + fromGregorian 1984 9 12 @=? (_bornOn . _born) (setBirthMonth 9 testPerson), + testCase "renameStreets birth" $ + "LONGWAY" @=? (_street . _bornAt . _born) (renameStreets (map toUpper) testPerson), + testCase "renameStreets current" $ + "SHORTLANE" @=? (_street . _address) (renameStreets (map toUpper) testPerson) + ]