add support for approx dates

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|<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

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)

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
 

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
       </description>
     |]
     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

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|<br> <span class=updated>updated $u</span>|]
 
   pure [b|@0
@@ -227,7 +227,7 @@ extLink (Link {title, url}) = [b|@8
       </a>
   |]
 
-makeUpdates :: [(Day, Text)] -> Builder
+makeUpdates :: [(Date, Text)] -> Builder
 makeUpdates ups =
   if null ups then "" else [b|@4
     <section id=updates class=info-section>
@@ -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
     <dt>$date'
     <dd>$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)
 

make-pages/make-pages.cabal

@@ -15,6 +15,7 @@ executable make-pages
   main-is: Main.hs
   other-modules:
     BuilderQQ,
+    Date,
     Depend,
     GalleryPage,
     Info,

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);

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;