{-# 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.Text as Text
import qualified Data.CaseInsensitive as CI
import Text.Read (readMaybe)

import Database.Persist.Sql

import Web.HttpApiData

import Data.Aeson.Types as Aeson


----
--  Terms, Seaons, anything loosely related to time

data Season = Summer | Winter
  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Binary, Universe, Finite, NFData)

seasonToChar :: Season -> Char
seasonToChar Summer = 'S'
seasonToChar Winter = 'W'

seasonFromChar :: Char -> Either Text Season
seasonFromChar c
  | c ~= 'S'  = Right Summer
  | c ~= 'W'  = Right Winter
  | otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
  where
    (~=) :: Char -> Char -> Bool
    (~=) = (==) `on` CI.mk

data TermIdentifier = TermIdentifier
  { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
  , season :: Season
  } deriving (Show, Read, Eq, Ord, Generic, Typeable)
    deriving anyclass (Binary, NFData)

instance Enum TermIdentifier where
  -- ^ Do not use for conversion – Enumeration only
  toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
  fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season

-- 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

termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)

-- also see Hander.Utils.tidFromText
termFromText :: Text -> Either Text TermIdentifier
termFromText t
  | (s:ys) <- Text.unpack t
  , Just (review shortened -> year) <- readMaybe ys
  , Right season <- seasonFromChar s
  = Right TermIdentifier{..}
  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number

termToRational :: TermIdentifier -> Rational
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
  where
    seasonOffset
      | Summer <- season = 0
      | Winter <- season = 0.5

termFromRational :: Rational -> TermIdentifier
termFromRational n = TermIdentifier{..}
  where
    year = floor n
    remainder = n - fromInteger (floor n)
    season
      | remainder == 0 = Summer
      | otherwise      = Winter

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 5 1

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

{- 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
-}


withinTerm :: Day -> TermIdentifier -> Bool
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
  where
    timeYear = fst3 $ toGregorian time
    termYear = year term


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

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, Ord, Read, Show, Generic, Typeable)

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

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

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


nullaryPathPiece ''DayOfWeek camelToPathPiece
