module Handler.Term
  ( getTermShowR
  , getTermEditR, postTermEditR
  , getTermEditExistR, postTermEditExistR
  ) where

import Import

import Utils.Course (mayViewCourse)

import Handler.Utils

import qualified Data.Map as Map

import qualified Database.Esqueleto as E

import qualified Data.Set as Set

import qualified Control.Monad.State.Class as State

import Data.Time.Calendar.WeekDate


data TermDay
  = TermDayStart | TermDayEnd
  | TermDayLectureStart | TermDayLectureEnd
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)

guessDay :: TermIdentifier
         -> TermDay
         -> Day
guessDay TermIdentifier{ year, season = Winter } TermDayStart
  = fromGregorian year 10 1
guessDay TermIdentifier{ year, season = Winter } TermDayEnd
  = fromGregorian (succ year) 3 31
guessDay TermIdentifier{ year, season = Summer } TermDayStart
  = fromGregorian year 4 1
guessDay TermIdentifier{ year, season = Summer } TermDayEnd
  = fromGregorian year 9 30
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureStart
  = fromWeekDate year (wWeekStart + 2) 1
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Winter } TermDayLectureEnd
  = fromWeekDate (succ year) ((wWeekStart + 21) `div` bool 53 54 longYear) 5
  where longYear = is _Just $ fromWeekDateValid year 53 1
        (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureStart
  = fromWeekDate year (wWeekStart + 2) 1
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart
guessDay tid@TermIdentifier{ year, season = Summer } TermDayLectureEnd
  = fromWeekDate year (wWeekStart + 17) 5
  where (_, wWeekStart, _) = toWeekDate $ guessDay tid TermDayStart


validateTerm :: (MonadHandler m, HandlerSite m ~ UniWorX)
             => FormValidator Term m ()
validateTerm = do
  Term{..} <- State.get
  guardValidation MsgTermStartMustMatchName $ termStart `withinTerm` termName
  guardValidation MsgTermEndMustBeAfterStart $ termStart < termEnd
  guardValidation MsgTermLectureEndMustBeAfterStart $ termLectureStart < termLectureEnd
  guardValidation MsgTermStartMustBeBeforeLectureStart $ termStart <= termLectureStart
  guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd


getTermShowR :: Handler Html
getTermShowR = do
  muid <- maybeAuthId
  now <- liftIO getCurrentTime
  ata <- getSessionActiveAuthTags
  table <- runDB $
    let termDBTable = DBTable{..}
          where dbtSQLQuery term = return (term, courseCount)
                  where courseCount = E.subSelectCount . E.from $ \course ->
                          E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
                            E.&&. mayViewCourse muid ata now course Nothing
                dbtRowKey = (E.^. TermId)
                dbtProj = return . dbrOutput
                dbtColonnade = widgetColonnade $ mconcat
                  [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
                      -> cell $ do
                           mayEdit <- hasWriteAccessTo $ TermEditExistR tid
                           [whamlet|
                             $newline never
                             <a href=@{TermCourseListR tid}>
                               #{toPathPiece tid}
                             $if mayEdit
                               &nbsp;
                               <a href=@{TermEditExistR tid}>
                                 #{iconMenuAdmin}
                           |]
                  , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_)
                      -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
                  , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_)
                      -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
                  , sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_)
                      -> tickmarkCell termActive
                  , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses)
                      -> cell [whamlet|_{MsgNumCourses numCourses}|]
                  , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_)
                      -> cell $ formatTime SelFormatDate termStart >>= toWidget
                  , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_)
                      -> cell $ formatTime SelFormatDate termEnd >>= toWidget
                  , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_)
                      -> cell $ do
                           let termHolidays' = groupHolidays termHolidays
                           [whamlet|
                             $newline never
                             <ul .list--inline .list--comma-separated>
                               $forall holiday <- termHolidays'
                                 $case holiday
                                   $of Left singleHoliday
                                     <li>^{formatTimeW SelFormatDate singleHoliday}
                                   $of Right (startD, endD)
                                     <li>
                                       ^{formatTimeW SelFormatDate startD}
                                       –
                                       ^{formatTimeW SelFormatDate endD}
                           |]
                  ]
                dbtSorting = Map.fromList
                  [ ( "start"
                    , SortColumn $ \term -> term E.^. TermStart
                    )
                  , ( "end"
                    , SortColumn $ \term -> term E.^. TermEnd
                    )
                  , ( "lecture-start"
                    , SortColumn $ \term -> term E.^. TermLectureStart
                    )
                  , ( "lecture-end"
                    , SortColumn $ \term -> term E.^. TermLectureEnd
                    )
                  , ( "term-id"
                    , SortColumn $ \term -> term E.^. TermId
                    )
                  ]
                dbtFilter = Map.fromList
                  [ ( "active"
                    , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
                    )
                  , ( "course"
                    , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are
                        []   -> E.val True :: E.SqlExpr (E.Value Bool)
                        cshs -> E.exists . E.from $ \course ->
                          E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
                               E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
                    )
                  ]
                dbtFilterUI = mempty
                dbtStyle = def
                dbtParams = def
                dbtIdent = "terms" :: Text
                dbtCsvEncode = noCsvEncode
                dbtCsvDecode = Nothing
                dbtExtraReps = []
        termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
    in dbTableWidget' termDBTableValidator termDBTable
  defaultLayout $ do
    setTitleI MsgTermsHeading
    $(widgetFile "terms")

