module Handler.Allocation.Form
  ( AllocationForm(..)
  , allocationForm
  ) where

import Import

import Handler.Utils

import qualified Database.Esqueleto.Legacy as E

import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

import qualified Control.Monad.State.Class as State

import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
  

data AllocationForm = AllocationForm
  { afTerm :: TermId
  , afSchool :: SchoolId
  , afShorthand :: AllocationShorthand
  , afName :: AllocationName
  , afLegacyShorthands :: Set AllocationShorthand
  , afDescription, afStaffDescription :: Maybe StoredMarkup
  , afStaffRegisterFrom, afStaffRegisterTo
  , afRegisterFrom, afRegisterTo
  , afStaffAllocationFrom, afStaffAllocationTo
  , afRegisterByStaffFrom, afRegisterByStaffTo
  , afRegisterByCourse, afOverrideDeregister :: Maybe UTCTime
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)


allocationForm :: Maybe AllocationForm
               -> AForm (YesodDB UniWorX) AllocationForm
allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ do
  mayEditTerms <- lift . lift $ hasWriteAccessTo TermEditR
  now <- liftIO getCurrentTime
  muid <- maybeAuthId
  termOptions <-
    let termQuery :: E.SqlQuery (E.SqlExpr (E.Value TermId))
        termQuery = E.from $ \t -> do
          unless mayEditTerms $
            E.where_ $ E.just (t E.^. TermId) E.==. E.val (afTerm <$> mTemplate)
                 E.||. termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
          E.orderBy [E.desc $ t E.^. TermStart]
          return $ t E.^. TermId
     in lift . lift $ mkOptionsE
          termQuery
          (return . toPathPiece . E.unValue)
          (return . ShortTermIdentifier . unTermKey . E.unValue)
          (return . E.unValue)

  schoolOptions <-
    let schoolQuery :: E.SqlQuery (E.SqlExpr (Entity School))
        schoolQuery = E.from $ \s -> do
          E.where_ $ E.exists (E.from $ \userFunction -> do
                                 E.where_ $ userFunction E.^. UserFunctionSchool E.==. s E.^. SchoolId
                                      E.&&. E.just (userFunction E.^. UserFunctionUser) E.==. E.val muid
                                      E.&&. userFunction E.^. UserFunctionFunction `E.in_` E.valList [SchoolAdmin, SchoolAllocation]
                              )
               E.||. E.just (s E.^. SchoolId) E.==. E.val (afSchool <$> mTemplate)
          E.orderBy [E.asc $ s E.^. SchoolShorthand]
          return s
     in lift . lift $ mkOptionsE
          schoolQuery
          (return . toPathPiece . entityKey)
          (return . schoolName . entityVal)
          (return . entityKey)

  template <- maybe (lift . lift $ suggestAllocationForm termOptions schoolOptions) (return . Just) mTemplate

  let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set (CI Text))
      cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . map CI.original . Set.toList)

  aFormToWForm . hoistAForm liftHandler $ AllocationForm
    <$> areq (selectField $ return termOptions) (fslI MsgAllocationFormTerm) (afTerm <$> template)
    <*> areq (selectField $ return schoolOptions) (fslI MsgAllocationFormSchool) (afSchool <$> template)
    <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormShorthand) (afShorthand <$> template)
    <*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormName) (afName <$> template)
    <*> (fromMaybe Set.empty <$> aopt (textField & cfCommaSeparatedSet) (fslI MsgAllocationFormLegacyShorthands & setTooltip MsgAllocationFormLegacyShorthandsTip) (fmap Just $ afLegacyShorthands <$> template))
    <*  aformSection MsgAllocationFormDescriptions
    <*> aopt htmlField (fslI MsgAllocationFormDescription & setTooltip MsgAllocationFormDescriptionTip) (afDescription <$> template)
    <*> aopt htmlField (fslI MsgAllocationFormStaffDescription & setTooltip MsgAllocationFormStaffDescriptionTip) (afStaffDescription <$> template)
    <*  aformSection MsgAllocationFormDeadlines
    <*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterFrom & setTooltip MsgAllocationFormStaffRegisterFromTip) (afStaffRegisterFrom <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterTo & setTooltip MsgAllocationFormStaffRegisterToTip) (afStaffRegisterTo <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormRegisterFrom & setTooltip MsgAllocationFormRegisterFromTip) (afRegisterFrom <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormRegisterTo & setTooltip MsgAllocationFormRegisterToTip) (afRegisterTo <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationFrom & setTooltip MsgAllocationFormStaffAllocationFromTip) (afStaffAllocationFrom <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationTo & setTooltip MsgAllocationFormStaffAllocationToTip) (afStaffAllocationTo <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffFrom & setTooltip MsgAllocationFormRegisterByStaffFromTip) (afRegisterByStaffFrom <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffTo & setTooltip MsgAllocationFormRegisterByStaffToTip) (afRegisterByStaffTo <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormRegisterByCourse & setTooltip MsgAllocationFormRegisterByCourseTip) (afRegisterByCourse <$> template)
    <*> aopt utcTimeField (fslI MsgAllocationFormOverrideDeregister & setTooltip MsgAllocationFormOverrideDeregisterTip) (afOverrideDeregister <$> template)

