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