getTermEditR, postTermEditR :: Handler Html
getTermEditR = postTermEditR
postTermEditR = do
  mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
  let template = case mbLastTerm of
        Nothing -> mempty
        (Just Entity{ entityVal=Term{..}})
          -> let ntid = succ termName
             in mempty
                  { tftName  = Just   ntid
                  , tftStart = Just $ guessDay ntid TermDayStart
                  , tftEnd   = Just $ guessDay ntid TermDayEnd
                  , tftLectureStart = Just $ guessDay ntid TermDayLectureStart
                  , tftLectureEnd   = Just $ guessDay ntid TermDayLectureEnd
                  }
  termEditHandler Nothing template

getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
getTermEditExistR = postTermEditExistR
postTermEditExistR tid = do
  term <- runDB $ get tid
  termEditHandler (Just tid) $ termToTemplate term


termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
termEditHandler mtid term = do
    eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid term
    case result of
      (FormSuccess res) -> do
          let tid = fromMaybe (TermKey $ termName res) mtid
          runDB $ do
            repsert tid res
            audit $ TransactionTermEdit tid
          addMessageI Success $ MsgTermEdited tid
          redirect TermShowR
      FormMissing     -> return ()
      (FormFailure _) -> addMessageI Warning MsgInvalidInput
    defaultLayout $ do
      setTitleI MsgTermEditHeading
      wrapForm formWidget def
        { formAction = Just $ SomeRoute eHandler
        , formEncoding = formEnctype
        }

data TermFormTemplate = TermFormTemplate
      { tftName         :: Maybe TermIdentifier
      , tftStart        :: Maybe Day
      , tftEnd          :: Maybe Day
      , tftHolidays     :: Maybe [Day]
      , tftLectureStart :: Maybe Day
      , tftLectureEnd   :: Maybe Day
      , tftActive       :: Maybe Bool
      }

-- | TermFormTemplates form a pointwise-left biased Semigroup
instance Semigroup TermFormTemplate where
  l <> r = TermFormTemplate
    { tftName         = tftName         l <|> tftName         r
    , tftStart        = tftStart        l <|> tftStart        r
    , tftEnd          = tftEnd          l <|> tftEnd          r
    , tftHolidays     = tftHolidays     l <|> tftHolidays     r
    , tftLectureStart = tftLectureStart l <|> tftLectureStart r
    , tftLectureEnd   = tftLectureEnd   l <|> tftLectureEnd   r
    , tftActive       = tftActive       l <|> tftActive       r
    }

instance Monoid TermFormTemplate where
  mappend = (<>)
  mempty  = TermFormTemplate
    { tftName         = Nothing
    , tftStart        = Nothing
    , tftEnd          = Nothing
    , tftHolidays     = Nothing
    , tftLectureStart = Nothing
    , tftLectureEnd   = Nothing
    , tftActive       = Nothing
    }

termToTemplate ::Maybe Term -> TermFormTemplate
termToTemplate Nothing = mempty
termToTemplate (Just Term{..}) = TermFormTemplate
    { tftName         = Just termName
    , tftStart        = Just termStart
    , tftEnd          = Just termEnd
    , tftHolidays     = Just termHolidays
    , tftLectureStart = Just termLectureStart
    , tftLectureEnd   = Just termLectureEnd
    , tftActive       = Just termActive
    }

newTermForm :: Maybe TermId -> TermFormTemplate -> Form Term
newTermForm mtid template = validateForm validateTerm $ \html -> do
    mr <- getMessageRender
    let
      tidForm
        | Just tid <- unTermKey <$> mtid
        = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
        | otherwise
        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
      holidayForm = massInputListA
        dayField
        (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))
        MsgTermHolidayMissing
        (const Nothing)
        ("holidays" :: Text)
        (fslI MsgTermHolidays)
        True
        (tftHolidays template)
    flip (renderAForm FormStandard) html $ Term
      <$> tidForm
      <*> areq dayField  (fslI MsgTermStartDay & setTooltip MsgTermStartDayTooltip) (tftStart template)
      <*> areq dayField  (fslI MsgTermEndDay   & setTooltip MsgTermEndDayTooltip)   (tftEnd   template)
      <*> (Set.toList . Set.fromList <$> holidayForm)
      <*> areq dayField  (fslI MsgTermLectureStart) (tftLectureStart template)
      <*> areq dayField  (fslI MsgTermLectureEnd & setTooltip MsgTermLectureEndTooltip) (tftLectureEnd template)
      <*> areq checkBoxField (fslI MsgTermActive) (tftActive template)