143 lines
3.9 KiB
Haskell
143 lines
3.9 KiB
Haskell
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
|