tweaks in Date

make-pages/Date.hs

@@ -5,24 +5,32 @@ module Date
    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 BuilderQQ
 import Data.Function (on)
+import Data.Functor
 import Data.Maybe (fromMaybe)
 import Data.YAML (FromYAML (..))
 import qualified Data.YAML as YAML
-import Data.Text (unpack)
+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}
+
+data Date = Date {year, month :: !Int, day :: !Day}
   deriving (Eq, Ord, Show)
 
 data Day =
-    Exact  Int
-  | Approx Int
+    Exact  !Int
+  | Approx !Int
   | Unknown
   deriving (Eq, Show)
 
@@ -37,66 +45,67 @@ exact :: Day -> Bool
 exact (Exact _) = True
 exact _         = False
 
-formatLong :: Date -> Builder
+formatLong :: Date -> Text
 formatLong (Date {year, month, day}) =
-  case dayN of
+  toText case dayN of
     Nothing         -> monthYear
-    Just (nth -> d) -> [b|$approx$weekday $d $monthYear|]
+    Just (nth -> d) -> mconcat [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. $&|]
+  approx        = if exact day then "" else "approx. "
+  dayN          = dayNum day
+  day'          = fromMaybe 1 dayN
+  monthYear     = formatted "%B %Y"
+  weekday       = formatted "%a"
+  greg          = fromGregorian (toInteger year) month day'
+  formatted str = Builder.fromString $ formatTime defaultTimeLocale str greg
 
-formatShort :: Date -> Builder
-formatShort (Date {month, day}) = [b|$day'$month'|] where
+formatShort :: Date -> Text
+formatShort (Date {month, day}) = toText $ day' <> month' where
   day' = case day of
-    Exact d  -> [b|$d $&|]
-    Approx d -> [b|$d? $&|]
-    Unknown  -> ""
-  month' = formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1
+    Exact d  -> bshow d <> " "
+    Approx d -> bshow d <> "? "
+    Unknown  -> mempty
+  month' = Builder.fromString $
+    formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1
 
-formatRSS :: Date -> Builder
-formatRSS = fromString . format . toTime where
+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
+   where
+    year' = toInteger year
+    day'  = fromMaybe 1 $ dayNum day
 
-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>|]
+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 = [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|]
+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_ '-'
+  dash
   month <- readp
   day <- option Unknown do
-    char_ '-'
+    dash
     d <- readp
-    approx <- option Exact (Approx <$ ReadP.char '?')
+    approx <- option Exact $ ReadP.char '?' $> Approx
     pure $ approx d
-  pure $ Date year month day
+  pure $ Date {year, month, day}
  where
   readp = readS_to_P reads
-  char_ c = () <$ ReadP.char c
-  option k p = p <++ pure k
+  dash = void $ ReadP.char '-'
+  option k p = p <++ return k
 
 parseS :: ReadS Date
 parseS = readP_to_S parseP
@@ -109,3 +118,26 @@ parseA str = case parseS str of
 
 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

make-pages/Info.hs

@@ -23,6 +23,7 @@ import Data.Hashable (Hashable)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import qualified Data.Map.Strict as Map
+import qualified Data.HashMap.Strict as HashMap
 import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe)
 import Data.List (nub, sortBy)
 import Data.Ord (comparing)
@@ -31,6 +32,8 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
 import qualified Data.YAML as YAML
+import Text.Ginger (GVal, ToGVal (..), (~>))
+import qualified Text.Ginger as Ginger
 import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
 import Data.Bifunctor (second)
 
@@ -258,26 +261,99 @@ instance FromYAML Info where
          <*>  m .:? "links"  .!= []
          <*>  m .:? "extras" .!= []
 
