{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Database.Relational.Monad.Unique
( QueryUnique, unsafeUniqueSubQuery,
toSubQuery,
) where
import Control.Applicative (Applicative)
import Database.Relational.Internal.ContextType (Flat)
import Database.Relational.SqlSyntax
(Duplication, Record, JoinProduct, NodeAttr,
SubQuery, Predicate, Qualified, )
import qualified Database.Relational.Record as Record
import Database.Relational.Projectable (PlaceHolders)
import Database.Relational.Monad.Class (MonadQualify, MonadQuery)
import Database.Relational.Monad.Trans.Join (unsafeSubQueryWithAttr)
import Database.Relational.Monad.Trans.Restricting (restrictings)
import Database.Relational.Monad.BaseType (ConfigureQuery, askConfig)
import Database.Relational.Monad.Type (QueryCore, extractCore)
import Database.Relational.SqlSyntax (flatSubQuery)
newtype QueryUnique a = QueryUnique (QueryCore a)
deriving (MonadQualify ConfigureQuery, MonadQuery, Monad, Applicative, Functor)
unsafeUniqueSubQuery :: NodeAttr
-> Qualified SubQuery
-> QueryUnique (Record c r)
unsafeUniqueSubQuery a = QueryUnique . restrictings . unsafeSubQueryWithAttr a
extract :: QueryUnique a
-> ConfigureQuery (((a, [Predicate Flat]), JoinProduct), Duplication)
extract (QueryUnique c) = extractCore c
toSubQuery :: QueryUnique (PlaceHolders p, Record c r)
-> ConfigureQuery SubQuery
toSubQuery q = do
((((_ph, pj), rs), pd), da) <- extract q
c <- askConfig
return $ flatSubQuery c (Record.untype pj) da pd rs []