{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module DOM.Card (
      HasCard(..)
    , make
  ) where

import Article (Article(..))
import ArticlesList (ArticlesList(..))
import qualified ArticlesList (description)
import Blog (Blog(..), Renderer, Skin(..), template)
import Collection (Collection(..))
import qualified Collection (title)
import Control.Applicative ((<|>))
import Control.Monad.Reader (asks)
import qualified Data.Map as Map (lookup)
import Data.Text (Text, pack)
import Lucid (HtmlT, content_, meta_)
import Lucid.Base (makeAttribute)
import Markdown (MarkdownContent(..), metadata)
import qualified Markdown (Markdown(..))
import Page (Page(..))
import Pretty ((.$))
import System.FilePath.Posix ((</>), (<.>))

class HasCard a where
  cardType :: Renderer m => a -> m Text
  description :: Renderer m => a -> m Text
  image :: Renderer m => a -> m (Maybe String)
  title :: Renderer m => a -> m String
  urlPath :: Renderer m => a -> m String

og :: Applicative m => Text -> Text -> HtmlT m ()
og :: Text -> Text -> HtmlT m ()
og Text
attribute Text
value =
  [Attribute] -> HtmlT m ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
meta_ [
        Text -> Text -> Attribute
makeAttribute Text
"property" (Text -> Attribute) -> Text -> Attribute
forall a b. (a -> b) -> a -> b
$ Text
"og:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attribute
      , Text -> Attribute
content_ Text
value
    ]

make :: (HasCard a, Renderer m) => a -> String -> HtmlT m ()
make :: a -> String -> HtmlT m ()
make a
element String
siteURL = do
  Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"url" (Text -> HtmlT m ()) -> (String -> Text) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
sitePrefix (String -> HtmlT m ()) -> HtmlT m String -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> HtmlT m String
forall a (m :: * -> *). (HasCard a, Renderer m) => a -> m String
urlPath a
element
  Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"type" (Text -> HtmlT m ()) -> HtmlT m Text -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> HtmlT m Text
forall a (m :: * -> *). (HasCard a, Renderer m) => a -> m Text
cardType a
element
  Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"title" (Text -> HtmlT m ()) -> (String -> Text) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack (String -> HtmlT m ()) -> HtmlT m String -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> HtmlT m String
forall a (m :: * -> *). (HasCard a, Renderer m) => a -> m String
title a
element
  Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"description" (Text -> HtmlT m ()) -> HtmlT m Text -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> HtmlT m Text
forall a (m :: * -> *). (HasCard a, Renderer m) => a -> m Text
description a
element
  Maybe String -> HtmlT m ()
maybeImage (Maybe String -> HtmlT m ())
-> HtmlT m (Maybe String) -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Maybe String -> Maybe String -> Maybe String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) (Maybe String -> Maybe String -> Maybe String)
-> HtmlT m (Maybe String) -> HtmlT m (Maybe String -> Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> HtmlT m (Maybe String)
forall a (m :: * -> *).
(HasCard a, Renderer m) =>
a -> m (Maybe String)
image a
element HtmlT m (Maybe String -> Maybe String)
-> HtmlT m (Maybe String) -> HtmlT m (Maybe String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Blog -> Maybe String) -> HtmlT m (Maybe String)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Blog -> Maybe String) -> HtmlT m (Maybe String))
-> (Blog -> Maybe String) -> HtmlT m (Maybe String)
forall a b. (a -> b) -> a -> b
$Blog -> Skin
skin(Blog -> Skin) -> (Skin -> Maybe String) -> Blog -> Maybe String
forall a b c. (a -> b) -> (b -> c) -> a -> c
.$Skin -> Maybe String
cardImage))
  Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"site_name" (Text -> HtmlT m ()) -> HtmlT m Text -> HtmlT m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((Blog -> Text) -> HtmlT m Text
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((Blog -> Text) -> HtmlT m Text) -> (Blog -> Text) -> HtmlT m Text
forall a b. (a -> b) -> a -> b
$Blog -> String
name(Blog -> String) -> (String -> Text) -> Blog -> Text
forall a b c. (a -> b) -> (b -> c) -> a -> c
.$String -> Text
pack)
  where
    maybeImage :: Maybe String -> HtmlT m ()
maybeImage = HtmlT m () -> (String -> HtmlT m ()) -> Maybe String -> HtmlT m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> HtmlT m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Text -> Text -> HtmlT m ()
forall (m :: * -> *). Applicative m => Text -> Text -> HtmlT m ()
og Text
"image" (Text -> HtmlT m ()) -> (String -> Text) -> String -> HtmlT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
sitePrefix)
    sitePrefix :: String -> Text
