{-# LANGUAGE OverloadedStrings #-}
module Contexts.Field (
    localDateField
  , iso8601DateField
  , jsonLdArticleField
  , jsonLdPersonField
  , jsonLdWebSiteField
  , breadcrumbField
  , tagsField'
  , tagCloudField'
  , descriptionField
  , imageField
  , ogImageField
  , yearMonthArchiveField
  , searchBoxResultField
) where

import           Control.Monad           (forM_, liftM2)
import           Control.Monad.Trans     (lift)
import           Data.Aeson              (Value, encode, object, (.=))
import qualified Data.ByteString.Lazy    as BL
import           Data.Function           (on)
import           Data.Functor            ((<&>))
import           Data.List               (inits, intercalate, isPrefixOf,
                                          isSuffixOf, sortBy)
import           Data.List.Extra         (mconcatMap)
import           Data.Maybe              (catMaybes, fromMaybe)
import qualified Data.Text               as T
import qualified Data.Text.Lazy          as TL
import qualified Data.Text.Lazy.Encoding as TLE
import           Data.Time.Format        (TimeLocale (..), formatTime)
import           Data.Time.LocalTime     (TimeZone (..), utcToLocalTime)
import           Hakyll                  hiding (isExternal)
import           Lucid.Base              (Html, ToHtml (..), renderText,
                                          renderTextT, toHtml)
import           Lucid.Html5
import           System.FilePath         (splitDirectories)
import qualified Text.HTML.TagSoup       as TS

import           Archives                (Archives (..), MonthlyArchives,
                                          YearlyArchives)
import           Config.Author           (authorDescriptionEn,
                                          authorDescriptionJa, authorGithub,
                                          authorJobTitle, authorName,
                                          authorStackOverflow, authorTwitter)
import           Config.Site             (baseUrl, defaultTimeLocale', siteName,
                                          timeZoneJST)

toLink :: String -> String -> Html ()
toLink :: String -> String -> HtmlT Identity ()
toLink String
text String
path = [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
toUrl String
path)] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtml String
text

localDateField :: TimeLocale -> TimeZone -> String -> String -> Context a
localDateField :: forall a. TimeLocale -> TimeZone -> String -> String -> Context a
localDateField TimeLocale
locale TimeZone
zone String
key String
format = String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$
    (UTCTime -> String) -> Compiler UTCTime -> Compiler String
forall a b. (a -> b) -> Compiler a -> Compiler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
locale String
format (LocalTime -> String)
-> (UTCTime -> LocalTime) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
zone) (Compiler UTCTime -> Compiler String)
-> (Item a -> Compiler UTCTime) -> Item a -> Compiler String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeLocale -> Identifier -> Compiler UTCTime
forall (m :: * -> *).
(MonadMetadata m, MonadFail m) =>
TimeLocale -> Identifier -> m UTCTime
getItemUTC TimeLocale
locale (Identifier -> Compiler UTCTime)
-> (Item a -> Identifier) -> Item a -> Compiler UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier

iso8601DateField :: String -> Context String
iso8601DateField :: String -> Context String
iso8601DateField String
key = TimeLocale -> TimeZone -> String -> String -> Context String
forall a. TimeLocale -> TimeZone -> String -> String -> Context a
localDateField TimeLocale
defaultTimeLocale' TimeZone
timeZoneJST String
key String
"%Y-%m-%dT%H:%M:%S%Ez"

-- | JSON-LD Article Schema (BlogPosting) を生成するフィールド
-- schema.org仕様に準拠したJSON-LDを出力
jsonLdArticleField :: String -> Context String
jsonLdArticleField :: String -> Context String
jsonLdArticleField String
key = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item -> do
    -- メタデータからタイトルと更新日を取得
    Metadata
metadata <- Identifier -> Compiler Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item)
    let mTitle :: Maybe String
