From 8d4ff29e56449a9b5b7191f430f519d7e5909872 Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Fri, 25 Sep 2020 23:08:44 +0200 Subject: [PATCH] add support for approx dates --- make-pages/Date.hs | 111 ++++++++++++++++++++++++++++++++++++ make-pages/GalleryPage.hs | 17 ++---- make-pages/Info.hs | 27 +++------ make-pages/RSS.hs | 11 +--- make-pages/SinglePage.hs | 31 ++-------- make-pages/make-pages.cabal | 1 + style/shiny/gallery.css | 2 + style/shiny/single.css | 6 ++ 8 files changed, 141 insertions(+), 65 deletions(-) create mode 100644 make-pages/Date.hs diff --git a/make-pages/Date.hs b/make-pages/Date.hs new file mode 100644 index 0000000..3c22927 --- /dev/null +++ b/make-pages/Date.hs @@ -0,0 +1,111 @@ +module Date + (Date (..), + Day (..), dayNum, exact, + formatLong, formatShort, formatRSS, formatSlash, + 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) +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 + +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|?|] + + +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 diff --git a/make-pages/GalleryPage.hs b/make-pages/GalleryPage.hs index be5be76..d5e8535 100644 --- a/make-pages/GalleryPage.hs +++ b/make-pages/GalleryPage.hs @@ -1,6 +1,10 @@ {-# LANGUAGE TransformListComp #-} module GalleryPage (make) where +import BuilderQQ +import Date +import Info + import Data.Foldable import Data.Function (on, (&)) import qualified Data.HashMap.Strict as HashMap @@ -8,13 +12,9 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import Data.List (intersperse, groupBy, sortOn) import qualified Data.Text.Lazy as Lazy -import qualified Data.Time as Time import System.FilePath (takeDirectory, joinPath, splitPath) import GHC.Exts (Down (..), the) -import BuilderQQ -import Info - make :: Text -> GalleryInfo -> [(FilePath, Info)] -> Lazy.Text make root ginfo infos = toLazyText $ make' root ginfo infos @@ -118,7 +118,7 @@ makeFilter prefix initial tag count = [b|@8 checked = if HashSet.member tag initial then [b| checked|] else "" makeYearItems :: Bool -- ^ nsfw - -> Integer -- ^ year + -> Int -- ^ year -> [(FilePath, Info)] -> Builder makeYearItems nsfw year infos = [b|@4 @@ -149,11 +149,6 @@ makeItem nsfw file info@(Info {title, bg}) = [b|@4 thumb = getThumb dir info nsfw' = if nsfw && #anyNsfw info then [b| nsfw|] else "" tags' = fold $ intersperse ";" $ map fromText $ tagsFor nsfw info - date' = formatDateShort $ #latestDate info + date' = formatShort $ #latestDate info updated' = if #updated info then [b|true|] else [b|false|] bgStyle = ifJust bg \col -> [b| style="background: $col"|] - -formatDateShort :: Time.Day -> Builder -formatDateShort date = [b|$day $month|] where - (_, m, day) = Time.toGregorian date - month = words "jan feb mar apr may jun jul aug sep oct nov dec" !! (m - 1) diff --git a/make-pages/Info.hs b/make-pages/Info.hs index 0020fff..d2d2baa 100644 --- a/make-pages/Info.hs +++ b/make-pages/Info.hs @@ -7,9 +7,10 @@ module Info readArtistFilter, matchArtist, readNsfwFilter, matchNsfw, matchFilters, NoThumb (..), getThumb, thumbFile, pageFile, -- ** Reexports - Day (..), Text) + Date (..), Day (..), Text) where +import Date import Records import Control.Applicative @@ -27,21 +28,19 @@ import Data.Ord (comparing) import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text -import Data.Time.Calendar (Day (..), toGregorian) import Data.YAML (FromYAML (..), (.:), (.:?), (.!=)) import qualified Data.YAML as YAML import System.FilePath ((), takeBaseName, takeExtension, splitExtension) -import Text.Read (readMaybe) data Info = Info { - date :: !Day, + date :: !Date, -- extra sort key after date -- e.g. multiple things on the same day might have a,b,c in @sortEx@ to -- put them in the right order in the gallery sortEx :: !Text, - updates :: !(Map Day Text), + updates :: !(Map Date Text), title :: !Text, artist :: !(Maybe Artist), -- nothing = me, obv nsfwOnly :: !Bool, @@ -105,17 +104,11 @@ instance HasField "thumb" Info (Maybe FilePath) where instance HasField "mine" Info Bool where getField = isNothing . #artist instance HasField "notMine" Info Bool where getField = isJust . #artist -instance HasField "dmy" Info (Integer, Int, Int) where - getField = toGregorian . #date -instance HasField "year" Info Integer where getField = #first . #dmy -instance HasField "month" Info Int where getField = #second . #dmy -instance HasField "day" Info Int where getField = #third . #dmy - -instance HasField "latestDate" Info Day where +instance HasField "latestDate" Info Date where getField (Info {date, updates}) = maximum (date : Map.keys updates) -instance HasField "latestYear" Info Integer where - getField = #first . toGregorian . #latestDate +instance HasField "latestYear" Info Int where + getField = #year . #latestDate instance HasField "updated" Info Bool where getField = not . Map.null . #updates @@ -328,12 +321,6 @@ instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where _ -> fail "expected exactly one pair" -instance FromYAML Day where - parseYAML = YAML.withStr "date" \str -> - case readMaybe $ Text.unpack str of - Just d -> pure d - Nothing -> fail $ "couldn't parse date " ++ show str - instance {-# OVERLAPPING #-} FromYAML String where parseYAML y = Text.unpack <$> parseYAML y diff --git a/make-pages/RSS.hs b/make-pages/RSS.hs index 370ee64..61f95f4 100644 --- a/make-pages/RSS.hs +++ b/make-pages/RSS.hs @@ -1,5 +1,6 @@ module RSS (make, make') where +import Date import Info import BuilderQQ import Records () @@ -9,7 +10,6 @@ import Data.Maybe (isJust) import Data.Ord (Down (..)) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy -import qualified Data.Time as Time import System.FilePath (takeDirectory) @@ -69,11 +69,4 @@ makeItem root prefix path (Info {title, desc, date, artist}) = [b|@4 |] else "" - date' = formatDate date - -formatDate :: Day -> Builder -formatDate d = - fromString $ Time.formatTime Time.defaultTimeLocale format $ - Time.UTCTime d 15669 - where - format = "%a, %d %b %_Y %T GMT" + date' = formatRSS date diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs index 88efc73..c4886d2 100644 --- a/make-pages/SinglePage.hs +++ b/make-pages/SinglePage.hs @@ -1,5 +1,6 @@ module SinglePage (make) where +import Date import Info import BuilderQQ import Records () @@ -9,7 +10,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Text as Strict import qualified Data.Text.Lazy as Lazy -import qualified Data.Time as Time import System.FilePath (joinPath, splitPath, ()) import qualified System.Process as Proc import Text.Read (readMaybe) @@ -43,7 +43,7 @@ make' root prefix nsfw dataDir dir let artistTag = ifJust artist makeArtist - let formattedDate = formatDate date + let formattedDate = formatLong date let buttonBar = makeButtonBar title images let (image0@(Image {path = path0, download = download0'}), @@ -79,7 +79,7 @@ make' root prefix nsfw dataDir dir Nothing -> "by niss" let thumb = getThumb "" info - let updateDate = ifJust (Map.lookupMax updates) \(formatDate -> u, _) -> + let updateDate = ifJust (Map.lookupMax updates) \(formatLong -> u, _) -> [b|
updated $u|] pure [b|@0 @@ -227,7 +227,7 @@ extLink (Link {title, url}) = [b|@8 |] -makeUpdates :: [(Day, Text)] -> Builder +makeUpdates :: [(Date, Text)] -> Builder makeUpdates ups = if null ups then "" else [b|@4
@@ -239,31 +239,12 @@ makeUpdates ups = |] where updateList = map (uncurry makeUpdate) ups -makeUpdate :: Day -> Text -> Builder +makeUpdate :: Date -> Text -> Builder makeUpdate date txt = [b|@8
$date'
$txt |] - where date' = Time.formatTime Time.defaultTimeLocale "%-d/%-m/%Y" date - -formatDate :: Day -> Builder -formatDate date = [b|$week $day $month $year|] where - (year, month', day') = Time.toGregorian date - week' = Time.dayOfWeek date - day = nth day' - month = Strict.words "january february march april may june july \ - \august september october november december" - !! (month' - 1) - week = Strict.words "mon tue wed thu fri sat sun" !! (fromEnum week' - 1) - -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|] - + where date' = formatSlash date data Size = Size {width, height :: !Int} deriving (Eq, Show) diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index 0e127f1..14af421 100644 --- a/make-pages/make-pages.cabal +++ b/make-pages/make-pages.cabal @@ -15,6 +15,7 @@ executable make-pages main-is: Main.hs other-modules: BuilderQQ, + Date, Depend, GalleryPage, Info, diff --git a/style/shiny/gallery.css b/style/shiny/gallery.css index f2291c1..c799044 100644 --- a/style/shiny/gallery.css +++ b/style/shiny/gallery.css @@ -135,6 +135,8 @@ figcaption .date, figcaption .title { figcaption .date { top: -1px; left: -1px; } figcaption .title { bottom: -1px; left: -1px; } +.date { text-transform: lowercase; } + .year-marker { grid-area: auto / 1; padding: var(--border-thickness); diff --git a/style/shiny/single.css b/style/shiny/single.css index 59b3f95..73a297d 100644 --- a/style/shiny/single.css +++ b/style/shiny/single.css @@ -100,6 +100,8 @@ body { content: url(../18_plus.svg); } +#date { text-transform: lowercase; } + #info { max-width: 80%; margin: auto; @@ -149,6 +151,10 @@ body { grid-area: auto / 2; } +#updates .q { + font-weight: 500; +} + .updated { font-size: 90%; font-style: italic;