-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE UndecidableInstances #-}

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

import ClassyPrelude

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

import Database.Persist (PersistField)

import Language.Haskell.TH

import Data.List (foldr1, foldl)

import Utils.TH
import Control.Lens.Iso (Iso', iso)

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)|]
          ]
        ) []
      ]
    ]


_unValue :: Iso' (E.Value v) v
_unValue = iso E.unValue E.Value

-- | 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.
--
--   > $(sqlIJproj 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

-- | Generic projections for Join-tuple
--   gives i-th element of n-tuple of left-associative join pairs, i.e.
--
--   > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3
sqlMIXproj :: String -> Int -> ExpQ
sqlMIXproj = leftAssociativeProjection . map decodeJoin
  where
    decodeJoin 'I' = 'E.InnerJoin
    decodeJoin 'L' = 'E.LeftOuterJoin
    decodeJoin 'R' = 'E.RightOuterJoin
    decodeJoin 'F' = 'E.FullOuterJoin
    decodeJoin 'O' = 'E.FullOuterJoin
    decodeJoin 'X' = 'E.CrossJoin
    decodeJoin 'C' = 'E.CrossJoin
    decodeJoin  c  = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\""  -- always raised at compile time, so this is ok

--  Alternative using `refiy`, but impractical due to TH staging restrictions
--    and currently confuses type and expression constructors somehow
sqlMIXproj' :: Name -> Int -> ExpQ
sqlMIXproj' t i = do
  ns <- extractConstructorNames t
  -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors
  leftAssociativeProjection ns i