mTitle = String -> Metadata -> Maybe String
lookupString String
"title" Metadata
metadata
        mUpdated :: Maybe String
mUpdated = String -> Metadata -> Maybe String
lookupString String
"updated" Metadata
metadata

    -- 日付をISO 8601形式で取得
    let iso8601Format :: String
iso8601Format = String
"%Y-%m-%dT%H:%M:%S%Ez"
        formatDate :: UTCTime -> String
formatDate = TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale' String
iso8601Format (LocalTime -> String)
-> (UTCTime -> LocalTime) -> UTCTime -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
timeZoneJST
    String
publishedDate <- UTCTime -> String
formatDate (UTCTime -> String) -> Compiler UTCTime -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TimeLocale -> Identifier -> Compiler UTCTime
forall (m :: * -> *).
(MonadMetadata m, MonadFail m) =>
TimeLocale -> Identifier -> m UTCTime
getItemUTC TimeLocale
defaultTimeLocale' (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item)

    -- dateModifiedはupdatedメタデータがあればそれを使用、なければpublishedDateと同じ
    let dateModified :: String
dateModified = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
publishedDate Maybe String
mUpdated

    -- URLを取得（絶対URL）
    Maybe String
mRoute <- Identifier -> Compiler (Maybe String)
getRoute (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item)
    let articleUrl :: String
articleUrl = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((String
baseUrl String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUrl) Maybe String
mRoute

    -- リソースボディを1回だけ取得してパフォーマンス改善
    String
resourceBody <- Item String -> String
forall a. Item a -> a
itemBody (Item String -> String)
-> Compiler (Item String) -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item String)
getResourceBody

    -- 説明文を取得（最初の150文字）
    let description :: String
description = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
150 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
resourceBody

    -- 画像URLを取得（なければデフォルト画像）
    let defaultImage :: String
defaultImage = String
baseUrl String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/images/avator/prof1000x1000.png"
        images :: [String]
images = [Tag String] -> [String]
extractImagesFromHtml ([Tag String] -> [String]) -> [Tag String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [Tag String]
forall str. StringLike str => str -> [Tag str]
TS.parseTags String
resourceBody
        imageUrl :: String
imageUrl = case [String]
images of
            []      -> String
defaultImage
            (String
src:[String]
_) -> if String -> Bool
isExternal String
src then String
src else String
baseUrl String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
src

    case Maybe String
mTitle of
        Maybe String
Nothing -> String -> Compiler String
forall a. String -> Compiler a
noResult (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": title not found"
        Just String
title -> String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
            [ Key
"@context" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"https://schema.org" :: String)
            , Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"BlogPosting" :: String)
            , Key
"headline" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
title
            , Key
"image" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
imageUrl
            , Key
"datePublished" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
publishedDate
            , Key
"dateModified" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
dateModified
            , Key
"author" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"Person" :: String)
                , Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
authorName
                , Key
"url" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
baseUrl
                ]
            , Key
"publisher" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                [ Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"Organization" :: String)
                , Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
siteName
                , Key
"logo" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
                    [ Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"ImageObject" :: String)
                    , Key
"url" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
defaultImage
                    ]
                ]
            , Key
"description" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
description
            , Key
"url" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
articleUrl
            ]

-- | JSON-LD Person Schema を生成するフィールド
-- サイト著者の構造化データを出力
-- langメタデータに応じてdescriptionを多言語切り替え
jsonLdPersonField :: String -> Context String
jsonLdPersonField :: String -> Context String
jsonLdPersonField String
key = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item -> do
    -- langメタデータを取得（デフォルトは"ja"）
    Maybe String
mLang <- Identifier -> String -> Compiler (Maybe String)
forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item) String
"lang"
    let description :: String
description = case Maybe String
mLang of
            Just String
"ja" -> String
authorDescriptionJa
            Just String
"en" -> String
authorDescriptionEn
            Maybe String
