{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Database.Beam.Query.CustomSQL
(
IsCustomExprFn(..)
, valueExpr_, agg_
, IsCustomSqlSyntax(..) ) where
import Database.Beam.Query.Internal
import Database.Beam.Backend.SQL.Builder
import Data.ByteString (ByteString)
import Data.ByteString.Builder (byteString, toLazyByteString)
import Data.ByteString.Lazy (toStrict)
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup
#endif
import Data.String
import qualified Data.Text as T
class (Monoid (CustomSqlSyntax syntax), Semigroup (CustomSqlSyntax syntax), IsString (CustomSqlSyntax syntax)) =>
IsCustomSqlSyntax syntax where
data CustomSqlSyntax syntax :: *
customExprSyntax :: CustomSqlSyntax syntax -> syntax
renderSyntax :: syntax -> CustomSqlSyntax syntax
instance IsCustomSqlSyntax SqlSyntaxBuilder where
newtype CustomSqlSyntax SqlSyntaxBuilder = SqlSyntaxBuilderCustom ByteString
deriving (IsString, Monoid, Semigroup)
customExprSyntax (SqlSyntaxBuilderCustom bs) = SqlSyntaxBuilder (byteString bs)
renderSyntax = SqlSyntaxBuilderCustom . toStrict . toLazyByteString . buildSql
newtype CustomSqlSnippet syntax = CustomSqlSnippet (T.Text -> CustomSqlSyntax syntax)
instance IsCustomSqlSyntax syntax => Semigroup (CustomSqlSnippet syntax) where
(<>) = mappend
instance IsCustomSqlSyntax syntax => Monoid (CustomSqlSnippet syntax) where
mempty = CustomSqlSnippet (pure mempty)
mappend (CustomSqlSnippet a) (CustomSqlSnippet b) =
CustomSqlSnippet $ \pfx -> a pfx <> b pfx
instance IsCustomSqlSyntax syntax => IsString (CustomSqlSnippet syntax) where
fromString s = CustomSqlSnippet $ \_ -> fromString s
class IsCustomExprFn fn res | res -> fn where
customExpr_ :: fn -> res
instance IsCustomSqlSyntax syntax => IsCustomExprFn (CustomSqlSnippet syntax) (QGenExpr ctxt syntax s res) where
customExpr_ (CustomSqlSnippet mkSyntax) = QExpr (customExprSyntax . mkSyntax)
instance (IsCustomExprFn a res, IsCustomSqlSyntax syntax) => IsCustomExprFn (CustomSqlSnippet syntax -> a) (QGenExpr ctxt syntax s r -> res) where
customExpr_ fn (QExpr e) = customExpr_ $ fn (CustomSqlSnippet (renderSyntax . e))
valueExpr_ :: QExpr syntax s a -> QExpr syntax s a
valueExpr_ = id
agg_ :: QAgg syntax s a -> QAgg syntax s a
agg_ = id