diff --git a/make-pages/Date.hs b/make-pages/Date.hs index 3c22927..efe9775 100644 --- a/make-pages/Date.hs +++ b/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|?|] +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 diff --git a/make-pages/Info.hs b/make-pages/Info.hs index b942a56..4427121 100644 --- a/make-pages/Info.hs +++ b/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 = diff --git a/make-pages/Records.hs b/make-pages/Records.hs index d58c5d2..ccd15bd 100644 --- a/make-pages/Records.hs +++ b/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 diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal index d564260..ac968fd 100644 --- a/make-pages/make-pages.cabal +++ b/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,