_         -> String
authorDescriptionJa  -- デフォルトは日本語
    String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
        [ Key
"@context" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"https://schema.org" :: String)
        , Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"Person" :: String)
        , Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
authorName
        , Key
"url" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
baseUrl
        , Key
"sameAs" Key -> [String] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.=
            [ String
"https://twitter.com/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
authorTwitter
            , String
"https://github.com/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
authorGithub
            , String
"https://stackoverflow.com/users/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
authorStackOverflow
            ]
        , Key
"jobTitle" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
authorJobTitle
        , Key
"description" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
description
        ]

-- | JSON-LD WebSite Schema を生成するフィールド
-- サイト全体の構造化データと検索機能を出力
jsonLdWebSiteField :: String -> Context String
jsonLdWebSiteField :: String -> Context String
jsonLdWebSiteField String
key = String -> String -> Context String
forall a. String -> String -> Context a
constField String
key (String -> Context String) -> String -> Context String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    [ Key
"@context" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"https://schema.org" :: String)
    , Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"WebSite" :: String)
    , Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
siteName
    , Key
"url" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
baseUrl
    , Key
"description" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"Roki's technical blog and hobby content" :: String)
    , Key
"potentialAction" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"SearchAction" :: String)
        , Key
"target" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
baseUrl String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/roki.log/search.html?q={search_term_string}")
        , Key
"query-input" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"required name=search_term_string" :: String)
        ]
    ]

-- | BreadcrumbList の個別要素を生成
mkListItem :: Int -> String -> String -> Value
mkListItem :: Int -> String -> String -> Value
mkListItem Int
pos String
name String
url = [Pair] -> Value
object
    [ Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"ListItem" :: String)
    , Key
"position" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
pos
    , Key
"name" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
name
    , Key
"item" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
url
    ]

-- | パスセグメントからパンくず要素のリストを構築
-- ホーム要素を先頭に追加し、各セグメントに累積的な URL を設定
buildBreadcrumbs :: String -> String -> [String] -> [Value]
buildBreadcrumbs :: String -> String -> [String] -> [Value]
buildBreadcrumbs String
base String
finalTitle [String]
segments =
    Value
homeItem Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: (Int -> String -> String -> Value)
-> [Int] -> [String] -> [String] -> [Value]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Int -> String -> String -> Value
mkListItem [Int
2 ..] [String]
names [String]
urls
  where
    homeItem :: Value
homeItem = Int -> String -> String -> Value
mkListItem Int
1 String
"ホーム" String
base
    names :: [String]
names = [String] -> [String]
forall a. HasCallStack => [a] -> [a]
init [String]
segments [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
finalTitle]
    urls :: [String]
urls = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
base String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/") ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [[String]]
forall a. HasCallStack => [a] -> [a]
tail ([[String]] -> [[String]]) -> [[String]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]]
forall a. [a] -> [[a]]
inits [String]
segments

-- | JSON-LD BreadcrumbList スキーマを生成するフィールド
-- パス構造から階層的なパンくずリストを構築し、schema.org 仕様に準拠した JSON-LD を出力
breadcrumbField :: String -> Context String
breadcrumbField :: String -> Context String
breadcrumbField String
key = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item ->
    Identifier -> Compiler (Maybe String)
getRoute (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item) Compiler (Maybe String)
-> (Maybe String -> Compiler String) -> Compiler String
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe String
mRoute ->
        case Maybe String
mRoute of
            Maybe String
