{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE Arrows                #-}

module Main where

import Opaleye
import Data.Profunctor.Product
import Data.Profunctor.Product.Default
import Data.Profunctor.Product.TH           (makeAdaptorAndInstance)

import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.FromField (FromField(..))

import Prelude hiding (id)
import Control.Arrow

newtype UserId = UserId Int deriving (Show)

data UserPoly id name email = User { id :: id, name :: name, email :: email } deriving (Show)

type User = UserPoly UserId String String
type UserPGW = UserPoly (Column PGInt4) (Column PGText) (Column PGText)
type UserPGR = UserPoly (Column PGInt4) (Column PGText) (Column PGText)

$(makeAdaptorAndInstance "pUser" ''UserPoly)

userTable :: Table UserPGW UserPGR
userTable = Table "users" (pUser User {
    id = required "id",
    name = required "name",
    email = required "email"
    }
  )

instance FromField UserId where
  fromField field bs = UserId <$> fromField field bs

instance QueryRunnerColumnDefault PGInt4 UserId where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

getUserRows :: IO [User]
getUserRows = do
  conn <- connect defaultConnectInfo { connectDatabase = "scratch"}
  runQuery conn $ proc () ->
    do
      user@User {name = pgName} <- queryTable userTable -< ()
      restrict -< (pgName .== (pgStrictText "John"))
      returnA -< user

main :: IO ()
main = do
  rows <- getUserRows
  putStrLn $ show rows

-- Output
-- [User {id = UserId 1, name = "John", email = "john@mail.com"},User {id = UserId
--  2, name = "Bob", email = "bob@mail.com"},User {id = UserId 3, name = "Alice",
-- email = "alice@mail.com"}]
