Language/TCT/Write/XML.hs

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