+instance MonadFail m => ToGVal m Info where
+  toGVal i = Ginger.dict
+    ["date" ~> #date i,
+     "sortEx" ~> #sortEx i,
+     "updates" ~> #updates i,
+     "sfwUpdates" ~> #sfwUpdates i,
+     "nsfwUpdates" ~> #nsfwUpdates i,
+     "showUpdated" ~> #showUpdated i,
+     "title" ~> #title i,
+     "artist" ~> #artist i,
+     "mine" ~> #mine i,
+     "notMine" ~> #notMine i,
+     "nsfwOnly" ~> #nsfwOnly i,
+     "tags" ~> #tags i,
+     "nsfwTags" ~> #nsfwTags i,
+     "desc" ~> #desc i,
+     "nsfwDesc" ~> #nsfwDesc i,
+     "bg" ~> #bg i,
+     "hasCat" ~> case #images i of Cat _ -> True; Uncat _ -> False,
+     "images" ~> #images i,
+     "sfwImages" ~> #sfwImages i,
+     "nsfwImages" ~> #nsfwImages i,
+     "allNsfw" ~> #allNsfw i,
+     "allSfw" ~> #allSfw i,
+     "anyNsfw" ~> #anyNsfw i,
+     "anySfw" ~> #anySfw i,
+     "thumb" ~> #thumb i,
+     "links" ~> #links i,
+     "sfwLinks" ~> #sfwLinks i,
+     "nsfwLinks" ~> #nsfwLinks i,
+     "extras" ~> #extras i,
+     "updated" ~> nsfwFunc "updated" (#updated i),
+     "latestDate" ~> nsfwFunc "latestDate" (#latestDate i),
+     "latestYear" ~> nsfwFunc "latestYear" (#latestYear i)]
+   where
+    nsfwFunc :: ToGVal m b => String -> (Bool -> b) -> GVal m
+    nsfwFunc name f = Ginger.fromFunction \args₀ -> do
+      let (args, pos, rest) = Ginger.matchFuncArgs ["nsfw"] args₀
+      unless (null pos) do
+        fail $ name <> ": extra positional args"
+      unless (HashMap.null rest) do
+        fail $ name <> ": extra named args " <> show (HashMap.keys rest)
+      nsfw <- case HashMap.lookup "nsfw" args of
+        Nothing -> fail $ name <> ": missing argument 'nsfw'"
+        Just x  -> Ginger.fromGValM x
+      pure $ toGVal $ f nsfw
+
+instance Monad m => ToGVal m Images where
+  toGVal (Uncat imgs) = toGVal imgs
+  toGVal (Cat   cats) = Ginger.dict $ second toGVal <$> cats
+
+
 instance FromYAML Artist where
   parseYAML y = justName y <|> withUrl y where
     justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
     withUrl  = YAML.withMap "full info" \m ->
       Artist <$> m .: "name" <*> m .:? "url"
 
+instance ToGVal m Artist where
+  toGVal (Artist {name, url}) = Ginger.dict ["name" ~> name, "url" ~> url]
+
 instance FromYAML Desc where
   parseYAML y = textDesc y <|> mapDesc y where
     textDesc = YAML.withStr "text" $ pure . TextDesc
     mapDesc  = fmap LongDesc . parseYAML
 
+instance ToGVal m Desc where
+  toGVal NoDesc         = toGVal ()
+  toGVal (TextDesc txt) = toGVal $ LongDesc [DescField defDescKey txt]
+  toGVal (LongDesc d)   = Ginger.dict [k ~> v | DescField k v <- d]
+
+
 instance FromYAML DescField where parseYAML = withPair DescField
 
-imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
-imageList y = pure <$> unlabelledImage y <|> parseYAML y
 
 instance FromYAML Image where
   parseYAML y = unlabelledImage y <|> labelled y where
     labelled = withPairM \label -> unlabelledImage' (Just label)
 
+instance ToGVal m Image where
+  toGVal i = Ginger.dict
+    ["label"    ~> #label i,
+     "path"     ~> #path i,
+     "download" ~> #download i,
+     "nsfw"     ~> #nsfw i,
+     "sfw"      ~> #sfw i,
+     "warning"  ~> #warning i]
+
+
+
+imageList :: YAML.Node YAML.Pos -> YAML.Parser [Image]
+imageList y = pure <$> unlabelledImage y <|> parseYAML y
+
 unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
 unlabelledImage = unlabelledImage' Nothing
 
@@ -314,6 +390,20 @@ instance FromYAML Link where
       nsfw <- m .:? "nsfw" .!= False
       pure $ Link {title, url, nsfw}
 
+instance ToGVal m Link where
+  toGVal l = Ginger.dict
+    ["title" ~> #title l,
+     "url" ~> #url l,
+     "nsfw" ~> #nsfw l,
+     "sfw" ~> #sfw l]
+
+
+instance ToGVal m Update where
+  toGVal u = Ginger.dict
+    ["date" ~> #date u,
+     "desc" ~> #desc u,
+     "nsfw" ~> #nsfw u,
+     "sfw"  ~> #sfw u]
 
 updateList :: Maybe (YAML.Node YAML.Pos) -> YAML.Parser [Update]
 updateList =

make-pages/Records.hs

@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeApplications #-}
+{-# LANGUAGE TypeApplications #-}
 module Records (HasField (..)) where
 
 import GHC.Records

make-pages/make-pages.cabal

@@ -40,6 +40,7 @@ executable make-pages
     FlexibleInstances,
     GeneralizedNewtypeDeriving,
     LambdaCase,
+    MultiParamTypeClasses,
     NamedFieldPuns,
     OverloadedLabels,
     OverloadedLists,
@@ -55,8 +56,6 @@ executable make-pages
   other-extensions:
     CPP,
     ImplicitParams,
-    MultiParamTypeClasses,
-    ScopedTypeVariables,
     TemplateHaskell,
     TransformListComp,
     TypeApplications
@@ -66,6 +65,7 @@ executable make-pages
     containers           ^>= 0.6.0.1,
     filemanip            ^>= 0.3.6.3,
     filepath             ^>= 1.4.2.1,
+    ginger               ^>= 0.10.1.0,
     hashable             ^>= 1.3.0.0,
     HsYAML               ^>= 0.2.1.0,
     optparse-applicative ^>= 0.15.1.0,