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(..))
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 hiding (Parser)
35 import Text.Blaze.XML ()
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
47 -- (`S.evalState` def) $
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 _) :< _ ->
60 case Seq.findIndexL isAbout content of
61 Nothing -> Tree (Cell bt et $ NodeHeader $ HeaderColon "about" "") mempty <| content
64 (unTree -> (unCell -> NodeHeader (HeaderColon "about" _wh))) -> True
69 partitionSection :: Root -> (Roots, Roots)
70 partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) =
71 case Seq.viewl body of
73 title@(unTree -> Cell _bt et NodePara) :< rest ->
74 let (subtitles, content) = spanlSubtitles et rest in
75 (title <| (subtitles >>= subTrees), content)
77 spanlSubtitles ep ts =
79 sub@(unTree -> Cell bs es (NodeHeader (HeaderSection lvlSub))) :< rs
81 , pos_line bs - pos_line ep <= 1 ->
82 let (subs, ts') = spanlSubtitles es rs in
86 partitionSection _ = mempty
92 , inh_para :: [Cell () -> XMLs -> XML]
95 instance Default Inh where
98 , inh_para = List.repeat xmlPara
103 xmlPara :: Cell a -> XMLs -> XML
104 xmlPara c = Tree (XmlElem "para" <$ c)
106 xmlTitle :: Cell a -> XMLs -> XML
107 xmlTitle c = Tree (XmlElem "title" <$ c)
109 xmlName :: Cell a -> XMLs -> XML
110 xmlName c = Tree (XmlElem "name" <$ c)
114 xmlify :: Inh -> a -> XMLs
115 instance Xmlify Roots where
117 case Seq.viewl roots of
119 r@(Tree cr@(Cell _br _er nr) ts) :< rs ->
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
127 xmlify inh $ Tree cr (ts<>span) <| rest
129 spanlHeaderColon :: Roots -> (Roots, Roots)
132 Tree (unCell -> NodeHeader (HeaderBar m _)) _ -> m == n
133 Tree (unCell -> NodeHeader (HeaderGreat m _)) _ -> m == n
135 ----------------------
136 -- NOTE: gather HeaderBrackets
137 NodeHeader HeaderBrackets{}
138 | (span,rest) <- spanlBrackets roots
140 (<| xmlify inh rest) $
141 element "references" $
144 spanlBrackets :: Roots -> (Roots, Roots)
147 Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True
149 ----------------------
150 -- NOTE: merge adjacent NodeText-s, shouldn't be needed, but just in case.
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]
157 | Tree (Cell bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
158 (<| xmlify inh rs') $
160 (toList -> [unTree -> Cell bl el (NodeToken (TokenLink lnk))]) ->
162 xmlAttrs [Cell bl el ("to",lnk)] <>
166 xmlAttrs [Cell bb eb ("to",Plain.document bracket)] <>
168 ----------------------
169 -- NOTE: gather HeaderDash
170 _ | (span, rest) <- spanlItems (==HeaderDash) roots
172 (<| xmlify inh rest) $
174 span >>= xmlify inh{inh_para=List.repeat xmlPara}
175 ----------------------
176 -- NOTE: gather HeaderDot
177 | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
179 (<| xmlify inh rest) $
181 span >>= xmlify inh{inh_para=List.repeat xmlPara}
183 spanlItems :: (Header -> Bool) -> Roots -> (Roots, Roots)
184 spanlItems liHeader =
185 Seq.spanl $ \(unTree -> (unCell -> nod)) ->
187 NodeHeader (HeaderColon "li" _wh) -> True
188 NodeHeader hdr -> liHeader hdr
189 NodePair (PairElem "li" _as) -> True
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
201 element :: XmlName -> XMLs -> XML
202 element n = Tree (XmlElem n <$ cr)
204 t@(Tree (NodePair (PairElem))) :< ts ->
206 [] -> xmlify inh t <> go inh ts
207 _ | isTokenElem toks -> xmlify inh t <> go inh ts
209 (case Seq.viewl toks of
211 (unTree -> cell_begin -> bp) :< _ -> (tree0 bp (xmlify inh t) <|)) $
214 instance Xmlify Root where
215 xmlify inh tn@(Tree (Cell bn en nod) ts) =
217 NodeGroup -> xmlify inh ts
218 ----------------------
219 NodePara -> xmlify inh ts
220 ----------------------
226 element "section" $ head <> xmlify inh' body
228 (titles, content) = partitionSection tn
229 (attrs, body) = partitionAttrs content
231 case Seq.viewl titles of
233 title@(unTree -> ct) :< subtitles ->
234 xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <>
238 subtitles >>= \subtitle@(unTree -> cs) ->
240 Tree (cs $> XmlElem "alias") $
241 xmlAttrs (return $ cs $> ("id",getAttrId subtitle))
243 { inh_para = xmlTitle : List.repeat xmlPara
248 let (attrs,body) = partitionAttrs ts in
250 -- NOTE: insert titles into <about>.
254 (xmlify inh' $ inh_titles inh) <>
257 -- NOTE: in <figure> mode, unreserved nodes become <figure>
258 _ | inh_figure inh && n`List.notElem`elems || TL.null n ->
261 -- xmlAttrs (setAttr (Cell en en ("type",n)) attrs) <>
262 xmlAttrs (attrs `defaultAttr` Cell bn bn ("type", n)) <>
264 [Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body
265 _ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body
266 -- NOTE: reserved nodes
269 element (xmlLocalName n) $
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
284 ----------------------
288 xmlAttrs (Seq.singleton $ Cell bn bn ("type", n)) <>
289 xmlify inh{inh_para=[]} ts
290 ----------------------
293 let (attrs,body) = partitionAttrs ts in
295 xmlAttrs (attrs `defaultAttr` Cell bn bn ("type", n)) <>
296 xmlify inh{inh_para=List.repeat xmlPara} body
298 HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
300 HeaderDot _n -> Seq.singleton $ element "li" $ xmlify inh ts
302 HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts
304 HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $
305 -- debug1_ ("TS", ts) $
306 -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $
308 -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
315 (\_k' -> cell1 . unCell)) <$> ts
318 HeaderBrackets ident ->
319 let (attrs,body) = partitionAttrs ts in
321 element "reference" $
322 xmlAttrs (setAttr (Cell en en ("id",ident)) attrs) <>
323 xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body
325 inh' = inh{inh_figure = False}
330 xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
332 ----------------------
335 PairBracket | to <- Plain.document ts
336 , TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
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
349 (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
351 m :> Tree0 (Cell br er (TokenPlain r)) ->
353 Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)))
354 <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))))
357 Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls
358 (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) ->
360 rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
366 xmlAttrs [cell ("to",Plain.document ts)]
367 PairElem name attrs ->
369 element (xmlLocalName name) $
370 xmlAttrs (Seq.fromList $ (\(_wh,ElemAttr{..}) ->
371 cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
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 ----------------------
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 ----------------------
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
402 -- | Reserved elements' name
498 -- | Convenient alias, forcing the types
499 xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
500 xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
502 -- | Extract attributes
503 partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
504 partitionAttrs ts = (attrs,cs)
506 (as,cs) = (`Seq.partition` ts) $ \case
507 Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True
511 Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
512 Cell bp ep (xmlLocalName n, v)
514 v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
517 getAttrId :: Root -> TL.Text
518 getAttrId = Plain.document . Seq.singleton
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
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
540 -- | Unify two 'XMLs', merging border 'XmlText's if any.
541 unionXml :: XMLs -> XMLs -> XMLs
543 case (Seq.viewr x, Seq.viewl y) of
544 (xs :> x0, y0 :< ys) ->
546 ( Tree0 (Cell bx ex (XmlText tx))
547 , Tree0 (Cell by ey (XmlText ty)) ) ->
549 Seq.singleton (Tree0 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml`
555 unionsXml :: Foldable f => f XMLs -> XMLs
556 unionsXml = foldl' unionXml mempty