sitePrefix = String -> Text
pack (String -> Text) -> (String -> String) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
siteURL String -> String -> String
</>)

mDImage :: (Renderer m, MarkdownContent a ) => a -> m (Maybe String)
mDImage :: a -> m (Maybe String)
mDImage = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> (a -> Maybe String) -> a -> m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"featuredImage" (Map String String -> Maybe String)
-> (a -> Map String String) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> Map String String
metadata (Markdown -> Map String String)
-> (a -> Markdown) -> a -> Map String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Markdown
forall a. MarkdownContent a => a -> Markdown
getMarkdown

mDTitle :: (Renderer m, MarkdownContent a) => a -> m String
mDTitle :: a -> m String
mDTitle = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> (a -> String) -> a -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> String
Markdown.title (Markdown -> String) -> (a -> Markdown) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Markdown
forall a. MarkdownContent a => a -> Markdown
getMarkdown

mDUrlPath :: (Renderer m, MarkdownContent a) => a -> m String
mDUrlPath :: a -> m String
mDUrlPath a
a = String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Markdown -> String
Markdown.path (a -> Markdown
forall a. MarkdownContent a => a -> Markdown
getMarkdown a
a) String -> String -> String
<.> String
"html"

mDDescription :: (Renderer m, MarkdownContent a) => String -> a -> m Text
mDDescription :: String -> a -> m Text
mDDescription String
key =
  Maybe String -> m Text
getDescription (Maybe String -> m Text) -> (a -> Maybe String) -> a -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"summary" (Map String String -> Maybe String)
-> (a -> Map String String) -> a -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> Map String String
metadata (Markdown -> Map String String)
-> (a -> Markdown) -> a -> Map String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Markdown
forall a. MarkdownContent a => a -> Markdown
getMarkdown
  where
    getDescription :: Maybe String -> m Text
getDescription = m Text -> (String -> m Text) -> Maybe String -> m Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Text
defaultDescription (Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> m Text) -> (String -> Text) -> String -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack)
    defaultDescription :: m Text
defaultDescription = (Blog -> String) -> m String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Blog -> String
name m String -> (String -> m Text) -> m Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Environment -> m Text
forall (m :: * -> *). Renderer m => String -> Environment -> m Text
template String
key (Environment -> m Text)
-> (String -> Environment) -> String -> m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \String
v -> [(Text
"name", String -> Text
pack String
v)]

instance HasCard Article where
  cardType :: Article -> m Text
cardType Article
_ = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"article"
  description :: Article -> m Text
description = String -> Article -> m Text
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
String -> a -> m Text
mDDescription String
"articleDescription"
  image :: Article -> m (Maybe String)
image = Article -> m (Maybe String)
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m (Maybe String)
mDImage
  title :: Article -> m String
title = Article -> m String
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m String
mDTitle
  urlPath :: Article -> m String
urlPath = Article -> m String
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m String
mDUrlPath

instance HasCard Page where
  cardType :: Page -> m Text
cardType Page
_ = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"website"
  description :: Page -> m Text
description = String -> Page -> m Text
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
String -> a -> m Text
mDDescription String
"pageDescription"
  image :: Page -> m (Maybe String)
image = Page -> m (Maybe String)
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m (Maybe String)
mDImage
  title :: Page -> m String
title = Page -> m String
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m String
mDTitle
  urlPath :: Page -> m String
urlPath = Page -> m String
forall (m :: * -> *) a.
(Renderer m, MarkdownContent a) =>
a -> m String
mDUrlPath

instance HasCard ArticlesList where
  cardType :: ArticlesList -> m Text
cardType ArticlesList
_ = Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"website"
  description :: ArticlesList -> m Text
description = ArticlesList -> m Text
forall (m :: * -> *). Renderer m => ArticlesList -> m Text
ArticlesList.description
  image :: ArticlesList -> m (Maybe String)
image ArticlesList
_ = Maybe String -> m (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  title :: ArticlesList -> m String
title (ArticlesList {Collection
collection :: ArticlesList -> Collection
collection :: Collection
collection}) = Collection -> m String
forall (m :: * -> *). MonadReader Blog m => Collection -> m String
Collection.title Collection
collection
  urlPath :: ArticlesList -> m String
urlPath al :: ArticlesList
al@(ArticlesList {Collection
collection :: Collection
collection :: ArticlesList -> Collection
collection}) =
    String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" String -> String
forall a. a -> a
id (Collection -> Maybe String
tag Collection
collection) String -> String -> String
</> String
file
    where
      file :: String
file = (if ArticlesList -> Bool
full ArticlesList
al then String
"all" else String
"index") String -> String -> String
<.> String
".html"