use labels for fields
This commit is contained in:
parent
120e258f7f
commit
7ad44577e5
4 changed files with 30 additions and 8 deletions
|
@ -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
12
make-pages/Records.hs
Normal 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
|
|
@ -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
|
||||
|
|
|
@ -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,
|
||||
|
|
Loading…
Reference in a new issue