{-# LANGUAGE ConstraintKinds    #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExplicitNamespaces #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}

module Control.Monad.Freer.Extras.Beam.Common where

import Cardano.BM.Data.Tracer (ToObject (..))
import Control.Exception (Exception)
import Data.Aeson (FromJSON, ToJSON)
import Data.Text (Text)
import Database.Beam (Beamable, QBaseScope)
import Database.Beam.Backend (BeamSqlBackendCanSerialize)
import Database.Beam.Query.Internal (QNested)
import Database.Beam.Schema.Tables (FieldsFulfillConstraint)
import GHC.Generics (Generic)
import Prettyprinter (Pretty (..), colon, (<+>))

type BeamableDb db table = (Beamable table, FieldsFulfillConstraint (BeamSqlBackendCanSerialize db) table)


type BeamThreadingArg = QNested (QNested QBaseScope)

newtype BeamError =
  SqlError Text
  deriving stock (BeamError -> BeamError -> Bool
(BeamError -> BeamError -> Bool)
-> (BeamError -> BeamError -> Bool) -> Eq BeamError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BeamError -> BeamError -> Bool
$c/= :: BeamError -> BeamError -> Bool
== :: BeamError -> BeamError -> Bool
$c== :: BeamError -> BeamError -> Bool
Eq, Int -> BeamError -> ShowS
[BeamError] -> ShowS
BeamError -> String
(Int -> BeamError -> ShowS)
-> (BeamError -> String)
-> ([BeamError] -> ShowS)
-> Show BeamError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BeamError] -> ShowS
$cshowList :: [BeamError] -> ShowS
show :: BeamError -> String
$cshow :: BeamError -> String
showsPrec :: Int -> BeamError -> ShowS
$cshowsPrec :: Int -> BeamError -> ShowS
Show, (forall x. BeamError -> Rep BeamError x)
-> (forall x. Rep BeamError x -> BeamError) -> Generic BeamError
forall x. Rep BeamError x -> BeamError
forall x. BeamError -> Rep BeamError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BeamError x -> BeamError
$cfrom :: forall x. BeamError -> Rep BeamError x
Generic)
  deriving anyclass (Value -> Parser [BeamError]
Value -> Parser BeamError
(Value -> Parser BeamError)
-> (Value -> Parser [BeamError]) -> FromJSON BeamError
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BeamError]
$cparseJSONList :: Value -> Parser [BeamError]
parseJSON :: Value -> Parser BeamError
$cparseJSON :: Value -> Parser BeamError
FromJSON, [BeamError] -> Value
[BeamError] -> Encoding
BeamError -> Value
BeamError -> Encoding
(BeamError -> Value)
-> (BeamError -> Encoding)
-> ([BeamError] -> Value)
-> ([BeamError] -> Encoding)
-> ToJSON BeamError
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BeamError] -> Encoding
$ctoEncodingList :: [BeamError] -> Encoding
toJSONList :: [BeamError] -> Value
$ctoJSONList :: [BeamError] -> Value
toEncoding :: BeamError -> Encoding
$ctoEncoding :: BeamError -> Encoding
toJSON :: BeamError -> Value
$ctoJSON :: BeamError -> Value
ToJSON, TracingVerbosity -> BeamError -> Object
BeamError -> Object -> Text
(TracingVerbosity -> BeamError -> Object)
-> (BeamError -> Object -> Text) -> ToObject BeamError
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
textTransformer :: BeamError -> Object -> Text
$ctextTransformer :: BeamError -> Object -> Text
toObject :: TracingVerbosity -> BeamError -> Object
$ctoObject :: TracingVerbosity -> BeamError -> Object
ToObject)

instance Exception BeamError

instance Pretty BeamError where
  pretty :: BeamError -> Doc ann
pretty = \case
    SqlError Text
s -> Doc ann
"SqlError (via Beam)" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
s

newtype BeamLog =
  SqlLog String
  deriving stock (BeamLog -> BeamLog -> Bool
(BeamLog -> BeamLog -> Bool)
-> (BeamLog -> BeamLog -> Bool) -> Eq BeamLog
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BeamLog -> BeamLog -> Bool
$c/= :: BeamLog -> BeamLog -> Bool
== :: BeamLog -> BeamLog -> Bool
$c== :: BeamLog -> BeamLog -> Bool
Eq, Int -> BeamLog -> ShowS
[BeamLog] -> ShowS
BeamLog -> String
(Int -> BeamLog -> ShowS)
-> (BeamLog -> String) -> ([BeamLog] -> ShowS) -> Show BeamLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BeamLog] -> ShowS
$cshowList :: [BeamLog] -> ShowS
show :: BeamLog -> String
$cshow :: BeamLog -> String
showsPrec :: Int -> BeamLog -> ShowS
$cshowsPrec :: Int -> BeamLog -> ShowS
Show, (forall x. BeamLog -> Rep BeamLog x)
-> (forall x. Rep BeamLog x -> BeamLog) -> Generic BeamLog
forall x. Rep BeamLog x -> BeamLog
forall x. BeamLog -> Rep BeamLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BeamLog x -> BeamLog
$cfrom :: forall x. BeamLog -> Rep BeamLog x
Generic)
  deriving anyclass (Value -> Parser [BeamLog]
Value -> Parser BeamLog
(Value -> Parser BeamLog)
-> (Value -> Parser [BeamLog]) -> FromJSON BeamLog
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [BeamLog]
$cparseJSONList :: Value -> Parser [BeamLog]
parseJSON :: Value -> Parser BeamLog
$cparseJSON :: Value -> Parser BeamLog
FromJSON, [BeamLog] -> Value
[BeamLog] -> Encoding
BeamLog -> Value
BeamLog -> Encoding
(BeamLog -> Value)
-> (BeamLog -> Encoding)
-> ([BeamLog] -> Value)
-> ([BeamLog] -> Encoding)
-> ToJSON BeamLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [BeamLog] -> Encoding
$ctoEncodingList :: [BeamLog] -> Encoding
toJSONList :: [BeamLog] -> Value
$ctoJSONList :: [BeamLog] -> Value
toEncoding :: BeamLog -> Encoding
$ctoEncoding :: BeamLog -> Encoding
toJSON :: BeamLog -> Value
$ctoJSON :: BeamLog -> Value
ToJSON, TracingVerbosity -> BeamLog -> Object
BeamLog -> Object -> Text
(TracingVerbosity -> BeamLog -> Object)
-> (BeamLog -> Object -> Text) -> ToObject BeamLog
forall a.
(TracingVerbosity -> a -> Object)
-> (a -> Object -> Text) -> ToObject a
textTransformer :: BeamLog -> Object -> Text
$ctextTransformer :: BeamLog -> Object -> Text
toObject :: TracingVerbosity -> BeamLog -> Object
$ctoObject :: TracingVerbosity -> BeamLog -> Object
ToObject)

instance Pretty BeamLog where
  pretty :: BeamLog -> Doc ann
pretty = \case
    SqlLog String
s -> Doc ann
"SqlLog" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
colon Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
s