Compare commits
3 Commits
Author | SHA1 | Date |
---|---|---|
Rhiannon Morris | 92b198afce | |
Rhiannon Morris | b8970b6436 | |
Rhiannon Morris | 2485e3e234 |
|
@ -5,24 +5,32 @@ module Date
|
||||||
parseP, parseS, parseA)
|
parseP, parseS, parseA)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
import Records ()
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import qualified Text.ParserCombinators.ReadP as ReadP
|
import qualified Text.ParserCombinators.ReadP as ReadP
|
||||||
import Text.ParserCombinators.ReadP (ReadP, readS_to_P, readP_to_S, (<++))
|
import Text.ParserCombinators.ReadP (ReadP, readS_to_P, readP_to_S, (<++))
|
||||||
import Data.Time hiding (Day)
|
import Data.Time hiding (Day)
|
||||||
import Data.Char (isSpace)
|
import Data.Char (isSpace)
|
||||||
import BuilderQQ
|
|
||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
|
import Data.Functor
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.YAML (FromYAML (..))
|
import Data.YAML (FromYAML (..))
|
||||||
import qualified Data.YAML as YAML
|
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)
|
deriving (Eq, Ord, Show)
|
||||||
|
|
||||||
data Day =
|
data Day =
|
||||||
Exact Int
|
Exact !Int
|
||||||
| Approx Int
|
| Approx !Int
|
||||||
| Unknown
|
| Unknown
|
||||||
deriving (Eq, Show)
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
@ -37,66 +45,67 @@ exact :: Day -> Bool
|
||||||
exact (Exact _) = True
|
exact (Exact _) = True
|
||||||
exact _ = False
|
exact _ = False
|
||||||
|
|
||||||
formatLong :: Date -> Builder
|
formatLong :: Date -> Text
|
||||||
formatLong (Date {year, month, day}) =
|
formatLong (Date {year, month, day}) =
|
||||||
case dayN of
|
toText case dayN of
|
||||||
Nothing -> monthYear
|
Nothing -> monthYear
|
||||||
Just (nth -> d) -> [b|$approx$weekday $d $monthYear|]
|
Just (nth -> d) -> mconcat [approx, weekday, " ", d, " ", monthYear]
|
||||||
where
|
where
|
||||||
dayN = dayNum day
|
approx = if exact day then "" else "approx. "
|
||||||
day' = fromMaybe 1 dayN
|
dayN = dayNum day
|
||||||
formatted str = fromString $
|
day' = fromMaybe 1 dayN
|
||||||
formatTime defaultTimeLocale str $
|
monthYear = formatted "%B %Y"
|
||||||
fromGregorian (toInteger year) month day'
|
weekday = formatted "%a"
|
||||||
monthYear = formatted "%B %Y"
|
greg = fromGregorian (toInteger year) month day'
|
||||||
weekday = formatted "%a"
|
formatted str = Builder.fromString $ formatTime defaultTimeLocale str greg
|
||||||
approx = if exact day then "" else [b|approx. $&|]
|
|
||||||
|
|
||||||
formatShort :: Date -> Builder
|
formatShort :: Date -> Text
|
||||||
formatShort (Date {month, day}) = [b|$day'$month'|] where
|
formatShort (Date {month, day}) = toText $ day' <> month' where
|
||||||
day' = case day of
|
day' = case day of
|
||||||
Exact d -> [b|$d $&|]
|
Exact d -> bshow d <> " "
|
||||||
Approx d -> [b|$d? $&|]
|
Approx d -> bshow d <> "? "
|
||||||
Unknown -> ""
|
Unknown -> mempty
|
||||||
month' = formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1
|
month' = Builder.fromString $
|
||||||
|
formatTime defaultTimeLocale "%b" $ fromGregorian 1 month 1
|
||||||
|
|
||||||
formatRSS :: Date -> Builder
|
formatRSS :: Date -> Text
|
||||||
formatRSS = fromString . format . toTime where
|
formatRSS = pack . format . toTime where
|
||||||
format = formatTime defaultTimeLocale "%a, %d %b %_Y %T GMT"
|
format = formatTime defaultTimeLocale "%a, %d %b %_Y %T GMT"
|
||||||
toTime (Date {year, month, day}) =
|
toTime (Date {year, month, day}) =
|
||||||
let year' = toInteger year; day' = fromMaybe 1 $ dayNum day in
|
|
||||||
UTCTime (fromGregorian year' month day') 15600
|
UTCTime (fromGregorian year' month day') 15600
|
||||||
|
where
|
||||||
|
year' = toInteger year
|
||||||
|
day' = fromMaybe 1 $ dayNum day
|
||||||
|
|
||||||
formatSlash :: Date -> Builder
|
formatSlash :: Date -> Text
|
||||||
formatSlash (Date {year, month, day}) = case dayNum day of
|
formatSlash (Date {year, month, day}) =
|
||||||
Nothing -> [b|$year/$month|]
|
toText $ mconcat [bshow year, "/", bshow month, "/", bshow day', bshow ex]
|
||||||
Just d -> [b|$year/$month/$d$q|]
|
where day' = dayNum day; ex = exact day
|
||||||
where q = if exact day then "" else [b|<span class=q>?</span>|]
|
|
||||||
|
|
||||||
|
|
||||||
nth :: Int -> Builder
|
nth :: Int -> Builder
|
||||||
nth n = [b|$n$suf|] where
|
nth n = bshow n <> suf where
|
||||||
suf | n >= 10, n <= 19 = [b|th|]
|
suf | n >= 10, n <= 19 = "th"
|
||||||
| n `mod` 10 == 1 = [b|st|]
|
| n `mod` 10 == 1 = "st"
|
||||||
| n `mod` 10 == 2 = [b|nd|]
|
| n `mod` 10 == 2 = "nd"
|
||||||
| n `mod` 10 == 3 = [b|rd|]
|
| n `mod` 10 == 3 = "rd"
|
||||||
| otherwise = [b|th|]
|
| otherwise = "th"
|
||||||
|
|
||||||
parseP :: ReadP Date
|
parseP :: ReadP Date
|
||||||
parseP = do
|
parseP = do
|
||||||
year <- readp
|
year <- readp
|
||||||
char_ '-'
|
dash
|
||||||
month <- readp
|
month <- readp
|
||||||
day <- option Unknown do
|
day <- option Unknown do
|
||||||
char_ '-'
|
dash
|
||||||
d <- readp
|
d <- readp
|
||||||
approx <- option Exact (Approx <$ ReadP.char '?')
|
approx <- option Exact $ ReadP.char '?' $> Approx
|
||||||
pure $ approx d
|
pure $ approx d
|
||||||
pure $ Date year month day
|
pure $ Date {year, month, day}
|
||||||
where
|
where
|
||||||
readp = readS_to_P reads
|
readp = readS_to_P reads
|
||||||
char_ c = () <$ ReadP.char c
|
dash = void $ ReadP.char '-'
|
||||||
option k p = p <++ pure k
|
option k p = p <++ return k
|
||||||
|
|
||||||
parseS :: ReadS Date
|
parseS :: ReadS Date
|
||||||
parseS = readP_to_S parseP
|
parseS = readP_to_S parseP
|
||||||
|
@ -109,3 +118,26 @@ parseA str = case parseS str of
|
||||||
|
|
||||||
instance FromYAML Date where
|
instance FromYAML Date where
|
||||||
parseYAML = YAML.withStr "date" $ parseA . unpack
|
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 Data.HashSet (HashSet)
|
||||||
import qualified Data.HashSet as HashSet
|
import qualified Data.HashSet as HashSet
|
||||||
import qualified Data.Map.Strict as Map
|
import qualified Data.Map.Strict as Map
|
||||||
|
import qualified Data.HashMap.Strict as HashMap
|
||||||
import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe)
|
import Data.Maybe (isJust, isNothing, fromMaybe, mapMaybe)
|
||||||
import Data.List (nub, sortBy)
|
import Data.List (nub, sortBy)
|
||||||
import Data.Ord (comparing)
|
import Data.Ord (comparing)
|
||||||
|
@ -31,6 +32,8 @@ import Data.Text (Text)
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
|
||||||
import qualified Data.YAML as YAML
|
import qualified Data.YAML as YAML
|
||||||
|
import Text.Ginger (GVal, ToGVal (..), (~>))
|
||||||
|
import qualified Text.Ginger as Ginger
|
||||||
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
import System.FilePath ((</>), takeBaseName, takeExtension, splitExtension)
|
||||||
import Data.Bifunctor (second)
|
import Data.Bifunctor (second)
|
||||||
|
|
||||||
|
@ -258,26 +261,99 @@ instance FromYAML Info where
|
||||||
<*> m .:? "links" .!= []
|
<*> m .:? "links" .!= []
|
||||||
<*> m .:? "extras" .!= []
|
<*> 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
|
instance FromYAML Artist where
|
||||||
parseYAML y = justName y <|> withUrl y where
|
parseYAML y = justName y <|> withUrl y where
|
||||||
justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
|
justName = YAML.withStr "name" \name -> pure $ Artist {name, url = Nothing}
|
||||||
withUrl = YAML.withMap "full info" \m ->
|
withUrl = YAML.withMap "full info" \m ->
|
||||||
Artist <$> m .: "name" <*> m .:? "url"
|
Artist <$> m .: "name" <*> m .:? "url"
|
||||||
|
|
||||||
|
instance ToGVal m Artist where
|
||||||
|
toGVal (Artist {name, url}) = Ginger.dict ["name" ~> name, "url" ~> url]
|
||||||
|
|
||||||
instance FromYAML Desc where
|
instance FromYAML Desc where
|
||||||
parseYAML y = textDesc y <|> mapDesc y where
|
parseYAML y = textDesc y <|> mapDesc y where
|
||||||
textDesc = YAML.withStr "text" $ pure . TextDesc
|
textDesc = YAML.withStr "text" $ pure . TextDesc
|
||||||
mapDesc = fmap LongDesc . parseYAML
|
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
|
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
|
instance FromYAML Image where
|
||||||
parseYAML y = unlabelledImage y <|> labelled y where
|
parseYAML y = unlabelledImage y <|> labelled y where
|
||||||
labelled = withPairM \label -> unlabelledImage' (Just label)
|
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 :: YAML.Node YAML.Pos -> YAML.Parser Image
|
||||||
unlabelledImage = unlabelledImage' Nothing
|
unlabelledImage = unlabelledImage' Nothing
|
||||||
|
|
||||||
|
@ -314,6 +390,20 @@ instance FromYAML Link where
|
||||||
nsfw <- m .:? "nsfw" .!= False
|
nsfw <- m .:? "nsfw" .!= False
|
||||||
pure $ Link {title, url, nsfw}
|
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 :: Maybe (YAML.Node YAML.Pos) -> YAML.Parser [Update]
|
||||||
updateList =
|
updateList =
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
module Records (HasField (..)) where
|
module Records (HasField (..)) where
|
||||||
|
|
||||||
import GHC.Records
|
import GHC.Records
|
||||||
|
|
|
@ -40,6 +40,7 @@ executable make-pages
|
||||||
FlexibleInstances,
|
FlexibleInstances,
|
||||||
GeneralizedNewtypeDeriving,
|
GeneralizedNewtypeDeriving,
|
||||||
LambdaCase,
|
LambdaCase,
|
||||||
|
MultiParamTypeClasses,
|
||||||
NamedFieldPuns,
|
NamedFieldPuns,
|
||||||
OverloadedLabels,
|
OverloadedLabels,
|
||||||
OverloadedLists,
|
OverloadedLists,
|
||||||
|
@ -55,8 +56,6 @@ executable make-pages
|
||||||
other-extensions:
|
other-extensions:
|
||||||
CPP,
|
CPP,
|
||||||
ImplicitParams,
|
ImplicitParams,
|
||||||
MultiParamTypeClasses,
|
|
||||||
ScopedTypeVariables,
|
|
||||||
TemplateHaskell,
|
TemplateHaskell,
|
||||||
TransformListComp,
|
TransformListComp,
|
||||||
TypeApplications
|
TypeApplications
|
||||||
|
@ -66,6 +65,7 @@ executable make-pages
|
||||||
containers ^>= 0.6.0.1,
|
containers ^>= 0.6.0.1,
|
||||||
filemanip ^>= 0.3.6.3,
|
filemanip ^>= 0.3.6.3,
|
||||||
filepath ^>= 1.4.2.1,
|
filepath ^>= 1.4.2.1,
|
||||||
|
ginger ^>= 0.10.1.0,
|
||||||
hashable ^>= 1.3.0.0,
|
hashable ^>= 1.3.0.0,
|
||||||
HsYAML ^>= 0.2.1.0,
|
HsYAML ^>= 0.2.1.0,
|
||||||
optparse-applicative ^>= 0.15.1.0,
|
optparse-applicative ^>= 0.15.1.0,
|
||||||
|
|
Loading…
Reference in New Issue