{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

module Hakyll.Convert.Blogger (FullPost (..), readPosts, distill) where

import Control.Arrow
import Control.Monad
import Data.Function
import Data.List
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Data.XML.Types (Element (..), Name (..), Node (..), elementChildren)
import Hakyll.Convert.Common
import Text.Atom.Feed
import Text.Atom.Feed.Import
import qualified Text.XML as XML

-- | A post and its comments
data FullPost = FullPost
  { FullPost -> Entry
fpPost :: Entry,
    FullPost -> [Entry]
fpComments :: [Entry],
    FullPost -> Text
fpUri :: T.Text
  }
  deriving (Int -> FullPost -> ShowS
[FullPost] -> ShowS
FullPost -> String
(Int -> FullPost -> ShowS)
-> (FullPost -> String) -> ([FullPost] -> ShowS) -> Show FullPost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FullPost] -> ShowS
$cshowList :: [FullPost] -> ShowS
show :: FullPost -> String
$cshow :: FullPost -> String
showsPrec :: Int -> FullPost -> ShowS
$cshowsPrec :: Int -> FullPost -> ShowS
Show)

-- | An entry is assumed to be either a post, or a comment.
--   If it's a post, it should be associated with the URI
--   that visitors would use to read the post (on the old blog)
--   If it's a comment, it should be the URI for the corresponding
--   post.
data BloggerEntry
  = Post {BloggerEntry -> Text
beUri_ :: T.Text, BloggerEntry -> Entry
beEntry :: Entry}
  | Comment {beUri_ :: T.Text, beEntry :: Entry}
  | Orphan {beEntry :: Entry}
  deriving (Int -> BloggerEntry -> ShowS
[BloggerEntry] -> ShowS
BloggerEntry -> String
(Int -> BloggerEntry -> ShowS)
-> (BloggerEntry -> String)
-> ([BloggerEntry] -> ShowS)
-> Show BloggerEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BloggerEntry] -> ShowS
$cshowList :: [BloggerEntry] -> ShowS
show :: BloggerEntry -> String
$cshow :: BloggerEntry -> String
showsPrec :: Int -> BloggerEntry -> ShowS
$cshowsPrec :: Int -> BloggerEntry -> ShowS
Show)

beUri :: BloggerEntry -> Maybe T.Text
beUri :: BloggerEntry -> Maybe Text
beUri (Orphan Entry
_) = Maybe Text
forall a. Maybe a
Nothing
beUri (Post Text
u Entry
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
u
beUri (Comment Text
u Entry
_) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
u

-- ---------------------------------------------------------------------
-- Feed to helper type
-- ---------------------------------------------------------------------

-- | Returns only published posts
readPosts :: FilePath -> IO (Maybe [FullPost])
readPosts :: String -> IO (Maybe [FullPost])
readPosts String
f = do
  Document
doc <- ParseSettings -> String -> IO Document
XML.readFile (ParseSettings
forall a. Default a => a
XML.def :: XML.ParseSettings) String
f
  let root :: Element
root = Element -> Element
XML.toXMLElement (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Document -> Element
XML.documentRoot Document
doc
  Maybe [FullPost] -> IO (Maybe [FullPost])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [FullPost] -> IO (Maybe [FullPost]))
-> Maybe [FullPost] -> IO (Maybe [FullPost])
forall a b. (a -> b) -> a -> b
$ (Feed -> [FullPost]) -> Maybe Feed -> Maybe [FullPost]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Entry] -> [FullPost]
extractPosts ([Entry] -> [FullPost]) -> (Feed -> [Entry]) -> Feed -> [FullPost]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feed -> [Entry]
feedEntries) (Maybe Feed -> Maybe [FullPost]) -> Maybe Feed -> Maybe [FullPost]
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Feed
elementFeed (Element -> Maybe Feed) -> Element -> Maybe Feed
forall a b. (a -> b) -> a -> b
$ Element -> Element
deleteDrafts Element
root

-- has to be done on the XML level as our atom lib doesn't understand
-- the blogger-specific XML for drafts
deleteDrafts :: Element -> Element
deleteDrafts :: Element -> Element
deleteDrafts Element
e =
  Element
