Fix HTML5 of <link>.
[doclang.git] / Language / TCT / Write / XML.hs
index d979ae653a4584d80059c05484a76a8ceeda5a5b..6b39dbdb56d62875f9dc81564bafca0e476b063f 100644 (file)
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Language.TCT.Write.XML where
 
-import Control.Arrow (first)
-import Control.Monad (Monad(..), (=<<))
+import Control.Monad (Monad(..))
 import Data.Bool
+import Data.Default.Class (Default(..))
 import Data.Eq (Eq(..))
-import Data.Foldable (null, foldl', any)
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import Data.Maybe (Maybe(..), maybe)
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>), (<$), ($>))
+import Data.List.NonEmpty (NonEmpty(..))
+import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
 import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
+import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
 import Data.Set (Set)
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.TreeSeq.Strict (Tree(..))
-import GHC.Exts (toList)
-import Prelude (error, undefined)
-import Text.Show (Show(..), showChar, showString)
+import Data.TreeSeq.Strict (Tree(..), tree0)
+import Data.Tuple (uncurry)
+import Prelude (Num(..), undefined)
 import qualified Data.Char as Char
 import qualified Data.List as List
 import qualified Data.Sequence as Seq
-import qualified Data.Text as Text
 import qualified Data.Text.Lazy as TL
-import qualified Language.TCT.Write.Text as Write
-import qualified System.FilePath as FP
+import qualified Language.TCT.Write.Plain as Plain
 
+-- import Language.TCT.Debug
+import Language.TCT.Utils
 import Language.TCT hiding (Parser)
-import qualified Data.TreeSeq.Strict as TreeSeq
+import Language.XML
+import Text.Blaze.XML ()
 
+-- | Main entry point
+--
+-- NOTE: 'XmlNode' are still annotated with 'Cell',
+--       but nothing is done to preserve any ordering amongst them,
+--       because 'Node's sometimes need to be reordered
+--       (eg. about/title may have a title from the section before,
+--       hence outside of about).
+--       Still holding: @'cell_begin' < 'cell_end'@ and 'Cell' nesting.
+writeXML :: Roots -> XMLs
+writeXML doc =
+       -- (`S.evalState` def) $
+       case Seq.viewl doc of
+        sec@(Tree (unCell -> NodeHeader HeaderSection{}) _body) :< foot ->
+               let (titles, content) = partitionSection sec in
+               case Seq.viewl titles of
+                (unTree -> Cell st _) :< _ ->
+                       xmlify def
+                        { inh_titles = titles
+                        , inh_figure = True
+                        } contentWithAbout <>
+                       xmlify def foot
+                       where
+                       contentWithAbout =
+                               case Seq.findIndexL isAbout content of
+                                Nothing -> Tree (Cell st $ NodeHeader $ HeaderColon "about" "") mempty <| content
+                                Just{} -> content
+                       isAbout = \case
+                        (unTree -> (unCell -> NodeHeader (HeaderColon "about" _wh))) -> True
+                        _ -> False
+                _ -> xmlify def doc
+        _ -> xmlify def doc
 
--- * Type 'XML'
-type XML  = Tree (Cell XmlName) (Cell XmlLeaf)
-type XMLs = Seq XML
-
--- ** Type 'XmlName'
-data XmlName
- =   XmlName
- {   xmlNamePrefix :: Text
- ,   xmlNameSpace  :: Text
- ,   xmlNameLocal  :: Text
- }
-instance Show XmlName where
-       showsPrec _p XmlName{xmlNameSpace="", ..} =
-               showString (Text.unpack xmlNameLocal)
-       showsPrec _p XmlName{..} =
-               if Text.null xmlNameSpace
-               then showString (Text.unpack xmlNameLocal)
-               else
-                       showChar '{' .
-                       showString (Text.unpack xmlNameSpace) .
-                       showChar '}' .
-                       showString (Text.unpack xmlNameLocal)
-instance Eq XmlName where
-       XmlName _ sx lx == XmlName _ sy ly = sx == sy && lx == ly
-instance Ord XmlName where
-       XmlName _ sx lx `compare` XmlName _ sy ly = compare sx sy <> compare lx ly
-instance IsString XmlName where
-       fromString "" = XmlName "" "" ""
-       fromString full@('{':rest) =
-               case List.break (== '}') rest of
-                (_, "")     -> error ("Invalid Clark notation: " <> show full)
-                (ns, local) -> XmlName "" (Text.pack ns) (Text.pack $ List.drop 1 local)
-       fromString local = XmlName "" "" (Text.pack local)
-
-xmlLocalName :: Text -> XmlName
-xmlLocalName = XmlName "" ""
-
--- ** Type 'XmlLeaf'
-data XmlLeaf
- =   XmlAttr    XmlName Text
- |   XmlComment Text
- |   XmlText    Text
- deriving (Eq,Ord,Show)
+partitionSection :: Root -> (Roots, Roots)
+partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) =
+       case Seq.viewl body of
+        EmptyL -> mempty
+        title@(unTree -> Cell (Span{span_end=et}:|_) NodePara) :< rest ->
+               let (subtitles, content) = spanlSubtitles et rest in
+               (title <| (subtitles >>= subTrees), content)
+               where
+               spanlSubtitles ep ts =
+                       case Seq.viewl ts of
+                        sub@(unTree -> Cell (Span{..}:|_) (NodeHeader (HeaderSection lvlSub))) :< rs
+                               | lvlSub <= lvlPar
+                               , pos_line span_begin - pos_line ep <= 1 ->
+                               let (subs, ts') = spanlSubtitles span_end rs in
+                               (sub <| subs, ts')
+                        _ -> (mempty, ts)
+        _ -> (mempty, body)
+partitionSection _ = mempty
 
--- * Type 'InhXml'
-data InhXml
- =   InhXml
- {   inhXml_figure :: Bool
- ,   inhXml_tree0  :: [Pos -> XMLs -> XML]
- ,   inhXml_titles :: Seq Tokens
- }
-inhXml :: InhXml
-inhXml = InhXml
- { inhXml_figure = False
- , inhXml_tree0  = []
- , inhXml_titles = mempty
+-- * Type 'Inh'
+data Inh
+ =   Inh
+ {   inh_figure :: Bool
+ ,   inh_para   :: [Inh -> Root -> XML]
+ ,   inh_titles :: Roots
  }
+instance Default Inh where
+       def = Inh
+        { inh_figure = False
+        , inh_para   = List.repeat elementPara
+        , inh_titles = mempty
+        }
 
-mimetype :: Text -> Maybe Text
-mimetype "hs"          = Just "text/x-haskell"
-mimetype "sh"          = Just "text/x-shellscript"
-mimetype "shell"       = Just "text/x-shellscript"
-mimetype "shellscript" = Just "text/x-shellscript"
-mimetype _             = Nothing
-
-xmlPhantom :: XmlName -> Pos -> XMLs -> XML
-xmlPhantom n bp = TreeN (Cell bp bp n)
-xmlPara :: Pos -> XMLs -> XML
-xmlPara = xmlPhantom "para"
-xmlTitle :: Pos -> XMLs -> XML
-xmlTitle = xmlPhantom "title"
-xmlName :: Pos -> XMLs -> XML
-xmlName bp (toList -> [Tree0 (unCell -> XmlText t)]) = Tree0 (Cell bp bp $ XmlAttr "name" t)
-xmlName bp ts = xmlPhantom "name" bp ts
-
-xmlDocument :: TCTs -> XMLs
-xmlDocument trees =
-       case Seq.viewl trees of
-        TreeN (unCell -> KeySection{}) vs :< ts ->
-               case spanlTokens vs of
-                (titles@(Seq.viewl -> (Seq.viewl -> Cell bp _ep _ :< _) :< _), vs') ->
-                       let vs'' =
-                               case Seq.findIndexL
-                                (\case
-                                TreeN (unCell -> KeyColon "about" _) _ -> True
-                                _ -> False) vs' of
-                                Just{} -> vs'
-                                Nothing -> TreeN (Cell bp bp $ KeyColon "about" "") mempty <| vs'
-                       in
-                       xmlTCTs inhXml
-                        { inhXml_titles = titles
-                        , inhXml_figure = True
-                        , inhXml_tree0  = List.repeat xmlPara
-                        } vs'' <>
-                       xmlTCTs inhXml ts
-                _ -> xmlTCTs inhXml trees
-        _ -> xmlTCTs inhXml trees
-
-xmlTCTs :: InhXml -> TCTs -> XMLs
-xmlTCTs inh_orig = go inh_orig
-       where
-       go :: InhXml -> TCTs -> XMLs
-       go inh trees =
-               case Seq.viewl trees of
-                TreeN (Cell bp ep (KeyBar n _)) _ :< _
-                 | (body,ts) <- spanlBar n trees
-                 , not (null body) ->
-                       (<| go inh ts) $
-                       TreeN (Cell bp ep "artwork") $
-                               maybe id (\v -> (Tree0 (Cell bp ep (XmlAttr "type" v)) <|)) (mimetype n) $
-                               body >>= xmlTCT inh{inhXml_tree0=[]}
-               
-                TreeN key@(unCell -> KeyColon n _) cs :< ts
-                 | (cs',ts') <- spanlKeyColon n ts
-                 , not (null cs') ->
-                       go inh $ TreeN key (cs<>cs') <| ts'
-               
-                TreeN (Cell bp ep KeyBrackets{}) _ :< _
-                 | (rl,ts) <- spanlBrackets trees
-                 , not (null rl) ->
-                       (<| go inh ts) $
-                       TreeN (Cell bp ep "rl") $
-                               rl >>= xmlTCT inh_orig
-               
-                _ | (ul,ts) <- spanlItems (==KeyDash) trees
-                  , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ul ->
-                       (<| go inh ts) $
-                       TreeN (Cell bp ep "ul") $
-                               ul >>= xmlTCT inh{inhXml_tree0=List.repeat xmlPara}
-               
-                _ | (ol,ts) <- spanlItems (\case KeyDot{} -> True; _ -> False) trees
-                  , TreeN (Cell bp ep _) _ :< _ <- Seq.viewl ol ->
-                       (<| go inh ts) $
-                       TreeN (Cell bp ep "ol") $
-                               ol >>= xmlTCT inh{inhXml_tree0=List.repeat xmlPara}
-               
-                t@(Tree0 toks) :< ts | isTokenElem toks ->
-                       xmlTCT inh_orig t <>
-                       go inh ts
-               
-                t@(Tree0 toks) :< ts ->
-                       case inhXml_tree0 inh of
-                        [] ->
-                               xmlTCT inh_orig t <>
-                               go inh{inhXml_tree0=[]} ts
-                        x:xs ->
-                               case Seq.viewl toks of
-                                EmptyL -> go inh{inhXml_tree0=xs} ts
-                                Cell bp _ep _ :< _ ->
-                                       (<| go inh{inhXml_tree0=xs} ts) $
-                                       x bp $
-                                               xmlTCT inh_orig t
-               
-                t:<ts ->
-                       xmlTCT inh_orig t <>
-                       go inh ts
-               
-                _ -> mempty
+-- ** 'inh_para'
+elementPara :: Inh -> Root -> XML
+elementPara inh (Tree c ts) = Tree (XmlElem "para" <$ c) $ xmlify inh ts
 
-xmlTCT :: InhXml -> TCT -> XMLs
-xmlTCT inh tr =
-       case tr of
-        TreeN (Cell bp ep KeySection{}) ts ->
-               let (attrs,body) = partitionAttributesChildren ts in
-               let inh' = inh
-                        { inhXml_tree0  = xmlTitle : List.repeat xmlPara
-                        , inhXml_figure = True
-                        } in
-               Seq.singleton $
-               TreeN (Cell bp ep "section") $
-                       xmlAttrs (defXmlAttr (Cell ep ep ("id", getAttrId body)) attrs) <>
-                       xmlTCTs inh' body
-       
-        TreeN key@(Cell bp ep (KeyColon kn _)) ts ->
-               let (attrs,body) = partitionAttributesChildren ts in
-               let inh' = inh { inhXml_tree0 =
-                       case kn of
-                        "about"     -> xmlTitle : xmlTitle : List.repeat xmlPara
-                        "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara
-                        "author"    -> List.repeat xmlName
-                        _           -> []
-                } in
-               case () of
-                _ | kn == "about" -> xmlAbout inh' key attrs body
-               
-                _ | inhXml_figure inh && not (kn`List.elem`elems) ->
-                       Seq.singleton $
-                       TreeN (Cell bp ep "figure") $
-                               xmlAttrs (setXmlAttr (Cell ep ep ("type", kn)) attrs) <>
-                               case toList body of
-                                [Tree0{}] -> xmlTCTs inh'{inhXml_tree0 = List.repeat xmlPara} body
-                                _         -> xmlTCTs inh'{inhXml_tree0 = xmlTitle : List.repeat xmlPara} body
-               
-                _ -> Seq.singleton $ xmlKey inh' key attrs body
-       
-        TreeN key ts -> Seq.singleton $ xmlKey inh key mempty ts
-       
-        Tree0 ts -> xmlTokens ts
+elementTitle :: Inh -> Root -> XML
+elementTitle inh (Tree c ts) = Tree (XmlElem "title" <$ c) $ xmlify inh ts
 
-xmlAbout ::
- InhXml ->
- Cell Key -> Seq (Cell (XmlName, Text)) ->
- TCTs -> XMLs
-xmlAbout inh key attrs body =
-       Seq.singleton $
-       xmlKey inh key attrs $
-       case Seq.viewl (inhXml_titles inh) of
-        (Seq.viewl -> Cell bt _et _ :< _) :< _ ->
-               ((<$> inhXml_titles inh) $ \title ->
-                       TreeN (Cell bt bt $ KeyColon "title" "") $
-                               Seq.singleton $ Tree0 title)
-                <> body
-        _ -> body
+elementName :: Inh -> Root -> XML
+elementName inh (Tree c ts) = Tree (XmlElem "name" <$ c) $ xmlify inh ts
 
-xmlKey :: InhXml -> Cell Key -> Seq (Cell (XmlName, Text)) -> TCTs -> XML
-xmlKey inh (Cell bp ep key) attrs ts =
-       case key of
-        KeyColon n _wh -> d_key n
-        KeyGreat n _wh -> d_key n
-        KeyEqual n _wh -> d_key n
-        KeyBar   n _wh -> d_key n
-        KeyDot _n   -> TreeN (cell "li") $ xmlTCTs inh ts
-        KeyDash     -> TreeN (cell "li") $ xmlTCTs inh ts
-        KeyDashDash -> Tree0 $ cell $ XmlComment $ TL.toStrict com
-               where
-               com :: TL.Text
-               com =
-                       Write.text Write.config_text $
-                       TreeSeq.mapAlsoKey
-                        (cell1 . unCell)
-                        (\_path -> fmap $ cell1 . unCell) <$> ts
-        KeyLower n as -> TreeN (cell "artwork") $ xmlTCTs inh ts
-        KeyBrackets ident ->
-               let inh' = inh{inhXml_figure = False} in
-               TreeN (cell "reference") $
-                       xmlAttrs (setXmlAttr (Cell ep ep ("id", ident)) attrs) <>
-                       xmlTCTs inh' ts
-        KeyDotSlash p ->
-               TreeN (cell "include") $
-                       xmlAttrs [cell ("href", Text.pack $ FP.replaceExtension p "dtc")] <>
-                       xmlTCTs inh ts
-       where
-       cell :: a -> Cell a
-       cell = Cell bp ep
-       d_key :: Text -> XML
-       d_key n =
-               TreeN (cell $ xmlLocalName n) $
-                       xmlAttrs attrs <>
-                       xmlTCTs inh ts
+attributeName :: Inh -> Root -> XML
+attributeName _inh (Tree c ts) = tree0 (XmlAttr "name" (Plain.writePlain ts) <$ c)
 
-xmlTokens :: Tokens -> XMLs
-xmlTokens tok = goTokens tok
-       where
-       go :: Cell Token -> XMLs
-       go (Cell bp ep tk) =
-               case tk of
-                TokenPlain t  -> Seq.singleton $ Tree0 $ cell $ XmlText t
-                TokenTag t    -> Seq.singleton $ TreeN (cell "ref") $ xmlAttrs [cell ("to",t)]
-                TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ Text.singleton c
-                TokenLink lnk -> Seq.singleton $
-                       TreeN (cell "eref") $
-                               xmlAttrs [cell ("to",lnk)] |>
-                               Tree0 (cell $ XmlText lnk)
-                TokenPair PairBracket ts | to <- Write.t_Tokens ts
-                                         , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
-                       Seq.singleton $
-                       TreeN (cell "rref") $
-                               xmlAttrs [cell ("to",TL.toStrict to)]
-                TokenPair PairStar ts      -> Seq.singleton $ TreeN (cell "b") $ goTokens ts
-                TokenPair PairSlash ts     -> Seq.singleton $ TreeN (cell "i") $ goTokens ts
-                TokenPair PairBackquote ts -> Seq.singleton $ TreeN (cell "code") $ goTokens ts
-                TokenPair PairFrenchquote toks@ts ->
-                       Seq.singleton $
-                       TreeN (cell "q") $
-                       case ts of
-                        (Seq.viewl -> Cell bl el (TokenPlain l) :< ls) ->
-                               case Seq.viewr ls of
-                                m :> Cell br er (TokenPlain r) ->
-                                       goTokens $
-                                               Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l))
-                                                <|(m|>Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r)))
+-- * Class 'Xmlify'
+class Xmlify a where
+       xmlify :: Inh -> a -> XMLs
+instance Xmlify Roots where
+       xmlify inh roots =
+               case Seq.viewl roots of
+                EmptyL -> mempty
+                r@(Tree cr@(Cell _sr nr) ts) :< rs ->
+                       case nr of
+                       ----------------------
+                        -- NOTE: HeaderColon becomes parent
+                        -- of any continuous following-sibling HeaderBar or HeaderGreat
+                        NodeHeader (HeaderColon n _wh)
+                         | (span, rest) <- spanlHeaderColon rs
+                         , not $ null span ->
+                               xmlify inh (Tree cr (ts<>span)) <>
+                               xmlify inh rest
+                               where
+                               spanlHeaderColon :: Roots -> (Roots, Roots)
+                               spanlHeaderColon =
+                                       Seq.spanl $ \case
+                                        Tree (unCell -> NodeHeader (HeaderBar   m _)) _ -> m == n
+                                        Tree (unCell -> NodeHeader (HeaderGreat m _)) _ -> m == n
+                                        _ -> False
+                       ----------------------
+                        -- NOTE: gather HeaderBrackets
+                        NodeHeader HeaderBrackets{}
+                         | (span,rest) <- spanlBrackets roots
+                         , not (null span) ->
+                               (<| xmlify inh rest) $
+                               element "references" $
+                                       span >>= xmlify inh
+                               where
+                               spanlBrackets :: Roots -> (Roots, Roots)
+                               spanlBrackets =
+                                       Seq.spanl $ \case
+                                        Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True
+                                        _ -> False
+                       ----------------------
+                        -- NOTE: merge adjacent NodeText-s, shouldn't be needed, but just in case.
+                        NodeText x
+                         | Tree (cy@(unCell -> NodeText y)) ys :< rs' <- Seq.viewl rs ->
+                               xmlify inh $ Tree (NodeText <$> (x <$ cr) <> (y <$ cy)) (ts <> ys) <| rs'
+                       ----------------------
+                        -- NOTE: detect [some text](http://some.url) or [SomeRef]
+                        NodePair PairParen
+                         | Tree (Cell sb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
+                               (<| xmlify inh rs') $
+                               case bracket of
+                                (toList -> [unTree -> Cell sl (NodeToken (TokenLink lnk))]) ->
+                                       element "eref" $
+                                               xmlAttrs [Cell sl ("to",lnk)] <>
+                                               xmlify inh ts
                                 _ ->
-                                       goTokens $
-                                               Cell bl el (TokenPlain (Text.dropAround Char.isSpace l)) <| ls
-                        (Seq.viewr -> rs :> Cell br er (TokenPlain r)) ->
-                               goTokens $
-                                       rs |> Cell br er (TokenPlain (Text.dropAround Char.isSpace r))
-                        _ -> goTokens toks
-                TokenPair PairHash (toList -> [unCell -> TokenPlain t]) ->
-                       Seq.singleton $
-                       TreeN (cell "ref") $
-                               xmlAttrs [cell ("to",t)]
-                TokenPair (PairElem name attrs) ts ->
+                                       element "rref" $
+                                               xmlAttrs [Cell sb ("to",Plain.writePlain bracket)] <>
+                                               xmlify inh ts
+                       ----------------------
+                        -- NOTE: gather HeaderDash
+                        _ | (span, rest) <- spanlItems (==HeaderDash) roots
+                          , not $ null span ->
+                               (<| xmlify inh rest) $
+                               element "ul" $
+                                       span >>= xmlify inh{inh_para=List.repeat elementPara}
+                       ----------------------
+                        -- NOTE: gather HeaderDot
+                          | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
+                          , not $ null span ->
+                               (<| xmlify inh rest) $
+                               element "ol" $
+                                       span >>= xmlify inh{inh_para=List.repeat elementPara}
+                               where
+                               spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots)
+                               spanlItems liHeader =
+                                       Seq.spanl $ \(unTree -> (unCell -> nod)) ->
+                                               case nod of
+                                                NodeHeader (HeaderColon "li" _wh) -> True
+                                                NodeHeader hdr -> liHeader hdr
+                                                NodePair (PairElem "li" _as) -> True
+                                                _ -> False
+                       ----------------------
+                        NodePara | para:inh_para <- inh_para inh ->
+                               para inh r <|
+                               -- para (() <$ cr) (xmlify inh ts) <|
+                               xmlify inh{inh_para} rs
+                       ----------------------
+                        -- NOTE: context-free Root
+                        _ ->
+                               xmlify inh r <>
+                               xmlify inh rs
+                       where
+                       element :: XmlName -> XMLs -> XML
+                       element n = Tree (XmlElem n <$ cr)
+instance Xmlify Root where
+       xmlify inh tn@(Tree (Cell ss@(sn:|ssn) nod) ts) =
+               case nod of
+               ----------------------
+                NodePara ->
+                       case inh_para inh of
+                        [] -> xmlify inh ts
+                        para:_ -> Seq.singleton $ para inh tn -- para (() <$ cn) $ xmlify inh ts
+               ----------------------
+                NodeHeader hdr ->
+                       case hdr of
+                       --
+                        HeaderSection{} ->
+                               Seq.singleton $
+                               element "section" $ head <> xmlify inh' body
+                               where
+                               (titles, content) = partitionSection tn
+                               (attrs, body)     = partitionAttrs content
+                               head =
+                                       case Seq.viewl titles of
+                                        EmptyL -> mempty
+                                        title@(unTree -> ct) :< subtitles ->
+                                               xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <>
+                                               xmlify inh{inh_para=List.repeat elementTitle} title <>
+                                               aliases
+                                               where
+                                               aliases =
+                                                       subtitles >>= \subtitle@(unTree -> cs) ->
+                                                               return $
+                                                               Tree (cs $> XmlElem "alias") $
+                                                                       xmlAttrs [cs $> ("id",getAttrId subtitle)]
+                               inh' = inh
+                                { inh_para   = List.repeat elementPara
+                                , inh_figure = True
+                                }
+                       --
+                        HeaderColon n _wh ->
+                               let (attrs,body) = partitionAttrs ts in
+                               case n of
+                               -- NOTE: insert titles into <about>.
+                                "about" ->
+                                       Seq.singleton $
+                                       element "about" $
+                                               xmlify inh' (inh_titles inh) <>
+                                               xmlAttrs attrs <>
+                                               xmlify inh'{inh_figure=False} body
+                               -- NOTE: in <figure> mode, unreserved elements become <figure>
+                                _ | inh_figure inh && n`List.notElem`elems || TL.null n ->
+                                       Seq.singleton $
+                                       element "figure" $
+                                               -- xmlAttrs (setAttr (Cell en en ("type",n)) attrs) <>
+                                               xmlAttrs (attrs `defaultAttr` Cell (sn{span_end=span_begin sn}:|ssn) ("type", n)) <>
+                                               case toList body of
+                                                [Tree0{}] -> xmlify inh'{inh_para = List.repeat elementPara} body
+                                                _         -> xmlify inh'{inh_para = elementTitle : List.repeat elementPara} body
+                               -- NOTE: reserved elements
+                                _ ->
+                                       Seq.singleton $
+                                       element (xmlLocalName n) $
+                                               xmlAttrs attrs <>
+                                               xmlify inh' body
+                               where
+                               inh' = inh
+                                { inh_para =
+                                       case n of
+                                        "about"     -> List.repeat elementTitle
+                                        "reference" -> elementTitle : List.repeat elementPara
+                                        "serie"     -> List.repeat attributeName
+                                        "author"    -> List.repeat attributeName
+                                        "editor"    -> List.repeat attributeName
+                                        "org"       -> List.repeat attributeName
+                                        "note"      -> List.repeat elementPara
+                                        _           -> []
+                                }
+                       --
+                        HeaderBar n wh ->
+                               if inh_figure inh && n`List.notElem`elems || TL.null n
+                               then
+                                       Seq.singleton $
+                                       element "artwork" $
+                                               xmlAttrs (Seq.singleton $ Cell (sn{span_end=span_end sn}:|ssn) ("type", n)) <>
+                                               xmlify inh{inh_para=[]} ts
+                               else
+                                       xmlify inh $
+                                               Tree (cell $ NodeHeader $ HeaderColon n wh) ts
+                       --
+                        HeaderGreat n _wh ->
+                               Seq.singleton $
+                               let (attrs,body) = partitionAttrs ts in
+                               element "quote" $
+                                       xmlAttrs (attrs `defaultAttr` Cell (sn{span_end=span_end sn}:|ssn) ("type", n)) <>
+                                       xmlify inh{inh_para=List.repeat elementPara} body
+                       --
+                        HeaderEqual n _wh ->
+                               Seq.singleton $
+                               Tree0 $ cell $ XmlAttr (xmlLocalName n) $
+                                       Plain.text (Plain.setStart ts def{Plain.state_escape = False}) ts
+                       --
+                        HeaderDot n ->
+                               Seq.singleton $
+                               element "li" $
+                                       let span_end = (span_begin sn){pos_column=pos_column (span_begin sn) + int (TL.length n)} in
+                                       xmlAttrs (Seq.singleton $ Cell (sn{span_end}:|ssn) ("name", n)) <>
+                                       xmlify inh ts
+                       --
+                        HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts
+                       --
+                        HeaderDashDash ->
+                               Seq.singleton $ Tree0 $ cell $
+                                       XmlComment $ Plain.writePlain ts
+                       --
+                        HeaderBrackets ident ->
+                               let (attrs,body) = partitionAttrs ts in
+                               Seq.singleton $
+                               element "reference" $
+                                       xmlAttrs (setAttr (Cell (sn{span_end=span_end sn}:|ssn) ("id",ident)) attrs) <>
+                                       xmlify inh'{inh_para = elementTitle : elementTitle : List.repeat elementPara} body
+                               where
+                               inh' = inh{inh_figure = False}
+                       --
+                        HeaderDotSlash _file -> xmlify inh ts
+               ----------------------
+                NodePair pair ->
+                       case pair of
+                        PairBracket | to <- Plain.writePlain ts
+                                    , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
+                               Seq.singleton $
+                               element "rref" $
+                                       xmlAttrs [cell ("to",to)]
+                        PairStar      -> Seq.singleton $ element "b"    $ xmlify inh ts
+                        PairSlash     -> Seq.singleton $ element "i"    $ xmlify inh ts
+                        PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts
+                        PairFrenchquote ->
+                               Seq.singleton $
+                               element "q" $
+                                       case ts of
+                                        (Seq.viewl -> Tree0 (Cell sl (NodeToken (TokenText l))) :< ls) ->
+                                               case Seq.viewr ls of
+                                                m :> Tree0 (Cell sr (NodeToken (TokenText r))) ->
+                                                       xmlify inh $
+                                                               Tree0 (Cell sl (NodeToken (TokenText (TL.dropWhile Char.isSpace l))))
+                                                                Seq.<|(m Seq.|>Tree0 (Cell sr (NodeToken (TokenText (TL.dropWhileEnd Char.isSpace r)))))
+                                                _ ->
+                                                       xmlify inh $
+                                                               Tree0 (Cell sl (NodeToken (TokenText (TL.dropAround Char.isSpace l)))) Seq.<| ls
+                                        (Seq.viewr -> rs :> Tree0 (Cell sr (NodeToken (TokenText r)))) ->
+                                               xmlify inh $
+                                                       rs Seq.|> Tree0 (Cell sr (NodeToken (TokenText (TL.dropAround Char.isSpace r))))
+                                        _ -> xmlify inh ts
+                        PairHash ->
+                               Seq.singleton $
+                               element "ref" $
+                                       xmlAttrs [cell ("to",Plain.writePlain ts)]
+                        PairElem name attrs ->
+                               Seq.singleton $
+                               element (xmlLocalName name) $
+                                       xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
+                                               cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
+                                       xmlify inh ts
+                        _ ->
+                               Seq.singleton (Tree0 $ Cell (sn{span_end=bn'}:|ssn) $ XmlText open) `unionXml`
+                               xmlify inh ts `unionXml`
+                               Seq.singleton (Tree0 $ Cell (sn{span_begin=en'}:|ssn) $ XmlText close)
+                               where
+                               (open, close) = pairBorders pair ts
+                               bn' = (span_begin sn){pos_column=pos_column (span_begin sn) + int (TL.length open)}
+                               en' = (span_end   sn){pos_column=pos_column (span_end   sn) - int (TL.length close)}
+               ----------------------
+                NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
+               ----------------------
+                NodeToken tok ->
+                       case tok of
+                        TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c
+                        TokenText t   -> Seq.singleton $ Tree0 $ cell $ XmlText t
+                        TokenTag t    -> Seq.singleton $ element "ref"  $ xmlAttrs [cell ("to",t)]
+                        TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)]
+               ----------------------
+                NodeLower n as ->
                        Seq.singleton $
-                       TreeN (cell $ xmlLocalName name) $
-                               xmlAttrs (Seq.fromList $ (\(_wh,Attr{..}) -> cell (xmlLocalName attr_name,attr_value)) <$> attrs) <>
-                               goTokens ts
-                TokenPair p ts ->
-                       let (o,c) = pairBorders p ts in
-                       Seq.singleton (Tree0 $ Cell bp bp $ XmlText o) `unionXml`
-                       goTokens ts `unionXml`
-                       Seq.singleton (Tree0 $ Cell ep ep $ XmlText c)
+                       element "artwork" $
+                               xmlify inh ts
                where
                cell :: a -> Cell a
-               cell = Cell bp ep
-       
-       goTokens :: Tokens -> XMLs
-       goTokens toks =
-               case Seq.viewl toks of
-                Cell bp _ep (TokenPair PairParen paren)
-                 :< (Seq.viewl -> Cell bb eb (TokenPair PairBracket bracket)
-                 :< ts) ->
-                       (<| goTokens ts) $
-                       case bracket of
-                        (toList -> [Cell bl el (TokenLink lnk)]) ->
-                               TreeN (Cell bp eb "eref") $
-                                       xmlAttrs [Cell bl el ("to",lnk)] <>
-                                       goTokens paren
-                        _ ->
-                               TreeN (Cell bp eb "rref") $
-                                       xmlAttrs [Cell bb eb ("to",TL.toStrict $ Write.t_Tokens bracket)] <>
-                                       goTokens paren
-                t :< ts -> go t `unionXml` goTokens ts
-                Seq.EmptyL -> mempty
-
--- | Unify two 'XMLs', merging border 'XmlText's if any.
-unionXml :: XMLs -> XMLs -> XMLs
-unionXml x y =
-       case (Seq.viewr x, Seq.viewl y) of
-        (xs :> x0, y0 :< ys) ->
-               case (x0,y0) of
-                (Tree0 (Cell bx _ex (XmlText tx)), Tree0 (Cell _by ey (XmlText ty))) ->
-                       xs `unionXml`
-                       Seq.singleton (Tree0 $ Cell bx ey $ XmlText $ tx <> ty) `unionXml`
-                       ys
-                _ -> x <> y
-        (Seq.EmptyR, _) -> y
-        (_, Seq.EmptyL) -> x
-
-
-spanlBar :: Name -> TCTs -> (TCTs, TCTs)
-spanlBar name = first unKeyBar . spanBar
-       where
-       unKeyBar :: TCTs -> TCTs
-       unKeyBar = (=<<) $ \case
-                TreeN (unCell -> KeyBar{}) ts -> ts
-                _ -> mempty
-       spanBar =
-               Seq.spanl $ \case
-                TreeN (unCell -> KeyBar n _) _ | n == name -> True
-                _ -> False
-
-spanlItems :: (Key -> Bool) -> TCTs -> (TCTs, TCTs)
-spanlItems liKey ts =
-       let (lis, ts') = spanLIs ts in
-       foldl' accumLIs (mempty,ts') lis
-       where
-       spanLIs = Seq.spanl $ \case
-                TreeN (unCell -> liKey -> True) _ -> True
-                Tree0 toks ->
-                       (`any` toks) $ \case
-                        (unCell -> TokenPair (PairElem "li" _) _) -> True
-                        _ -> False
-                       {-
-                       case toList $ Seq.dropWhileR (isTokenWhite . unCell) toks of
-                        [unCell -> TokenPair (PairElem "li" _) _] -> True
-                        _ -> False
-                       -}
-                _ -> False
-       accumLIs acc@(oks,kos) t =
-               case t of
-                TreeN (unCell -> liKey -> True) _ -> (oks|>t,kos)
-                Tree0 toks ->
-                       let (ok,ko) =
-                               (`Seq.spanl` toks) $ \tok ->
-                                       case unCell tok of
-                                        TokenPair (PairElem "li" _) _ -> True
-                                        TokenPlain txt -> Char.isSpace`Text.all`txt
-                                        _ -> False in
-                       ( if null ok then oks else oks|>Tree0 (rmTokenPlain ok)
-                       , if null ko then kos else Tree0 ko<|kos )
-                _ -> acc
-       rmTokenPlain =
-               Seq.filter $ \case
-                (unCell -> TokenPlain{}) -> False
-                _ -> True
-
-spanlKeyColon :: Name -> TCTs -> (TCTs, TCTs)
-spanlKeyColon name =
-       Seq.spanl $ \case
-        TreeN (unCell -> KeyBar   n _) _ -> n == name
-        TreeN (unCell -> KeyGreat n _) _ -> n == name
-        _ -> False
-
-spanlBrackets :: TCTs -> (TCTs, TCTs)
-spanlBrackets =
-       Seq.spanl $ \case
-        TreeN (unCell -> KeyBrackets{}) _ -> True
-        _ -> False
-
-spanlTokens :: TCTs -> (Seq Tokens, TCTs)
-spanlTokens =
-       first ((\case
-        Tree0 ts -> ts
-        _ -> undefined) <$>) .
-       Seq.spanl (\case
-        Tree0{} -> True
-        _ -> False)
+               cell = Cell ss
+               element :: XmlName -> XMLs -> XML
+               element n = Tree (cell $ XmlElem n)
+instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
+       xmlify _inh = xmlAttrs
 
-getAttrId :: TCTs -> Text
-getAttrId ts =
-       case Seq.index ts <$> Seq.findIndexL TreeSeq.isTree0 ts of
-        Just (Tree0 toks) -> TL.toStrict $ Write.t_Tokens toks
-        _ -> ""
+-- * Elements
 
-setXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text))
-setXmlAttr a@(unCell -> (k, _v)) as =
-       case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
-        Just idx -> Seq.update idx a as
-        Nothing -> a <| as
-
-defXmlAttr :: Cell (XmlName, Text) -> Seq (Cell (XmlName, Text)) -> Seq (Cell (XmlName, Text))
-defXmlAttr a@(unCell -> (k, _v)) as =
-       case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
-        Just _idx -> as
-        Nothing -> a <| as
-
-xmlAttrs :: Seq (Cell (XmlName,Text)) -> XMLs
-xmlAttrs = ((\(Cell bp ep (n,v)) -> Tree0 (Cell bp ep $ XmlAttr n v)) <$>)
-
-{-
-xmlAttr :: XmlAttrs -> (Text,Attr) -> XmlAttrs
-xmlAttr acc (_,Attr{..}) = Map.insert (xmlLocalName attr_name) attr_value acc
- -- TODO: conflict
--}
-
-{-
-d_Attributes :: XmlAttrs -> DTC -> DTC
-d_Attributes = flip $ Map.foldrWithKey $ \n v ->
-       B.AddCustomAttribute (B.Text n) (B.Text v)
--}
-
-partitionAttributesChildren :: TCTs -> (Seq (Cell (XmlName, Text)), TCTs)
-partitionAttributesChildren ts = (attrs,cs)
-       where
-       (as,cs) = (`Seq.partition` ts) $ \case
-                TreeN (unCell -> KeyEqual{}) _cs -> True
-                _ -> False
-       attrs = foldl' (\acc a -> acc |> attr a) Seq.empty as
-       attr = \case
-                TreeN (Cell bp ep (KeyEqual n _wh)) a ->
-                       Cell bp ep (xmlLocalName n, v)
-                       where
-                       v = TL.toStrict $
-                               Write.text Write.config_text{Write.config_text_escape = False} $
-                               TreeSeq.mapAlsoKey (cell1 . unCell) (\_path -> fmap $ cell1 . unCell) <$> a
-                _ -> undefined
-
-elems :: Set Text
+-- | Reserved elements' name
+elems :: Set TL.Text
 elems =
  [ "about"
  , "abstract"
@@ -511,6 +413,7 @@ elems =
  , "authors"
  , "bcp14"
  , "br"
+ , "break"
  , "call"
  , "city"
  , "code"
@@ -555,8 +458,8 @@ elems =
  , "q"
  , "ref"
  , "reference"
+ , "references"
  , "region"
- , "rl"
  , "rref"
  , "sc"
  , "section"
@@ -579,6 +482,7 @@ elems =
  , "tof"
  , "tr"
  , "tt"
+ , "u"
  , "ul"
  , "uri"
  , "version"
@@ -587,3 +491,65 @@ elems =
  , "xml"
  , "zipcode"
  ]
+
+-- * Attributes
+
+-- | Convenient alias, forcing the types
+xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
+xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
+
+-- | Extract attributes
+partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
+partitionAttrs ts = (attrs,cs)
+       where
+       (as,cs) = (`Seq.partition` ts) $ \case
+        Tree (unCell -> NodeHeader (HeaderEqual n _wh)) _cs -> not $ TL.null n
+        _ -> False
+       attrs = attr <$> as
+       attr = \case
+        Tree (Cell ssn (NodeHeader (HeaderEqual n _wh))) a ->
+               Cell ssn (xmlLocalName n, v)
+               where
+               v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
+        _ -> undefined
+
+getAttrId :: Root -> TL.Text
+getAttrId = Plain.writePlain . Seq.singleton
+
+setAttr ::
+ Cell (XmlName, TL.Text) ->
+ Seq (Cell (XmlName, TL.Text)) ->
+ Seq (Cell (XmlName, TL.Text))
+setAttr a@(unCell -> (k, _v)) as =
+       case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
+        Just idx -> Seq.update idx a as
+        Nothing -> a <| as
+
+defaultAttr ::
+ Seq (Cell (XmlName, TL.Text)) ->
+ Cell (XmlName, TL.Text) ->
+ Seq (Cell (XmlName, TL.Text))
+defaultAttr as a@(unCell -> (k, _v)) =
+       case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
+        Just _idx -> as
+        Nothing -> a <| as
+
+-- * Text
+
+-- | Unify two 'XMLs', merging border 'XmlText's if any.
+unionXml :: XMLs -> XMLs -> XMLs
+unionXml x y =
+       case (Seq.viewr x, Seq.viewl y) of
+        (xs :> x0, y0 :< ys) ->
+               case (x0,y0) of
+                (  Tree0 (Cell ssx@(Span {span_file=fx}:|_sx) (XmlText tx))
+                 , Tree0 (Cell ssy@(Span {span_file=fy}:|_sy) (XmlText ty)) ) | fx == fy ->
+                       xs `unionXml`
+                       Seq.singleton (Tree0 $ (XmlText <$>) $ Cell ssx tx <> Cell ssy ty) `unionXml`
+                       ys
+                _ -> x <> y
+        (Seq.EmptyR, _) -> y
+        (_, Seq.EmptyL) -> x
+
+unionsXml :: Foldable f => f XMLs -> XMLs
+unionsXml = foldl' unionXml mempty