gallery/make-pages/Date.hs

120 lines
3.2 KiB
Haskell

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