e {elementNodes :: [Node]
elementNodes = (Node -> Bool) -> [Node] -> [Node]
forall a. (a -> Bool) -> [a] -> [a]
filter Node -> Bool
isInnocent (Element -> [Node]
elementNodes Element
e)}
  where
    isInnocent :: Node -> Bool
isInnocent (NodeElement Element
element) = Bool -> Bool
not (Element -> Bool
isDraft Element
element)
    isInnocent Node
_ = Bool
True

isDraft :: Element -> Bool
isDraft :: Element -> Bool
isDraft Element
e =
  Bool -> Bool
not (Bool -> Bool) -> ([Element] -> Bool) -> [Element] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Element] -> Bool) -> [Element] -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Element -> [Element]
findElements Name
draft Element
e
  where
    draft :: Name
draft =
      Name :: Text -> Maybe Text -> Maybe Text -> Name
Name
        { nameLocalName :: Text
nameLocalName = Text
"draft",
          nameNamespace :: Maybe Text
nameNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://purl.org/atom/app#",
          namePrefix :: Maybe Text
namePrefix = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"app"
        }

-- | Warning: this silently ignores orphans, templates, settings
extractPosts :: [Entry] -> [FullPost]
extractPosts :: [Entry] -> [FullPost]
extractPosts [Entry]
entries =
  ((Text, [BloggerEntry]) -> FullPost)
-> [(Text, [BloggerEntry])] -> [FullPost]
forall a b. (a -> b) -> [a] -> [b]
map (Text, [BloggerEntry]) -> FullPost
toFullPost [(Text, [BloggerEntry])]
blocks
  where
    toFullPost :: (Text, [BloggerEntry]) -> FullPost
toFullPost (Text
uri, [BloggerEntry]
blockEntries) =
      FullPost :: Entry -> [Entry] -> Text -> FullPost
FullPost
        { fpPost :: Entry
fpPost = Entry
post,
          fpComments :: [Entry]
fpComments = [Entry]
comments,
          fpUri :: Text
fpUri = Text
uri
        }
      where
        post :: Entry
post = case [Entry
e | Post Text
_ Entry
e <- [BloggerEntry]
blockEntries] of
          [] -> String -> Entry
forall c. String -> c
huh String
"Block of entries with no post?!"
          [Entry
p] -> Entry
p
          [Entry]
_ps -> String -> Entry
forall c. String -> c
huh String
"Block of entries with more than one post?!"
        comments :: [Entry]
comments = [Entry
e | Comment Text
_ Entry
e <- [BloggerEntry]
blockEntries]
        huh :: String -> c
huh String
msg = String -> c
forall a. HasCallStack => String -> a
error (String -> c) -> ([String] -> String) -> [String] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> c) -> [String] -> c
forall a b. (a -> b) -> a -> b
$ String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (BloggerEntry -> String) -> [BloggerEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (TextContent -> String
txtToString (TextContent -> String)
-> (BloggerEntry -> TextContent) -> BloggerEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> TextContent
entryTitle (Entry -> TextContent)
-> (BloggerEntry -> Entry) -> BloggerEntry -> TextContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BloggerEntry -> Entry
beEntry) [BloggerEntry]
blockEntries
    blocks :: [(Text, [BloggerEntry])]
blocks = [(Text
u, [BloggerEntry]
xs) | (Just Text
u, [BloggerEntry]
xs) <- [(Maybe Text, [BloggerEntry])]
blocks_] -- drop orphans
    blocks_ :: [(Maybe Text, [BloggerEntry])]
blocks_ =
      (BloggerEntry -> Maybe Text)
-> [BloggerEntry] -> [(Maybe Text, [BloggerEntry])]
forall b a. Ord b => (a -> b) -> [a] -> [(b, [a])]
buckets BloggerEntry -> Maybe Text
beUri ([BloggerEntry] -> [(Maybe Text, [BloggerEntry])])
-> [BloggerEntry] -> [(Maybe Text, [BloggerEntry])]
forall a b. (a -> b) -> a -> b
$
        (Entry -> BloggerEntry) -> [Entry] -> [BloggerEntry]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> BloggerEntry
identifyEntry ([Entry] -> [BloggerEntry]) -> [Entry] -> [BloggerEntry]
forall a b. (a -> b) -> a -> b
$
          (Entry -> Bool) -> [Entry] -> [Entry]
forall a. (a -> Bool) -> [a] -> [a]
filter Entry -> Bool
isInteresting [Entry]
entries

-- | Contains actual meat (posts, comments; but not eg. templates)
isInteresting :: Entry -> Bool
isInteresting :: Entry -> Bool
isInteresting Entry
e =
  Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Category -> Bool) -> [Category] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Category -> Bool