Nothing -> String -> Compiler String
forall a. String -> Compiler a
noResult (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": route not found"
            Just String
route ->
                let segments :: [String]
segments = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitDirectories String
route
                in case [String]
segments of
                    [] -> String -> Compiler String
forall a. String -> Compiler a
noResult (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": empty route"
                    [String]
_ -> do
                        Metadata
metadata <- Identifier -> Compiler Metadata
forall (m :: * -> *). MonadMetadata m => Identifier -> m Metadata
getMetadata (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item)
                        let title :: String
title = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe ([String] -> String
forall a. HasCallStack => [a] -> a
last [String]
segments) (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ String -> Metadata -> Maybe String
lookupString String
"title" Metadata
metadata
                            breadcrumbs :: [Value]
breadcrumbs = String -> String -> [String] -> [Value]
buildBreadcrumbs String
baseUrl String
title [String]
segments
                        String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
TLE.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
                            [ Key
"@context" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"https://schema.org" :: String)
                            , Key
"@type" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (String
"BreadcrumbList" :: String)
                            , Key
"itemListElement" Key -> [Value] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Value]
breadcrumbs
                            ]

isExternal :: String -> Bool
isExternal :: String -> Bool
isExternal String
url = String
"http://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
url Bool -> Bool -> Bool
|| String
"https://" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
url

-- | HTML文字列から画像URLを抽出する共通関数
-- 外部URL、SVG画像、空のsrc属性を除外
extractImagesFromHtml :: [TS.Tag String] -> [String]
extractImagesFromHtml :: [Tag String] -> [String]
extractImagesFromHtml = (Tag String -> String) -> [Tag String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Tag String -> String
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
TS.fromAttrib String
"src") ([Tag String] -> [String])
-> ([Tag String] -> [Tag String]) -> [Tag String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
filter Tag String -> Bool
isValidImage
  where
    isValidImage :: Tag String -> Bool
isValidImage Tag String
tag =
        let src :: String
src = String -> Tag String -> String
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
TS.fromAttrib String
"src" Tag String
tag
        in String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
TS.isTagOpenName String
"img" Tag String
tag
            Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
src)
            Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
isExternal String
src)
            Bool -> Bool -> Bool
&& Bool -> Bool
not (String
".svg" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
src)

imageField :: String -> Context String
imageField :: String -> Context String
imageField String
key = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item ->
    case [Tag String] -> [String]
extractImagesFromHtml ([Tag String] -> [String]) -> [Tag String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [Tag String]
forall str. StringLike str => str -> [Tag str]
TS.parseTags (String -> [Tag String]) -> String -> [Tag String]
forall a b. (a -> b) -> a -> b
$ Item String -> String
forall a. Item a -> a
itemBody Item String
item of
        [] -> String -> Compiler String
forall a. String -> Compiler a
noResult (String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" has no image")
        (String
src:[String]
_) -> String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return String
src

ogImageField :: String -> String -> Context String
ogImageField :: String -> String -> Context String
ogImageField String
key String
defaultImage = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ \Item String
item ->
    (Maybe String -> String)
-> Compiler (Maybe String) -> Compiler String
forall a b. (a -> b) -> Compiler a -> Compiler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String
makeAbsoluteUrl (String -> String)
-> (Maybe String -> String) -> Maybe String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
defaultImage)
        (Compiler (Maybe String) -> Compiler String)
-> Compiler (Maybe String) -> Compiler String
forall a b. (a -> b) -> a -> b
$ Identifier -> String -> Compiler (Maybe String)
forall (m :: * -> *).
MonadMetadata m =>
Identifier -> String -> m (Maybe String)
getMetadataField (Item String -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item String
item) String
"og-image"
  where
    makeAbsoluteUrl :: String -> String
    makeAbsoluteUrl :: String -> String
makeAbsoluteUrl String
path
        | (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
path) [String
"http://", String
"https://"] = String
path
        | Bool
otherwise = String
"https://" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
siteName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
ensureLeadingSlash String
path

    ensureLeadingSlash :: String -> String
    ensureLeadingSlash :: String -> String
ensureLeadingSlash s :: String
s@(Char
'/':String
_) = String
s
    ensureLeadingSlash String
s         = Char
'/' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s

