add info data structure & yaml parsing

make-pages/Info.hs

@@ -0,0 +1,97 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+module Info
+  (Info (..), Image (..), Link (..),
+   -- ** Reexports
+   Day (..), Text, Vector)
+where
+
+import Data.YAML (FromYAML (..), (.:))
+import qualified Data.YAML as YAML
+import Data.Time.Calendar (Day (..))
+import Data.Text (Text)
+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)
+
+
+data Info =
+  Info {
+    infoDate   :: !Day,
+    infoTitle  :: !Text,
+    infoTags   :: !(Vector Text),
+    infoDesc   :: !Text,
+    infoImages :: !(Vector Image),
+    infoThumb  :: !Text,
+    infoLinks  :: !(Vector Link)
+  }
+  deriving (Eq, Show)
+
+data Image =
+  Image {
+    imageLabel :: !Text,
+    imagePath  :: !Text,
+    imageNsfw  :: !Bool
+  }
+  deriving (Eq, Show)
+
+data Link =
+  Link {
+    linkTitle :: !Text,
+    linkUrl   :: !Text
+  }
+  deriving (Eq, Show)
+
+
+instance FromYAML Info where
+  parseYAML = YAML.withMap "info" \m ->
+    Info <$> m .: "date"
+         <*> m .: "title"
+         <*> m .: "tags"
+         <*> m .: "description"
+         <*> m .: "images"
+         <*> m .: "thumb"
+         <*> m .: "links"
+
+instance FromYAML Image where
+  parseYAML y = parseYAML y <&> \(Pair l b) -> case b of
+    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
+
+
+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 ->
+      case Map.toList m of
+        [(a, b)] -> Pair <$> parseYAML a <*> parseYAML b
+        _        -> fail "expected exactly one pair"
+
+instance FromYAML Day where
+  parseYAML = YAML.withStr "date" \str ->
+    case readMaybe $ Text.unpack str of
+      Just d -> pure d
+      Nothing -> fail $ "couldn't parse date " ++ show str
+
+instance FromYAML a => FromYAML (Vector a) where
+  parseYAML = YAML.withSeq "seq" $ fmap Vector.fromList . traverse parseYAML

make-pages/make-pages.cabal

@@ -9,12 +9,20 @@ maintainer: Rhiannon Morris <rhi@rhiannon.website>
 executable make-pages
   hs-source-dirs: .
   main-is: Main.hs
+  other-modules: Info
   default-language: Haskell2010
   default-extensions:
-    OverloadedStrings
+    BlockArguments,
+    LambdaCase,
+    OverloadedStrings,
+    RecordWildCards
   build-depends:
     base ^>= 4.12.0.0,
-    yaml ^>= 0.11.4.0,
+    containers ^>= 0.6.0.1,
+    time ^>= 1.8.0.2,
+    text ^>= 1.2.3.1,
+    vector ^>= 0.12.1.2,
+    HsYAML ^>= 0.2.1.0,
     blaze-html ^>= 0.9.1.2
   ghc-options:
     -Wall -threaded -rtsopts -with-rtsopts=-N