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)
|
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
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
|
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
|
||||||
|
|
|
@ -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,
|
||||||
|
|
Loading…
Reference in a new issue