From 2485e3e234f6a292d1b8faddf7de3f4b09f0797c Mon Sep 17 00:00:00 2001 From: Rhiannon Morris Date: Sat, 20 Mar 2021 12:46:32 +0100 Subject: [PATCH] add ToGVal instances --- make-pages/Date.hs | 21 +++++++++ make-pages/Info.hs | 94 ++++++++++++++++++++++++++++++++++++- make-pages/Records.hs | 2 +- make-pages/make-pages.cabal | 4 +- 4 files changed, 116 insertions(+), 5 deletions(-) diff --git a/make-pages/Date.hs b/make-pages/Date.hs index 3c22927..7b040a7 100644 --- a/make-pages/Date.hs +++ b/make-pages/Date.hs @@ -5,6 +5,7 @@ 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, (<++)) @@ -15,6 +16,9 @@ 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 (unpack) data Date = Date {year, month :: Int, day :: Day} @@ -109,3 +113,20 @@ 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 = toStrictText $ formatLong d + short = toStrictText $ formatShort d + rss = toStrictText $ formatRSS d + slash = toStrictText $ formatSlash d 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,