{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , RecordWildCards
           , NamedFieldPuns
           , OverloadedStrings
           , TemplateHaskell
           , QuasiQuotes
           , LambdaCase
           , ViewPatterns
           , FlexibleContexts
           , FlexibleInstances
           , MultiParamTypeClasses
           , TypeFamilies
           , ScopedTypeVariables
           , TupleSections
           , RankNTypes
  #-}

module Handler.Utils.Table.Pagination
  ( SortColumn(..), SortDirection(..)
  , FilterColumn(..), IsFilterColumn
  , DBRow(..), DBOutput
  , DBTable(..), IsDBTable(..)
  , PaginationSettings(..)
  , PSValidator(..)
  , defaultFilter, defaultSorting
  , restrictFilter, restrictSorting
  , ToSortable(..), Sortable(..), sortable
  , dbTable
  , widgetColonnade, formColonnade
  , textCell, stringCell, i18nCell, anchorCell
  , formCell, DBFormResult, getDBFormResult
  , dbRow, dbSelect
  ) where

import Handler.Utils.Table.Pagination.Types

import Import hiding (Proxy(..))
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
import qualified Database.Esqueleto.Internal.Language as E (From)
import Text.Blaze (Attribute)
import qualified Text.Blaze.Html5.Attributes as Html5
import qualified Text.Blaze.Html5 as Html5

import qualified Data.Binary.Builder as Builder

import qualified Network.Wai as Wai

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)

import Data.Map (Map, (!))
import qualified Data.Map as Map

import Data.Profunctor (lmap)

import Colonnade hiding (bool, fromMaybe, singleton)
import qualified Colonnade (singleton)
import Colonnade.Encode

import Text.Hamlet (hamletFile)

import Data.Ratio ((%))

import Control.Lens

import Data.Proxy


data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }

data SortDirection = SortAsc | SortDesc
  deriving (Eq, Ord, Enum, Show, Read)
instance PathPiece SortDirection where
  toPathPiece SortAsc  = "asc"
  toPathPiece SortDesc = "desc"
  fromPathPiece (CI.mk -> t)
    | t == "asc"  = Just SortAsc
    | t == "desc" = Just SortDesc
    | otherwise   = Nothing

sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t


data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a

filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
filterColumn (FilterColumn f) = filterColumn' f

class IsFilterColumn t a where
  filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)

instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
  filterColumn' fin _ _ = fin

instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
  filterColumn' cont is t = filterColumn' (cont t) is t

instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
  filterColumn' cont is t = filterColumn' (cont input) is' t
    where
      (input, ($ []) -> is') = go (mempty, id) is
      go acc [] = acc
      go (acc, is') (i:is)
        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
        | otherwise = go (acc, is' . (i:)) is


data DBRow r = DBRow
  { dbrOutput :: r
  , dbrIndex, dbrCount :: Int64
  } deriving (Show, Read, Eq, Ord)

class DBOutput r r' where
  dbProj :: r -> r'

instance DBOutput (DBRow r) (DBRow r) where
  dbProj = id
instance DBOutput (DBRow r) r where
  dbProj = dbrOutput
instance DBOutput (DBRow r) (Int64, r) where
  dbProj = (,) <$> dbrIndex <*> dbrOutput

data DBTable m x = forall a r r' h i t.
  ( ToSortable h, Functor h
  , E.SqlSelect a r, DBOutput (DBRow r) r'
  , PathPiece i
  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
  ) => DBTable
  { dbtSQLQuery :: t -> E.SqlQuery a
  , dbtColonnade :: Colonnade h r' (DBCell m x)
  , dbtSorting :: Map (CI Text) (SortColumn t)
  , dbtFilter :: Map (CI Text) (FilterColumn t)
  , dbtAttrs :: Attribute -- FIXME: currently unused
  , dbtIdent :: i
  }


data PaginationSettings = PaginationSettings
  { psSorting      :: [(CI Text, SortDirection)]
  , psFilter       :: Map (CI Text) [Text]
  , psLimit        :: Int64
  , psPage         :: Int64
  , psShortcircuit :: Bool
  }

instance Default PaginationSettings where
  def = PaginationSettings
    { psSorting      = []
    , psFilter       = Map.empty
    , psLimit        = 50
    , psPage         = 0
    , psShortcircuit = False
    }

newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }

instance Default (PSValidator m x) where
  def = PSValidator $ \DBTable{..} -> \case
    Nothing -> def
    Just ps -> swap . (\act -> execRWS act () ps) $ do
      l <- gets psLimit
      when (l <= 0) $ do
        modify $ \ps -> ps { psLimit = psLimit def }
        tell . pure $ SomeMessage MsgPSLimitNonPositive

defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
defaultFilter psFilter (runPSValidator -> f) = PSValidator g
  where
    g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
    g dbTable x = f dbTable x

defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
  where
    g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
    g dbTable x = f dbTable x

restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
  where
    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }

restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
  where
    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }

class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
  type DBResult m x :: *
  -- type DBResult' m x :: *

  data DBCell m x :: *
  cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
  cellContents :: DBCell m x -> WriterT x m Widget

  cell :: Widget -> DBCell m x

    
  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
  dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)

