Example of using lenses. Code material for presentation on Dev2Dev 2.0 (30 of May, 2015, Krasnoyarsk)

LensExample

{-# LANGUAGE TemplateHaskell, Rank2Types #-}

module Main where

import Control.Lens
import Control.Monad.State

import Data.Monoid
import Data.List as L (insert, isInfixOf)

data ContactType = VK | FB | Twitter | Email
    deriving (Show, Eq, Ord)

vk user = (VK, user)
fb user = (FB, user)
twitter user = (Twitter, user)
email user = (Email, user)

type Contact = (ContactType, String)

data Skill = Cpp | CSharp | Haskell | Java | FSharp | Python
    deriving (Show, Eq, Ord)

type Skills = [Skill]
type Contacts = [Contact]

data Person = Person {
    _name :: String,
    _surname :: String,
    _contacts :: Contacts,
    _skills :: Skills
} deriving (Show, Eq, Ord)

type Persons = [Person]

type Presentation = String
type Presentations = [Presentation]
type Msg = String

data Attendee = Speaker {
                    _person :: Person,
                    _visited :: Presentations,
                    _presentationTitle :: String
                }
                | Attendee {
                    _person :: Person,
                    _visited :: Presentations
                }
              deriving (Show, Eq)

data Conference = Conference {
    _attendees :: [Attendee],
    _currentPresentation :: Presentation,
    _conferenceTweets :: [(Presentation, Person, Msg)]
    }
  deriving (Show, Eq)

makeLenses ''Person
makeLenses ''Attendee
makeLenses ''Conference


addSkill :: Person -> Skill -> Person
addSkill (Person n s cs existSkills) newSkill =
    Person n s cs (newSkill : existSkills)


setAttendeeName :: Attendee -> String -> Attendee
setAttendeeName attendee n = case attendee of
    Speaker pers visit theme -> Speaker  (setName pers) visit theme
    Attendee pers visit -> Attendee (setName pers) visit
  where
    setName (Person _ s cts skls) = Person n s cts skls

setAttendeeName' attendee n = set (person.name) n attendee

addContact attendee contact = case attendee of
    Speaker pers visit theme -> Speaker (appendContact pers) visit theme
    Attendee pers visit -> Attendee (appendContact pers) visit
  where
    appendContact (Person n s cts skls) = Person n s (contact : cts) skls

addContact' :: Attendee -> Contact -> Attendee
addContact' attendee contact =
    over (person . contacts) (insert contact) attendee

addSkill' :: Attendee -> Skill -> Attendee
addSkill' attendee sk =
    over (person . skills) (insert sk) attendee

anyEqual s = any (== s)
isJava = (==Java)

attendeeSkills :: Attendee -> Skills
attendeeSkills attendee = attendee ^. person.skills

attendeeContacts :: Attendee -> Contacts
attendeeContacts attendee = attendee ^. person.contacts

javaDevs = filter (\a -> any isJava (a ^.. person.skills.traverse)) confAttendees

filterSkill s = traverse.person.skills.filtered (anyEqual s)

javaAttendeesSkills    = confAttendees ^. (filterSkill Java)
haskellAttendeesSkills = confAttendees ^. (filterSkill Haskell)

beginPresentation :: Presentation -> StateT Conference IO ()
beginPresentation title = do
    currentPresentation .= title
    event "[Conf]" " Presentation by "
    p <- use $ singular $ speakerOf title
    printPerson p
    putStrIO ": "
    putStrLnIO title

onlyListeners :: Persons -> Traversal' [Attendee] Attendee
onlyListeners ls = traversed . filtered f
  where
    f att = att ^. person `elem` ls

speakerOf title = attendees . traversed . filtered f . person
  where
    f att = att ^. presentationTitle == title

listeners :: [Person] -> StateT Conference IO ()
listeners ls = setVisited (attendees . onlyListeners ls)
  where
    setVisited atts = do
        title <- use currentPresentation
        atts.visited %= (insert title)

writeTweet :: Person -> Msg -> StateT Conference IO ()
writeTweet p msg = do
    pName <- use currentPresentation
    conferenceTweets %= insert (pName, p, msg)

tweeted p msg = if conftag `isInfixOf` msg
    then do
        event "[Conf] " "[Tweet] "
        printTweet
        writeTweet p msg
    else do
        event "[....] " "[Tweet] "
        printTweet
  where
    printTweet = do
        printPerson p
        putStrIO ": "
        putStrLnIO msg

printPerson p = do
     putStrIO $ p ^. name
     putStrIO " "
     putStrIO $ p ^. surname

event eType msg = do
    putStrIO eType
    putStrIO msg

printIO :: (Show m) => m -> StateT a IO ()   
printIO = lift . print
putStrIO = lift . putStr
putStrLnIO = lift . putStrLn

conferenceScenario :: StateT Conference IO ()
conferenceScenario = do
    alex `tweeted` "Rush hour, sorry. #conf"
    
    beginPresentation multilang
    listeners [pete, jakob, lana]
    jakob `tweeted` "Great talk! #conf"
    lana `tweeted` "So technical. #conf"
    pete `tweeted` "#MLP 222 coming soon."
    
    beginPresentation lenses
    listeners [pete, jakob, lana, guru]
    lana `tweeted` "Some new ideas. #conf"
    pete `tweeted` "Check it out, #cats!"
    pete `tweeted` "#wtf my phone vibrates!"
    
    beginPresentation cpp22
    listeners [guru]

conftag = "#conf"

alex = Person "Alexander" "Granin" [vk "graninas"] [Haskell]
pete = Person "Pete" "Howard" [fb "pete"] [Java, Python]
jakob = Person "Jakob" "Brown" [twitter "jab"] [Java, CSharp]
lana = Person "Lana" "Dell" [] [FSharp]
guru = Person "Real" "Guru" [] [Cpp, Java, CSharp, Haskell]
steve = Person "Steve" "Cobb" [fb "steve"] [Cpp]

peteAttendee = attendee pete

attendee p = Attendee p []
speaker p title = Speaker p [] title

attendeeName att = _name (_person att)

multilang = "Multilanguage projects"
lenses = "Lenses"
cpp22 = "C++22"

confAttendees =
    [ attendee pete
    , attendee jakob
    , attendee lana
    , speaker guru multilang
    , speaker alex lenses
    --, speaker steve cpp22 
    ]

conference = Conference confAttendees "" []

main = do
    r <- runStateT conferenceScenario conference
    print r
    putStrLn "All ok."
    



tweeted' :: Person -> Msg -> State Conference ()
tweeted' pers msg = if "#conf" `isInfixOf` msg
    then writeTweet' pers msg
    else return ()

writeTweet' :: Person -> Msg -> State Conference ()
writeTweet' pers msg = do
    presentationName <- use currentPresentation
    conferenceTweets %= insert (presentationName, pers, msg)

beginPresentation' :: Presentation -> State Conference ()
beginPresentation' title = currentPresentation .= title

listeners' :: [Person] -> State Conference ()
listeners' ls = setVisited (attendees . onlyListeners ls)
  where
    setVisited atts = do
        title <- use currentPresentation
        atts.visited %= (insert title)