descriptionField :: String -> Int -> Context String
descriptionField :: String -> Int -> Context String
descriptionField String
key Int
len = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item String -> Compiler String) -> Context String)
-> (Item String -> Compiler String) -> Context String
forall a b. (a -> b) -> a -> b
$ Compiler String -> Item String -> Compiler String
forall a b. a -> b -> a
const (Compiler String -> Item String -> Compiler String)
-> Compiler String -> Item String -> Compiler String
forall a b. (a -> b) -> a -> b
$
    Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
len (String -> String)
-> (Item String -> String) -> Item String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String)
-> (Item String -> [String]) -> Item String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String])
-> (Item String -> String) -> Item String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item String -> String
forall a. Item a -> a
itemBody (Item String -> String)
-> Compiler (Item String) -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Compiler (Item String)
getResourceBody

tagsField' :: String -> Tags -> Context a
tagsField' :: forall a. String -> Tags -> Context a
tagsField' String
key Tags
tags = String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ \Item a
item -> do
    [HtmlT Identity ()]
links <- Identifier -> Compiler [String]
forall (m :: * -> *). MonadMetadata m => Identifier -> m [String]
getTags (Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item)
        Compiler [String]
-> ([String] -> Compiler [Maybe (HtmlT Identity ())])
-> Compiler [Maybe (HtmlT Identity ())]
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> Compiler (Maybe (HtmlT Identity ())))
-> [String] -> Compiler [Maybe (HtmlT Identity ())]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Maybe String -> Maybe (HtmlT Identity ()))
 -> Compiler (Maybe String) -> Compiler (Maybe (HtmlT Identity ())))
-> (String -> Maybe String -> Maybe (HtmlT Identity ()))
-> (String -> Compiler (Maybe String))
-> String
-> Compiler (Maybe (HtmlT Identity ()))
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (Maybe String -> Maybe (HtmlT Identity ()))
-> Compiler (Maybe String) -> Compiler (Maybe (HtmlT Identity ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
(<$>) String -> Maybe String -> Maybe (HtmlT Identity ())
forall {f :: * -> *}.
Functor f =>
String -> f String -> f (HtmlT Identity ())
toLink' (Identifier -> Compiler (Maybe String)
getRoute (Identifier -> Compiler (Maybe String))
-> (String -> Identifier) -> String -> Compiler (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tags -> String -> Identifier
tagsMakeId Tags
tags))
        Compiler [Maybe (HtmlT Identity ())]
-> ([Maybe (HtmlT Identity ())] -> [HtmlT Identity ()])
-> Compiler [HtmlT Identity ()]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [Maybe (HtmlT Identity ())] -> [HtmlT Identity ()]
forall a. [Maybe a] -> [a]
catMaybes
    if [HtmlT Identity ()] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [HtmlT Identity ()]
links
        then String -> Compiler String
forall a. String -> Compiler a
noResult (String
"Field " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": tag not set (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Identifier -> String
forall a. Show a => a -> String
show (Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
        else String -> Compiler String
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ (HtmlT Identity () -> HtmlT Identity ())
-> [HtmlT Identity ()] -> HtmlT Identity ()
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap ([Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"tag is-dark"]) [HtmlT Identity ()]
links
    where
        toLink' :: String -> f String -> f (HtmlT Identity ())
toLink' String
tag = (String -> HtmlT Identity ()) -> f String -> f (HtmlT Identity ())
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> HtmlT Identity ()
toLink String
tag)

tagCloudField' :: String -> Tags -> Context a
tagCloudField' :: forall a. String -> Tags -> Context a
tagCloudField' String
key Tags
tags = String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ Compiler String -> Item a -> Compiler String
forall a b. a -> b -> a
const (Compiler String -> Item a -> Compiler String)
-> Compiler String -> Item a -> Compiler String
forall a b. (a -> b) -> a -> b
$
    Text -> String
TL.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text)
-> (String -> HtmlT Identity ()) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"tags"] (HtmlT Identity () -> HtmlT Identity ())
-> (String -> HtmlT Identity ()) -> String -> HtmlT Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HtmlT Identity ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtmlRaw (String -> String) -> Compiler String -> Compiler String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> String -> Int -> Int -> Int -> String)
-> ([String] -> String) -> Tags -> Compiler String
renderTags String -> String -> Int -> Int -> Int -> String
forall {b} {b} {b}. String -> String -> b -> b -> b -> String
toLink' [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Tags
tags
    where
        toLink' :: String -> String -> b -> b -> b -> String
