Add schema.org/BreadcrumbList support (grossss)

src/Foundation.hs

@@ -23,6 +23,9 @@ import qualified Yesod.Core.Unsafe as Unsafe
 import Package
 import Entry.Kind ( EntryKind, pluralise )
 
+import Data.Aeson ( encode, object )
+import qualified Data.Text.Lazy.Encoding as E
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
@@ -97,7 +100,9 @@ instance Yesod App where
         mcurrentRoute <- getCurrentRoute
 
         -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-        (title, parents) <- breadcrumbs
+        (title, crumbs) <- breadcrumbs
+        let allCrumbs = maybe crumbs (\route -> crumbs ++ [(route, title)]) mcurrentRoute
+        jsonCrumbs <- fmap (E.decodeUtf8 . encode) . withUrlRenderer $ jsonLdBreadcrumbList allCrumbs
 
         let navbars = [leftMenuItems, rightMenuItems] <*> [muser]
 
@@ -164,6 +169,22 @@ instance YesodBreadcrumbs App where
     return (entryName entry, Just $ EntriesR kind)
   breadcrumb _ = return ("home", Nothing)
 
+jsonLdBreadcrumbList :: [(Route App, Text)] -> (Route App -> [(Text, Text)] -> Text) -> Value
+jsonLdBreadcrumbList crumbs url = object
+  [ ("@context", "http://schema.org")
+  , ("@type", "BreadcrumbList")
+  , "itemListElement" .= zipWith (jsonLdListItem url) [1 :: Int ..] crumbs
+  ]
+jsonLdListItem :: (Route App -> [(Text, Text)] -> Text) -> Int -> (Route App, Text) -> Value
+jsonLdListItem url i (r, t) = object
+  [ ("@type", "ListItem")
+  , "position" .= i
+  , "item" .= object
+    [ "@id" .= url r []
+    , "name" .= t
+    ]
+  ]
+
 -- How to run database actions.
 instance YesodPersist App where
     type YesodPersistBackend App = SqlBackend

templates/default-layout.hamlet

@@ -12,12 +12,13 @@
                         <li .nav-item :Just route == mcurrentRoute:.active>
                             <a .nav-link href=@{route}>#{label}
 
-    $if not $ null parents
-        <ul .breadcrumb>
-            $forall bc <- parents
+    $if not $ null crumbs
+        <ol .breadcrumb>
+            $forall (route, title) <- crumbs
                 <li .breadcrumb-item>
-                    <a href=@{fst bc}>#{snd bc}
+                    <a href=@{route}>#{title}
             <li .breadcrumb-item.active>#{title}
+        <script type="application/ld+json">#{preEscapedToMarkup jsonCrumbs}
     $maybe msg <- mmsg
       <div .alert.alert-info #message>#{msg}