gallery/make-pages/Date.hs

121 lines
3.2 KiB
Haskell
Raw Normal View History

2020-09-25 17:08:44 -04:00
module Date
(Date (..),
Day (..), dayNum, exact,
2023-06-21 13:58:01 -04:00
formatLong, formatShort, formatRSS, formatSlash, formatTooltip,
2020-09-25 17:08:44 -04:00
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)
2023-06-21 13:58:01 -04:00
import Data.Char (isSpace, toLower)
2020-09-25 17:08:44 -04:00
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
2023-06-21 13:58:01 -04:00
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
2020-09-25 17:08:44 -04:00
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