{-# OPTIONS_GHC -fno-warn-redundant-constraints -fno-warn-incomplete-uni-patterns #-}
module Handler.Participants
  ( getParticipantsListR
  , getParticipantsR
  , getParticipantsIntersectR, postParticipantsIntersectR
  ) where

import Import
import Handler.Utils

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E

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

import Handler.Utils.Csv

import qualified Data.Csv as Csv

import qualified Data.Conduit.List as C


data ParticipantEntry = ParticipantEntry
  { peCourse :: CourseName
  , peEmail  :: UserEmail
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance ToNamedRecord ParticipantEntry where
  toNamedRecord ParticipantEntry{..} = Csv.namedRecord
    [ "course" Csv..= peCourse
    , "email" Csv..= peEmail
    ]

instance DefaultOrdered ParticipantEntry where
  headerOrder _ = Csv.header ["course", "email"]


getParticipantsListR :: Handler Html
getParticipantsListR = do
  schoolTerms'' <- runDB . E.select . E.from $ \(school `E.InnerJoin` term) -> do
    E.on E.true

    E.where_ . E.exists . E.from $ \(course `E.InnerJoin` participant) -> do
      E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
      E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
           E.&&. course E.^. CourseSchool E.==. school E.^. SchoolId
      E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive

    return (school E.^. SchoolId, term E.^. TermId)

  schoolTerms' <- flip filterM schoolTerms'' $ \(E.Value ssh, E.Value tid) ->
    hasReadAccessTo $ ParticipantsR tid ssh

  let schoolTerms :: Set (SchoolId, TermId)
      schoolTerms = setOf (folded . $(multifocusG 2) (_1 . _Value) (_2 . _Value)) schoolTerms'

  siteLayoutMsg MsgParticipantsList $ do
    setTitleI MsgParticipantsList

    let schools :: Set SchoolId
        schools = Set.map (view _1) schoolTerms
        terms   :: Set TermId
        terms   = Set.map (view _2) schoolTerms
    $(widgetFile "participants-list")

getParticipantsR :: TermId -> SchoolId -> Handler TypedContent
getParticipantsR tid ssh = do
  setContentDispositionCsv $ MsgParticipantsCsvName tid ssh
  respondDefaultOrderedCsvDB (MsgParticipantsCsvSheetName tid ssh) $ E.selectSource partQuery .| C.map toParticipantEntry
  where
    partQuery = E.from $ \(course `E.InnerJoin` participant `E.InnerJoin` user) -> do
      E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
      E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse

      E.where_ $ course E.^. CourseTerm   E.==. E.val tid
           E.&&. course E.^. CourseSchool E.==. E.val ssh
      E.where_ $ participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive

      return (course E.^. CourseName, user E.^. UserEmail)

    toParticipantEntry (E.Value peCourse, E.Value peEmail) = ParticipantEntry{..}

getParticipantsIntersectR, postParticipantsIntersectR :: Handler Html
getParticipantsIntersectR = postParticipantsIntersectR
postParticipantsIntersectR = do
  let
    courseQuery = E.from return
    termSchoolAccess (Entity _ Course{..}) =
      hasReadAccessTo $ ParticipantsR courseTerm courseSchool
  ((coursesRes, coursesView), coursesEnc) <- runFormPost . renderAForm FormStandard $ courseSelectForm courseQuery termSchoolAccess (const Nothing) ("participants-intersect" :: Text) (fslI MsgParticipantsIntersectCourses) False Nothing
  let formWidget = wrapForm coursesView def
        { formAction = Just . SomeRoute $ ParticipantsIntersectR :#: ("table" :: Text)
        , formEncoding = coursesEnc
        }

  intersectionsRes <- formResultMaybe coursesRes . fmap (fmap Just) $ \cids -> runDB $ do
    courseUsers <- flip mapFromSetM cids $ \cid -> fmap (Set.fromList . map E.unValue) . E.select . E.from $ \participant -> do
      E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
           E.&&. participant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
      return $ participant E.^. CourseParticipantUser
    courses <- sortOn (view $ _entityVal . $(multifocusL 3) _courseTerm _courseSchool _courseShorthand) <$> forM (Set.toList cids) getEntity404

    let coursePairs = Set.fromAscList $ do
          cid <- Set.toAscList cids
          other <- Set.toAscList . snd $ Set.split cid cids
          return (cid, other)
        intersections = flip Map.fromSet coursePairs $ \(lCid, uCid)
          -> Set.size $ Map.findWithDefault Set.empty lCid courseUsers `Set.intersection` Map.findWithDefault Set.empty uCid courseUsers
        selfIntersections = Map.mapKeysMonotonic (\cid -> (cid, cid)) $ Set.size <$> courseUsers
        intersections' = Map.union intersections selfIntersections 
    let allUsersUnion = Set.size . Set.unions $ Map.elems courseUsers
    let mapIntersect = mapIntersectNotOne courseUsers
    let allUsersIntersection = Set.size . setIntersections $ Map.elems courseUsers
    return (courses, intersections', mapIntersect, allUsersUnion, allUsersIntersection)

  let
    symmIntersection intersections lCid uCid = fromMaybe 0 $ intersections !? (lCid, uCid) <|> intersections !? (uCid, lCid)
    intersectionHotness :: _ -> _ -> _ -> Centi
    intersectionHotness intersections lCid uCid
      | sumSize == 0 = 0
      | intersectSize == 0 = 0
      | otherwise    = realToFrac . (0.5 +) . (0.5 *) . max 0 . min 1 $ 2 * intersectSize % sumSize
      where
        sumSize = (min `on` (intersections !)) (lCid, lCid) (uCid, uCid)
        intersectSize = symmIntersection intersections lCid uCid
    showNumber n lCid uCid = n /= 0 || lCid == uCid

    lIxed = zip [0..]

  siteLayoutMsg MsgParticipantsIntersect $ do
    setTitleI MsgParticipantsIntersect
    $(widgetFile "participants-intersect")