module Database.Esqueleto.Utils.TH
  ( SqlIn(..)
  , sqlInTuple, sqlInTuples
  , unValueN, unValueNIs
  , sqlIJproj, sqlLOJproj
  ) where

import ClassyPrelude

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)

import Database.Persist (PersistField)

import Language.Haskell.TH

import Data.List (foldr1, foldl)

import Utils.TH

class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
  sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)

instance PersistField a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
  x `sqlIn` xs = x `E.in_` E.valList (map E.unValue xs)

sqlInTuples :: [Int] -> DecsQ
sqlInTuples = mapM sqlInTuple

sqlInTuple :: Int -> DecQ
sqlInTuple arity = do
  tyVars <- replicateM arity $ newName "t"
  vVs <- replicateM arity $ newName "v"
  xVs <- replicateM arity $ newName "x"
  xsV <- newName "xs"

  let
    matchE = lam1E (tupP $ map (\vV -> conP 'E.Value [varP vV]) vVs) (foldr1 (\e1 e2 -> [e|$(e1) E.&&. $(e2)|]) . map (\(varE -> vE, varE -> xE) -> [e|E.val $(vE) E.==. $(xE)|]) $ zip vVs xVs)
    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars

  instanceD (cxt $ map (\v -> [t|PersistField $(varT v)|]) tyVars) [t|SqlIn $(tupTy $ \v -> [t|E.SqlExpr (E.Value $(v))|]) $(tupTy $ \v -> [t|E.Value $(v)|])|]
    [ funD 'sqlIn
      [ clause [tupP $ map varP xVs, varP xsV]
        ( guardedB
          [ normalGE [e|null $(varE xsV)|] [e|E.val False|]
          , normalGE [e|otherwise|] [e|foldr1 (E.||.) $ map $(matchE) $(varE xsV)|]
          ]
        ) []
      ]
    ]

-- | Generic unValuing of Tuples of Values, i.e.
--
--   > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
unValueN :: Int -> ExpQ
unValueN arity = do
    vs <- replicateM arity $ newName "v"
    let pat = tupP $ map varP vs
    let uvE v = [e|E.unValue $(varE v)|]
    let rhs = tupE $ map uvE vs
    lam1E pat rhs

-- | Generic unValuing of certain indices of a Tuple, i.e.
--
--   > $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
unValueNIs :: Int -> [Int] -> ExpQ
unValueNIs arity uvIdx = do
    vs <- replicateM arity $ newName "v"
    let pat = tupP $ map varP vs
    let rhs = tupE $ zipWith (curry uvEi) vs [1 ..]
    lam1E pat rhs
  where
    uvEi (v,i) | i `elem` uvIdx = [e|E.unValue $(varE v)|]
               | otherwise      = varE v



-- | Generic projections for InnerJoin-tuples
--   gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
--
--   > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
sqlIJproj :: Int -> Int -> ExpQ
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin

sqlLOJproj :: Int -> Int -> ExpQ
sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin
