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 (Cell bn en nod) ts) =
 216                 case nod of
 217                  NodeGroup -> xmlify inh ts
 218                 ----------------------
 219                  NodePara -> xmlify inh ts
 220                 ----------------------
 221                  NodeHeader hdr ->
 222                         case hdr of
 223                         --
 224                          HeaderSection{} ->
 225                                 Seq.singleton $
 226                                 element "section" $ head <> xmlify inh' body
 227                                 where
 228                                 (titles, content) = partitionSection tn
 229                                 (attrs, body)     = partitionAttrs content
 230                                 head =
 231                                         case Seq.viewl titles of
 232                                          EmptyL -> mempty
 233                                          title@(unTree -> ct) :< subtitles ->
 234                                                 xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <>
 235                                                 aliases
 236                                                 where
 237                                                 aliases =
 238                                                         subtitles >>= \subtitle@(unTree -> cs) ->
 239                                                                 return $
 240                                                                 Tree (cs $> XmlElem "alias") $
 241                                                                         xmlAttrs (return $ cs $> ("id",getAttrId subtitle))
 242                                 inh' = inh
 243                                  { inh_para   = xmlTitle : List.repeat xmlPara
 244                                  , inh_figure = True
 245                                  }
 246                         --
 247                          HeaderColon n _wh ->
 248                                 let (attrs,body) = partitionAttrs ts in
 249                                 case n of
 250                                 -- NOTE: insert titles into <about>.
 251                                  "about" ->
 252                                         Seq.singleton $
 253                                         element "about" $
 254                                                 (xmlify inh' $ inh_titles inh) <>
 255                                                 xmlAttrs attrs <>
 256                                                 xmlify inh' body
 257                                 -- NOTE: in <figure> mode, unreserved nodes become <figure>
 258                                  _ | inh_figure inh && n`List.notElem`elems || TL.null n ->
 259                                         Seq.singleton $
 260                                         element "figure" $
 261                                                 -- xmlAttrs (setAttr (Cell en en ("type",n)) attrs) <>
 262                                                 xmlAttrs (attrs `defaultAttr` Cell bn bn ("type", n)) <>
 263                                                 case toList body of
 264                                                  [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body
 265                                                  _         -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body
 266                                 -- NOTE: reserved nodes
 267                                  _ ->
 268                                         Seq.singleton $
 269                                         element (xmlLocalName n) $
 270                                                 xmlAttrs attrs <>
 271                                                 xmlify inh' ts
 272                                 where
 273                                 inh' = inh
 274                                  { inh_para =
 275                                         case n of
 276                                          "about"     -> List.repeat xmlTitle
 277                                          "reference" -> xmlTitle : List.repeat xmlPara
 278                                          "serie"     -> List.repeat xmlName
 279                                          "author"    -> List.repeat xmlName
 280                                          "editor"    -> List.repeat xmlName
 281                                          "org"       -> List.repeat xmlName
 282                                          _           -> []
 283                                  }
 284                         ----------------------
 285                          HeaderBar n _wh ->
 286                                 Seq.singleton $
 287                                 element "artwork" $
 288                                         xmlAttrs (Seq.singleton $ Cell bn bn ("type", n)) <>
 289                                         xmlify inh{inh_para=[]} ts
 290                         ----------------------
 291                          HeaderGreat n _wh ->
 292                                 Seq.singleton $
 293                                 let (attrs,body) = partitionAttrs ts in
 294                                 element "quote" $
 295                                         xmlAttrs (attrs `defaultAttr` Cell bn bn ("type", n)) <>
 296                                         xmlify inh{inh_para=List.repeat xmlPara} body
 297                         --
 298                          HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
 299                         --
 300                          HeaderDot _n   -> Seq.singleton $ element "li" $ xmlify inh ts
 301                         --
 302                          HeaderDash     -> Seq.singleton $ element "li" $ xmlify inh ts
 303                         --
 304                          HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $
 305                                         -- debug1_ ("TS", ts) $
 306                                         -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $
 307                                         Plain.document ts
 308                                         -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
 309                                         {-
 310                                         TreeSeq.mapAlsoNode
 311                                          (cell1 . unCell)
 312                                          (\_k -> fmap $
 313                                                 TreeSeq.mapAlsoNode
 314                                                  (cell1 . unCell)
 315                                                  (\_k' -> cell1 . unCell)) <$> ts
 316                                         -}
 317                         --
 318                          HeaderBrackets ident ->
 319                                 let (attrs,body) = partitionAttrs ts in
 320                                 Seq.singleton $
 321                                 element "reference" $
 322                                         xmlAttrs (setAttr (Cell en en ("id",ident)) attrs) <>
 323                                         xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body
 324                                 where
 325                                 inh' = inh{inh_figure = False}
 326                         --
 327                          HeaderDotSlash p ->
 328                                 Seq.singleton $
 329                                 element "include" $
 330                                         xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
 331                                         xmlify inh ts
 332                 ----------------------
 333                  NodePair pair ->
 334                         case pair of
 335                          PairBracket | to <- Plain.document ts
 336                                      , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
 337                                 Seq.singleton $
 338                                 element "rref" $
 339                                         xmlAttrs [cell ("to",to)]
 340                          PairStar      -> Seq.singleton $ element "b"    $ xmlify inh ts
 341                          PairSlash     -> Seq.singleton $ element "i"    $ xmlify inh ts
 342                          PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts
 343                          PairFrenchquote ->
 344                                 Seq.singleton $
 345                                 element "q" $
 346                                         xmlify inh ts
 347                                 {-
 348                                 case ts of
 349                                  (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
 350                                         case Seq.viewr ls of
 351                                          m :> Tree0 (Cell br er (TokenPlain r)) ->
 352                                                 xmlify inh $
 353                                                         Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)))
 354                                                          <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))))
 355                                          _ ->
 356                                                 xmlify inh $
 357                                                         Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls
 358                                  (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) ->
 359                                         xmlify inh $
 360                                                 rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
 361                                  _ -> xmlify inh ts
 362                                 -}
 363                          PairHash ->
 364                                 Seq.singleton $
 365                                 element "ref" $
 366                                         xmlAttrs [cell ("to",Plain.document ts)]
 367                          PairElem name attrs ->
 368                                 Seq.singleton $
 369                                 element (xmlLocalName name) $
 370                                         xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
 371                                                 cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
 372                                         xmlify inh ts
 373                          _ ->
 374                                 let (open, close) = pairBorders pair ts in
 375                                 Seq.singleton (Tree0 $ Cell bn bn $ XmlText open) `unionXml`
 376                                 xmlify inh ts `unionXml`
 377                                 Seq.singleton (Tree0 $ Cell en en $ XmlText close)
 378                 ----------------------
 379                  NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
 380                 ----------------------
 381                  NodeToken tok ->
 382                         case tok of
 383                          TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c
 384                          TokenText t   -> Seq.singleton $ Tree0 $ cell $ XmlText t
 385                          TokenTag t    -> Seq.singleton $ element "ref"  $ xmlAttrs [cell ("to",t)]
 386                          TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)]
 387                 ----------------------
 388                  NodeLower n as ->
 389                         Seq.singleton $
 390                         element "artwork" $
 391                                 xmlify inh ts
 392                 where
 393                 cell :: a -> Cell a
 394                 cell = Cell bn en
 395                 element :: XmlName -> XMLs -> XML
 396                 element n = Tree (cell $ XmlElem n)
 397 instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
 398         xmlify _inh = xmlAttrs
 399
 400 -- * Elements
 401
 402 -- | Reserved elements' name
 403 elems :: Set TL.Text
 404 elems =
 405  [ "about"
 406  , "abstract"
 407  , "address"
 408  , "alias"
 409  , "annotation"
 410  , "area"
 411  , "artwork"
 412  , "aside"
 413  , "audio"
 414  , "author"
 415  , "authors"
 416  , "bcp14"
 417  , "br"
 418  , "call"
 419  , "city"
 420  , "code"
 421  , "comment"
 422  , "comments"
 423  , "country"
 424  , "date"
 425  , "dd"
 426  , "define"
 427  , "del"
 428  , "div"
 429  , "dl"
 430  , "document"
 431  , "dt"
 432  , "editor"
 433  , "email"
 434  , "embed"
 435  , "eref"
 436  , "fax"
 437  , "feed"
 438  , "feedback"
 439  , "figure"
 440  , "filter"
 441  , "format"
 442  , "from"
 443  , "h"
 444  , "hi"
 445  , "html5"
 446  , "i"
 447  , "index"
 448  , "iref"
 449  , "keyword"
 450  , "li"
 451  , "link"
 452  , "name"
 453  , "note"
 454  , "ol"
 455  , "organization"
 456  , "para"
 457  , "postamble"
 458  , "preamble"
 459  , "q"
 460  , "ref"
 461  , "reference"
 462  , "references"
 463  , "region"
 464  , "rref"
 465  , "sc"
 466  , "section"
 467  , "serie"
 468  , "source"
 469  , "span"
 470  , "street"
 471  , "style"
 472  , "sub"
 473  , "sup"
 474  , "table"
 475  , "tbody"
 476  , "td"
 477  , "tel"
 478  , "tfoot"
 479  , "title"
 480  , "th"
 481  , "thead"
 482  , "toc"
 483  , "tof"
 484  , "tr"
 485  , "tt"
 486  , "u"
 487  , "ul"
 488  , "uri"
 489  , "version"
 490  , "video"
 491  , "workgroup"
 492  , "xml"
 493  , "zipcode"
 494  ]
 495
 496 -- * Attributes
 497
 498 -- | Convenient alias, forcing the types
 499 xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
 500 xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
 501
 502 -- | Extract attributes
 503 partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
 504 partitionAttrs ts = (attrs,cs)
 505         where
 506         (as,cs) = (`Seq.partition` ts) $ \case
 507                  Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True
 508                  _ -> False
 509         attrs = attr <$> as
 510         attr = \case
 511          Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
 512                 Cell bp ep (xmlLocalName n, v)
 513                 where
 514                 v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
 515          _ -> undefined
 516
 517 getAttrId :: Root -> TL.Text
 518 getAttrId = Plain.document . Seq.singleton
 519
 520 setAttr ::
 521  Cell (XmlName, TL.Text) ->
 522  Seq (Cell (XmlName, TL.Text)) ->
 523  Seq (Cell (XmlName, TL.Text))
 524 setAttr a@(unCell -> (k, _v)) as =
 525         case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
 526          Just idx -> Seq.update idx a as
 527          Nothing -> a <| as
 528
 529 defaultAttr ::
 530  Seq (Cell (XmlName, TL.Text)) ->
 531  Cell (XmlName, TL.Text) ->
 532  Seq (Cell (XmlName, TL.Text))
 533 defaultAttr as a@(unCell -> (k, _v)) =
 534         case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
 535          Just _idx -> as
 536          Nothing -> a <| as
 537
 538 -- * Text
 539
 540 -- | Unify two 'XMLs', merging border 'XmlText's if any.
 541 unionXml :: XMLs -> XMLs -> XMLs
 542 unionXml x y =
 543         case (Seq.viewr x, Seq.viewl y) of
 544          (xs :> x0, y0 :< ys) ->
 545                 case (x0,y0) of
 546                  (  Tree0 (Cell bx ex (XmlText tx))
 547                   , Tree0 (Cell by ey (XmlText ty)) ) ->
 548                         xs `unionXml`
 549                         Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml`
 550                         ys
 551                  _ -> x <> y
 552          (Seq.EmptyR, _) -> y
 553          (_, Seq.EmptyL) -> x
 554
 555 unionsXml :: Foldable f => f XMLs -> XMLs
 556 unionsXml = foldl' unionXml mempty