gallery/make-pages/Date.hs

module Date
  (Date (..),
   Day (..), dayNum, exact,
   formatLong, formatShort, formatRSS, formatSlash, formatTooltip,
   parseP, parseS, parseA)
where

import Control.Applicative
import qualified Text.ParserCombinators.ReadP as ReadP
import Text.ParserCombinators.ReadP (ReadP, readS_to_P, readP_to_S, (<++))
import Data.Time hiding (Day)
import Data.Char (isSpace, toLower)
import BuilderQQ
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.YAML (FromYAML (..))
import qualified Data.YAML as YAML
import Data.Text (unpack)

data Date = Date {year, month :: Int, day :: Day}
  deriving (Eq, Ord, Show)

data Day =
    Exact  Int
  | Approx Int
  | Unknown
  deriving (Eq, Show)

dayNum :: Day -> Maybe Int
dayNum (Exact  x) = Just x
dayNum (Approx x) = Just x
dayNum Unknown    = Nothing

instance Ord Day where compare = compare `on` dayNum

exact :: Day -> Bool
exact (Exact _) = True
exact _         = False

formatLong :: Date -> Builder
formatLong (Date {year, month, day}) =
  case dayN of
    Nothing         -> monthYear
    Just (nth -> d) -> [b|$approx$weekday $d $monthYear|]
 where
  dayN = dayNum day
  day' = fromMaybe 1 dayN
  formatted str = fromString $
    formatTime defaultTimeLocale str $
    fromGregorian (toInteger year) month day'
  monthYear = formatted "%B %Y"
  weekday = formatted "%a"
  approx = if exact day then "" else [b|approx. $&|]

formatShort :: Date -> Builder
formatShort (Date {month, day}) = [b|$day'$month'|] where
  day' = case day of
    Exact d  -> [b|$d $&|]
    Approx d -> [b|$d? $&|]
    Unknown  -> ""
  month' = formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1

formatTooltip :: Date -> Builder
formatTooltip (Date {year, month, day}) = [b|$day'$month' $year|] where
  day' = case day of
    Exact d  -> [b|$d $&|]
    Approx d -> [b|$d? $&|]
    Unknown  -> ""
  month' = map toLower $
    formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1

formatRSS :: Date -> Builder
formatRSS = fromString . format . toTime where
  format = formatTime defaultTimeLocale "%a, %d %b %_Y %T GMT"
  toTime (Date {year, month, day}) =
    let year' = toInteger year; day' = fromMaybe 1 $ dayNum day in
    UTCTime (fromGregorian year' month day') 15600

formatSlash :: Date -> Builder
formatSlash (Date {year, month, day}) = case dayNum day of
  Nothing -> [b|$year/$month|]
  Just d  -> [b|$year/$month/$d$q|]
    where q = if exact day then "" else [b|<span class=q>?</span>|]


nth :: Int -> Builder
nth n = [b|$n$suf|] where
  suf | n >= 10, n <= 19 = [b|th|]
      | n `mod` 10 == 1  = [b|st|]
      | n `mod` 10 == 2  = [b|nd|]
      | n `mod` 10 == 3  = [b|rd|]
      | otherwise        = [b|th|]

parseP :: ReadP Date
parseP = do
  year <- readp
  char_ '-'
  month <- readp
  day <- option Unknown do
    char_ '-'
    d <- readp
    approx <- option Exact (Approx <$ ReadP.char '?')
    pure $ approx d
  pure $ Date year month day
 where
  readp = readS_to_P reads
  char_ c = () <$ ReadP.char c
  option k p = p <++ pure k

parseS :: ReadS Date
parseS = readP_to_S parseP

parseA :: Alternative f => String -> f Date
parseA str = case parseS str of
  [(d, rest)] | all isSpace rest -> pure d
  _                              -> empty


instance FromYAML Date where
  parseYAML = YAML.withStr "date" $ parseA . unpack