isBoring [Category]
cats
  where
    isBoring :: Category -> Bool
isBoring Category
c = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
t -> Text -> Category -> Bool
isBloggerCategoryOfType Text
t Category
c) [Text
"settings", Text
"template"]
    cats :: [Category]
cats = Entry -> [Category]
entryCategories Entry
e

-- | Tag an entry from the blogger feed as either being a post,
--   a comment, or an "orphan" (a comment without an associated post)
identifyEntry :: Entry -> BloggerEntry
identifyEntry :: Entry -> BloggerEntry
identifyEntry Entry
e =
  if Entry -> Bool
isPost Entry
e
    then case Text -> Maybe Link
getLink Text
"self" Maybe Link -> Maybe Link -> Maybe Link
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Text -> Maybe Link
getLink Text
"alternate" of
      Just Link
l -> Text -> Entry -> BloggerEntry
Post (Link -> Text
postUrl Link
l) Entry
e
      Maybe Link
Nothing -> Entry -> Text -> BloggerEntry
forall a. Entry -> Text -> a
entryError Entry
e Text
oopsSelf
    else case Text -> Maybe Link
getLink Text
"alternate" of
      Just Link
l -> Text -> Entry -> BloggerEntry
Comment (Link -> Text
postUrl Link
l) Entry
e
      Maybe Link
Nothing -> Entry -> BloggerEntry
Orphan Entry
e
  where
    isPost :: Entry -> Bool
isPost = (Category -> Bool) -> [Category] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Category -> Bool
isBloggerCategoryOfType Text
"post") ([Category] -> Bool) -> (Entry -> [Category]) -> Entry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> [Category]
entryCategories
    postUrl :: Link -> Text
postUrl = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?') (Text -> Text) -> (Link -> Text) -> Link -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
replaceSchema (Text -> Text) -> (Link -> Text) -> Link -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Link -> Text
linkHref
    replaceSchema :: Text -> Text
replaceSchema Text
url = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
url (Text -> Text -> Text
T.append Text
"https://") (Text -> Text -> Maybe Text
T.stripPrefix Text
"http://" Text
url)
    getLink :: Text -> Maybe Link
getLink Text
ty = case (Link -> Bool) -> [Link] -> [Link]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Link -> Bool
isLink Text
ty) ([Link] -> [Link]) -> [Link] -> [Link]
forall a b. (a -> b) -> a -> b
$ Entry -> [Link]
entryLinks Entry
e of
      [] -> Maybe Link
forall a. Maybe a
Nothing
      [Link
x] -> Link -> Maybe Link
forall a. a -> Maybe a
Just Link
x
      [Link]
_xs -> Entry -> Text -> Maybe Link
forall a. Entry -> Text -> a
entryError Entry
e (Text -> Text
oopsLink Text
ty)
    isLink :: Text -> Link -> Bool
isLink Text
ty Link
l = Link -> Maybe (Either Text Text)
linkRel Link
l Maybe (Either Text Text) -> Maybe (Either Text Text) -> Bool
forall a. Eq a => a -> a -> Bool
== Either Text Text -> Maybe (Either Text Text)
forall a. a -> Maybe a
Just (Text -> Either Text Text
forall a b. b -> Either a b
Right Text
ty) Bool -> Bool -> Bool
&& Link -> Maybe Text
linkType Link
l Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"text/html"
    oopsSelf :: Text
oopsSelf = Text
"Was expecting blog posts to have a self link"
    oopsLink :: Text -> Text
oopsLink Text
ty = Text -> Text -> Text
T.append Text
"Was expecting entries have at most one link of type " Text
ty