toLink' String
tag String
path = (b -> b -> String) -> b -> b -> b -> String
forall a b. a -> b -> a
const ((b -> b -> String) -> b -> b -> b -> String)
-> (b -> b -> String) -> b -> b -> b -> String
forall a b. (a -> b) -> a -> b
$ (b -> String) -> b -> b -> String
forall a b. a -> b -> a
const ((b -> String) -> b -> b -> String)
-> (b -> String) -> b -> b -> String
forall a b. (a -> b) -> a -> b
$ String -> b -> String
forall a b. a -> b -> a
const (String -> b -> String) -> String -> b -> String
forall a b. (a -> b) -> a -> b
$
            Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
span_ [Text -> Attribute
class_ Text
"tag is-dark"] (HtmlT Identity () -> HtmlT Identity ())
-> HtmlT Identity () -> HtmlT Identity ()
forall a b. (a -> b) -> a -> b
$ String -> String -> HtmlT Identity ()
toLink String
tag String
path


{-# INLINE buildYearMonthArchiveField #-}
buildYearMonthArchiveField :: YearlyArchives
    -> MonthlyArchives
    -> Maybe String
    -> Compiler String
buildYearMonthArchiveField :: YearlyArchives
-> MonthlyArchives -> Maybe String -> Compiler String
buildYearMonthArchiveField YearlyArchives
ya MonthlyArchives
ma Maybe String
pageYear = (Text -> String) -> Compiler Text -> Compiler String
forall a b. (a -> b) -> Compiler a -> Compiler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
TL.unpack (Compiler Text -> Compiler String)
-> Compiler Text -> Compiler String
forall a b. (a -> b) -> a -> b
$ HtmlT Compiler () -> Compiler Text
forall (m :: * -> *) a. Monad m => HtmlT m a -> m Text
renderTextT (HtmlT Compiler () -> Compiler Text)
-> HtmlT Compiler () -> Compiler Text
forall a b. (a -> b) -> a -> b
$
    [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
ul_ [Text -> Attribute
class_ Text
"archive-tree"] (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ do
        let yearMap :: [(String, [Identifier])]
yearMap = ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
-> [(String, [Identifier])] -> [(String, [Identifier])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int -> Int -> Ordering) -> Int -> Int -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> ((String, [Identifier]) -> Int)
-> (String, [Identifier])
-> (String, [Identifier])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String -> Int
forall a. Read a => String -> a
read :: String -> Int) (String -> Int)
-> ((String, [Identifier]) -> String)
-> (String, [Identifier])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [Identifier]) -> String
forall a b. (a, b) -> a
fst) ([(String, [Identifier])] -> [(String, [Identifier])])
-> [(String, [Identifier])] -> [(String, [Identifier])]
forall a b. (a -> b) -> a -> b
$ YearlyArchives -> [(String, [Identifier])]
forall k. Archives k -> [(k, [Identifier])]
archivesMap YearlyArchives
ya
            getUrl :: Identifier -> HtmlT Compiler String
getUrl = Compiler String -> HtmlT Compiler String
forall (m :: * -> *) a. Monad m => m a -> HtmlT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Compiler String -> HtmlT Compiler String)
-> (Identifier -> Compiler String)
-> Identifier
-> HtmlT Compiler String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String -> String)
-> Compiler (Maybe String) -> Compiler String
forall a b. (a -> b) -> Compiler a -> Compiler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String
toUrl (String -> String)
-> (Maybe String -> String) -> Maybe String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"#") (Compiler (Maybe String) -> Compiler String)
-> (Identifier -> Compiler (Maybe String))
-> Identifier
-> Compiler String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Compiler (Maybe String)
getRoute

        [(String, [Identifier])]
