cleanup in Info.hs

This commit is contained in:
Rhiannon Morris 2021-03-07 22:09:17 +01:00
parent 5c3ca348c2
commit 04b7872a17

View file

@ -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)