{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoFieldSelectors #-}

module Sq.Statement
   ( SQL
   , sql
   , Statement (..)
   , readStatement
   , writeStatement
   , BoundStatement (..)
   , bindStatement
   ) where

import Control.DeepSeq
import Control.Monad
import Data.Coerce
import Data.Functor.Contravariant
import Data.Profunctor
import Data.String
import Data.Text qualified as T
import Di.Df1 qualified as Di
import GHC.Records
import GHC.Show
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Prelude hiding (Read, log)

import Sq.Input
import Sq.Mode
import Sq.Output

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

-- | Raw SQL string. Completely unchecked.
newtype SQL = SQL T.Text
   deriving newtype
      ( SQL -> SQL -> Bool
(SQL -> SQL -> Bool) -> (SQL -> SQL -> Bool) -> Eq SQL
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SQL -> SQL -> Bool
== :: SQL -> SQL -> Bool
$c/= :: SQL -> SQL -> Bool
/= :: SQL -> SQL -> Bool
Eq
      , Eq SQL
Eq SQL =>
(SQL -> SQL -> Ordering)
-> (SQL -> SQL -> Bool)
-> (SQL -> SQL -> Bool)
-> (SQL -> SQL -> Bool)
-> (SQL -> SQL -> Bool)
-> (SQL -> SQL -> SQL)
-> (SQL -> SQL -> SQL)
-> Ord SQL
SQL -> SQL -> Bool
SQL -> SQL -> Ordering
SQL -> SQL -> SQL
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SQL -> SQL -> Ordering
compare :: SQL -> SQL -> Ordering
$c< :: SQL -> SQL -> Bool
< :: SQL -> SQL -> Bool
$c<= :: SQL -> SQL -> Bool
<= :: SQL -> SQL -> Bool
$c> :: SQL -> SQL -> Bool
> :: SQL -> SQL -> Bool
$c>= :: SQL -> SQL -> Bool
>= :: SQL -> SQL -> Bool
$cmax :: SQL -> SQL -> SQL
max :: SQL -> SQL -> SQL
$cmin :: SQL -> SQL -> SQL
min :: SQL -> SQL -> SQL
Ord
      , -- | Raw SQL string.
        Int -> SQL -> ShowS
[SQL] -> ShowS
SQL -> String
(Int -> SQL -> ShowS)
-> (SQL -> String) -> ([SQL] -> ShowS) -> Show SQL
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SQL -> ShowS
showsPrec :: Int -> SQL -> ShowS
$cshow :: SQL -> String
show :: SQL -> String
$cshowList :: [SQL] -> ShowS
showList :: [SQL] -> ShowS
Show
      , String -> SQL
(String -> SQL) -> IsString SQL
forall a. (String -> a) -> IsString a
$cfromString :: String -> SQL
fromString :: String -> SQL
IsString
      , NonEmpty SQL -> SQL
SQL -> SQL -> SQL
(SQL -> SQL -> SQL)
-> (NonEmpty SQL -> SQL)
-> (forall b. Integral b => b -> SQL -> SQL)
-> Semigroup SQL
forall b. Integral b => b -> SQL -> SQL
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: SQL -> SQL -> SQL
<> :: SQL -> SQL -> SQL
$csconcat :: NonEmpty SQL -> SQL
sconcat :: NonEmpty SQL -> SQL
$cstimes :: forall b. Integral b => b -> SQL -> SQL
stimes :: forall b. Integral b => b -> SQL -> SQL
Semigroup
      , SQL -> ()
(SQL -> ()) -> NFData SQL
forall a. (a -> ()) -> NFData a
$crnf :: SQL -> ()
rnf :: SQL -> ()
NFData
      )

instance Di.ToMessage SQL where
   message :: SQL -> Message
message = String -> Message
forall a. ToMessage a => a -> Message
Di.message (String -> Message) -> (SQL -> String) -> SQL -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> String
forall a. Show a => a -> String
show

-- | Raw SQL string as 'T.Text'.
instance HasField "text" SQL T.Text where getField :: SQL -> Text
getField = SQL -> Text
forall a b. Coercible a b => a -> b
coerce

-- | A 'QuasiQuoter' for raw SQL strings.
--
-- __WARNING:__ This doesn't check the validity of the SQL. It is offered simply
-- because writing multi-line strings in Haskell is otherwise very annoying.
sql :: QuasiQuoter
sql :: QuasiQuoter
sql =
   QuasiQuoter
      { quoteExp :: String -> Q Exp
quoteExp = \String
s -> [|fromString @SQL s|]
      , quotePat :: String -> Q Pat
quotePat = \String
_ -> String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sql: No quotePat"
      , quoteType :: String -> Q Type
quoteType = \String
_ -> String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sql: No quoteType"
      , quoteDec :: String -> Q [Dec]
quoteDec = \String
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"sql: No quoteDec"
      }

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

-- | * A SQL statement taking a value @i@ as input and producing rows of
-- @o@ values as output.
--
-- * @s@ indicates whether the statement is 'Read'-only or read-'Write'.
--
-- * Construct with 'readStatement' or 'writeStatement'.

-- Note: We don't export this constructor because 'readStatement' and
-- 'writeStatement' because it lead to better type inferrence, force users to
-- make a conscious choice about whether they are dealing with a 'Read' or
-- 'Write' statement, and prevent type system from accidentally inferring a
-- 'Write' mode for a 'Read' only statement, which would restrict its
-- usability.
data Statement (s :: Mode) i o = Statement
   { forall (s :: Mode) i o. Statement s i o -> Input i
input :: Input i
   , forall (s :: Mode) i o. Statement s i o -> Output o
output :: Output o
   , forall (s :: Mode) i o. Statement s i o -> SQL
sql :: SQL
   }

instance Show (Statement s i o) where
   showsPrec :: Int -> Statement s i o -> ShowS
showsPrec Int
n Statement s i o
s =
      Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
         String -> ShowS
showString String
"Statement{sql = "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> ShowS
forall a. Show a => a -> ShowS
shows Statement s i o
s.sql
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", input = .., output = ..}"

-- | Construct a 'Read'-only 'Statement'.
--
-- __WARNING__: This library doesn't __yet__ provide a safe way to construct
-- 'Statement's. You can potentially write anything in your 'SQL' string.
-- Don't do that.
--
-- * The 'SQL' must be read-only.
--
-- * The 'SQL' must contain a single statement.
--
-- * The 'SQL' must not contain any transaction nor savepoint management
-- statements.
readStatement :: Input i -> Output o -> SQL -> Statement 'Read i o
readStatement :: forall i o. Input i -> Output o -> SQL -> Statement 'Read i o
readStatement = Input i -> Output o -> SQL -> Statement 'Read i o
forall (s :: Mode) i o.
Input i -> Output o -> SQL -> Statement s i o
Statement
{-# INLINE readStatement #-}

-- | Construct a 'Statement' that can only be executed as part of a 'Write'
-- 'Transaction'.
--
-- __WARNING__: This library doesn't __yet__ provide a safe way to construct
-- 'Statement's. You can potentially write anything in your 'SQL' string.
-- Don't do that.
--
-- * The 'SQL' must contain a single statement.
--
-- * The 'SQL' must not contain any transaction nor savepoint management
-- statements.
writeStatement :: Input i -> Output o -> SQL -> Statement 'Write i o
writeStatement :: forall i o. Input i -> Output o -> SQL -> Statement 'Write i o
writeStatement = Input i -> Output o -> SQL -> Statement 'Write i o
forall (s :: Mode) i o.
Input i -> Output o -> SQL -> Statement s i o
Statement
{-# INLINE writeStatement #-}

instance Functor (Statement s i) where
   fmap :: forall a b. (a -> b) -> Statement s i a -> Statement s i b
fmap = (a -> b) -> Statement s i a -> Statement s i b
forall b c a. (b -> c) -> Statement s a b -> Statement s a c
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap
   {-# INLINE fmap #-}

instance Profunctor (Statement s) where
   dimap :: forall a b c d.
(a -> b) -> (c -> d) -> Statement s b c -> Statement s a d
dimap a -> b
f c -> d
g (Statement Input b
i Output c
o SQL
s) = Input a -> Output d -> SQL -> Statement s a d
forall (s :: Mode) i o.
Input i -> Output o -> SQL -> Statement s i o
Statement (a -> b
f (a -> b) -> Input b -> Input a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Input b
i) (c -> d
g (c -> d) -> Output c -> Output d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Output c
o) SQL
s
   {-# INLINE dimap #-}

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

data BoundStatement (s :: Mode) o = BoundStatement
   { forall (s :: Mode) o. BoundStatement s o -> BoundInput
input :: BoundInput
   , forall (s :: Mode) o. BoundStatement s o -> Output o
output :: Output o
   , forall (s :: Mode) o. BoundStatement s o -> SQL
sql :: SQL
   }

instance Show (BoundStatement s o) where
   showsPrec :: Int -> BoundStatement s o -> ShowS
showsPrec Int
n BoundStatement s o
s =
      Bool -> ShowS -> ShowS
showParen (Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
appPrec1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
         String -> ShowS
showString String
"Statement{sql = "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SQL -> ShowS
forall a. Show a => a -> ShowS
shows BoundStatement s o
s.sql
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", input = "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BoundInput -> ShowS
forall a. Show a => a -> ShowS
shows BoundStatement s o
s.input
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", output = ..}"

bindStatement :: Statement s i o -> i -> Either ErrInput (BoundStatement s o)
bindStatement :: forall (s :: Mode) i o.
Statement s i o -> i -> Either ErrInput (BoundStatement s o)
bindStatement Statement s i o
st i
i = do
   BoundInput
bi <- Input i -> i -> Either ErrInput BoundInput
forall i. Input i -> i -> Either ErrInput BoundInput
bindInput Statement s i o
st.input i
i
   BoundStatement s o -> Either ErrInput (BoundStatement s o)
forall a. a -> Either ErrInput a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BoundStatement{input :: BoundInput
input = BoundInput
bi, output :: Output o
output = Statement s i o
st.output, sql :: SQL
sql = Statement s i o
st.sql}
{-# INLINE bindStatement #-}