-> ((String, [Identifier]) -> HtmlT Compiler ())
-> HtmlT Compiler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(String, [Identifier])]
yearMap (((String, [Identifier]) -> HtmlT Compiler ())
 -> HtmlT Compiler ())
-> ((String, [Identifier]) -> HtmlT Compiler ())
-> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ \(String
year, [Identifier]
yids) ->
            HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ do
                let monthMap :: [((String, String), [Identifier])]
monthMap = (((String, String), [Identifier])
 -> ((String, String), [Identifier]) -> Ordering)
-> [((String, String), [Identifier])]
-> [((String, String), [Identifier])]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Int -> Int -> Ordering) -> Int -> Int -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> Int -> Ordering)
-> (((String, String), [Identifier]) -> Int)
-> ((String, String), [Identifier])
-> ((String, String), [Identifier])
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String -> Int
forall a. Read a => String -> a
read :: String -> Int) (String -> Int)
-> (((String, String), [Identifier]) -> String)
-> ((String, String), [Identifier])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> (((String, String), [Identifier]) -> (String, String))
-> ((String, String), [Identifier])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String), [Identifier]) -> (String, String)
forall a b. (a, b) -> a
fst) ([((String, String), [Identifier])]
 -> [((String, String), [Identifier])])
-> [((String, String), [Identifier])]
-> [((String, String), [Identifier])]
forall a b. (a -> b) -> a -> b
$
                        (((String, String), [Identifier]) -> Bool)
-> [((String, String), [Identifier])]
-> [((String, String), [Identifier])]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
year) (String -> Bool)
-> (((String, String), [Identifier]) -> String)
-> ((String, String), [Identifier])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (((String, String), [Identifier]) -> (String, String))
-> ((String, String), [Identifier])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String), [Identifier]) -> (String, String)
forall a b. (a, b) -> a
fst) ([((String, String), [Identifier])]
 -> [((String, String), [Identifier])])
-> [((String, String), [Identifier])]
-> [((String, String), [Identifier])]
forall a b. (a -> b) -> a -> b
$ MonthlyArchives -> [((String, String), [Identifier])]
forall k. Archives k -> [(k, [Identifier])]
archivesMap MonthlyArchives
ma
                    treeLael :: Text
treeLael = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"tree-label-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
year

                [Attribute] -> HtmlT Compiler ()
