{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}

module Opaleye.SQLite.Internal.Values where

import qualified Opaleye.SQLite.PGTypes as T

import           Opaleye.SQLite.Internal.Column (Column(Column))
import qualified Opaleye.SQLite.Internal.Unpackspec as U
import qualified Opaleye.SQLite.Internal.Tag as T
import qualified Opaleye.SQLite.Internal.PrimQuery as PQ
import qualified Opaleye.SQLite.Internal.PackMap as PM
import qualified Opaleye.SQLite.Internal.HaskellDB.PrimQuery as HPQ

import           Data.Profunctor (Profunctor, dimap, rmap)
import           Data.Profunctor.Product (ProductProfunctor, empty, (***!))
import qualified Data.Profunctor.Product as PP
import           Data.Profunctor.Product.Default (Default, def)

import           Control.Applicative (Applicative, pure, (<*>))

-- There are two annoyances with creating SQL VALUES statements
--
-- 1. SQL does not allow empty VALUES statements so if we want to
--    create a VALUES statement from an empty list we have to fake it
--    somehow.  The current approach is to make a VALUES statement
--    with a single row of NULLs and then restrict it with WHERE
--    FALSE.

-- 2. Postgres's type inference of constants is pretty poor so we will
--    sometimes have to give explicit type signatures.  The future
--    ShowConstant class will have the same problem.  NB We don't
--    actually currently address this problem.

