{-# 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

--------------------------------------------------------------------------------

-- | How to decode an output row from a single 'Sq.Statement'.
--
-- * Construct with 'decode', 'IsString'.
--
-- * Nest with 'output'.
--
-- * Compose with 'Monoid', 'Functor', 'Applicative', 'Alternative', 'Monad',
-- 'MonadPlus', 'MonadFail' and 'Ex.MonadThrow' tools.
data Output o
   = Output_Pure o
   | Output_Fail Ex.SomeException
   | Output_Decode BindingName (Decode (Output o))

data ErrOutput
   = -- | Error from v'Decode'.
     ErrOutput_ColumnValue BindingName ErrDecode
   | -- | Missing column name in the raw 'SQL'.
     ErrOutput_ColumnMissing BindingName
   | -- | Error from 'Ex.MonadThrow'.
     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 the column with the given 'Name'.
--
-- @
-- 'Sq.readStatement'
--         'mempty'
--         ('decode' \"foo\" 'decodeDefault')
--         \"SELECT foo FROM t\"
--    :: ('DecodeDefault' x)
--    => 'Sq.Statement' 'Sq.Read' () x
-- @
--
-- Note that by design, this library doesn't support positional 'Output'
-- parameters. You must always pick a 'Name'. In the raw SQL, you can use @AS@
-- to rename your output columns as necessary.
--
-- @
-- 'Sq.readStatement'
--         'mempty'
--         ('decode' \"abc\" 'decodeDefault')
--         \"SELECT foo AS abc FROM t\"
--    :: ('DecodeDefault' x)
--    => 'Sq.Statement' 'Sq.Read' () x
-- @
--
-- Multiple 'Outputs's can be composed with 'Monoid', 'Functor', 'Applicative',
-- 'Alternative', 'Monad', 'MonadPlus', 'MonadFail' and 'Ex.MonadThrow' tools.
--
-- @
-- 'Sq.readStatement'
--         'mempty'
--         (do foo <- 'decode' \"foo\" 'decodeDefault'
--             'when' (foo > 10) do
--                'fail' \"Oh no!"
--             bar <- 'decode' \"bar\" 'decodeDefault'
--             'pure' (foo, bar))
--         \"SELECT foo, bar FROM t\"
--    :: ('DecodeDefault' y)
--    => 'Sq.Statement' 'Sq.Read' () ('Int', y)
-- @
--
-- Pro-tip: Consider using the 'IsString' instance for 'Output',
-- where for example @\"foo\"@ means @'decode' \"foo\" 'decodeDefault'@:
--
-- @
-- 'Sq.readStatement'
--         ('liftA2' (,) \"foo\" \"bar\")
--         'mempty'
--         \"SELECT foo, bar FROM t\"
--    :: ('DecodeDefault' x, 'DecodeDefault' y)
--    => 'Sq.Statement' 'Sq.Read' () (x, y)
-- @
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 #-}

-- | Add a prefix 'Name' to column names in the given 'Output',
-- separated by @\__@
--
-- This is useful for making reusable 'Output's. For example,
-- consider the following.
--
-- @
-- data Point = Point { x :: 'Int', y :: 'Int' }
--
-- pointOutput :: 'Output' Point
-- pointOutput = Point '<$>' \"x\" '<*>' \"y\"
-- @
--
-- After using 'output':
--
-- @
-- 'Sq.readStatement'
--         'mempty'
--         ('liftA2' ('output' \"p1\" pointInput)
--                 ('output' \"p2\" pointInput))
--         ['Sq.sql'|
--           SELECT ax AS p1\__x, ay AS p1\__y,
--                  bx AS p2\__x, by AS p2\__y
--           FROM vectors|]
--    :: 'Sq.Statement' 'Sq.Read' () (Point, Point)
-- @
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

-- | TODO cache names after lookup. Important for Alternative.
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 #-}