isBloggerCategory :: Category -> Bool
isBloggerCategory :: Category -> Bool
isBloggerCategory =
  (Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://schemas.google.com/g/2005#kind")
    (Maybe Text -> Bool)
-> (Category -> Maybe Text) -> Category -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Maybe Text
catScheme

isBloggerCategoryOfType ::
  -- | \"comment\", \"post\", etc
  T.Text ->
  Category ->
  Bool
isBloggerCategoryOfType :: Text -> Category -> Bool
isBloggerCategoryOfType Text
ty Category
c =
  Category -> Bool
isBloggerCategory Category
c
    Bool -> Bool -> Bool
&& Category -> Text
catTerm Category
c Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Text -> Text
T.append Text
"http://schemas.google.com/blogger/2008/kind#" Text
ty

-- ---------------------------------------------------------------------
--
-- ---------------------------------------------------------------------

distill :: Bool -> FullPost -> DistilledPost
distill :: Bool -> FullPost -> DistilledPost
distill Bool
extractComments FullPost
fp =
  DistilledPost :: Text
-> Text
-> Maybe Text
-> [Text]
-> [Text]
-> UTCTime
-> DistilledPost
DistilledPost
    { dpBody :: Text
dpBody = Entry -> Text
body Entry
fpost,
      dpUri :: Text
dpUri = FullPost -> Text
fpUri FullPost
fp,
      dpTitle :: Maybe Text
dpTitle = Entry -> Maybe Text
title Entry
fpost,
      dpTags :: [Text]
dpTags = Entry -> [Text]
tags Entry
fpost,
      dpCategories :: [Text]
dpCategories = [],
      dpDate :: UTCTime
dpDate = Entry -> UTCTime
forall p. ParseTime p => Entry -> p
date Entry
fpost
    }
  where
    fpost :: Entry
fpost = FullPost -> Entry
fpPost FullPost
fp
    fcomments :: [Entry]
fcomments = FullPost -> [Entry]
fpComments FullPost
fp
    --
    body :: Entry -> Text
body Entry
post =
      let article :: Text
article = Maybe EntryContent -> Text
fromContent (Maybe EntryContent -> Text) -> Maybe EntryContent -> Text
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe EntryContent
entryContent Entry
post
          comments :: Text
comments = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Entry -> Text) -> [Entry] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> Text
formatComment [Entry]
fcomments
       in if Bool
extractComments
            then
              Text -> [Text] -> Text
T.intercalate
                Text
"\n"
                [ Text
article,
                  Text
"",
                  Text
"<h3 id='hakyll-convert-comments-title'>Comments</h3>",
                  Text
comments
                ]
            else Text
article

    fromContent :: Maybe EntryContent -> Text
fromContent (Just (HTMLContent Text
x)) = Text
x
    fromContent Maybe EntryContent
_ = String -> Text
forall a. HasCallStack => String -> a
error String
"Hakyll.Convert.Blogger.distill expecting HTML"

    formatComment :: Entry -> Text
formatComment Entry
c =
      Text -> [Text] -> Text
T.intercalate
        Text
"\n"
        [ Text
"<div class='hakyll-convert-comment'>",
          [Text] -> Text
T.concat
            [ Text
"<p class='hakyll-convert-comment-date'>",
              Text
"On ",
              Text
pubdate,
              Text
", ",
              Text
author,
              Text
" wrote:",
              Text
"</p>"
            ],
          Text
"<div class='hakyll-convert-comment-body'>",
          Text
comment,
          Text
"</div>",
          Text
"</div>"
        ]
      where
        pubdate :: Text
pubdate = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"unknown date" (Entry -> Maybe Text
entryPublished Entry
c)
        author :: Text
author = [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Person -> Text) -> [Person] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Person -> Text
personName (Entry -> [Person]
entryAuthors Entry
c)
        comment :: Text
comment = Maybe EntryContent -> Text
fromContent (Maybe EntryContent -> Text) -> Maybe EntryContent -> Text
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe EntryContent
entryContent Entry
c
    --
    title :: Entry -> Maybe Text
title Entry
p = case TextContent -> String
txtToString (Entry -> TextContent
entryTitle Entry
p) of
      String
