use labels for fields

This commit is contained in:
Rhiannon Morris 2020-07-13 08:33:27 +02:00
parent 120e258f7f
commit 7ad44577e5
4 changed files with 30 additions and 8 deletions

View file

@ -5,6 +5,8 @@ module Info
Day (..), Text) Day (..), Text)
where where
import Records
import Data.YAML (FromYAML (..), (.:), (.:?), (.!=)) import Data.YAML (FromYAML (..), (.:), (.:?), (.!=))
import qualified Data.YAML as YAML import qualified Data.YAML as YAML
import Data.Time.Calendar (Day (..)) import Data.Time.Calendar (Day (..))
@ -52,6 +54,11 @@ data Link =
} }
deriving (Eq, Show) deriving (Eq, Show)
instance HasField "nsfw" Info Bool where getField = all #nsfw . #images
instance HasField "sfw" Info Bool where getField = not . #nsfw
instance HasField "sfw" Image Bool where getField = not . #nsfw
instance HasField "sfw" Link Bool where getField = not . #nsfw
instance FromYAML Info where instance FromYAML Info where
parseYAML = YAML.withMap "info" \m -> parseYAML = YAML.withMap "info" \m ->

12
make-pages/Records.hs Normal file
View file

@ -0,0 +1,12 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE
FlexibleInstances, InstanceSigs, MultiParamTypeClasses, ScopedTypeVariables,
TypeApplications
#-}
module Records (HasField (..)) where
import GHC.Records
import GHC.OverloadedLabels
instance HasField x r a => IsLabel x (r -> a) where
fromLabel = getField @x

View file

@ -1,5 +1,6 @@
module SinglePage (make) where module SinglePage (make) where
import Records ()
import Info hiding (Text) import Info hiding (Text)
import BuildVar import BuildVar
@ -59,9 +60,11 @@ make' nsfw (Info {date, title, tags, nsfwTags,
where where
titleTag = ifJust title \t -> [b|<title>$*t</title>|] titleTag = ifJust title \t -> [b|<title>$*t</title>|]
titleHeader = ifJust title \t -> [b|<h1>$*t</h1>|] titleHeader = ifJust title \t -> [b|<h1>$*t</h1>|]
formattedDate = formatDate date formattedDate = formatDate date
buttonBar = makeButtonBar (fromMaybe path0 title) nsfw images buttonBar = makeButtonBar (fromMaybe path0 title) nsfw images
path0 = let Image {path} = head images in path path0 = #path $ head images
descSection = ifJust description makeDesc descSection = ifJust description makeDesc
tagsList = makeTags nsfw tags nsfwTags tagsList = makeTags nsfw tags nsfwTags
@ -96,9 +99,8 @@ makeButtonBar title nsfw allImages =
|] |]
where where
images | nsfw = allImages images | nsfw = allImages
| otherwise = filter (\Image {nsfw} -> not nsfw) allImages | otherwise = filter #sfw allImages
iimages = zip [0..] images alts = map (uncurry altButton) $ zip [0..] images
alts = map (uncurry altButton) iimages
altButton :: Int -> Image -> Builder altButton :: Int -> Image -> Builder
altButton i (Image {label, path, nsfw}) = [b|@6 altButton i (Image {label, path, nsfw}) = [b|@6
@ -145,8 +147,7 @@ extLinks nsfw allLinks =
</div> </div>
|] |]
where where
links | nsfw = allLinks links = if nsfw then allLinks else filter #sfw allLinks
| otherwise = filter (\Link {nsfw} -> not nsfw) allLinks
linkList = map extLink links linkList = map extLink links
extLink :: Link -> Builder extLink :: Link -> Builder

View file

@ -9,15 +9,17 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
executable make-pages executable make-pages
hs-source-dirs: . hs-source-dirs: .
main-is: Main.hs main-is: Main.hs
other-modules: Info, SinglePage, BuildVar other-modules: Info, SinglePage, BuildVar, Records
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
BlockArguments, BlockArguments,
DataKinds,
DeriveAnyClass, DeriveAnyClass,
DerivingStrategies, DerivingStrategies,
DuplicateRecordFields, DuplicateRecordFields,
LambdaCase, LambdaCase,
NamedFieldPuns, NamedFieldPuns,
OverloadedLabels,
OverloadedStrings, OverloadedStrings,
PatternSynonyms, PatternSynonyms,
QuasiQuotes, QuasiQuotes,