-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|
Module: Model.Types.DateTime
Description: Time related types

Terms, Seasons, and Occurrence schedules
-}
module Model.Types.DateTime
  ( module Model.Types.DateTime
  ) where

import Import.NoModel

-- import qualified Data.Set as Set
import Data.Ratio ((%))
import qualified Data.Text as Text
-- import Data.Either.Combinators (maybeToRight, mapLeft)
import Text.Read (readMaybe)

-- import Data.Time.LocalTime
import Data.Time.Calendar.WeekDate
-- import Data.Time.Format.ISO8601

-- import qualified Text.Parsec as Parse (choice, parse, string, try)
-- import qualified Text.ParserCombinators.Parsec.Number as ParseNum (nat)

import Database.Persist.Sql

import Web.HttpApiData

import Data.Aeson.Types as Aeson


----
--  Terms and anything loosely related to time

newtype TermIdentifier = TermIdentifier { year :: Integer } -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
    deriving (Show, Read, Eq, Ord, Generic, Enum)     
    deriving newtype (Binary) -- , ISO8601, PersistField, PersistFieldSql) -- , ToJSON, FromJSON)
    deriving anyclass (NFData)
    -- ought to be equivalent to deriving stock (Show, Read, Eq, Ord, Generic, Enum, Binary, NFData)

-- Note: Working Implementations for TermIdentifiers being single Days, half-years and quarters exits in git history

-- Conversion TermId <-> TermIdentifier::
-- from_TermId_to_TermIdentifier = unTermKey
-- from_TermIdentifier_to_TermId = TermKey

shortened :: Iso' Integer Integer
-- ^ Year numbers shortened to two digits
shortened = iso shorten expand
  where
    century :: Integer
    century = ($currentYear `div` 100) * 100
    expand year
      | 0 <= year
      , year < 100 = let
          options = [ expanded | offset <- [-1, 0, 1]
                               , let century' = century + offset * 100
                                     expanded = century' + year
                               , $currentYear - 50 <= expanded
                               , expanded < $currentYear + 50
                               ]
          in case options of
               [unique] -> unique
               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
      | otherwise = year
    shorten year
      | $currentYear - 50 <= year
      , year < $currentYear + 50 = year `mod` 100
      | otherwise = year

-- Also see
--   Handler.Utils.Widget.tidFromText
--   MsgTermPlaceHolder
termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = tshow year ---- * (^. shortened)

termFromText :: Text -> Either Text TermIdentifier
termFromText t
  | Just year <- readMaybe $ Text.unpack t
  = Right TermIdentifier {..}
  ---- *  | Just (review shortened -> year) <- readMaybe $ Text.unpack t
  ---- *  = Right TermIdentifier {..}
  | otherwise 
  = Left $ "Invalid TermIdentifier: “" <> t <> "”; expected is just a year number." 
  
  
daysPerYear :: Rational
daysPerYear = 365 + (97 % 400)

dayOffset :: Rational 
dayOffset = fromIntegral yearzero + (fromIntegral diffstart / daysPerYear)
  where     
    dayzero   = toEnum 0
    yearzero  = fst3 $ toGregorian dayzero
    diffstart = diffDays dayzero $ fromGregorian yearzero 1 1 
    
-- Attempt to ensure that ``truncate . termToRational == fst3 . toGregorian . getTermDay´´ holds
termToRational :: TermIdentifier -> Rational 
termToRational = fromInteger . year 

termFromRational :: Rational -> TermIdentifier
termFromRational = TermIdentifier . floor


instance PersistField TermIdentifier where
  toPersistValue = PersistRational . termToRational
  fromPersistValue (PersistRational t) = Right $ termFromRational t
  fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x

instance PersistFieldSql TermIdentifier where
  sqlType _ = SqlNumeric 4 0 -- total significant digits; significant digits after decimal point


instance ToHttpApiData TermIdentifier where
  toUrlPiece = termToText

instance FromHttpApiData TermIdentifier where
  parseUrlPiece = termFromText

instance PathPiece TermIdentifier where
  fromPathPiece = either (const Nothing) Just . termFromText
  toPathPiece = termToText

instance ToJSON TermIdentifier where
  toJSON = Aeson.String . termToText

instance FromJSON TermIdentifier where
  parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText

pathPieceCsv ''TermIdentifier

{- Must be defined in a later module:
    termField :: Field (HandlerT UniWorX IO) TermIdentifier
    termField = checkMMap (return . termFromText) termToText textField
   See Handler.Utils.Form.termsField and termActiveField
-}

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

