add ToGVal instances

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

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,