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.Maybe (Maybe(..))
17 import Data.Monoid (Monoid(..))
18 import Data.Ord (Ord(..))
19 import Data.Semigroup (Semigroup(..))
20 import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
22 import Data.TreeSeq.Strict (Tree(..), tree0)
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
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 document :: 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 bt et _) :< _ ->
61 case Seq.findIndexL isAbout content of
62 Nothing -> Tree (Cell bt et $ 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 _bt et NodePara) :< rest ->
75 let (subtitles, content) = spanlSubtitles et rest in
76 (title <| (subtitles >>= subTrees), content)
78 spanlSubtitles ep ts =
80 sub@(unTree -> Cell bs es (NodeHeader (HeaderSection lvlSub))) :< rs
82 , pos_line bs - pos_line ep <= 1 ->
83 let (subs, ts') = spanlSubtitles es 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.document ts) <$ c)
118 xmlify :: Inh -> a -> XMLs
119 instance Xmlify Roots where
121 case Seq.viewl roots of
123 r@(Tree cr@(Cell _br _er 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 bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
163 (<| xmlify inh rs') $
165 (toList -> [unTree -> Cell bl el (NodeToken (TokenLink lnk))]) ->
167 xmlAttrs [Cell bl el ("to",lnk)] <>
171 xmlAttrs [Cell bb eb ("to",Plain.document 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 bn en 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 bn bn ("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 bn bn ("type", n)) <>
290 xmlify inh{inh_para=[]} ts
293 Tree (Cell bn en $ NodeHeader $ HeaderColon n wh) ts
297 let (attrs,body) = partitionAttrs ts in
299 xmlAttrs (attrs `defaultAttr` Cell bn bn ("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 xmlAttrs (Seq.singleton $ Cell bn bn{pos_column=pos_column bn + int (TL.length n)} ("name", n)) <>
313 HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts
316 Seq.singleton $ Tree0 $ cell $
317 XmlComment $ Plain.document ts
319 HeaderBrackets ident ->
320 let (attrs,body) = partitionAttrs ts in
322 element "reference" $
323 xmlAttrs (setAttr (Cell en en ("id",ident)) attrs) <>
324 xmlify inh'{inh_para = elementTitle : elementTitle : List.repeat elementPara} body
326 inh' = inh{inh_figure = False}
331 xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
333 ----------------------
336 PairBracket | to <- Plain.document ts
337 , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
340 xmlAttrs [cell ("to",to)]
341 PairStar -> Seq.singleton $ element "b" $ xmlify inh ts
342 PairSlash -> Seq.singleton $ element "i" $ xmlify inh ts
343 PairBackquote -> Seq.singleton $ element "code" $ xmlify inh ts
350 (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
352 m :> Tree0 (Cell br er (TokenPlain r)) ->
354 Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)))
355 <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))))
358 Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls
359 (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) ->
361 rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
367 xmlAttrs [cell ("to",Plain.document ts)]
368 PairElem name attrs ->
370 element (xmlLocalName name) $
371 xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
372 cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
375 Seq.singleton (Tree0 $ Cell bn bn' $ XmlText open) `unionXml`
376 xmlify inh ts `unionXml`
377 Seq.singleton (Tree0 $ Cell en' en $ XmlText close)
379 (open, close) = pairBorders pair ts
380 bn' = bn{pos_column=pos_column bn + int (TL.length open)}
381 en' = en{pos_column=pos_column bn - int (TL.length close)}
382 ----------------------
383 NodeText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
384 ----------------------
387 TokenEscape c -> Seq.singleton $ Tree0 $ cell $ XmlText $ TL.singleton c
388 TokenText t -> Seq.singleton $ Tree0 $ cell $ XmlText t
389 TokenTag t -> Seq.singleton $ element "ref" $ xmlAttrs [cell ("to",t)]
390 TokenLink lnk -> Seq.singleton $ element "eref" $ xmlAttrs [cell ("to",lnk)]
391 ----------------------
399 element :: XmlName -> XMLs -> XML
400 element n = Tree (cell $ XmlElem n)
401 instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
402 xmlify _inh = xmlAttrs
406 -- | Reserved elements' name
502 -- | Convenient alias, forcing the types
503 xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
504 xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
506 -- | Extract attributes
507 partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
508 partitionAttrs ts = (attrs,cs)
510 (as,cs) = (`Seq.partition` ts) $ \case
511 Tree (unCell -> NodeHeader (HeaderEqual n _wh)) _cs -> not $ TL.null n
515 Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
516 Cell bp ep (xmlLocalName n, v)
518 v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
521 getAttrId :: Root -> TL.Text
522 getAttrId = Plain.document . Seq.singleton
525 Cell (XmlName, TL.Text) ->
526 Seq (Cell (XmlName, TL.Text)) ->
527 Seq (Cell (XmlName, TL.Text))
528 setAttr a@(unCell -> (k, _v)) as =
529 case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
530 Just idx -> Seq.update idx a as
534 Seq (Cell (XmlName, TL.Text)) ->
535 Cell (XmlName, TL.Text) ->
536 Seq (Cell (XmlName, TL.Text))
537 defaultAttr as a@(unCell -> (k, _v)) =
538 case Seq.findIndexL (\(unCell -> (n,_v)) -> n == k) as of
544 -- | Unify two 'XMLs', merging border 'XmlText's if any.
545 unionXml :: XMLs -> XMLs -> XMLs
547 case (Seq.viewr x, Seq.viewl y) of
548 (xs :> x0, y0 :< ys) ->
550 ( Tree0 (Cell bx ex (XmlText tx))
551 , Tree0 (Cell by ey (XmlText ty)) ) ->
553 Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml`
559 unionsXml :: Foldable f => f XMLs -> XMLs
560 unionsXml = foldl' unionXml mempty