valuesU :: U.Unpackspec columns columns'
        -> Valuesspec columns columns'
        -> [columns]
        -> ((), T.Tag) -> (columns', PQ.PrimQuery, T.Tag)
valuesU :: Unpackspec columns columns'
-> Valuesspec columns columns'
-> [columns]
-> ((), Tag)
-> (columns', PrimQuery, Tag)
valuesU Unpackspec columns columns'
unpack Valuesspec columns columns'
valuesspec [columns]
rows ((), Tag
t) = (columns'
newColumns, PrimQuery
primQ', Tag -> Tag
T.next Tag
t)
  where runRow :: columns -> [PrimExpr]
runRow columns
row = [PrimExpr]
valuesRow
           where (columns'
_, [PrimExpr]
valuesRow) =
                   PM [PrimExpr] columns' -> (columns', [PrimExpr])
forall a r. PM [a] r -> (r, [a])
PM.run (Unpackspec columns columns'
-> (PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr)
-> columns
-> PM [PrimExpr] columns'
forall (f :: * -> *) columns b.
Applicative f =>
Unpackspec columns b -> (PrimExpr -> f PrimExpr) -> columns -> f b
U.runUnpackspec Unpackspec columns columns'
unpack PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr
extractValuesEntry columns
row)

        (columns'
newColumns, [(Symbol, PrimExpr)]
valuesPEs_nulls) =
          PM [(Symbol, PrimExpr)] columns'
-> (columns', [(Symbol, PrimExpr)])
forall a r. PM [a] r -> (r, [a])
PM.run (Valuesspec columns columns'
-> (PrimExpr
    -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr)
-> PM [(Symbol, PrimExpr)] columns'
forall (f :: * -> *) columns columns'.
Applicative f =>
Valuesspec columns columns'
-> (PrimExpr -> f PrimExpr) -> f columns'
runValuesspec Valuesspec columns columns'
valuesspec (Tag
-> PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractValuesField Tag
t))

        valuesPEs :: [Symbol]
valuesPEs = ((Symbol, PrimExpr) -> Symbol) -> [(Symbol, PrimExpr)] -> [Symbol]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> Symbol
forall a b. (a, b) -> a
fst [(Symbol, PrimExpr)]
valuesPEs_nulls
        nulls :: [PrimExpr]
nulls = ((Symbol, PrimExpr) -> PrimExpr)
-> [(Symbol, PrimExpr)] -> [PrimExpr]
forall a b. (a -> b) -> [a] -> [b]
map (Symbol, PrimExpr) -> PrimExpr
forall a b. (a, b) -> b
snd [(Symbol, PrimExpr)]
valuesPEs_nulls

        yieldNoRows :: PQ.PrimQuery -> PQ.PrimQuery
        yieldNoRows :: PrimQuery -> PrimQuery
yieldNoRows = PrimExpr -> PrimQuery -> PrimQuery
PQ.restrict (Literal -> PrimExpr
HPQ.ConstExpr (Bool -> Literal
HPQ.BoolLit Bool
False))

        values' :: [[HPQ.PrimExpr]]
        ([[PrimExpr]]
values', PrimQuery -> PrimQuery
wrap) = if [columns] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [columns]
rows
                          then ([[PrimExpr]
nulls], PrimQuery -> PrimQuery
yieldNoRows)
                          else ((columns -> [PrimExpr]) -> [columns] -> [[PrimExpr]]
forall a b. (a -> b) -> [a] -> [b]
map columns -> [PrimExpr]
runRow [columns]
rows, PrimQuery -> PrimQuery
forall a. a -> a
id)

        primQ' :: PrimQuery
primQ' = PrimQuery -> PrimQuery
wrap ([Symbol] -> [[PrimExpr]] -> PrimQuery
PQ.Values [Symbol]
valuesPEs [[PrimExpr]]
values')

-- We don't actually use the return value of this.  It might be better
-- to come up with another Applicative instance for specifically doing
-- what we need.
extractValuesEntry :: HPQ.PrimExpr -> PM.PM [HPQ.PrimExpr] HPQ.PrimExpr
extractValuesEntry :: PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr
extractValuesEntry PrimExpr
pe = do
  PrimExpr -> PM [PrimExpr] ()
forall a. a -> PM [a] ()
PM.write PrimExpr
pe
  PrimExpr -> StateT ([PrimExpr], Int) Identity PrimExpr
forall (m :: * -> *) a. Monad m => a -> m a
return PrimExpr
pe

extractValuesField :: T.Tag -> HPQ.PrimExpr
                   -> PM.PM [(HPQ.Symbol, HPQ.PrimExpr)] HPQ.PrimExpr
extractValuesField :: Tag
-> PrimExpr -> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
extractValuesField = String
-> Tag
-> PrimExpr
-> StateT ([(Symbol, PrimExpr)], Int) Identity PrimExpr
forall primExpr.
String -> Tag -> primExpr -> PM [(Symbol, primExpr)] PrimExpr
PM.extractAttr String
"values"

newtype Valuesspec columns columns' =
  Valuesspec (PM.PackMap HPQ.PrimExpr HPQ.PrimExpr () columns')

runValuesspec :: Applicative f => Valuesspec columns columns'
              -> (HPQ.PrimExpr -> f HPQ.PrimExpr) -> f columns'
runValuesspec :: Valuesspec columns columns'
-> (PrimExpr -> f PrimExpr) -> f columns'
runValuesspec (Valuesspec PackMap PrimExpr PrimExpr () columns'
v) PrimExpr -> f PrimExpr
f = PackMap PrimExpr PrimExpr () columns'
-> (PrimExpr -> f PrimExpr) -> () -> f columns'
forall (f :: * -> *) a b s t.
Applicative f =>
PackMap a b s t -> (a -> f b) -> s -> f t
PM.traversePM PackMap PrimExpr PrimExpr () columns'
v PrimExpr -> f PrimExpr
f ()

instance Default Valuesspec (Column T.PGInt4) (Column T.PGInt4) where
  def :: Valuesspec (Column PGInt4) (Column PGInt4)
def = PackMap PrimExpr PrimExpr () (Column PGInt4)
-> Valuesspec (Column PGInt4) (Column PGInt4)
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((forall (f :: * -> *).
 Applicative f =>
 (PrimExpr -> f PrimExpr) -> () -> f (Column PGInt4))
-> PackMap PrimExpr PrimExpr () (Column PGInt4)
forall a b s t.
(forall (f :: * -> *). Applicative f => (a -> f b) -> s -> f t)
-> PackMap a b s t
PM.PackMap (\PrimExpr -> f PrimExpr
f () -> (PrimExpr -> Column PGInt4) -> f PrimExpr -> f (Column PGInt4)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PrimExpr -> Column PGInt4
forall a. PrimExpr -> Column a
Column (PrimExpr -> f PrimExpr
f (Literal -> PrimExpr
HPQ.ConstExpr Literal
HPQ.NullLit))))

-- {

-- Boilerplate instance definitions.  Theoretically, these are derivable.

instance Functor (Valuesspec a) where
  fmap :: (a -> b) -> Valuesspec a a -> Valuesspec a b
fmap a -> b
f (Valuesspec PackMap PrimExpr PrimExpr () a
g) = PackMap PrimExpr PrimExpr () b -> Valuesspec a b
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((a -> b)
-> PackMap PrimExpr PrimExpr () a -> PackMap PrimExpr PrimExpr () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f PackMap PrimExpr PrimExpr () a
g)

instance Applicative (Valuesspec a) where
  pure :: a -> Valuesspec a a
pure = PackMap PrimExpr PrimExpr () a -> Valuesspec a a
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec (PackMap PrimExpr PrimExpr () a -> Valuesspec a a)
-> (a -> PackMap PrimExpr PrimExpr () a) -> a -> Valuesspec a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PackMap PrimExpr PrimExpr () a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Valuesspec PackMap PrimExpr PrimExpr () (a -> b)
f <*> :: Valuesspec a (a -> b) -> Valuesspec a a -> Valuesspec a b
<*> Valuesspec PackMap PrimExpr PrimExpr () a
x = PackMap PrimExpr PrimExpr () b -> Valuesspec a b
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec (PackMap PrimExpr PrimExpr () (a -> b)
f PackMap PrimExpr PrimExpr () (a -> b)
-> PackMap PrimExpr PrimExpr () a -> PackMap PrimExpr PrimExpr () b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PackMap PrimExpr PrimExpr () a
x)

instance Profunctor Valuesspec where
  dimap :: (a -> b) -> (c -> d) -> Valuesspec b c -> Valuesspec a d
dimap a -> b
_ c -> d
g (Valuesspec PackMap PrimExpr PrimExpr () c
q) = PackMap PrimExpr PrimExpr () d -> Valuesspec a d
forall columns columns'.
PackMap PrimExpr PrimExpr () columns'
-> Valuesspec columns columns'
Valuesspec ((c -> d)
-> PackMap PrimExpr PrimExpr () c -> PackMap PrimExpr PrimExpr () d
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap c -> d
g PackMap PrimExpr PrimExpr () c
q)

instance ProductProfunctor Valuesspec where
  empty :: Valuesspec () ()
empty = Valuesspec () ()
forall (p :: * -> * -> *). Applicative (p ()) => p () ()
PP.defaultEmpty
  ***! :: Valuesspec a b -> Valuesspec a' b' -> Valuesspec (a, a') (b, b')
(***!) = Valuesspec a b -> Valuesspec a' b' -> Valuesspec (a, a') (b, b')
forall (p :: * -> * -> *) a a' b b'.
(Applicative (p (a, a')), Profunctor p) =>
p a b -> p a' b' -> p (a, a') (b, b')
PP.defaultProfunctorProduct

-- }