"" -> Maybe Text
forall a. Maybe a
Nothing
      String
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just (String -> Text
T.pack String
t)
    tags :: Entry -> [Text]
tags =
      (Category -> Text) -> [Category] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Category -> Text
catTerm
        ([Category] -> [Text]) -> (Entry -> [Category]) -> Entry -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Category -> Bool) -> [Category] -> [Category]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Category -> Bool) -> Category -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Bool
isBloggerCategory)
        ([Category] -> [Category])
-> (Entry -> [Category]) -> Entry -> [Category]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> [Category]
entryCategories
    date :: Entry -> p
date Entry
x = case Text -> Maybe p
forall (m :: * -> *) a.
(MonadPlus m, MonadFail m, ParseTime a) =>
Text -> m a
parseTime' (Text -> Maybe p) -> Maybe Text -> Maybe p
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Entry -> Maybe Text
entryPublished Entry
x of
      Maybe p
Nothing -> Maybe p -> p
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe p -> p) -> Maybe p -> p
forall a b. (a -> b) -> a -> b
$ Text -> Maybe p
forall (m :: * -> *) a.
(MonadPlus m, MonadFail m, ParseTime a) =>
Text -> m a
parseTime' Text
"1970-01-01T00:00:00Z"
      Just p
d -> p
d
    parseTime' :: Text -> m a
parseTime' Text
d =
      [m a] -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m a] -> m a) -> [m a] -> m a
forall a b. (a -> b) -> a -> b
$
        (String -> m a) -> [String] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map
          (\String
f -> Bool -> TimeLocale -> String -> String -> m a
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
f (Text -> String
T.unpack Text
d))
          [ String
"%FT%T%Q%z", -- with time zone
            String
"%FT%T%QZ" -- zulu time
          ]

-- ---------------------------------------------------------------------
-- odds and ends
-- ---------------------------------------------------------------------

entryError :: forall a. Entry -> T.Text -> a
entryError :: Entry -> Text -> a
entryError Entry
e Text
msg =
  String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ (Text -> String
T.unpack Text
msg) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" [on entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Text -> String
T.unpack (Entry -> Text
entryId Entry
e)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e

buckets :: Ord b => (a -> b) -> [a] -> [(b, [a])]
buckets :: (a -> b) -> [a] -> [(b, [a])]
buckets a -> b
f =
  ([(b, a)] -> (b, [a])) -> [[(b, a)]] -> [(b, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (([b] -> b) -> ([b], [a]) -> (b, [a])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first [b] -> b
forall a. [a] -> a
head (([b], [a]) -> (b, [a]))
-> ([(b, a)] -> ([b], [a])) -> [(b, a)] -> (b, [a])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(b, a)] -> ([b], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip)
    ([[(b, a)]] -> [(b, [a])])
-> ([a] -> [[(b, a)]]) -> [a] -> [(b, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, a) -> (b, a) -> Bool) -> [(b, a)] -> [[(b, a)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (b -> b -> Bool) -> ((b, a) -> b) -> (b, a) -> (b, a) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (b, a) -> b
forall a b. (a, b) -> a
fst)
    ([(b, a)] -> [[(b, a)]]) -> ([a] -> [(b, a)]) -> [a] -> [[(b, a)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((b, a) -> (b, a) -> Ordering) -> [(b, a)] -> [(b, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (b -> b -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (b -> b -> Ordering)
-> ((b, a) -> b) -> (b, a) -> (b, a) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (b, a) -> b
forall a b. (a, b) -> a
fst)
    ([(b, a)] -> [(b, a)]) -> ([a] -> [(b, a)]) -> [a] -> [(b, a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (b, a)) -> [a] -> [(b, a)]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> b
f a
x, a
x))

-- | Find all non-nested elements which are named `name`, starting with `root`.
-- ("Non-nested" means we don't search sub-elements of an element that's named
-- `name`.)
findElements :: Name -> Element -> [Element]
findElements :: Name -> Element -> [Element]
findElements Name
name Element
element =
  if Element -> Name
elementName Element
element Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name
    then [Element
element]
    else (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Element -> [Element]
findElements Name
name) (Element -> [Element]
elementChildren Element
element)