Как обобщить Opaleye Query в Haskell (используя винил)?

Question

У меня вопрос между огромными баннерами в блоке кода ниже.

Простите за дамп кода, это все вставлено сюда для всех, кто хочет копировать, и этот код работает как положено, хотя это немного странно. Обратите внимание на последние две строки, они печатают правильный SQL.

Цель:

У меня есть таблицы с первичными ключами типа Text, в частности, электронные письма. Вместо того, чтобы писать новую функцию запроса для каждой таблицы, я взял на себя задачу обобщения функции, чтобы можно было безопасно вводить запросы для любой таблицы, в которой есть электронные письма.

Проблема:

Чтобы заставить это работать, я должен был включить:

instance Default Constant CEmail (Column PGText) where
  def = undefined

Что заставляет меня думать, что я делаю что-то не так. Любой совет для создания запроса, который может найти записи из любой таблицы, которая имеет электронную почту?

{- stack
--resolver lts-8.2
--install-ghc
exec ghci
--package aeson
--package composite-base
--package composite-aeson
--package text
--package string-conversions
--package postgres-simple
--package vinyl
-}

{-# LANGUAGE
Arrows
, DataKinds
, OverloadedStrings
, PatternSynonyms
, TypeOperators
, TemplateHaskell
, FlexibleContexts
, RankNTypes

, ConstraintKinds
, TypeSynonymInstances
, FlexibleInstances
, MultiParamTypeClasses
#-}

import Data.Vinyl (RElem)
import Data.Functor.Identity (Identity)
import Data.Vinyl.TypeLevel (RIndex)
import Composite.Aeson (JsonFormat, defaultJsonFormatRec, recJsonFormat, toJsonWithFormat)
import Composite.Opaleye (defaultRecTable)

import Composite.Record (Record, Rec(RNil), (:->), pattern (:*:))
import Composite.TH (withOpticsAndProxies)
import Control.Arrow (returnA)
import Control.Lens (view)
import Data.Int (Int64)
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text)
import Opaleye
import Opaleye.Internal.TableMaker (ColumnMaker)
import Data.String.Conversions (cs)
import qualified Data.Aeson as Aeson

import qualified Database.PostgreSQL.Simple as PGS -- used for printSql
import Data.Profunctor.Product.Default (Default(def))


--------------------------------------------------
-- | Types


-- | Newtype ClearPassword so it can't be passed around as ordinary Text
newtype ClearPassword a = ClearPassword a

withOpticsAndProxies [d|
  type FEmail = "email" :-> Text
  type CEmail = "email" :-> Column PGText

  type FAge = "age" :-> Text
  type CAge = "age" :-> Column PGText

  type FClearPassword = "clearpass" :-> ClearPassword Text
  type CHashPassword = "hashpass" :-> Column PGText
  |]


--------------------------------------------------
-- | Db Setup

-- | Helper Fn
printSql :: Default Unpackspec a a => Query a -> IO ()
printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres

-- | Db Records
type DbUser = '[CEmail, CAge]
type DbPassword = '[CEmail, CHashPassword]


--------------------------------------------------
--------------------------------------------------
--
-- LOOK HERE vvvvvvvvvvvvvvvvvvvvvvvv
--
--------------------------------------------------
--------------------------------------------------

type RecWith f rs = (Default ColumnMaker (Record rs) (Record rs),
                     Default Constant f (Column PGText),
                     RElem f rs (RIndex f rs))

-- | queryByEmail needs this, but totally works if `def` is declared
-- as `undefined` ???
instance Default Constant CEmail (Column PGText) where
  def = undefined

queryByEmail :: (RecWith CEmail rs) =>
                Table a (Record rs) -> Text -> QueryArr () (Record rs)
queryByEmail table email = proc () -> do
  u <- queryTable table -< ()
  let uEmail = view cEmail u
  restrict -< uEmail .=== constant email
  returnA -< u

--------------------------------------------------
--------------------------------------------------
--
-- LOOK UP ^^^^^^^^^^^^^^^^^^^^^^^^
--
--------------------------------------------------
--------------------------------------------------

userTable :: Table (Record DbUser) (Record DbUser)
userTable = Table "user" defaultRecTable

-- | Password
passwordTable :: Table (Record DbPassword) (Record DbPassword)
passwordTable = Table "password" defaultRecTable

-- SELECT ... FROM "user" ...
queryUserTest = printSql $ queryByEmail userTable "hi"

-- SELECT ... FROM "password" ...
queryPasswordTest = printSql $ queryByEmail passwordTable "hi"

Answer 1

Бросьте постороннее Default Constant f (Column PGTest) ограничение, и вы должны быть хорошо идти:

#!/usr/bin/env stack
{- stack --resolver lts-8.11 --install-ghc exec ghci --package aeson --package composite-base --package composite-aeson --package text --package string-conversions --package vinyl --package composite-opaleye -}
{-# LANGUAGE Arrows, DataKinds, OverloadedStrings, PatternSynonyms, TypeOperators, TemplateHaskell, FlexibleContexts, RankNTypes, ConstraintKinds, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}

import Composite.Opaleye (defaultRecTable)
import Composite.Record (Record, (:->))
import Composite.TH (withOpticsAndProxies)
import Control.Arrow (returnA)
import Control.Lens (view)
import Data.Profunctor.Product.Default (Default)
import Data.Text (Text)
import Data.Vinyl (RElem)
import Data.Vinyl.TypeLevel (RIndex)
import Opaleye.Internal.TableMaker (ColumnMaker)

import Opaleye


newtype ClearPassword a = ClearPassword a

withOpticsAndProxies [d|
  type FEmail = "email" :-> Text
  type CEmail = "email" :-> Column PGText

  type FAge = "age" :-> Text
  type CAge = "age" :-> Column PGText

  type FClearPassword = "clearpass" :-> ClearPassword Text
  type CHashPassword = "hashpass" :-> Column PGText
  |]

type DbUser = '[CEmail, CAge]
type DbPassword = '[CEmail, CHashPassword]

printSql :: Default Unpackspec a a => Query a -> IO ()
printSql = putStrLn . maybe "Empty query" id . showSqlForPostgres

queryByEmail :: (RElem CEmail rs (RIndex CEmail rs), Default ColumnMaker (Record rs) (Record rs)) => Table a (Record rs) -> Text -> QueryArr () (Record rs)
queryByEmail table email = proc () -> do
  u <- queryTable table -< ()
  let uEmail = view cEmail u
  restrict -< uEmail .=== constant email
  returnA -< u

userTable :: Table (Record DbUser) (Record DbUser)
userTable = Table "user" defaultRecTable

passwordTable :: Table (Record DbPassword) (Record DbPassword)
passwordTable = Table "password" defaultRecTable

queryUserTest = printSql $ queryByEmail userTable "hi"
queryPasswordTest = printSql $ queryByEmail passwordTable "hi"

constant email вызов использует (уже существует) Default Constant Text (Column PGText) ограничение; мы email иметь тип CEmail вместо этого вам понадобится нетривиальный экземпляр с неопределенным использованием.