From 7ad44577e53ea3857b4e9be8cebcee4aeaf51f1a Mon Sep 17 00:00:00 2001
From: Rhiannon Morris <rhi@rhiannon.website>
Date: Mon, 13 Jul 2020 08:33:27 +0200
Subject: [PATCH] use labels for fields

---
 make-pages/Info.hs          |  7 +++++++
 make-pages/Records.hs       | 12 ++++++++++++
 make-pages/SinglePage.hs    | 15 ++++++++-------
 make-pages/make-pages.cabal |  4 +++-
 4 files changed, 30 insertions(+), 8 deletions(-)
 create mode 100644 make-pages/Records.hs

diff --git a/make-pages/Info.hs b/make-pages/Info.hs
index 063c57c..c78a5e2 100644
--- a/make-pages/Info.hs
+++ b/make-pages/Info.hs
@@ -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 ->
diff --git a/make-pages/Records.hs b/make-pages/Records.hs
new file mode 100644
index 0000000..245e773
--- /dev/null
+++ b/make-pages/Records.hs
@@ -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
diff --git a/make-pages/SinglePage.hs b/make-pages/SinglePage.hs
index 56b4424..00d84b7 100644
--- a/make-pages/SinglePage.hs
+++ b/make-pages/SinglePage.hs
@@ -1,5 +1,6 @@
 module SinglePage (make) where
 
+import Records ()
 import Info hiding (Text)
 import BuildVar
 
@@ -57,11 +58,13 @@ make' nsfw (Info {date, title, tags, nsfwTags,
     </footer>
   |]
   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>|]
+
     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
diff --git a/make-pages/make-pages.cabal b/make-pages/make-pages.cabal
index 29064ec..9a76ed1 100644
--- a/make-pages/make-pages.cabal
+++ b/make-pages/make-pages.cabal
@@ -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,