WIP: use ginger templates #9
4 changed files with 169 additions and 47 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeApplications #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
module Records (HasField (..)) where
|
||||
|
||||
import GHC.Records
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue