{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Handler.Allocation.List
  ( getAllocationListR
  ) where

import Import

import Utils.Course (mayViewCourse)
  
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Pagination


type AllocationTableExpr = E.SqlExpr (Entity Allocation)
type AllocationTableData = DBRow (Entity Allocation, Natural, Natural)

allocationListIdent :: Text
allocationListIdent = "allocations"

queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
queryAllocation = id


countCourses :: (Num n, PersistField n)
             => Maybe UserId -> AuthTagActive -> UTCTime
             -> (E.SqlExpr (Entity AllocationCourse) -> E.SqlExpr (E.Value Bool)) 
             -> E.SqlExpr (Entity Allocation)
             -> E.SqlExpr (E.Value n)
countCourses muid ata now addWhere allocation = E.subSelectCount . E.from $ \allocationCourse ->
  E.where_ $ allocationCourse E.^. AllocationCourseAllocation E.==. allocation E.^. AllocationId
       E.&&. E.exists (E.from $ \course -> E.where_ $ 
           course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse 
           E.&&. mayViewCourse muid ata now course (Just (allocation E.^. AllocationId))
       ) E.&&. addWhere allocationCourse
  
queryAvailable :: Maybe UserId -> AuthTagActive -> UTCTime
               -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
queryAvailable muid ata now = queryAllocation . to (countCourses muid ata now $ const E.true)
  
queryApplied :: AuthTagActive -> UTCTime -> UserId -> Getter AllocationTableExpr (E.SqlExpr (E.Value Natural))
queryApplied ata now uid = queryAllocation . to (\allocation -> countCourses (Just uid) ata now (addWhere allocation) allocation)
  where
    addWhere allocation allocationCourse
      = E.exists . E.from $ \courseApplication ->
          E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. allocationCourse E.^. AllocationCourseCourse
               E.&&. courseApplication E.^. CourseApplicationAllocation E.==. E.just (allocation E.^. AllocationId)
               E.&&. courseApplication E.^. CourseApplicationUser E.==. E.val uid

resultAllocation :: Lens' AllocationTableData (Entity Allocation)
resultAllocation = _dbrOutput . _1

resultAvailable, resultApplied :: Lens' AllocationTableData Natural
resultAvailable = _dbrOutput . _2
resultApplied = _dbrOutput . _3

allocationTermLink :: TermId -> SomeRoute UniWorX
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])

allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])

allocationLink :: Allocation -> SomeRoute UniWorX
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR

getAllocationListR :: Handler Html
getAllocationListR = do
  muid <- maybeAuthId
  ata <- getSessionActiveAuthTags
  now <- liftIO getCurrentTime
  let
    dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
    dbtSQLQuery = runReaderT $ (,,)
                    <$> view queryAllocation
                    <*> view (queryAvailable muid ata now)
                    <*> view (maybe (to . const $ E.val 0) (queryApplied ata now) muid)

    dbtProj :: DBRow _ -> DB AllocationTableData
    dbtProj = return . over (_dbrOutput . _2) E.unValue . over (_dbrOutput . _3) E.unValue

    dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)

    dbtColonnade :: Colonnade Sortable _ _
    dbtColonnade = mconcat
      [ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
      , anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
      , anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
      , sortable (Just "available") (i18nCell MsgAllocationAvailableCourses) $ views resultAvailable i18nCell
      , if
          | Just _ <- muid
            -> sortable (Just "applied") (i18nCell MsgAllocationAppliedCourses) . views resultApplied $ maybe mempty i18nCell . assertM' (> 0)
          | otherwise
            -> mempty
      ]

    dbtSorting = mconcat
      [ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
      , sortSchoolShort $ queryAllocation . to (E.^. AllocationSchool)
      , sortAllocationName $ queryAllocation . to (E.^. AllocationName)
      , singletonMap "available" . SortColumn $ view (queryAvailable muid ata now)
      , if
          | Just uid <- muid
            -> singletonMap "applied" . SortColumn . view $ queryApplied ata now uid
          | otherwise
            -> mempty
      ]

    dbtFilter = mconcat
      [ fltrAllocationActive now queryAllocation
      , fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
      , fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
      , fltrAllocation queryAllocation
      ]
    dbtFilterUI = mconcat
      [ fltrAllocationActiveUI
      , fltrTermUI
      , fltrSchoolUI
      , fltrAllocationUI
      ]

    dbtStyle = def
      { dbsFilterLayout = defaultDBSFilterLayout
      }
    dbtParams = def

    dbtCsvEncode = noCsvEncode
    dbtCsvDecode = Nothing

    dbtIdent = allocationListIdent

    psValidator :: PSValidator _ _
    psValidator = def
      & defaultSorting [SortDescBy "term", SortAscBy "school-short", SortAscBy "allocation"]

  table <- runDB $ dbTableWidget' psValidator DBTable{..}

  siteLayoutMsg MsgAllocationListTitle $ do
    setTitleI MsgAllocationListTitle
    table