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
import Control.Monad
import qualified Control.Monad.State as State
import qualified Control.Monad.Reader as Reader
import Control.Monad.Identity
type Name = String
type City = String
data Person = Person { name :: Name, city :: City } deriving (Eq,Show,Generic)
$( makePutlensFields ''Person )
nameP :: Monad m => PutlensM m Person Name
nameP = innPut .< keepsndPut
peopleNamesPut0 :: Monad m => City -> PutlensM m [Person] [Name]
peopleNamesPut0 newc = mapPut (innPut .< addsndPut cityOf)
where cityOf p v = return $ maybe newc snd p
exPeopleNamesPut1 = put (put2lens $ peopleNamesPut0 "Braga") [sebastian,zhenjiang] ["Hugo","Sebastian","Zhenjiang"]
peopleNamesPut :: Monad m => City -> PutlensReaderM m [Person] [Person] [Name]
peopleNamesPut newc = mapPut (innPut .< addsndPut cityOf)
where cityOf s n = Reader.ask >>= \people -> return $ case find (\p -> get nameLns p == n) people of
{ Just p -> get cityLns p; Nothing -> newc }
exPeopleNamesPut2 = Reader.runReader (put (put2lensM $ peopleNamesPut "Braga") [sebastian,zhenjiang] ["Hugo","Sebastian","Zhenjiang"]) [sebastian,zhenjiang]
selectPut :: (Monad m,Eq a,Ord k) => (a -> k) -> (Maybe [a] -> m [a]) -> (a -> Bool) -> PutlensM m [a] [a]
selectPut key entries p = runStatePut (\s v -> entries s >>= \rs -> return (Nothing,rs)) (selectPut' key p)
selectPut' :: (Monad m,Eq a,Ord k) => (a -> k) -> (a -> Bool) -> PutlensStateM m (Maybe a,[a]) [a] [a]
selectPut' key p = ifthenelsePut cond recover iter
where cond s v' = do { (_,rs) <- State.get; let (h,t) = recoverEntry key rs v' in State.put (h,t) >> return (isJust h) }
recover = consPut .< (phiPut (not . p) ><< selectPut' key p) .< addfstPut (\s v -> do { (Just x,_) <- State.get; return x })
iter = 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 :: Monad m => City -> PutlensM m [Person] [Person]
peopleFromPut from = selectPut (get nameLns) elsewhere (isFrom from)
where elsewhere = return . maybe [] (filter (not . isFrom from))
peopleFromToPut :: Monad m => City -> City -> PutlensM m [Person] [Person]
peopleFromToPut from to = selectPut (get nameLns) rs (isFrom from)
where move p | get cityLns p == from = runIdentity $ put cityLns p to
| otherwise = p
rs = return . maybe [] (map move)
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)
booksOfPeoplePut :: Monad m => PutlensM m ([Book],[Person]) [BookPerson]
booksOfPeoplePut = paramsndPut (\ps -> booksOfPut ps) .< booksOfPeoplePut'
booksOfPeoplePut' :: Monad m => PutlensM m ([Book],[Person]) [BookPerson]
booksOfPeoplePut' = runStatePut (\s _ -> return $ maybe [] snd s) $ (innPut ><< idPut) .< undistlPut .< (keepsndOrPut (\v -> State.get) -|-< it) .< outPut
where it = unforkPut ((keepsndOrPut (const $ return []) ><< idPut) .< booksOfPersonPut) ((keepfstPut ><< idPut) .< booksOfPeoplePut')
booksOfPersonPut :: Monad m => PutlensStateM m [Person] (Book,[Person]) BookPerson
booksOfPersonPut = paramfstPut (\(b,n) -> selectPersonPut n) .< joinBookPersonPut
joinBookPersonPut :: Monad m => PutlensM m (Book,Person) BookPerson
joinBookPersonPut = assoclPut .< (idPut ><< addfstPut (\_ -> return . get nameLns))
booksOfPeoplePut2 :: Monad m => PutlensM m ([Book],[Person]) [BookPerson]
booksOfPeoplePut2 = paramsndPut (\ps -> booksOfPut ps) .< modifyS (\s v' -> return $ fmap (\(bs,ps) -> (bs,peopleWithoutBooks (bs,ps))) s) 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 :: Monad m => [Person] -> PutlensM m [Book] [Book]
booksOfPut ps = selectPut fst (return . elsewhere) (isOf ps)
where elsewhere = maybe [] (filter (not . isOf ps))
isOf ps (b,p) = p `elem` (map (get nameLns) ps)
selectPersonPut :: Monad m => Name -> PutlensStateM m [Person] [Person] Person
selectPersonPut n = selectPut (get nameLns) (\s -> State.get >>= \st -> return $ 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 = runIdentity $ put (put2lens booksOfPeoplePut) (someBooks,somePeople) insMock
exJoinPut2 = runIdentity $ put (put2lens booksOfPeoplePut2) (someBooks,somePeople) insMock
delLOTR = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")
,("The Maias",Person "Hugo" "Braga")]
exJoinPut3 = runIdentity $ put (put2lens booksOfPeoplePut) (someBooks,somePeople) delLOTR
exJoinPut4 = runIdentity $ put (put2lens booksOfPeoplePut2) (someBooks,somePeople) delLOTR
delLOTRMaias = [("The Art of Computer Programming",Person "Zhenjiang" "Tokyo")]
exJoinPut5 = runIdentity $ put (put2lens booksOfPeoplePut) (someBooks,somePeople) delLOTRMaias
exJoinPut6 = runIdentity $ put (put2lens booksOfPeoplePut2) (someBooks,somePeople) delLOTRMaias