gallery/make-pages/Date.hs

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

import Records ()
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)
import Data.Function (on)
import Data.Maybe (fromMaybe)
import Data.YAML (FromYAML (..))
import qualified Data.YAML as YAML
import Text.Ginger (GVal, ToGVal (..), (~>))
import qualified Text.Ginger as Ginger
import qualified Text.Ginger.Html as Ginger
import Data.Text (Text, pack, unpack)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (Builder)
import qualified Data.Text.Lazy.Builder as Builder


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

formatShort :: Date -> Text
formatShort (Date {month, day}) = toText $ day' <> month' where
  day' = case day of
    Exact d  -> bshow d <> " "
    Approx d -> bshow d <> "? "
    Unknown  -> mempty
  month' = Builder.fromString $
    formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1

formatRSS :: Date -> Text
formatRSS = pack . 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 -> Text
formatSlash (Date {year, month, day}) =
  toText $ mconcat [bshow year, "/", bshow month, "/", bshow day', bshow ex]
  where day' = dayNum day; ex = exact day


nth :: Int -> Builder
nth n = bshow n <> suf
 where
  suf | n >= 10, n <= 19 = "th"
      | n `mod` 10 == 1  = "st"
      | n `mod` 10 == 2  = "nd"
      | n `mod` 10 == 3  = "rd"
      | otherwise        = "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

instance ToGVal m Date where
  toGVal d@(Date {year, month, day=day'}) =
    dict {Ginger.asText = long, Ginger.asHtml = Ginger.html long}
   where
    dict = Ginger.dict
      ["year" ~> year, "month" ~> month, "day" ~> day, "exact" ~> exact day',
       "long" ~> long, "short" ~> short, "rss" ~> rss, "slash" ~> slash]
    day :: GVal m
    day = case day' of
      Exact x  -> toGVal x
      Approx x -> toGVal $ show x <> "?"
      Unknown  -> "?"
    long  = formatLong  d
    short = formatShort d
    rss   = formatRSS   d
    slash = formatSlash d

toText :: Builder -> Text
toText = toStrict . Builder.toLazyText

bshow :: Show a => a -> Builder
bshow = Builder.fromString . show