-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Putlenses.Examples.People
-- Copyright   :  (C) 2014 Hugo Pacheco
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Hugo Pacheco <hpacheco@nii.ac.jp>
-- Stability   :  provisional
--
-- Database examples for a source database with a list of people.
-- 
--
--
----------------------------------------------------------------------------

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 ) -- generates two putlenses namePut and cityPut

nameP :: Monad m => PutlensM m Person Name
nameP = innPut .< keepsndPut

-- ** DB project

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]

-- ** DB select

-- | Generic database select putlens
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,[]) -- empty state
recoverEntry key (x:xs) [] = (Just x,xs) -- when the view is empty
recoverEntry key (x:xs) (v:vs) | key v < key x = (Nothing,x:xs) -- iterate
                               | key v == key x = (Nothing,xs) -- iterate
                               | key v > key x = (Just x,xs) -- recover

nameLns = put2lens namePut
cityLns = put2lens cityPut

isFrom c p = get cityLns p == c

-- | Selects all people @from@ a city
peopleFromPut :: Monad m => City -> PutlensM m [Person] [Person]
peopleFromPut from = selectPut (get nameLns) elsewhere (isFrom from)
	where elsewhere = return . maybe [] (filter (not . isFrom from))

-- | Selects all people @from@ a city (moves deleted people to a new city @to@)
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]

-- ** DB Join

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")]
-- insert person and delete other books for the same person

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")]
-- delete only book

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")]
-- delete both books; delete only books/only person

exJoinPut5 = runIdentity $ put (put2lens booksOfPeoplePut) (someBooks,somePeople) delLOTRMaias
exJoinPut6 = runIdentity $ put (put2lens booksOfPeoplePut2) (someBooks,somePeople) delLOTRMaias