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

View file

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