{-# LANGUAGE StrictData #-}
module Sq.Output
( Output
, ErrOutput (..)
, decode
, runOutput
, output
) where
import Control.Applicative
import Control.Exception.Safe qualified as Ex
import Control.Monad
import Control.Monad.Trans.Resource qualified as R hiding (runResourceT)
import Data.String
import Database.SQLite3 qualified as S
import Sq.Decoders
import Sq.Names
data Output o
= Output_Pure o
| Output_Fail Ex.SomeException
| Output_Decode BindingName (Decode (Output o))
data ErrOutput
=
ErrOutput_ColumnValue BindingName ErrDecode
|
ErrOutput_ColumnMissing BindingName
|
ErrOutput_Fail Ex.SomeException
deriving stock (Int -> ErrOutput -> ShowS
[ErrOutput] -> ShowS
ErrOutput -> String
(Int -> ErrOutput -> ShowS)
-> (ErrOutput -> String)
-> ([ErrOutput] -> ShowS)
-> Show ErrOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ErrOutput -> ShowS
showsPrec :: Int -> ErrOutput -> ShowS
$cshow :: ErrOutput -> String
show :: ErrOutput -> String
$cshowList :: [ErrOutput] -> ShowS
showList :: [ErrOutput] -> ShowS
Show)
deriving anyclass (Show ErrOutput
Typeable ErrOutput
(Typeable ErrOutput, Show ErrOutput) =>
(ErrOutput -> SomeException)
-> (SomeException -> Maybe ErrOutput)
-> (ErrOutput -> String)
-> Exception ErrOutput
SomeException -> Maybe ErrOutput
ErrOutput -> String
ErrOutput -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ErrOutput -> SomeException
toException :: ErrOutput -> SomeException
$cfromException :: SomeException -> Maybe ErrOutput
fromException :: SomeException -> Maybe ErrOutput
$cdisplayException :: ErrOutput -> String
displayException :: ErrOutput -> String
Ex.Exception)
decode :: Name -> Decode o -> Output o
decode :: forall o. Name -> Decode o -> Output o
decode Name
n Decode o
vda = BindingName -> Decode (Output o) -> Output o
forall o. BindingName -> Decode (Output o) -> Output o
Output_Decode (Name -> BindingName
bindingName Name
n) (o -> Output o
forall o. o -> Output o
Output_Pure (o -> Output o) -> Decode o -> Decode (Output o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode o
vda)
{-# INLINE decode #-}
output :: Name -> Output o -> Output o
output :: forall o. Name -> Output o -> Output o
output Name
n = \case
Output_Decode BindingName
bn Decode (Output o)
d ->
BindingName -> Decode (Output o) -> Output o
forall o. BindingName -> Decode (Output o) -> Output o
Output_Decode (Name -> BindingName
bindingName Name
n BindingName -> BindingName -> BindingName
forall a. Semigroup a => a -> a -> a
<> BindingName
bn) (Name -> Output o -> Output o
forall o. Name -> Output o -> Output o
output Name
n (Output o -> Output o) -> Decode (Output o) -> Decode (Output o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decode (Output o)
d)
Output o
o -> Output o
o
runOutput
:: (Monad m)
=> (BindingName -> m (Maybe S.SQLData))
-> Output o
-> m (Either ErrOutput o)
runOutput :: forall (m :: * -> *) o.
Monad m =>
(BindingName -> m (Maybe SQLData))
-> Output o -> m (Either ErrOutput o)
runOutput BindingName -> m (Maybe SQLData)
f = \case
Output_Decode BindingName
bn (Decode SQLData -> Either ErrDecode (Output o)
vda) -> do
BindingName -> m (Maybe SQLData)
f BindingName
bn m (Maybe SQLData)
-> (Maybe SQLData -> m (Either ErrOutput o))
-> m (Either ErrOutput o)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just SQLData
s -> case SQLData -> Either ErrDecode (Output o)
vda SQLData
s of
Right Output o
d -> (BindingName -> m (Maybe SQLData))
-> Output o -> m (Either ErrOutput o)
forall (m :: * -> *) o.
Monad m =>
(BindingName -> m (Maybe SQLData))
-> Output o -> m (Either ErrOutput o)
runOutput BindingName -> m (Maybe SQLData)
f Output o
d
Left ErrDecode
e -> Either ErrOutput o -> m (Either ErrOutput o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrOutput o -> m (Either ErrOutput o))
-> Either ErrOutput o -> m (Either ErrOutput o)
forall a b. (a -> b) -> a -> b
$ ErrOutput -> Either ErrOutput o
forall a b. a -> Either a b
Left (ErrOutput -> Either ErrOutput o)
-> ErrOutput -> Either ErrOutput o
forall a b. (a -> b) -> a -> b
$ BindingName -> ErrDecode -> ErrOutput
ErrOutput_ColumnValue BindingName
bn ErrDecode
e
Maybe SQLData
Nothing -> Either ErrOutput o -> m (Either ErrOutput o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrOutput o -> m (Either ErrOutput o))
-> Either ErrOutput o -> m (Either ErrOutput o)
forall a b. (a -> b) -> a -> b
$ ErrOutput -> Either ErrOutput o
forall a b. a -> Either a b
Left (ErrOutput -> Either ErrOutput o)
-> ErrOutput -> Either ErrOutput o
forall a b. (a -> b) -> a -> b
$ BindingName -> ErrOutput
ErrOutput_ColumnMissing BindingName
bn
Output_Pure o
a -> Either ErrOutput o -> m (Either ErrOutput o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrOutput o -> m (Either ErrOutput o))
-> Either ErrOutput o -> m (Either ErrOutput o)
forall a b. (a -> b) -> a -> b
$ o -> Either ErrOutput o
forall a b. b -> Either a b
Right o
a
Output_Fail SomeException
e -> Either ErrOutput o -> m (Either ErrOutput o)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ErrOutput o -> m (Either ErrOutput o))
-> Either ErrOutput o -> m (Either ErrOutput o)
forall a b. (a -> b) -> a -> b
$ ErrOutput -> Either ErrOutput o
forall a b. a -> Either a b
Left (ErrOutput -> Either ErrOutput o)
-> ErrOutput -> Either ErrOutput o
forall a b. (a -> b) -> a -> b
$ SomeException -> ErrOutput
ErrOutput_Fail SomeException
e
instance Functor Output where
fmap :: forall a b. (a -> b) -> Output a -> Output b
fmap = (a -> b) -> Output a -> Output b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA
{-# INLINE fmap #-}
instance Applicative Output where
pure :: forall o. o -> Output o
pure = a -> Output a
forall o. o -> Output o
Output_Pure
{-# INLINE pure #-}
liftA2 :: forall a b c. (a -> b -> c) -> Output a -> Output b -> Output c
liftA2 = (a -> b -> c) -> Output a -> Output b -> Output c
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2
{-# INLINE liftA2 #-}
instance Alternative Output where
empty :: forall a. Output a
empty = String -> Output a
forall a. String -> Output a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"empty"
{-# INLINE empty #-}
Output a
l <|> :: forall a. Output a -> Output a -> Output a
<|> Output a
r = case Output a
l of
Output_Decode BindingName
n Decode (Output a)
vda ->
BindingName -> Decode (Output a) -> Output a
forall o. BindingName -> Decode (Output o) -> Output o
Output_Decode BindingName
n ((Output a -> Output a) -> Decode (Output a) -> Decode (Output a)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Output a -> Output a -> Output a
forall a. Output a -> Output a -> Output a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Output a
r) Decode (Output a)
vda)
Output_Pure a
_ -> Output a
l
Output_Fail SomeException
_ -> Output a
r
instance MonadPlus Output where
mzero :: forall a. Output a
mzero = String -> Output a
forall a. String -> Output a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"mzero"
{-# INLINE mzero #-}
mplus :: forall a. Output a -> Output a -> Output a
mplus = Output a -> Output a -> Output a
forall a. Output a -> Output a -> Output a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
{-# INLINE mplus #-}
instance Monad Output where
Output a
l >>= :: forall a b. Output a -> (a -> Output b) -> Output b
>>= a -> Output b
k = case Output a
l of
Output_Decode BindingName
n Decode (Output a)
vda ->
BindingName -> Decode (Output b) -> Output b
forall o. BindingName -> Decode (Output o) -> Output o
Output_Decode BindingName
n ((Output a -> Output b) -> Decode (Output a) -> Decode (Output b)
forall a b. (a -> b) -> Decode a -> Decode b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Output a -> (a -> Output b) -> Output b
forall a b. Output a -> (a -> Output b) -> Output b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Output b
k) Decode (Output a)
vda)
Output_Pure a
a -> a -> Output b
k a
a
Output_Fail SomeException
e -> SomeException -> Output b
forall o. SomeException -> Output o
Output_Fail SomeException
e
instance Ex.MonadThrow Output where
throwM :: forall e a. (HasCallStack, Exception e) => e -> Output a
throwM = SomeException -> Output a
forall o. SomeException -> Output o
Output_Fail (SomeException -> Output a)
-> (e -> SomeException) -> e -> Output a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeException
forall e. Exception e => e -> SomeException
Ex.toException
instance MonadFail Output where
fail :: forall a. String -> Output a
fail = String -> Output a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
Ex.throwString
instance (Semigroup o) => Semigroup (Output o) where
<> :: Output o -> Output o -> Output o
(<>) = (o -> o -> o) -> Output o -> Output o -> Output o
forall a b c. (a -> b -> c) -> Output a -> Output b -> Output c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 o -> o -> o
forall a. Semigroup a => a -> a -> a
(<>)
{-# INLINE (<>) #-}
instance (Monoid o) => Monoid (Output o) where
mempty :: Output o
mempty = o -> Output o
forall o. o -> Output o
forall (f :: * -> *) a. Applicative f => a -> f a
pure o
forall a. Monoid a => a
mempty
{-# INLINE mempty #-}
instance (DecodeDefault i) => IsString (Output i) where
fromString :: String -> Output i
fromString String
s = Name -> Decode i -> Output i
forall o. Name -> Decode o -> Output o
decode (String -> Name
forall a. IsString a => String -> a
fromString String
s) Decode i
forall a. DecodeDefault a => Decode a
decodeDefault
{-# INLINE fromString #-}