{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}

-- | Allows the creation of custom SQL expressions from arbitrary string-like values.
--
--   Simply write a polymorphic function with an arbitrary number of arguments,
--   all of the same type, and returns a value of the same type. The type will
--   have instances of 'Monoid' and 'IsString'.
--
--   For example, to implement a function @MYFUNC@ that takes three arguments
--
-- @
-- myFuncImpl :: (Monoid a, IsString a) => a -> a -> a -> a
-- @
--
--   Then, apply 'customExpr_' to your function.  This will result in a function
--   with the same arity, that takes in and returns 'QGenExpr's instead of
--   generic @a@s.
--
--   The returned function is polymorphic in the types of SQL expressions it
--   will accept, but you can give it a more specific signature. For example, to
--   mandate that we receive two 'Int32's and a 'T.Text' and return a 'Bool'.
--
-- @
-- myFunc_ :: QGenExpr e ctxt s Int32 -> QGenExpr e ctxt s Int32 -> QGenExpr e ctxt s T.Text -> QGenExpr e ctxt s Bool
-- myFunc_ = customExpr_ myFuncImpl
-- @
--
--   Semantically, the expression builder function (@myFuncImpl@ in this case)
--   is called with arguments representing SQL expressions, that, when
--   evaluated, will evaluate to the result of the expressions supplied as
--   arguments to 'customExpr_'. See the section on
--   <https://haskell-beam.github.io/beam/user-guide/extensibility/extensibility>
--   in the user guide for example usage.
module Database.Beam.Query.CustomSQL
  (
  -- * The 'customExpr_' function
  IsCustomExprFn(..)

  -- ** Type-inference help
  , valueExpr_, agg_

  -- * For backends
  , IsCustomSqlSyntax(..) ) where

import           Database.Beam.Query.Internal
import           Database.Beam.Backend.SQL
import           Database.Beam.Backend.SQL.Builder

import           Data.ByteString (ByteString)
import           Data.ByteString.Builder (byteString, toLazyByteString)
import           Data.ByteString.Lazy (toStrict)

import           Data.Kind (Type)
import           Data.String
import qualified Data.Text as T

-- | A type-class for expression syntaxes that can embed custom expressions.
class (Monoid (CustomSqlSyntax syntax), Semigroup (CustomSqlSyntax syntax), IsString (CustomSqlSyntax syntax)) =>
  IsCustomSqlSyntax syntax where
  data CustomSqlSyntax syntax :: Type

  -- | Given an arbitrary string-like expression, produce a 'syntax' that represents the
  --   'ByteString' as a SQL expression.
  customExprSyntax :: CustomSqlSyntax syntax -> syntax

  -- | Given an arbitrary 'syntax', produce a string-like value that corresponds to
  --   how that syntax would look when rendered in the backend.
  renderSyntax :: syntax -> CustomSqlSyntax syntax

instance IsCustomSqlSyntax SqlSyntaxBuilder where
  newtype CustomSqlSyntax SqlSyntaxBuilder = SqlSyntaxBuilderCustom ByteString
    deriving (String -> CustomSqlSyntax SqlSyntaxBuilder
(String -> CustomSqlSyntax SqlSyntaxBuilder)
-> IsString (CustomSqlSyntax SqlSyntaxBuilder)
forall a. (String -> a) -> IsString a
fromString :: String -> CustomSqlSyntax SqlSyntaxBuilder
$cfromString :: String -> CustomSqlSyntax SqlSyntaxBuilder
IsString, Semigroup (CustomSqlSyntax SqlSyntaxBuilder)
CustomSqlSyntax SqlSyntaxBuilder
Semigroup (CustomSqlSyntax SqlSyntaxBuilder)
-> CustomSqlSyntax SqlSyntaxBuilder
-> (CustomSqlSyntax SqlSyntaxBuilder
    -> CustomSqlSyntax SqlSyntaxBuilder
    -> CustomSqlSyntax SqlSyntaxBuilder)
-> ([CustomSqlSyntax SqlSyntaxBuilder]
    -> CustomSqlSyntax SqlSyntaxBuilder)
-> Monoid (CustomSqlSyntax SqlSyntaxBuilder)
[CustomSqlSyntax SqlSyntaxBuilder]
-> CustomSqlSyntax SqlSyntaxBuilder
CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CustomSqlSyntax SqlSyntaxBuilder]
-> CustomSqlSyntax SqlSyntaxBuilder
$cmconcat :: [CustomSqlSyntax SqlSyntaxBuilder]
-> CustomSqlSyntax SqlSyntaxBuilder
mappend :: CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
$cmappend :: CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
mempty :: CustomSqlSyntax SqlSyntaxBuilder
$cmempty :: CustomSqlSyntax SqlSyntaxBuilder
$cp1Monoid :: Semigroup (CustomSqlSyntax SqlSyntaxBuilder)
Monoid, b
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
NonEmpty (CustomSqlSyntax SqlSyntaxBuilder)
-> CustomSqlSyntax SqlSyntaxBuilder
CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
(CustomSqlSyntax SqlSyntaxBuilder
 -> CustomSqlSyntax SqlSyntaxBuilder
 -> CustomSqlSyntax SqlSyntaxBuilder)
-> (NonEmpty (CustomSqlSyntax SqlSyntaxBuilder)
    -> CustomSqlSyntax SqlSyntaxBuilder)
-> (forall b.
    Integral b =>
    b
    -> CustomSqlSyntax SqlSyntaxBuilder
    -> CustomSqlSyntax SqlSyntaxBuilder)