validateAllocationForm :: FormValidator AllocationForm (YesodDB UniWorX) ()
validateAllocationForm = do
  State.modify $ \af -> af { afLegacyShorthands = Set.delete (afShorthand af) $ afLegacyShorthands af }
  
  AllocationForm{..} <- State.get

  guardValidation MsgAllocationFormStaffRegisterToMustBeAfterFrom
    $ NTop afStaffRegisterFrom <= NTop afStaffRegisterTo
  guardValidation MsgAllocationFormStaffAllocationToMustBeAfterFrom
    $ NTop afStaffAllocationFrom <= NTop afStaffAllocationTo
  guardValidation MsgAllocationFormRegisterToMustBeAfterFrom
    $ NTop afRegisterFrom <= NTop afRegisterTo
  guardValidation MsgAllocationFormRegisterByStaffToMustBeAfterFrom
    $ NTop afRegisterByStaffFrom <= NTop afRegisterByStaffTo

  guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeStaffAllocationFrom
    $ NTop afStaffRegisterFrom <= NTop afStaffAllocationFrom
  guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeStaffAllocationTo
    $ NTop afStaffRegisterTo <= NTop afStaffAllocationTo

  guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeRegisterFrom
    $ NTop afStaffRegisterFrom <= NTop afRegisterFrom
  guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeRegisterTo
    $ NTop afStaffRegisterTo <= NTop afRegisterTo

  warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByStaffFrom
    $ NTop afStaffAllocationTo <= NTop afRegisterByStaffFrom
  warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByCourse
    $ NTop afStaffAllocationTo <= NTop afRegisterByCourse
  warnValidation MsgAllocationFormStaffAllocationToShouldBeAfterRegisterTo
    $ NTop afStaffAllocationTo >= NTop afRegisterTo

  warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByStaffFrom
    $ NTop afRegisterTo <= NTop afRegisterByStaffFrom
  warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByCourse
    $ NTop afRegisterTo <= NTop afRegisterByCourse

  warnValidation MsgAllocationFormRegisterByStaffFromShouldBeBeforeRegisterByCourse
    $ NTop afRegisterByStaffFrom <= NTop afRegisterByCourse

suggestAllocationForm :: OptionList TermId -> OptionList SchoolId
                      -> DB (Maybe AllocationForm)
suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> terms) (Set.fromList . map optionInternalValue . olOptions -> schools) = runMaybeT $ do
  allocs <- lift . E.select . E.from $ \alloc -> do
    E.where_ $ alloc E.^. AllocationSchool `E.in_` E.valList (Set.toList schools)
    return ( alloc E.^. AllocationTerm
           , alloc E.^. AllocationSchool
           , alloc E.^. AllocationShorthand
           )
  let allocTerms = Map.fromListWith (<>) $ do
        (E.Value tid, E.Value ssh, E.Value ash) <- allocs
        return ((ssh, ash), Set.singleton tid)
      nextAlloc = flip Map.mapMaybe allocTerms $ \(Set.toDescList -> tids) -> case tids of
        TermKey t1 : TermKey t2 : _ -> Just . TermKey . toEnum $ fromEnum t1 + (fromEnum t1 - fromEnum t2)
        TermKey t1 : _              -> Just . TermKey $ succ t1
        _other                      -> Nothing
  maxAllocTerm <- hoistMaybe . fmap maximum . fromNullable $ Map.mapMaybe Set.lookupMax allocTerms
  ((ssh, ash), tid) <- hoistMaybe . fmap (minimumBy $ comparing (view _2) <> comparing (view _1)) . fromNullable . Map.toList $ Map.filter (\t -> t >= maxAllocTerm && t `Set.member` terms) nextAlloc
  oldTid <- hoistMaybe $ Set.lookupMax =<< Map.lookup (ssh, ash) allocTerms
  oldTerm <- MaybeT $ get oldTid
  newTerm <- MaybeT $ get tid
  Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash

  let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm      

  return AllocationForm
    { afTerm = tid
    , afSchool = ssh
    , afShorthand = ash
    , afName = allocationName
    , afLegacyShorthands = Set.delete ash $ Set.fromList allocationLegacyShorthands
    , afDescription = allocationDescription
    , afStaffDescription = allocationStaffDescription
    , afStaffRegisterFrom = addTime <$> allocationStaffRegisterFrom
    , afStaffRegisterTo = addTime <$> allocationStaffRegisterTo
    , afStaffAllocationFrom = addTime <$> allocationStaffAllocationFrom
    , afStaffAllocationTo = addTime <$> allocationStaffAllocationTo
    , afRegisterFrom = addTime <$> allocationRegisterFrom
    , afRegisterTo = addTime <$> allocationRegisterTo
    , afRegisterByStaffFrom = addTime <$> allocationRegisterByStaffFrom
    , afRegisterByStaffTo = addTime <$> allocationRegisterByStaffTo
    , afRegisterByCourse = addTime <$> allocationRegisterByCourse
    , afOverrideDeregister = addTime <$> allocationOverrideDeregister
    }