instance IsDBTable (WidgetT UniWorX IO) () where
  type DBResult (WidgetT UniWorX IO) () = Widget
  -- type DBResult' (WidgetT UniWorX IO) () = ()

  data DBCell (WidgetT UniWorX IO) () = WidgetCell
    { dbCellAttrs :: [(Text, Text)]
    , dbCellContents :: Widget
    }
  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
  cellContents = return . dbCellContents

  cell = WidgetCell []
  
  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
  dbWidget Proxy Proxy = return
  runDBTable = return . join . fmap (view _2)

instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
  -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)

  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
    { formCellAttrs :: [(Text, Text)]
    , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
    }
  cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
  cellContents = WriterT . fmap swap . formCellContents

  cell widget = FormCell [] $ return (mempty, widget)
  
  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
  dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
  runDBTable = return . withFragment

instance IsDBTable m a => IsString (DBCell m a) where
  fromString = cell . fromString
      

dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
  let
    sortingOptions = mkOptionList
      [ Option t' (t, d) t'
      | (t, _) <- mapToList dbtSorting
      , d <- [SortAsc, SortDesc]
      , let t' = CI.foldedCase t <> "-" <> toPathPiece d
      ]
    (_, defPS) = runPSValidator dbtable Nothing
    wIdent n
      | not $ null dbtIdent = dbtIdent <> "-" <> n
      | otherwise           = n
    dbtAttrs'
      | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
      | otherwise           = dbtAttrs
    multiTextField = Field
      { fieldParse = \ts _ -> return . Right $ Just ts
      , fieldView = undefined
      , fieldEnctype = UrlEncoded
      }
    
  psResult <- runInputGetResult $ PaginationSettings
    <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
    <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
    <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
    <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
    <*> ireq checkBoxField (wIdent "table-only")

  $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult)
                               <*> (Map.keys . psFilter <$> psResult)
                               <*> (psLimit <$> psResult)
                               <*> (psPage <$> psResult)
                               <*> (psShortcircuit <$> psResult)

  let
    (errs, PaginationSettings{..}) = case psResult of
      FormSuccess ps   -> runPSValidator dbtable $ Just ps
      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
      FormMissing      -> runPSValidator dbtable Nothing
    psSorting' = map (first (dbtSorting !)) psSorting
    sqlQuery' = E.from $ \t -> dbtSQLQuery t
      <* E.orderBy (map (sqlSortDirection t) psSorting')
      <* E.limit psLimit
      <* E.offset (psPage * psLimit)
      <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter

  mapM_ (addMessageI "warning") errs

  rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'

  let
    rowCount
      | ((_, E.Value n), _):_ <- rows' = n
      | otherwise = 0
    rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows'

    table' :: WriterT x m Widget
    table' = do
      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest

      let
        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams

        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
          widget <- cellContents sortableContent
          let
            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
            isSortable = isJust sortableKey
            isSorted = (`elem` directions)
            attrs = sortableContent ^. cellAttrs
          return $(widgetFile "table/cell/header")

        columnCount :: Int64
        columnCount = olength64 $ getColonnade dbtColonnade

      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable

      wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
        widget <- cellContents cell
        let attrs = cell ^. cellAttrs
        return $(widgetFile "table/cell/body")
      
      let table = $(widgetFile "table/colonnade")
          pageCount = max 1 . ceiling $ rowCount % psLimit
          pageNumbers = [0..pred pageCount]

      return $(widgetFile "table/layout")

    dbWidget' :: DBResult m x -> Handler Widget
    dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)

  bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
  where
    tblLayout :: Widget -> Handler Html
    tblLayout tbl' = do
      tbl <- widgetToPageContent tbl'
      withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")

    setParam :: Text -> Maybe Text -> QueryText -> QueryText
    setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]

--- DBCell utility functions

widgetColonnade :: Headedness h
                => Colonnade h r (DBCell (WidgetT UniWorX IO) ())
                -> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
widgetColonnade = id

formColonnade :: (Headedness h, Monoid a)
              => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
formColonnade = id

textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
stringCell = textCell
i18nCell = textCell
textCell msg = cell [whamlet|_{msg}|]

anchorCell :: IsDBTable m a
           => (r -> Route UniWorX)
           -> (r -> Widget)
           -> (r -> DBCell m a)
anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
  where
    route = mkRoute val
    widget = mkWidget val

newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))

instance Ord i => Monoid (DBFormResult r i a) where
  mempty = DBFormResult Map.empty
  (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2

getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m

formCell :: forall r i a. Ord i
         => (r -> MForm (HandlerT UniWorX IO) i)
         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
         -> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
formCell genIndex genForm input = FormCell
  { formCellAttrs    = []
  , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
      i <- genIndex input
      (edit, w) <- genForm input i
      return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
  }

-- Predefined colonnades

dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex

dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
         => Setter' a Bool
         -> (r -> MForm (HandlerT UniWorX IO) i)
         -> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
  return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])