-> Semigroup (CustomSqlSyntax SqlSyntaxBuilder)
forall b.
Integral b =>
b
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
$cstimes :: forall b.
Integral b =>
b
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
sconcat :: NonEmpty (CustomSqlSyntax SqlSyntaxBuilder)
-> CustomSqlSyntax SqlSyntaxBuilder
$csconcat :: NonEmpty (CustomSqlSyntax SqlSyntaxBuilder)
-> CustomSqlSyntax SqlSyntaxBuilder
<> :: CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
$c<> :: CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
Semigroup)

  customExprSyntax :: CustomSqlSyntax SqlSyntaxBuilder -> SqlSyntaxBuilder
customExprSyntax (SqlSyntaxBuilderCustom bs) = Builder -> SqlSyntaxBuilder
SqlSyntaxBuilder (ByteString -> Builder
byteString ByteString
bs)
  renderSyntax :: SqlSyntaxBuilder -> CustomSqlSyntax SqlSyntaxBuilder
renderSyntax = ByteString -> CustomSqlSyntax SqlSyntaxBuilder
SqlSyntaxBuilderCustom (ByteString -> CustomSqlSyntax SqlSyntaxBuilder)
-> (SqlSyntaxBuilder -> ByteString)
-> SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (SqlSyntaxBuilder -> ByteString)
-> SqlSyntaxBuilder
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (SqlSyntaxBuilder -> Builder) -> SqlSyntaxBuilder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlSyntaxBuilder -> Builder
buildSql

newtype CustomSqlSnippet be = CustomSqlSnippet (T.Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Semigroup (CustomSqlSnippet be) where
  CustomSqlSnippet Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
a <> :: CustomSqlSnippet be -> CustomSqlSnippet be -> CustomSqlSnippet be
<> CustomSqlSnippet Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
b =
    (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet ((Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
 -> CustomSqlSnippet be)
-> (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall a b. (a -> b) -> a -> b
$ \Text
pfx -> Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
a Text
pfx CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
-> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
-> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall a. Semigroup a => a -> a -> a
<> Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
b Text
pfx
instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => Monoid (CustomSqlSnippet be) where
  mempty :: CustomSqlSnippet be
mempty = (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet (CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
-> Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall a. Monoid a => a
mempty)
  mappend :: CustomSqlSnippet be -> CustomSqlSnippet be -> CustomSqlSnippet be
mappend = CustomSqlSnippet be -> CustomSqlSnippet be -> CustomSqlSnippet be
forall a. Semigroup a => a -> a -> a
(<>)

instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => IsString (CustomSqlSnippet be) where
  fromString :: String -> CustomSqlSnippet be
fromString String
s = (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet ((Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
 -> CustomSqlSnippet be)
-> (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall a b. (a -> b) -> a -> b
$ \Text
_ -> String -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall a. IsString a => String -> a
fromString String
s

class IsCustomExprFn fn res | res -> fn where
  customExpr_ :: fn -> res

type BeamSqlBackendHasCustomSyntax be = IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be)

instance BeamSqlBackendHasCustomSyntax be => IsCustomExprFn (CustomSqlSnippet be) (QGenExpr ctxt be s res) where
  customExpr_ :: CustomSqlSnippet be -> QGenExpr ctxt be s res
customExpr_ (CustomSqlSnippet Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
mkSyntax) = (Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr ctxt be s res
forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr (CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
-> BeamSqlBackendExpressionSyntax be
forall syntax.
IsCustomSqlSyntax syntax =>
CustomSqlSyntax syntax -> syntax
customExprSyntax (CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
 -> BeamSqlBackendExpressionSyntax be)
-> (Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> Text
-> BeamSqlBackendExpressionSyntax be
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
mkSyntax)

instance (IsCustomExprFn a res, BeamSqlBackendHasCustomSyntax be) =>
  IsCustomExprFn (CustomSqlSnippet be -> a) (QGenExpr ctxt be s r -> res) where
  customExpr_ :: (CustomSqlSnippet be -> a) -> QGenExpr ctxt be s r -> res
customExpr_ CustomSqlSnippet be -> a
fn (QExpr Text -> BeamSqlBackendExpressionSyntax be
e) = a -> res
forall fn res. IsCustomExprFn fn res => fn -> res
customExpr_ (a -> res) -> a -> res
forall a b. (a -> b) -> a -> b
$ CustomSqlSnippet be -> a
fn ((Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet (BeamSqlBackendExpressionSyntax be
-> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall syntax.
IsCustomSqlSyntax syntax =>
syntax -> CustomSqlSyntax syntax
renderSyntax (BeamSqlBackendExpressionSyntax be
 -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> (Text -> BeamSqlBackendExpressionSyntax be)
-> Text
-> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> BeamSqlBackendExpressionSyntax be
e))

-- | Force a 'QGenExpr' to be typed as a value expression (a 'QExpr'). Useful
--   for getting around type-inference errors with supplying the entire type.
valueExpr_ :: QExpr be s a -> QExpr be s a
valueExpr_ :: QExpr be s a -> QExpr be s a
valueExpr_ = QExpr be s a -> QExpr be s a
forall a. a -> a
id

-- | Force a 'QGenExpr' to be typed as an aggregate. Useful for defining custom
--   aggregates for use in 'aggregate_'.
agg_ :: QAgg be s a -> QAgg be s a
agg_ :: QAgg be s a -> QAgg be s a
agg_ = QAgg be s a -> QAgg be s a
forall a. a -> a
id