Merge pull request #84 from pminten/lens-person

Add lens-person exercise

Author: etrepum

_test/bootstrap.sh

@@ -23,4 +23,5 @@ cabal install \
       vector \
       parallel \
       stm \
-      old-locale
+      old-locale \
+      lens

config.json

@@ -72,6 +72,7 @@
     "go-counting",
     "zipper",
     "forth",
+    "lens-person",
     "pov"
   ],
   "deprecated": [

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

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

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)
+  ]