{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Basic.Example where

import Internal.Interlude hiding (filter)

import Data.Basic
import Language.Haskell.TH hiding (location)

import Unsafe.Coerce

data User = User { _userId   :: {-# UNPACK #-} !Key
                 , _userName :: {-# UNPACK #-} !Text
                 , _userLocation :: Point } deriving (Eq, Ord, Read, Show)

makeLenses ''User

instance Table User where
    type TableName User = "blog_user"
    type TableFields User = ["id", "name", "location"]
    type TableConstraints User = '[ 'Unique "blog_user_pkey"]
    type TablePrimaryKey User = 'Just "blog_user_pkey"
    type TableRequiredFields User = ['Required "id", 'Required "name"]
    newEntity = Entity (User (unsafeCoerce ()) (unsafeCoerce ()) (Point 0 0))

instance UniqueConstraint "blog_user_pkey" where
    type UniqueTable "blog_user_pkey" = User
    type UniqueFields "blog_user_pkey" = '["id"]

instance PrimaryKeyConstraint "blog_user_pkey"

instance TableField User "id" where
    type TableFieldType User "id" = Key
    tableFieldLens = userId

instance TableField User "name" where
    type TableFieldType User "name" = Text
    tableFieldLens = userName

instance TableField User "location" where
    type TableFieldType User "location" = Point
    tableFieldLens = userLocation

instance FromRow User where
    fromRow = User <$> field <*> field <*> field

data Post = Post { _postId     :: Key
                 , _postName   :: Text
                 , _postUserId :: Key } deriving (Eq, Ord, Read, Show)

makeLenses ''Post

instance Table Post where
    type TableName Post = "blog_post"
    type TableFields Post = ["id", "name", "author"]
    type TableConstraints Post = '[ 'ForeignKey "blog_post_author_fkey"]
    type TablePrimaryKey Post = 'Just "blog_post_pkey"
    type TableRequiredFields Post = ['Required "id", 'Required "name", 'Required "author"]
    newEntity = Entity (Post (unsafeCoerce ()) (unsafeCoerce ()) (unsafeCoerce ()))

instance UniqueConstraint "blog_post_pkey" where
    type UniqueTable "blog_post_pkey" = Post
    type UniqueFields "blog_post_pkey" = '["id"]

instance PrimaryKeyConstraint "blog_post_pkey"

instance FromRow Post where
    fromRow = Post <$> field <*> field <*> field

instance TableField Post "id" where
    type TableFieldType Post "id" = Key
    tableFieldLens = postId

instance TableField Post "name" where
    type TableFieldType Post "name" = Text
    tableFieldLens = postName

instance TableField Post "author" where
    type TableFieldType Post "author" = Key
    tableFieldLens = postUserId

instance ForeignKeyConstraint "blog_post_author_fkey" where
    type ForeignKeyFrom "blog_post_author_fkey" = Post
    type ForeignKeyFromFields "blog_post_author_fkey" = '["author"]
    type ForeignKeyTo "blog_post_author_fkey" = User
    type ForeignKeyToFields "blog_post_author_fkey" = '["id"]

allUsers :: AllRows User res => res
allUsers = allRows @"blog_user"

allPosts :: AllRows Post res => res
allPosts = allRows @"blog_post"

newUser :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "location"]) User
newUser = Entity (User 0 "" (Point 0 0))

newPost :: Entity ('Fresh ['Required "id", 'Required "name", 'Required "author"]) Post
newPost = Entity (Post 0 "" 1)

posts :: VirtualTable "blog_post_author_fkey" res
      => Getter' (Entity ('FromDb c) (ForeignKeyTo "blog_post_author_fkey")) res
posts = virtualTableLens @"blog_post_author_fkey"

id :: FieldOpticProxy (Proxy "id" -> o) => o
id = fieldOptic @"id"

name :: FieldOpticProxy (Proxy "name" -> o) => o
name = fieldOptic @"name"

location :: FieldOpticProxy (Proxy "location" -> o) => o
location = fieldOptic @"location"

authorId :: FieldOpticProxy (Proxy "author" -> o) => o
authorId = fieldOptic @"author"

author :: ForeignKeyLensProxy (Proxy "blog_post_author_fkey" -> o) => o
author = foreignKeyLens @"blog_post_author_fkey"

test1 :: (MonadIO m, MonadEffect Basic m) => m ()
test1 = do
    void $ ddelete allPosts
    void $ ddelete allUsers
    let user = newUser & name .~ "Luka"
                       & id .~ 1
                       & location .~ Point 5 6
    user' <- insert user
    let post = newPost & id .~ 1
                       & name .~ "New post"
                       & author .~ user'
    post' <- insert post
    void $ dfilter (\u -> In (u ^. id) [1, 3, 4]) allUsers
    void $ dfilter (\u -> u ^. id <. (2 :: Key)) allUsers

    auth <- post' ^. author
    void $ save (auth & name .~ "Luka H")

    let user2 = newUser & name .~ "Ivan"
                        & id .~ 2
                        & location .~ Point 6 7
    void $ insert user2

    us <- dtake 1 $ dsortOn (\u -> Down (u ^. id)) allUsers
    print us

    void $ dupdate (\u' -> u' & location .~ Point 7 8) allUsers

    usersPosts <- allUsers `djoin` allPosts
    print usersPosts

    -- Folding/grouping test
    void $ ddelete allPosts
    void $ ddelete allUsers
    void $ insert $
        newUser
            & name .~ "A"
            & id .~ 1
            & location .~ Point 0 0

    void $ insert $
        newUser
            & name .~ "A"
            & id .~ 2
            & location .~ Point 0 0

    void $ insert $
        newUser
            & name .~ "B"
            & id .~ 3
            & location .~ Point 0 0

    void $ insert $
        newUser
            & name .~ "B"
            & id .~ 4
            & location .~ Point 0 0

    print =<< dfoldMap (\u -> (Min (u ^. id), Max (u ^. id))) allUsers
    print =<< dmap (\u -> u ^. name) allUsers
    allUsers
        & dgroupOn (view name)
        & dmap (\(_, g) ->
            (dfoldMap ((,) <$> Min . view id <*> Max . view id) g)
            )
        & (>>= print)
    allUsers
        & dgroupOn (view name)
        & dfoldMapInner ((,) <$> Min . view id <*> Max . view id)
        & (>>= print)

test :: IO ()
test = do
    conn <- connectPostgreSQL "host=localhost port=5432 user=postgres dbname=postgres password=admin connect_timeout=10"
    handleBasicPsql conn test1

-- Two very useful functions.
-- And these are just good for printing out code.

putQ :: Show a => Q a -> IO ()
putQ xQ = do x <- runQ xQ
             print x

putQLn :: Show a => Q a -> IO ()
putQLn xQ = do putQ xQ
               putText ""