Hdoc/TCT/Write/XML.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedLists #-}
   4 {-# LANGUAGE ViewPatterns #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hdoc.TCT.Write.XML where
   7
   8 import Control.Monad (Monad(..))
   9 import Data.Bool
  10 import Data.Default.Class (Default(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Foldable (Foldable(..))
  13 import Data.Function (($), (.))
  14 import Data.Functor ((<$>), (<$), ($>))
  15 import Data.List.NonEmpty (NonEmpty(..))
  16 import Data.Maybe (Maybe(..), maybe)
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
  21 import Data.Set (Set)
  22 import Data.String (String, IsString(..))
  23 import Data.TreeSeq.Strict (Tree(..), tree0)
  24 import Language.Symantic.XML (XML, XMLs)
  25 import Prelude (Num(..), undefined)
  26 import qualified Data.Char as Char
  27 import qualified Data.List as List
  28 import qualified Data.Set as Set
  29 import qualified Data.Sequence as Seq
  30 import qualified Data.Text.Lazy as TL
  31 import qualified Hdoc.TCT.Write.Plain as Plain
  32 import qualified Language.Symantic.XML as XML
  33
  34 -- import Hdoc.TCT.Debug
  35 import Hdoc.TCT as TCT hiding (Parser)
  36 import Hdoc.TCT.Utils
  37 import Text.Blaze.DTC (xmlns_dtc)
  38 import Text.Blaze.XML ()
  39
  40 -- | Main entry point
  41 --
  42 -- NOTE: 'XmlNode' are still annotated with 'Sourced',
  43 --       but nothing is done to preserve any ordering amongst them,
  44 --       because 'Node's sometimes need to be reordered
  45 --       (eg. about/title may have a title from the section before,
  46 --       hence outside of about).
  47 writeXML :: Roots -> XMLs
  48 writeXML (tn@(Tree (Sourced src (NodeHeader (HeaderSection 1))) _ts) Seq.:<| rs) =
  49         element src "head" (xmlifySection def tn) <|
  50         xmlify def rs
  51 writeXML roots = xmlify def roots
  52
  53 -- | Generate the content of <section> or <head>.
  54 xmlifySection :: Inh -> Root -> XMLs
  55 xmlifySection inh tn@(Tree (Sourced src _nt) _ts) =
  56         about <>
  57         xmlify inh' body
  58         where
  59         inh' = inh
  60          { inh_para   = List.repeat elementPara
  61          , inh_figure = True
  62          }
  63         (titles, content) = partitionSection tn
  64         (attrs, body)     = partitionAttrs content
  65         about =
  66                 case Seq.viewl titles of
  67                  EmptyL -> mempty
  68                  title@(unTree -> src_title) :< subtitles ->
  69                         (xmlAttrs (attrs `defaultAttr` (src_title $> (fromString "id", getAttrId title))) <>) $
  70                         Seq.singleton $
  71                         element src "about" $
  72                                 xmlify inh{inh_para=List.repeat elementTitle} title <>
  73                                 aliases
  74                         where
  75                         aliases =
  76                                 subtitles >>= \subtitle@(unTree -> Sourced src_subtitle _) ->
  77                                         return $
  78                                         element src_subtitle "alias" $
  79                                                 xmlAttrs [src_title $> (fromString "id", getAttrId subtitle)] <>
  80                                                 xmlify inh{inh_para=List.repeat elementTitle} subtitle
  81
  82 -- * Type 'Inh'
  83 data Inh
  84  =   Inh
  85  {   inh_figure :: Bool
  86  ,   inh_para   :: [Inh -> Root -> XML]
  87  }
  88 instance Default Inh where
  89         def = Inh
  90          { inh_figure = False
  91          , inh_para   = List.repeat elementPara
  92          }
  93
  94 -- ** 'inh_para'
  95 elementPara :: Inh -> Root -> XML
  96 elementPara inh (Tree (Sourced src _) ts) = element src "para" $ xmlify inh ts
  97
  98 elementTitle :: Inh -> Root -> XML
  99 elementTitle inh (Tree (Sourced src _) ts) =
 100         element src "title" $
 101                 xmlify inh ts
 102
 103 elementTitleWith :: Attrs -> Inh -> Root -> XML
 104 elementTitleWith attrs inh (Tree (Sourced src _) ts) =
 105         element src "title" $
 106                 xmlAttrs attrs <> xmlify inh ts
 107
 108 elementName :: Inh -> Root -> XML
 109 elementName inh (Tree (Sourced src _) ts) =
 110         element src "name" $
 111                 xmlify inh ts
 112
 113 attributeName :: Inh -> Root -> XML
 114 attributeName _inh (Tree (Sourced src _) ts) =
 115         Tree (Sourced src $ XML.NodeAttr $ XML.qName $ fromString "name") $
 116                 return $ tree0 $ Sourced src $
 117                         XML.NodeText $ XML.escapeText $ Plain.writePlain ts
 118
 119 attributeId :: Inh -> Root -> XML
 120 attributeId _inh (Tree (Sourced src _) ts) =
 121         element src "id" $
 122                 return $ tree0 $ Sourced src $
 123                         XML.NodeText $ XML.escapeText $ Plain.writePlain ts
 124
 125 -- * Class 'Xmlify'
 126 class Xmlify a where
 127         xmlify :: Inh -> a -> XMLs
 128 instance Xmlify Roots where
 129         xmlify inh roots =
 130                 case Seq.viewl roots of
 131                  EmptyL -> mempty
 132                  r@(Tree cr@(Sourced src nr) ts) :< rs ->
 133                         case nr of
 134                         ----------------------
 135                          -- NOTE: HeaderColon becomes parent
 136                          -- of any continuous following-sibling HeaderBar or HeaderGreat
 137                          NodeHeader (HeaderColon n _wh)
 138                           | (span, rest) <- spanlHeaderColon rs
 139                           , not $ null span ->
 140                                 xmlify inh (Tree cr (ts<>span)) <>
 141                                 xmlify inh rest
 142                                 where
 143                                 spanlHeaderColon :: Roots -> (Roots, Roots)
 144                                 spanlHeaderColon =
 145                                         Seq.spanl $ \case
 146                                          Tree (unSourced -> NodeHeader (HeaderBar   m _)) _ -> m == n
 147                                          Tree (unSourced -> NodeHeader (HeaderGreat m _)) _ -> m == n
 148                                          _ -> False
 149                         ----------------------
 150                          -- NOTE: gather HeaderBrackets
 151                          NodeHeader HeaderBrackets{}
 152                           | (span,rest) <- spanlBrackets roots
 153                           , not (null span) ->
 154                                 (<| xmlify inh rest) $
 155                                 element src "references" $
 156                                         span >>= xmlify inh
 157                                 where
 158                                 spanlBrackets :: Roots -> (Roots, Roots)
 159                                 spanlBrackets =
 160                                         Seq.spanl $ \case
 161                                          Tree (unSourced -> NodeHeader HeaderBrackets{}) _ -> True
 162                                          _ -> False
 163                         ----------------------
 164                          -- NOTE: merge adjacent NodeText-s, shouldn't be needed, but just in case.
 165                          NodeText x
 166                           | Tree (cy@(unSourced -> NodeText y)) ys :< rs' <- Seq.viewl rs ->
 167                                 xmlify inh $ Tree (NodeText <$> (x <$ cr) <> (y <$ cy)) (ts <> ys) <| rs'
 168                         ----------------------
 169                          -- NOTE: detect (some text)[http://some.url] or (some text)[SomeRef]
 170                          NodePair PairParen
 171                           | Tree (Sourced sb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
 172                                 (<| xmlify inh rs') $
 173                                 case bracket of
 174                                  (toList -> [unTree -> Sourced sl (NodeToken (TokenLink lnk))]) ->
 175                                         element src "eref" $
 176                                                 xmlAttrs [Sourced sl (fromString "to", lnk)] <>
 177                                                 xmlify inh ts
 178                                  _ ->
 179                                         element src "ref" $
 180                                                 xmlAttrs [Sourced sb (fromString "to", Plain.writePlain bracket)] <>
 181                                                 if null ts -- NOTE: preserve empty parens
 182                                                 then Seq.singleton $ tree0 (XML.NodeText mempty <$ cr)
 183                                                 else xmlify inh ts
 184                         ----------------------
 185                          -- NOTE: gather HeaderDash
 186                          _ | (span, rest) <- spanlItems (==HeaderDash) roots
 187                            , not $ null span ->
 188                                 (<| xmlify inh rest) $
 189                                 element src "ul" $
 190                                         span >>= xmlify inh{inh_para=List.repeat elementPara}
 191                         ----------------------
 192                          -- NOTE: gather HeaderDot
 193                            | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
 194                            , not $ null span ->
 195                                 (<| xmlify inh rest) $
 196                                 element src "ol" $
 197                                         span >>= xmlify inh{inh_para=List.repeat elementPara}
 198                                 where
 199                                 spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots)
 200                                 spanlItems liHeader =
 201                                         Seq.spanl $ \(unTree -> (unSourced -> nod)) ->
 202                                                 case nod of
 203                                                  NodeHeader (HeaderColon (Just (XML.NCName (TL.unpack -> "li"))) _wh) -> True
 204                                                  NodeHeader hdr -> liHeader hdr
 205                                                  NodePair (PairElem (XML.NCName (TL.unpack -> "li")) _as) -> True
 206                                                  _ -> False
 207                         ----------------------
 208                          NodePara | para:inh_para <- inh_para inh ->
 209                                 para inh r <|
 210                                 xmlify inh{inh_para} rs
 211                         ----------------------
 212                          -- NOTE: context-free Root
 213                          _ ->
 214                                 xmlify inh r `XML.union`
 215                                 xmlify inh rs
 216 instance Xmlify Root where
 217         xmlify inh tn@(Tree (Sourced src@(sn:|ssn) nod) ts) =
 218                 case nod of
 219                 ----------------------
 220                  NodePara ->
 221                         case inh_para inh of
 222                          [] -> xmlify inh ts
 223                          para:_ -> Seq.singleton $ para inh tn
 224                 ----------------------
 225                  NodeHeader hdr ->
 226                         case hdr of
 227                         --
 228                          HeaderSection{} ->
 229                                 Seq.singleton $
 230                                 element src "section" $
 231                                         xmlifySection inh tn
 232                         --
 233                          HeaderColon localName _wh ->
 234                                 let (attrs, body) = partitionAttrs ts in
 235                                 case name of
 236                                 -- NOTE: disable 'inh_figure'
 237                                  "about" ->
 238                                         Seq.singleton $
 239                                         element src "about" $
 240                                                 xmlAttrs attrs <>
 241                                                 xmlify inh'{inh_figure=False} body
 242                                 -- NOTE: handle judgment
 243                                  _ | Just lName <- localName
 244                                    , lName`List.elem`elemsJudgment -> -- FIXME: not a special case so far.
 245                                         Seq.singleton $
 246                                         element src name $
 247                                                 xmlAttrs attrs <>
 248                                                 xmlify inh'' body
 249                                         where
 250                                         inh'' = inh'
 251                                          { inh_para =
 252                                                 case name of
 253                                                  "grades" -> List.repeat attributeId
 254                                                  "judges" -> List.repeat attributeId
 255                                                  _ -> List.repeat elementTitle
 256                                          }
 257                                 -- NOTE: in <figure> mode, unreserved elements become <figure>
 258                                  _ | Just lName <- localName
 259                                    , inh_figure inh
 260                                    && lName`List.notElem`elems || null name ->
 261                                         Seq.singleton $
 262                                         element src "figure" $
 263                                                 -- xmlAttrs (setAttr (Sourced en en ("type", XML.unNCName lName)) attrs) <>
 264                                                 xmlAttrs
 265                                                  (attrs `defaultAttr` Sourced (sn{fileRange_end=fileRange_begin sn}:|ssn)
 266                                                  (fromString "type", XML.unNCName lName)) <>
 267                                                 case toList body of
 268                                                  [Tree0{}] -> xmlify inh'{inh_para = List.repeat elementPara} body
 269                                                  _         -> xmlify inh'{inh_para = elementTitle : List.repeat elementPara} body
 270                                 -- NOTE: reserved elements
 271                                  _ ->
 272                                         Seq.singleton $
 273                                         element src name $
 274                                                 xmlAttrs attrs <>
 275                                                 xmlify inh' body
 276                                 where
 277                                 name = maybe mempty (TL.unpack . XML.unNCName) localName
 278                                 inh' = inh
 279                                  { inh_para =
 280                                         case name of
 281                                          "about"     -> List.repeat elementTitle
 282                                          "reference" -> List.repeat elementTitle
 283                                          "serie"     -> List.repeat attributeName
 284                                          "author"    -> List.repeat attributeName
 285                                          "editor"    -> List.repeat attributeName
 286                                          "org"       -> List.repeat attributeName
 287                                          "note"      -> List.repeat elementPara
 288                                          _           -> []
 289                                  }
 290                         --
 291                          HeaderBar localName wh ->
 292                                 case localName of
 293                                  Just lName
 294                                   | inh_figure inh && lName`List.notElem`elems ->
 295                                         xmlify inh $
 296                                                 Tree (Sourced src $ NodeHeader $ HeaderColon localName wh) ts
 297                                  _ ->
 298                                         Seq.singleton $
 299                                         element src "artwork" $
 300                                                 xmlAttrs
 301                                                  (Seq.singleton $ Sourced (sn{fileRange_end=fileRange_end sn}:|ssn)
 302                                                          (fromString "type", maybe mempty XML.unNCName localName)) <>
 303                                                 xmlify inh{inh_para=[]} ts
 304                         --
 305                          HeaderGreat localName _wh ->
 306                                 let (attrs,body) = partitionAttrs ts in
 307                                 Seq.singleton $
 308                                 element src "quote" $
 309                                         xmlAttrs
 310                                          (attrs `defaultAttr` Sourced (sn{fileRange_end=fileRange_end sn}:|ssn)
 311                                                  (fromString "type", maybe mempty XML.unNCName localName)) <>
 312                                         xmlify inh{inh_para=List.repeat elementPara} body
 313                         --
 314                          HeaderEqual localName _wh ->
 315                                 Seq.singleton $
 316                                         Tree (Sourced src $ XML.NodeAttr (XML.qName localName)) $
 317                                                 return $ tree0 $ Sourced src $ XML.NodeText $
 318                                                         XML.escapeText $
 319                                                                 Plain.text (Plain.setStart ts def{Plain.state_escape = False}) ts
 320                         --
 321                          HeaderDot n ->
 322                                 Seq.singleton $
 323                                 element src "li" $
 324                                         let fileRange_end =
 325                                                 (fileRange_begin sn)
 326                                                  { filePos_column=
 327                                                         filePos_column (fileRange_begin sn) +
 328                                                         int (TL.length n) } in
 329                                         xmlAttrs
 330                                          (Seq.singleton $ Sourced (sn{fileRange_end}:|ssn)
 331                                                  (fromString "name", n)) <>
 332                                         xmlify inh ts
 333                         --
 334                          HeaderDash -> Seq.singleton $ element src "li" $ xmlify inh ts
 335                         --
 336                          HeaderDashDash ->
 337                                 Seq.singleton $ Tree0 $ Sourced src $
 338                                         XML.NodeComment $ Plain.writePlain ts
 339                         --
 340                          HeaderBrackets ident ->
 341                                 let (attrs, body) = partitionAttrs ts in
 342                                 Seq.singleton $
 343                                 element src "reference" $
 344                                         xmlAttrs
 345                                          (setAttr (Sourced (sn{fileRange_end=fileRange_end sn}:|ssn)
 346                                                  (fromString "id",ident)) attrs) |>
 347                                         element src "about" (
 348                                                 xmlify inh'{inh_para = List.repeat elementTitle} body
 349                                          )
 350                                 where
 351                                 inh' = inh{inh_figure = False}
 352                         --
 353                          HeaderDotSlash _file -> xmlify inh ts
 354                 ----------------------
 355                  NodePair pair ->
 356                         case pair of
 357                          PairBracket | to <- Plain.writePlain ts
 358                                      , TL.all (\c -> c/='[' && c/=']' && Char.isPrint c && not (Char.isSpace c)) to ->
 359                                 Seq.singleton $
 360                                 element src "ref" $
 361                                         xmlAttrs [Sourced src (fromString "to",to)]
 362                          PairStar       -> Seq.singleton $ element src "b"    $ xmlify inh ts
 363                          PairDash       -> Seq.singleton $ element src "del"  $ xmlify inh ts
 364                          PairUnderscore -> Seq.singleton $ element src "u"    $ xmlify inh ts
 365                          PairSlash      -> Seq.singleton $ element src "i"    $ xmlify inh ts
 366                          PairBackquote  -> Seq.singleton $ element src "code" $ xmlify inh ts
 367                          PairFrenchquote ->
 368                                 Seq.singleton $
 369                                 element src "q" $
 370                                         case ts of
 371                                          (Seq.viewl -> Tree0 (Sourced sl (NodeToken (TokenText l))) :< ls) ->
 372                                                 case Seq.viewr ls of
 373                                                  m :> Tree0 (Sourced sr (NodeToken (TokenText r))) ->
 374                                                         xmlify inh $
 375                                                                 Tree0 (Sourced sl (NodeToken (TokenText (TL.dropWhile Char.isSpace l))))
 376                                                                  Seq.<|(m Seq.|>Tree0 (Sourced sr (NodeToken (TokenText (TL.dropWhileEnd Char.isSpace r)))))
 377                                                  _ ->
 378                                                         xmlify inh $
 379                                                                 Tree0 (Sourced sl (NodeToken (TokenText (TL.dropAround Char.isSpace l)))) Seq.<| ls
 380                                          (Seq.viewr -> rs :> Tree0 (Sourced sr (NodeToken (TokenText r)))) ->
 381                                                 xmlify inh $
 382                                                         rs Seq.|> Tree0 (Sourced sr (NodeToken (TokenText (TL.dropAround Char.isSpace r))))
 383                                          _ -> xmlify inh ts
 384                          PairTag isBackref ->
 385                                 Seq.singleton $
 386                                 element src (if isBackref then "tag-back" else "tag") $
 387                                         xmlAttrs [Sourced src (fromString "to", Plain.writePlain ts)]
 388                                         -- xmlAttrs [Sourced src ("to",to)]
 389                                         -- xmlify inh{inh_para=[]} ts
 390                                         -- xmlAttrs [Sourced src ("to",Plain.writePlain ts)]
 391                          PairAt isBackref ->
 392                                 Seq.singleton $
 393                                 element src (if isBackref then "at-back" else "at") $
 394                                         xmlAttrs [Sourced src (fromString "to", Plain.writePlain ts)]
 395                          PairElem n attrs ->
 396                                 Seq.singleton $
 397                                 Tree (Sourced src $ XML.NodeElem $ XML.QName xmlns_dtc n) $
 398                                         xmlAttrs (Seq.fromList $ (\(_wh, ElemAttr{..}) ->
 399                                                 Sourced src (elemAttr_name, elemAttr_value)) <$> attrs) <>
 400                                         xmlify inh ts
 401                          _ ->
 402                                 Seq.singleton (Tree0 $ Sourced (sn{fileRange_end=bn'}:|ssn) $
 403                                         XML.NodeText [XML.EscapedPlain open]) `XML.union`
 404                                 xmlify inh ts `XML.union`
 405                                 Seq.singleton (Tree0 $ Sourced (sn{fileRange_begin=en'}:|ssn) $
 406                                         XML.NodeText [XML.EscapedPlain close])
 407                                 where
 408                                 (open, close) = pairBorders pair ts
 409                                 bn' = (fileRange_begin sn){filePos_column=filePos_column (fileRange_begin sn) + int (TL.length open)}
 410                                 en' = (fileRange_end   sn){filePos_column=filePos_column (fileRange_end   sn) - int (TL.length close)}
 411                 ----------------------
 412                  NodeText t -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText $ XML.escapeText t
 413                 ----------------------
 414                  NodeToken tok ->
 415                         case tok of
 416                          TokenEscape c -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText [XML.escapeChar c]
 417                          TokenText t   -> Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText $ XML.escapeText t
 418                          TokenAt  b to -> Seq.singleton $ element src (if b then "at-back" else "at") $
 419                                           xmlAttrs [Sourced src (fromString "to", to)]
 420                                           -- Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText to
 421                          TokenTag b to -> Seq.singleton $ element src (if b then "tag-back" else "tag") $
 422                                           xmlAttrs [Sourced src (fromString "to", to)]
 423                                           -- Seq.singleton $ Tree0 $ Sourced src $ XML.NodeText to
 424                          TokenLink lnk -> Seq.singleton $ element src "eref" $
 425                                           xmlAttrs [Sourced src (fromString "to", lnk)]
 426                 ----------------------
 427                  NodeLower n as ->
 428                         Seq.singleton $
 429                         element src "artwork" $
 430                                 xmlify inh ts
 431 {-
 432 instance Xmlify (Seq (Cell (XML.QName,TL.Text))) where
 433         xmlify _inh = xmlAttrs
 434 -}
 435
 436 -- * Elements
 437
 438 element :: XML.FileSource -> String -> XMLs -> XML
 439 element src n = Tree (Sourced src $ XML.NodeElem $ XML.QName xmlns_dtc $ fromString n)
 440
 441 -- | Reserved elements' name
 442 elems :: Set ElemName -- TODO: use a @data@ or maybe a @data family@ instead of 'TL.Text'
 443 elems = Set.fromList $ fromString <$>
 444  [ "about"
 445  , "abstract"
 446  , "address"
 447  , "alias"
 448  , "annotation"
 449  , "area"
 450  , "artwork"
 451  , "aside"
 452  , "at"
 453  , "at-back"
 454  , "audio"
 455  , "author"
 456  , "authors"
 457  , "bcp14"
 458  , "br"
 459  , "break"
 460  , "call"
 461  , "city"
 462  , "code"
 463  , "comment"
 464  , "comments"
 465  , "country"
 466  , "date"
 467  , "dd"
 468  , "default"
 469  , "define"
 470  , "del"
 471  , "div"
 472  , "dl"
 473  , "document"
 474  , "dt"
 475  , "editor"
 476  , "email"
 477  , "embed"
 478  , "eref"
 479  , "fax"
 480  , "feed"
 481  , "feedback"
 482  , "figure"
 483  , "filter"
 484  , "format"
 485  , "from"
 486  , "h"
 487  , "head"
 488  , "hi"
 489  , "html5"
 490  , "i"
 491  , "index"
 492  , "iref"
 493  , "keyword"
 494  , "li"
 495  , "link"
 496  , "name"
 497  , "note"
 498  , "ol"
 499  , "organization"
 500  , "para"
 501  , "postamble"
 502  , "preamble"
 503  , "q"
 504  , "ref"
 505  , "reference"
 506  , "references"
 507  , "refs"
 508  , "region"
 509  , "sc"
 510  , "section"
 511  , "serie"
 512  , "source"
 513  , "span"
 514  , "street"
 515  , "style"
 516  , "sub"
 517  , "sup"
 518  , "table"
 519  , "tag"
 520  , "tag-back"
 521  , "tbody"
 522  , "td"
 523  , "tel"
 524  , "tfoot"
 525  , "th"
 526  , "thead"
 527  , "title"
 528  , "toc"
 529  , "tof"
 530  , "tr"
 531  , "tt"
 532  , "u"
 533  , "ul"
 534  , "uri"
 535  , "version"
 536  , "video"
 537  , "workgroup"
 538  , "xml"
 539  , "zipcode"
 540  ]
 541
 542 elemsJudgment :: Set ElemName
 543 elemsJudgment = Set.fromList $ fromString <$>
 544  [ "choice"
 545  , "grade"
 546  , "grades"
 547  , "judge"
 548  , "judges"
 549  , "judgment"
 550  , "opinion"
 551  ]
 552
 553 -- * Attributes
 554 type Attrs = Seq (Cell (XML.NCName, TL.Text))
 555
 556 -- | Convenient alias, forcing the types
 557 xmlAttrs :: Attrs -> XMLs
 558 xmlAttrs =
 559         (<$>) $ \(Sourced src (n, v)) ->
 560                 Tree (Sourced src $ XML.NodeAttr (XML.qName n)) $
 561                         Seq.singleton $ tree0 $
 562                                 Sourced src $
 563                                         XML.NodeText $ XML.escapeText v
 564
 565 -- | Extract section titles
 566 partitionSection :: Root -> (Roots, Roots)
 567 partitionSection (Tree (unSourced -> NodeHeader (HeaderSection lvlPar)) body) =
 568         case Seq.viewl body of
 569          EmptyL -> mempty
 570          title@(unTree -> Sourced (FileRange{fileRange_end=et}:|_) NodePara) :< rest ->
 571                 let (subtitles, content) = spanlSubtitles et rest in
 572                 (title <| (subtitles >>= subTrees), content)
 573                 where
 574                 spanlSubtitles ep ts =
 575                         case Seq.viewl ts of
 576                          sub@(unTree -> Sourced (FileRange{..}:|_) (NodeHeader (HeaderSection lvlSub))) :< rs
 577                                 | lvlSub <= lvlPar
 578                                 , filePos_line fileRange_begin - filePos_line ep <= 1 ->
 579                                 let (subs, ts') = spanlSubtitles fileRange_end rs in
 580                                 (sub <| subs, ts')
 581                          _ -> (mempty, ts)
 582          _ -> (mempty, body)
 583 partitionSection _ = mempty
 584
 585 -- | Extract attributes
 586 partitionAttrs :: Roots -> (Attrs, Roots)
 587 partitionAttrs ts = (attrs, cs)
 588         where
 589         (as,cs) = (`Seq.partition` ts) $ \case
 590          Tree (unSourced -> NodeHeader (HeaderEqual (XML.NCName n) _wh)) _cs -> not $ TL.null n
 591          _ -> False
 592         attrs = attr <$> as
 593         attr = \case
 594          Tree (Sourced loc (NodeHeader (HeaderEqual n _wh))) a ->
 595                 Sourced loc (n, v)
 596                 where v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
 597          _ -> undefined
 598
 599 getAttrId :: Root -> TL.Text
 600 getAttrId = Plain.writePlain . Seq.singleton
 601
 602 setAttr :: Cell (XML.NCName, TL.Text) -> Attrs -> Attrs
 603 setAttr a@(unSourced -> (k, _v)) as =
 604         case Seq.findIndexL (\(unSourced -> (n,_v)) -> n == k) as of
 605          Just idx -> Seq.update idx a as
 606          Nothing -> a <| as
 607
 608 defaultAttr :: Attrs -> Cell (XML.NCName, TL.Text) -> Attrs
 609 defaultAttr as a@(unSourced -> (k, _v)) =
 610         case Seq.findIndexL (\(unSourced -> (n,_v)) -> n == k) as of
 611          Just _idx -> as
 612          Nothing -> a <| as