120 lines
3.2 KiB
Haskell
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
|