{-# 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
forall a. (String -> a) -> IsString a
fromString :: String -> CustomSqlSyntax SqlSyntaxBuilder
$cfromString :: String -> CustomSqlSyntax SqlSyntaxBuilder
IsString, Semigroup (CustomSqlSyntax SqlSyntaxBuilder)
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
Monoid, NonEmpty (CustomSqlSyntax SqlSyntaxBuilder)
-> CustomSqlSyntax SqlSyntaxBuilder
CustomSqlSyntax SqlSyntaxBuilder
-> CustomSqlSyntax SqlSyntaxBuilder
-> 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 :: forall b.
Integral b =>
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 ByteString
bs) = Builder -> SqlSyntaxBuilder
SqlSyntaxBuilder (ByteString -> Builder
byteString ByteString
bs)
  renderSyntax :: SqlSyntaxBuilder -> CustomSqlSyntax SqlSyntaxBuilder
renderSyntax = ByteString -> CustomSqlSyntax SqlSyntaxBuilder
SqlSyntaxBuilderCustom forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString 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 =
    forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet forall a b. (a -> b) -> a -> b
$ \Text
pfx -> Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be)
a Text
pfx 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 = forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
  mappend :: CustomSqlSnippet be -> CustomSqlSnippet be -> CustomSqlSnippet be
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance IsCustomSqlSyntax (BeamSqlBackendExpressionSyntax be) => IsString (CustomSqlSnippet be) where
  fromString :: String -> CustomSqlSnippet be
fromString String
s = forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet forall a b. (a -> b) -> a -> b
$ \Text
_ -> 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) = forall context be s t.
(Text -> BeamSqlBackendExpressionSyntax be)
-> QGenExpr context be s t
QExpr (forall syntax.
IsCustomSqlSyntax syntax =>
CustomSqlSyntax syntax -> syntax
customExprSyntax 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) = forall fn res. IsCustomExprFn fn res => fn -> res
customExpr_ forall a b. (a -> b) -> a -> b
$ CustomSqlSnippet be -> a
fn (forall be.
(Text -> CustomSqlSyntax (BeamSqlBackendExpressionSyntax be))
-> CustomSqlSnippet be
CustomSqlSnippet (forall syntax.
IsCustomSqlSyntax syntax =>
syntax -> CustomSqlSyntax syntax
renderSyntax 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_ :: forall be s a. QExpr be s a -> QExpr be s a
valueExpr_ = 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_ :: forall be s a. QAgg be s a -> QAgg be s a
agg_ = forall a. a -> a
id