{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Handler.Utils.Table.Pagination.Types
  ( FilterKey, SortingKey
  , Sortable(..)
  , sortable
  , ToSortable(..)
  , SortableP(..)
  , SqlIn(..)
  , sqlInTuples
  , DBTableInvalid(..)
  ) where

import Import hiding (singleton)

import Colonnade
import Colonnade.Encode

import Data.CaseInsensitive (CI)

import Data.Aeson (FromJSON, ToJSON, FromJSONKey, ToJSONKey)

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

import Language.Haskell.TH

import Data.List (foldr1, foldl)


newtype FilterKey = FilterKey { _unFilterKey :: CI Text }
  deriving (Show, Read, Generic)
  deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
newtype SortingKey = SortingKey { _unSortingKey :: CI Text }
  deriving (Show, Read, Generic)
  deriving newtype (Ord, Eq, PathPiece, IsString, FromJSON, ToJSON, FromJSONKey, ToJSONKey)


data Sortable a = Sortable
  { sortableKey :: Maybe SortingKey
  , sortableContent :: a
  }

sortable :: Maybe SortingKey -> c -> (a -> c) -> Colonnade Sortable a c
sortable k h = singleton (Sortable k h)

instance Headedness Sortable where
  headednessPure = Sortable Nothing
  headednessExtract = Just $ \(Sortable _ x) -> x
  headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x)

instance Functor Sortable where
  fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. }
                                                 
newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}

class Headedness s => ToSortable s where
  pSortable :: Maybe (SortableP s)

instance ToSortable Sortable where
  pSortable = Just $ SortableP id

instance ToSortable Headed where
  pSortable = Just $ SortableP (\(Headed x) -> Sortable Nothing x)

instance ToSortable Headless where
  pSortable = Nothing


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


data DBTableInvalid = DBTIRowsMissing Int
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Exception DBTableInvalid

embedRenderMessage ''UniWorX ''DBTableInvalid id