forall (m :: * -> *). Applicative m => [Attribute] -> HtmlT m ()
input_ ([Attribute] -> HtmlT Compiler ())
-> [Attribute] -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ [Text -> Attribute
class_ Text
"tree-toggle", Text -> Attribute
type_ Text
"checkbox", Text -> Attribute
id_ Text
treeLael] [Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++
                    [Attribute
checked_ | String -> Maybe String
forall a. a -> Maybe a
Just String
year Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe String
pageYear]
                [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
label_ [Text -> Attribute
class_ Text
"tree-toggle-button", Text -> Attribute
for_ Text
treeLael] (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ do
                    [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
i_ [[Text] -> Attribute
classes_ [Text
"fas", Text
"fa-angle-right", Text
"fa-fw"]] HtmlT Compiler ()
""
                    [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
i_ [[Text] -> Attribute
classes_ [Text
"fas", Text
"fa-angle-down", Text
"fa-fw"]] HtmlT Compiler ()
""

                String
yurl <- Identifier -> HtmlT Compiler String
getUrl (Identifier -> HtmlT Compiler String)
-> Identifier -> HtmlT Compiler String
forall a b. (a -> b) -> a -> b
$ YearlyArchives -> String -> Identifier
forall k. Archives k -> k -> Identifier
archivesMakeId YearlyArchives
ya String
year
                [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (String -> Text
T.pack String
yurl)] (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$
                    String -> HtmlT Compiler ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtml (String -> HtmlT Compiler ()) -> String -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ String
year String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Identifier] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
yids) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

                [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
ul_ [Text -> Attribute
class_ Text
"tree-child"] (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$
                    [((String, String), [Identifier])]
-> (((String, String), [Identifier]) -> HtmlT Compiler ())
-> HtmlT Compiler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [((String, String), [Identifier])]
monthMap ((((String, String), [Identifier]) -> HtmlT Compiler ())
 -> HtmlT Compiler ())
-> (((String, String), [Identifier]) -> HtmlT Compiler ())
-> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ \(mk :: (String, String)
mk@(String
_, String
month), [Identifier]
mids) ->
                        HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
li_ (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ do
                            String
murl <- Identifier -> HtmlT Compiler String
getUrl (Identifier -> HtmlT Compiler String)
-> Identifier -> HtmlT Compiler String
forall a b. (a -> b) -> a -> b
$ MonthlyArchives -> (String, String) -> Identifier
forall k. Archives k -> k -> Identifier
archivesMakeId MonthlyArchives
ma (String, String)
mk
                            [Attribute] -> HtmlT Compiler () -> HtmlT Compiler ()
forall arg result. Term arg result => arg -> result
a_ [Text -> Attribute
href_ (String -> Text
T.pack String
murl)] (HtmlT Compiler () -> HtmlT Compiler ())
-> HtmlT Compiler () -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$
                                String -> HtmlT Compiler ()
forall a (m :: * -> *). (ToHtml a, Monad m) => a -> HtmlT m ()
forall (m :: * -> *). Monad m => String -> HtmlT m ()
toHtml (String -> HtmlT Compiler ()) -> String -> HtmlT Compiler ()
forall a b. (a -> b) -> a -> b
$ String
year String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
month String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show ([Identifier] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Identifier]
mids) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

yearMonthArchiveField :: String
    -> YearlyArchives
    -> MonthlyArchives
    -> Maybe String
    -> Context a
yearMonthArchiveField :: forall a.
String
-> YearlyArchives -> MonthlyArchives -> Maybe String -> Context a
yearMonthArchiveField String
key YearlyArchives
ya MonthlyArchives
ma Maybe String
s = String -> (Item a -> Compiler String) -> Context a
forall a. String -> (Item a -> Compiler String) -> Context a
field String
key
    ((Item a -> Compiler String) -> Context a)
-> (Item a -> Compiler String) -> Context a
forall a b. (a -> b) -> a -> b
$ Compiler String -> Item a -> Compiler String
forall a b. a -> b -> a
const
    (Compiler String -> Item a -> Compiler String)
-> Compiler String -> Item a -> Compiler String
forall a b. (a -> b) -> a -> b
$ YearlyArchives
-> MonthlyArchives -> Maybe String -> Compiler String
buildYearMonthArchiveField YearlyArchives
ya MonthlyArchives
ma Maybe String
s

searchBoxResultField :: Context String
searchBoxResultField :: Context String
searchBoxResultField = String -> String -> Context String
forall a. String -> String -> Context a
constField String
"body" (String -> Context String) -> String -> Context String
forall a b. (a -> b) -> a -> b
$
    Text -> String
TL.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ HtmlT Identity () -> Text
forall a. Html a -> Text
renderText (HtmlT Identity () -> Text) -> HtmlT Identity () -> Text
forall a b. (a -> b) -> a -> b
$ [Attribute] -> HtmlT Identity () -> HtmlT Identity ()
forall arg result. Term arg result => arg -> result
div_ [Text -> Attribute
class_ Text
"gcse-searchresults-only"] HtmlT Identity ()
forall a. Monoid a => a
mempty