From 04b7872a176472f3bcd467738fb672ce346c02a5 Mon Sep 17 00:00:00 2001
From: Rhiannon Morris <rhi@rhiannon.website>
Date: Sun, 7 Mar 2021 22:09:17 +0100
Subject: [PATCH] cleanup in Info.hs

---
 make-pages/Info.hs | 56 +++++++++++++++++++++++++---------------------
 1 file changed, 30 insertions(+), 26 deletions(-)

diff --git a/make-pages/Info.hs b/make-pages/Info.hs
index cd42281..99ead1f 100644
--- a/make-pages/Info.hs
+++ b/make-pages/Info.hs
@@ -206,7 +206,7 @@ instance FromYAML Info where
   parseYAML = YAML.withMap "info" \m ->
     Info <$>  m .:  "date"
          <*>  m .:? "sort"         .!= ""
-         <*>  (maybe [] getUL <$> m .:? "updates")
+         <*> (m .:? "updates" >>= updateList)
          <*>  m .:? "show-updated" .!= True
          <*>  m .:  "title"
          <*>  m .:? "artist"
@@ -239,30 +239,31 @@ imageList y = pure <$> unlabelledImage y <|> parseYAML y
 
 instance FromYAML Image where
   parseYAML y = unlabelledImage y <|> labelled y where
-    labelled y' = do
-      Pair label rest <- parseYAML y'
-      i <- unlabelledImage rest
-      pure $ i {label}
+    labelled = withPairM \label -> unlabelledImage' (Just label)
 
 unlabelledImage :: YAML.Node YAML.Pos -> YAML.Parser Image
-unlabelledImage y = asStr y <|> asObj y
+unlabelledImage = unlabelledImage' Nothing
+
+unlabelledImage' :: Maybe Text ->  YAML.Node YAML.Pos -> YAML.Parser Image
+unlabelledImage' label' y = asStr y <|> asObj y
  where
   asStr = YAML.withStr "path" \(Text.unpack -> path) ->
-    pure $ Image {label = pathToLabel path, path, download = Nothing,
+    let label = fromMaybe (pathToLabel path) label' in
+    pure $ Image {label, path, download = Nothing,
                   nsfw = False, warning = Nothing}
   asObj = YAML.withMap "image info" \m -> do
     path     <- m .:  "path"
     download <- m .:? "download"
     nsfw     <- m .:? "nsfw" .!= False
     warning  <- m .:? "warning"
-    pure $ Image {label = pathToLabel path, path, download, nsfw, warning}
+    let label = fromMaybe (pathToLabel path) label'
+    pure $ Image {label, path, download, nsfw, warning}
   pathToLabel = Text.pack . dashToSpace . takeBaseName
   dashToSpace = map \case '-' -> ' '; c -> c
 
 instance FromYAML Link where
-  parseYAML y = do
-    Pair title rest <- parseYAML y
-    asStr title rest <|> asObj title rest
+  parseYAML =
+    withPairM \title rest -> asStr title rest <|> asObj title rest
    where
     asStr title = YAML.withStr "url" \url ->
       pure $ Link {title, url, nsfw = False}
@@ -271,22 +272,20 @@ instance FromYAML Link where
       nsfw <- m .:? "nsfw" .!= False
       pure $ Link {title, url, nsfw}
 
-newtype UpdateList = UL {getUL :: [Update]}
 
-instance FromYAML UpdateList where
-  parseYAML y = do
-    pairs <- YAML.withMap "updates" (pure . Map.toList) y
-    UL <$> traverse asEither pairs
-   where
-    asEither (date', rest) = do
-      date <- parseYAML date'
-      asDesc date rest <|> asObj date rest
-    asDesc date = YAML.withStr "desc" \desc ->
-      pure $ Update {date, desc, nsfw = False}
-    asObj date = YAML.withMap "update info" \m -> do
-      desc <- m .:  "desc"
-      nsfw <- m .:? "nsfw" .!= False
-      pure $ Update {date, desc, nsfw}
+updateList :: Maybe (YAML.Node YAML.Pos) -> YAML.Parser [Update]
+updateList =
+  maybe (pure []) $ YAML.withMap "updates" $ traverse asEither . Map.toList
+ where
+  asEither (date', rest) = do
+    date <- parseYAML date'
+    asDesc date rest <|> asObj date rest
+  asDesc date = YAML.withStr "desc" \desc ->
+    pure $ Update {date, desc, nsfw = False}
+  asObj date = YAML.withMap "update info" \m -> do
+    desc <- m .:  "desc"
+    nsfw <- m .:? "nsfw" .!= False
+    pure $ Update {date, desc, nsfw}
 
 
 data GalleryInfo =
@@ -399,6 +398,11 @@ instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
       [(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
       _        -> fail "expected exactly one pair"
 
+withPairM :: (FromYAML a, FromYAML b)
+          => (a -> b -> YAML.Parser c)
+          -> (YAML.Node YAML.Pos -> YAML.Parser c)
+withPairM k y = parseYAML y >>= \(Pair a b) -> k a b
+
 withPair :: (FromYAML a, FromYAML b)
          => (a -> b -> c)
          -> (YAML.Node YAML.Pos -> YAML.Parser c)