can mark links as nsfw too

make-pages/Info.hs

@@ -13,7 +13,6 @@ import qualified Data.Text as Text
 import Data.Vector (Vector)
 import qualified Data.Vector as Vector
 import qualified Data.Map.Strict as Map
-import Data.Functor
 import Control.Applicative
 import Text.Read (readMaybe)
 
@@ -41,7 +40,8 @@ data Image =
 data Link =
   Link {
     title :: !Text,
-    url   :: !Text
+    url   :: !Text,
+    nsfw  :: !Bool
   }
   deriving (Eq, Show)
 
@@ -57,29 +57,14 @@ instance FromYAML Info where
          <*> m .: "links"
 
 instance FromYAML Image where
-  parseYAML y = parseYAML y <&> \(Pair l b) -> case b of
+  parseYAML = labelledOptNsfw Image "path" "path"
-    IBPath p   -> Image l p False
-    IBFull p n -> Image l p n
-
-
-data ImageBody = IBPath !Text | IBFull !Text !Bool
-
-instance FromYAML ImageBody where
-  parseYAML y = path y <|> full y where
-    path = fmap IBPath . parseYAML
-    full = YAML.withMap "path & nsfw" \m ->
-      IBFull <$> m .: "path" <*> m .: "nsfw"
-
 
 instance FromYAML Link where
-  parseYAML = fmap (uncurryP Link) . parseYAML
+  parseYAML = labelledOptNsfw Link "url" "url"
 
 
 data Pair a b = Pair !a !b
 
-uncurryP :: (a -> b -> c) -> Pair a b -> c
-uncurryP f (Pair a b) = f a b
-
 instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
   parseYAML =
     YAML.withMap "single-pair map" \m ->
@@ -87,6 +72,33 @@ instance (FromYAML a, FromYAML b) => FromYAML (Pair a b) where
         [(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
         _        -> fail "expected exactly one pair"
 
+
+data OptNsfw a = NoNsfw !a | WithNsfw !a !Bool
+
+appOptNsfw :: (a -> Bool -> b) -> OptNsfw a -> b
+appOptNsfw f (NoNsfw   x)   = f x False
+appOptNsfw f (WithNsfw x n) = f x n
+
+labelledOptNsfw :: FromYAML a
+                => (Text -> a -> Bool -> b)
+                -> String -- ^ name in \"expected\" message
+                -> Text   -- ^ field name
+                -> YAML.Node YAML.Pos -> YAML.Parser b
+labelledOptNsfw f name field y = do
+  Pair l n' <- parseYAML y
+  n <- parseOptNsfw name field n'
+  pure $ appOptNsfw (f l) n
+
+parseOptNsfw :: FromYAML a
+             => String -- ^ name in \"expected\" message
+             -> Text   -- ^ field name
+             -> YAML.Node YAML.Pos -> YAML.Parser (OptNsfw a)
+parseOptNsfw name field y = yes y <|> no y where
+  yes = YAML.withMap (name <> " & nsfw") \m ->
+    WithNsfw <$> m .: field <*> m .: "nsfw"
+  no = fmap NoNsfw . parseYAML
+
+
 instance FromYAML Day where
   parseYAML = YAML.withStr "date" \str ->
     case readMaybe $ Text.unpack str of