{-# LANGUAGE UndecidableInstances #-}

module Database.Esqueleto.Utils.TH
  ( SqlIn(..)
  , sqlInTuple, sqlInTuples
  , unValueN, unValueNIs
  , sqlIJproj, sqlLOJproj, sqlFOJproj
  ) 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 SqlEq a => SqlIn (E.SqlExpr (E.Value a)) (E.Value a) where
  sqlIn x = foldr (\x' e -> e E.||. sqlEq (E.val $ E.unValue x') x) (E.val False)

class PersistField a => SqlEq a where
  sqlEq :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Bool)

instance {-# OVERLAPPABLE #-} PersistField a => SqlEq a where
  sqlEq = (E.==.)

instance PersistField a => SqlEq (Maybe a) where
  sqlEq a b = (E.isNothing a E.&&. E.isNothing b) E.||. a E.==. b

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)|]) $ zipWith (\(varE -> vE) (varE -> xE) -> [e|E.val $(vE) `sqlEq` $(xE)|]) vVs xVs)
    tupTy f = foldl (\typ v -> typ `appT` f (varT v)) (tupleT arity) tyVars

  instanceD (cxt $ map (\v -> [t|SqlEq $(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

sqlFOJproj :: Int -> Int -> ExpQ
sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin