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
9 import Control.Monad (Monad(..))
11 import Data.Default.Class (Default(..))
12 import Data.Eq (Eq(..))
13 import Data.Foldable (Foldable(..))
14 import Data.Function (($), (.))
15 import Data.Functor ((<$>), (<$), ($>))
16 import Data.List.NonEmpty (NonEmpty(..))
17 import Data.Maybe (Maybe(..))
18 import Data.Monoid (Monoid(..))
19 import Data.Ord (Ord(..))
20 import Data.Semigroup (Semigroup(..))
21 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
23 import Data.TreeSeq.Strict (Tree(..), tree0)
24 import Data.Tuple (uncurry)
25 import Prelude (Num(..), undefined)
26 import qualified Data.Char as Char
27 import qualified Data.List as List
28 import qualified Data.Sequence as Seq
29 import qualified Data.Text.Lazy as TL
30 import qualified Language.TCT.Write.Plain as Plain
32 -- import Language.TCT.Debug
33 import Language.TCT.Utils
34 import Language.TCT hiding (Parser)
36 import Text.Blaze.XML ()
40 -- NOTE: 'XmlNode' are still annotated with 'Cell',
41 -- but nothing is done to preserve any ordering amongst them,
42 -- because 'Node's sometimes need to be reordered
43 -- (eg. about/title may have a title from the section before,
44 -- hence outside of about).
45 -- Still holding: @'cell_begin' < 'cell_end'@ and 'Cell' nesting.
46 writeXML :: Roots -> XMLs
48 -- (`S.evalState` def) $
50 sec@(Tree (unCell -> NodeHeader HeaderSection{}) _body) :< foot ->
51 let (titles, content) = partitionSection sec in
52 case Seq.viewl titles of
53 (unTree -> Cell st _) :< _ ->
61 case Seq.findIndexL isAbout content of
62 Nothing -> Tree (Cell st $ NodeHeader $ HeaderColon "about" "") mempty <| content
65 (unTree -> (unCell -> NodeHeader (HeaderColon "about" _wh))) -> True
70 partitionSection :: Root -> (Roots, Roots)
71 partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) =
72 case Seq.viewl body of
74 title@(unTree -> Cell (Span{span_end=et}:|_) NodePara) :< rest ->
75 let (subtitles, content) = spanlSubtitles et rest in
76 (title <| (subtitles >>= subTrees), content)
78 spanlSubtitles ep ts =
80 sub@(unTree -> Cell (Span{..}:|_) (NodeHeader (HeaderSection lvlSub))) :< rs
82 , pos_line span_begin - pos_line ep <= 1 ->
83 let (subs, ts') = spanlSubtitles span_end rs in
87 partitionSection _ = mempty
93 , inh_para :: [Inh -> Root -> XML]
96 instance Default Inh where
99 , inh_para = List.repeat elementPara
100 , inh_titles = mempty
104 elementPara :: Inh -> Root -> XML
105 elementPara inh (Tree c ts) = Tree (XmlElem "para" <$ c) $ xmlify inh ts
107 elementTitle :: Inh -> Root -> XML
108 elementTitle inh (Tree c ts) = Tree (XmlElem "title" <$ c) $ xmlify inh ts
110 elementName :: Inh -> Root -> XML
111 elementName inh (Tree c ts) = Tree (XmlElem "name" <$ c) $ xmlify inh ts
113 attributeName :: Inh -> Root -> XML
114 attributeName _inh (Tree c ts) = tree0 (XmlAttr "name" (Plain.writePlain ts) <$ c)
118 xmlify :: Inh -> a -> XMLs
119 instance Xmlify Roots where
121 case Seq.viewl roots of
123 r@(Tree cr@(Cell _sr nr) ts) :< rs ->
125 ----------------------
126 -- NOTE: HeaderColon becomes parent
127 -- of any continuous following-sibling HeaderBar or HeaderGreat
128 NodeHeader (HeaderColon n _wh)
129 | (span, rest) <- spanlHeaderColon rs
131 xmlify inh (Tree cr (ts<>span)) <>
134 spanlHeaderColon :: Roots -> (Roots, Roots)
137 Tree (unCell -> NodeHeader (HeaderBar m _)) _ -> m == n
138 Tree (unCell -> NodeHeader (HeaderGreat m _)) _ -> m == n
140 ----------------------
141 -- NOTE: gather HeaderBrackets
142 NodeHeader HeaderBrackets{}
143 | (span,rest) <- spanlBrackets roots
145 (<| xmlify inh rest) $
146 element "references" $
149 spanlBrackets :: Roots -> (Roots, Roots)
152 Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True
154 ----------------------
155 -- NOTE: merge adjacent NodeText-s, shouldn't be needed, but just in case.
157 | Tree (cy@(unCell -> NodeText y)) ys :< rs' <- Seq.viewl rs ->
158 xmlify inh $ Tree (NodeText <$> (x <$ cr) <> (y <$ cy)) (ts <> ys) <| rs'
159 ----------------------
160 -- NOTE: detect [some text](http://some.url) or [SomeRef]
162 | Tree (Cell sb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
163 (<| xmlify inh rs') $
165 (toList -> [unTree -> Cell sl (NodeToken (TokenLink lnk))]) ->
167 xmlAttrs [Cell sl ("to",lnk)] <>
171 xmlAttrs [Cell sb ("to",Plain.writePlain bracket)] <>
173 ----------------------
174 -- NOTE: gather HeaderDash
175 _ | (span, rest) <- spanlItems (==HeaderDash) roots
177 (<| xmlify inh rest) $
179 span >>= xmlify inh{inh_para=List.repeat elementPara}
180 ----------------------
181 -- NOTE: gather HeaderDot
182 | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
184 (<| xmlify inh rest) $
186 span >>= xmlify inh{inh_para=List.repeat elementPara}
188 spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots)
189 spanlItems liHeader =
190 Seq.spanl $ \(unTree -> (unCell -> nod)) ->
192 NodeHeader (HeaderColon "li" _wh) -> True
193 NodeHeader hdr -> liHeader hdr
194 NodePair (PairElem "li" _as) -> True
196 ----------------------
197 NodePara | para:inh_para <- inh_para inh ->
199 -- para (() <$ cr) (xmlify inh ts) <|
200 xmlify inh{inh_para} rs
201 ----------------------
202 -- NOTE: context-free Root
207 element :: XmlName -> XMLs -> XML
208 element n = Tree (XmlElem n <$ cr)
209 instance Xmlify Root where
210 xmlify inh tn@(Tree (Cell ss@(sn:|ssn) nod) ts) =
212 ----------------------
216 para:_ -> Seq.singleton $ para inh tn -- para (() <$ cn) $ xmlify inh ts
217 ----------------------
223 element "section" $ head <> xmlify inh' body
225 (titles, content) = partitionSection tn
226 (attrs, body) = partitionAttrs content
228 case Seq.viewl titles of
230 title@(unTree -> ct) :< subtitles ->
231 xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <>
232 xmlify inh{inh_para=List.repeat elementTitle} title <>
236 subtitles >>= \subtitle@(unTree -> cs) ->
238 Tree (cs $> XmlElem "alias") $
239 xmlAttrs [cs $> ("id",getAttrId subtitle)]
241 { inh_para = List.repeat elementPara
246 let (attrs,body) = partitionAttrs ts in
248 -- NOTE: insert titles into <about>.
252 xmlify inh' (inh_titles inh) <>
254 xmlify inh'{inh_figure=False} body
255 -- NOTE: in <figure> mode, unreserved elements become <figure>
256 _ | inh_figure inh && n`List.notElem`elems || TL.null n ->
259 -- xmlAttrs (setAttr (Cell en en ("type",n)) attrs) <>
260 xmlAttrs (attrs `defaultAttr` Cell (sn{span_end=span_begin sn}:|ssn) ("type", n)) <>
262 [Tree0{}] -> xmlify inh'{inh_para = List.repeat elementPara} body
263 _ -> xmlify inh'{inh_para = elementTitle : List.repeat elementPara} body
264 -- NOTE: reserved elements
267 element (xmlLocalName n) $
274 "about" -> List.repeat elementTitle
275 "reference" -> elementTitle : List.repeat elementPara
276 "serie" -> List.repeat attributeName
277 "author" -> List.repeat attributeName
278 "editor" -> List.repeat attributeName
279 "org" -> List.repeat attributeName
280 "note" -> List.repeat elementPara
285 if inh_figure inh && n`List.notElem`elems || TL.null n
289 xmlAttrs (Seq.singleton $ Cell (sn{span_end=span_end sn}:|ssn) ("type", n)) <>
290 xmlify inh{inh_para=[]} ts
293 Tree (cell $ NodeHeader $ HeaderColon n wh) ts
297 let (attrs,body) = partitionAttrs ts in
299 xmlAttrs (attrs `defaultAttr` Cell (sn{span_end=span_end sn}:|ssn) ("type", n)) <>
300 xmlify inh{inh_para=List.repeat elementPara} body
304 Tree0 $ cell $ XmlAttr (xmlLocalName n) $
305 Plain.text (Plain.setStart ts def{Plain.state_escape = False}) ts
310 let span_end = (span_begin sn){pos_column=pos_column (span_begin sn) + int (TL.length n)} in
311 xmlAttrs (Seq.singleton $ Cell (sn{span_end}:|ssn) ("name", n)) <>
314 HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts
317 Seq.singleton $ Tree0 $ cell $
318 XmlComment $ Plain.writePlain ts
320 HeaderBrackets ident ->
321 let (attrs,body) = partitionAttrs ts in
323 element "reference" $
324 xmlAttrs (setAttr (Cell (sn{span_end=span_end sn}:|ssn) ("id",ident)) attrs) <>
325 xmlify inh'{inh_para = elementTitle : elementTitle : List.repeat elementPara} body
327 inh' = inh{inh_figure = False}
329 HeaderDotSlash _file -> xmlify inh ts
330 ----------------------
333 PairBracket | to <- Plain.writePlain ts
334 , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
337 xmlAttrs [cell ("to",to)]
338 PairStar -> Seq.singleton $ element "b" $ xmlify inh ts
339 PairSlash -> Seq.singleton $ element "i" $ xmlify inh ts
340 PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts
345 (Seq.viewl -> Tree0 (Cell sl (NodeToken (TokenText l))) :< ls) ->
347 m :> Tree0 (Cell sr (NodeToken (TokenText r))) ->
349 Tree0 (Cell sl (NodeToken (TokenText (TL.dropWhile Char.isSpace l))))
350 Seq.<|(m Seq.|>Tree0 (Cell sr (NodeToken (TokenText (TL.dropWhileEnd Char.isSpace r)))))
353 Tree0 (Cell sl (NodeToken (TokenText (TL.dropAround Char.isSpace l)))) Seq.<| ls
354 (Seq.viewr -> rs :> Tree0 (Cell sr (NodeToken (TokenText r)))) ->
356 rs Seq.|> Tree0 (Cell sr (NodeToken (TokenText (TL.dropAround Char.isSpace r))))
361 xmlAttrs [cell ("to",Plain.writePlain ts)]
362 PairElem name attrs ->
364 element (xmlLocalName name) $
365 xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
366 cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
369 Seq.singleton (Tree0 $ Cell (sn{span_end=bn'}:|ssn) $ XmlText open) `unionXml`
370 xmlify inh ts `unionXml`
371 Seq.singleton (Tree0 $ Cell (sn{span_begin=en'}:|ssn) $ XmlText close)
373 (open, close) = pairBorders pair ts
374 bn' = (span_begin sn){pos_column=pos_column (span_begin sn) + int (TL.length open)}
375 en' = (span_end sn){pos_column=pos_column (span_end sn) - int (TL.length close)}
376 ----------------------
377 NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
378 ----------------------
381 TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c
382 TokenText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
383 TokenTag t -> Seq.singleton $ element "ref" $ xmlAttrs [cell ("to",t)]
384 TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)]
385 ----------------------
393 element :: XmlName -> XMLs -> XML
394 element n = Tree (cell $ XmlElem n)
395 instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
396 xmlify _inh = xmlAttrs
400 -- | Reserved elements' name
496 -- | Convenient alias, forcing the types
497 xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
498 xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
500 -- | Extract attributes
501 partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
502 partitionAttrs ts = (attrs,cs)
504 (as,cs) = (`Seq.partition` ts) $ \case
505 Tree (unCell -> NodeHeader (HeaderEqual n _wh)) _cs -> not $ TL.null n
509 Tree (Cell ssn (NodeHeader (HeaderEqual n _wh))) a ->
510 Cell ssn (xmlLocalName n, v)
512 v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
515 getAttrId :: Root -> TL.Text
516 getAttrId = Plain.writePlain . Seq.singleton
519 Cell (XmlName, TL.Text) ->
520 Seq (Cell (XmlName, TL.Text)) ->
521 Seq (Cell (XmlName, TL.Text))
522 setAttr a@(unCell -> (k, _v)) as =
523 case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
524 Just idx -> Seq.update idx a as
528 Seq (Cell (XmlName, TL.Text)) ->
529 Cell (XmlName, TL.Text) ->
530 Seq (Cell (XmlName, TL.Text))
531 defaultAttr as a@(unCell -> (k, _v)) =
532 case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
538 -- | Unify two 'XMLs', merging border 'XmlText's if any.
539 unionXml :: XMLs -> XMLs -> XMLs
541 case (Seq.viewr x, Seq.viewl y) of
542 (xs :> x0, y0 :< ys) ->
544 ( Tree0 (Cell ssx@(Span {span_file=fx}:|_sx) (XmlText tx))
545 , Tree0 (Cell ssy@(Span {span_file=fy}:|_sy) (XmlText ty)) ) | fx == fy ->
547 Seq.singleton (Tree0 $ (XmlText <$>) $ Cell ssx tx <> Cell ssy ty) `unionXml`
553 unionsXml :: Foldable f => f XMLs -> XMLs
554 unionsXml = foldl' unionXml mempty