module Generics.Putlenses.Examples.People where
import Generics.Putlenses.Language
import Generics.Putlenses.TH
import Generics.Putlenses.Putlens
import Generics.Putlenses.Examples.Examples
import Data.Maybe
import Data.List
import GHC.Generics
type Name = String
type City = String
data Person = Person { name :: Name, city :: City } deriving (Eq,Show,Generic)
$( makePutlensFields ''Person )
nameP :: Putlens st e Person Name
nameP = innPut .< keepsndPut
peopleNamesPut0 :: City -> Putlens st e [Person] [Name]
peopleNamesPut0 newc = mapPut (withMbS (innPut .< addsndPut cityOf))
where cityOf st s v = maybe newc (get cityLns) s
exPeopleNamesPut1 = put (put2lens $ peopleNamesPut0 "Braga") [sebastian,zhenjiang] ["Hugo","Sebastian","Zhenjiang"]
peopleNamesPut :: City -> Putlens st e [Person] [Name]
peopleNamesPut newc = withS (mapPut (innPut .< addsndPut cityOf))
where cityOf st people n = case find (\p -> get nameLns p == n) people of
{ Just p -> get cityLns p; Nothing -> newc }
exPeopleNamesPut2 = put (put2lens $ peopleNamesPut "Braga") [sebastian,zhenjiang] ["Hugo","Sebastian","Zhenjiang"]
selectPut :: (Eq a,Ord k) => (a -> k) -> (st -> e -> [a]) -> (a -> Bool) -> Putlens st e [a] [a]
selectPut key entries p = initSt (\st m v -> (Nothing,entries st m)) (selectPut' key p)
selectPut' :: (Eq a,Ord k) => (a -> k) -> (a -> Bool) -> Putlens (Maybe a,[a]) e [a] [a]
selectPut' key p = modifySt (\(_,xs) _ vs -> recoverEntry key xs vs) (ifthenelsePut (\(x,_) _ _ -> isJust x) recover it)
where recover = consPut .< phiPut (not . p . fst) .< (idPut ><< selectPut' key p) .< addfstPut (\(Just x,_) _ _ -> x)
it = innPut .< (idPut -|-< idPut ><< selectPut' key p) .< outPut
recoverEntry :: Ord k => (a -> k) -> [a] -> [a] -> (Maybe a,[a])
recoverEntry key [] _ = (Nothing,[])
recoverEntry key (x:xs) [] = (Just x,xs)
recoverEntry key (x:xs) (v:vs) | key v < key x = (Nothing,x:xs)
| key v == key x = (Nothing,xs)
| key v > key x = (Just x,xs)
nameLns = put2lens namePut
cityLns = put2lens cityPut
isFrom c p = get cityLns p == c
peopleFromPut :: City -> Putlens st [Person] [Person] [Person]
peopleFromPut from = selectPut (get nameLns) (\st -> elsewhere) (isFrom from)
where elsewhere = filter (not . isFrom from)
peopleFromToPut :: City -> City -> Putlens st [Person] [Person] [Person]
peopleFromToPut from to = selectPut (get nameLns) (\st -> map move) (isFrom from)
where move p | get cityLns p == from = put cityLns p to
| otherwise = p
people = [hugo,sebastian,zhenjiang]
hugo = Person "Hugo" "Tokyo"
sebastian = Person "Sebastian" "Kiel"
zhenjiang = Person "Zhenjiang" "Tokyo"
sebastianTokyo = Person "Sebastian" "Tokyo"
exPeopleFromPut1 = get (put2lens (peopleFromPut "Tokyo")) people
exPeopleFromPut2 = put (put2lens (peopleFromPut "Tokyo")) people [zhenjiang]
exPeopleFromPut3 = put (put2lens (peopleFromPut "Tokyo")) people [sebastianTokyo,zhenjiang]
exPeopleFromToPut1 = put (put2lens (peopleFromToPut "Tokyo" "Braga")) people [zhenjiang]
exPeopleFromToPut2 = put (put2lens (peopleFromToPut "Tokyo" "Braga")) people [sebastianTokyo,zhenjiang]
type Book = (String,String)
type BookPerson = (String,Person)
withM :: (m1 -> Maybe s -> Maybe v -> v -> m2) -> Putlens st m2 s v -> Putlens st m1 s v
withM = undefined
booksOfPeoplePut :: Putlens st ([Book],[Person]) ([Book],[Person]) [BookPerson]
booksOfPeoplePut = paramsndPut (\ps -> withS $ booksOfPut ps) .< booksOfPeoplePut'
booksOfPeoplePut' :: Putlens st e ([Book],[Person]) [BookPerson]
booksOfPeoplePut' = withS $ initSt (\_ s _ -> snd s) $ (innPut ><< idPut) .< undistlPut .< (keepsndOrPut (\st e v -> st) -|-< it) .< outPut
where it = unforkPut ((keepsndOrPut (\st e -> const []) ><< idPut) .< booksOfPersonPut) ((keepfstPut ><< idPut) .< booksOfPeoplePut')
booksOfPersonPut :: Putlens [Person] e (Book,[Person]) BookPerson
booksOfPersonPut = paramfstPut (\(b,n) -> selectPersonPut n) .< joinBookPersonPut
joinBookPersonPut :: Putlens st e (Book,Person) BookPerson
joinBookPersonPut = assoclPut .< (idPut ><< addfstPut (\_ _ -> get nameLns))
booksOfPeoplePut2 :: Putlens st ([Book],[Person]) ([Book],[Person]) [BookPerson]
booksOfPeoplePut2 = paramsndPut (\ps -> withS $ booksOfPut ps) .< modifyS (\st m (bs,ps) v' -> (bs,peopleWithoutBooks (bs,ps))) booksOfPeoplePut'
where peopleWithoutBooks (bs,ps) = let bps = get (put2lens booksOfPeoplePut') (bs,ps)
in filter (\p -> not ((get nameLns p) `elem` (map (get nameLns . snd) bps))) ps
booksOfPut :: [Person] -> Putlens st [Book] [Book] [Book]
booksOfPut ps = selectPut fst (\st -> elsewhere) (isOf ps)
where elsewhere = filter (not . isOf ps)
isOf ps (b,p) = p `elem` (map (get nameLns) ps)
selectPersonPut :: Name -> Putlens [Person] e [Person] Person
selectPersonPut n = selectPut (get nameLns) (\st e -> elseone st) (isPerson n) .< wrapPut
where elseone = filter (not . isPerson n)
isPerson n p = get nameLns p == n
someBooks = [("The Art of Computer Programming","Zhenjiang")
,("The Elements of Style","Sebastian")
,("The Maias","Hugo")
,("The Lord of the Rings","Hugo")]
somePeople = [Person "Hugo" "Braga",Person "Zhenjiang" "Tokyo",Person "Tim" "New York"]
someJoin = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")
,("The Maias",Person "Hugo" "Braga")
,("The Lord of the Rings",Person "Hugo" "Braga")]
insMock = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")
,("The Maias",Person "Hugo" "Braga")
,("The Lord of the Rings",Person "Hugo" "Braga")
,("To Mock a Mocking Bird",Person "Sebastian" "Kiel")]
exJoinPut1 = put (put2lens booksOfPeoplePut) (someBooks,somePeople) insMock
exJoinPut2 = put (put2lens booksOfPeoplePut2) (someBooks,somePeople) insMock
delLOTR = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")
,("The Maias",Person "Hugo" "Braga")]
exJoinPut3 = put (put2lens booksOfPeoplePut) (someBooks,somePeople) delLOTR
exJoinPut4 = put (put2lens booksOfPeoplePut2) (someBooks,somePeople) delLOTR
delLOTRMaias = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")]
exJoinPut5 = put (put2lens booksOfPeoplePut) (someBooks,somePeople) delLOTRMaias
exJoinPut6 = put (put2lens booksOfPeoplePut2) (someBooks,somePeople) delLOTRMaias