-- See Handler.Term.validateTerm for term specification
guessDay :: TermIdentifier
         -> TermDay
         -> Day
guessDay TermIdentifier{..} TermDayStart = fromWeekDate year weeknr wday -- Monday of first calendar week, might be within previous year
  where weeknr = 1 -- 1st ISO8601 week
        wday    = 1 -- Monday
guessDay t TermDayLectureStart =               guessDay t TermDayStart
guessDay t TermDayEnd          = pred $ guessDay (succ t) TermDayStart
guessDay t TermDayLectureEnd   = pred $ pred $ guessDay t TermDayEnd  -- Friday of last calendar week, no lectures on Saturday/Sunday


withinTerm :: Day -> TermIdentifier -> Bool 
withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd

data OccurrenceSchedule = ScheduleWeekly
                          { scheduleDayOfWeek :: WeekDay
                          , scheduleStart     :: TimeOfDay
                          , scheduleEnd       :: TimeOfDay
                          }
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (NFData)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  , constructorTagModifier = camelToPathPiece' 1
  , tagSingleConstructors = True
  , sumEncoding = TaggedObject "repeat" "schedule"
  } ''OccurrenceSchedule

data OccurrenceException = ExceptOccur
                          { exceptDay   :: Day
                          , exceptStart :: TimeOfDay
                          , exceptEnd   :: TimeOfDay
                          }
                        | ExceptNoOccur
                          { exceptTime  :: LocalTime
                          }
  deriving (Eq, Read, Show, Generic)
  deriving anyclass (NFData)

-- Handler.Utils.Occurrences.occurrencesAddBusinessDays assumes that OccurrenceException is ordered chronologically
instance Ord OccurrenceException where 
  compare ExceptOccur{exceptDay=ad, exceptStart=as, exceptEnd=ae} ExceptOccur{exceptDay=bd, exceptStart=bs, exceptEnd=be}  
    = compare (ad,as,ae) (bd,bs,be)
  compare ExceptOccur{exceptDay=d, exceptStart=s} ExceptNoOccur{exceptTime=e}
    = replaceEq LT $ compare (LocalTime d s) e
  compare ExceptNoOccur{exceptTime=e } ExceptOccur{exceptDay=d, exceptStart=s} 
    = replaceEq GT $ compare e (LocalTime d s)
  compare ExceptNoOccur{exceptTime=ae } ExceptNoOccur{exceptTime=be }
    = compare ae be 

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  , constructorTagModifier = camelToPathPiece' 1
  , sumEncoding = TaggedObject "exception" "for"
  } ''OccurrenceException

dayOfOccurrenceException :: OccurrenceException -> Day
dayOfOccurrenceException ExceptOccur{exceptDay=d} = d
dayOfOccurrenceException ExceptNoOccur{exceptTime=LocalTime{localDay=d}} = d

setDayOfOccurrenceException :: Day -> OccurrenceException -> OccurrenceException
setDayOfOccurrenceException d ex@ExceptOccur{} = ex{exceptDay=d}
setDayOfOccurrenceException d ExceptNoOccur{exceptTime=t} = ExceptNoOccur{exceptTime = t{localDay=d}}

data Occurrences = Occurrences
  { occurrencesScheduled  :: Set OccurrenceSchedule
  , occurrencesExceptions :: Set OccurrenceException
  }
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (NFData)

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''Occurrences
derivePersistFieldJSON ''Occurrences


nullaryPathPiece ''DayOfWeek camelToPathPiece


-- test :: IO [OccurrenceException]
-- test = do 
--   now <- getCurrentTime
--   tz <- getCurrentTimeZone
--   let lt1 = utcToLocalTime tz now 
--       tomorrow = addUTCTime nominalDay now 
--       lt2 = utcToLocalTime tz tomorrow
--       yesterday = addUTCTime (negate nominalDay) now 
--       lt3 = utcToLocalTime tz yesterday
--   pure 
--     [ ExceptOccur (utctDay tomorrow ) midday midnight
--     , ExceptOccur (utctDay now      ) midnight midnight
--     , ExceptOccur (utctDay now      ) midday midnight
--     , ExceptOccur (utctDay yesterday) midday midnight 
--     , ExceptNoOccur lt3
--     , ExceptNoOccur lt1
--     , ExceptNoOccur lt2
--     ]