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