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 qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Language.TCT.Write.Plain as Plain
-import qualified System.FilePath as FP
-- import Language.TCT.Debug
import Language.TCT.Utils
-- (eg. about/title may have a title from the section before,
-- hence outside of about).
-- Still holding: @'cell_begin' < 'cell_end'@ and 'Cell' nesting.
-document :: Roots -> XMLs
-document doc =
+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 bt et _) :< _ ->
+ (unTree -> Cell st _) :< _ ->
xmlify def
{ inh_titles = titles
, inh_figure = True
where
contentWithAbout =
case Seq.findIndexL isAbout content of
- Nothing -> Tree (Cell bt et $ NodeHeader $ HeaderColon "about" "") mempty <| content
+ Nothing -> Tree (Cell st $ NodeHeader $ HeaderColon "about" "") mempty <| content
Just{} -> content
isAbout = \case
(unTree -> (unCell -> NodeHeader (HeaderColon "about" _wh))) -> True
partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) =
case Seq.viewl body of
EmptyL -> mempty
- title@(unTree -> Cell _bt et NodePara) :< rest ->
+ 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 bs es (NodeHeader (HeaderSection lvlSub))) :< rs
+ sub@(unTree -> Cell (Span{..}:|_) (NodeHeader (HeaderSection lvlSub))) :< rs
| lvlSub <= lvlPar
- , pos_line bs - pos_line ep <= 1 ->
- let (subs, ts') = spanlSubtitles es rs in
+ , pos_line span_begin - pos_line ep <= 1 ->
+ let (subs, ts') = spanlSubtitles span_end rs in
(sub <| subs, ts')
_ -> (mempty, ts)
_ -> (mempty, body)
elementName inh (Tree c ts) = Tree (XmlElem "name" <$ c) $ xmlify inh ts
attributeName :: Inh -> Root -> XML
-attributeName _inh (Tree c ts) = tree0 (XmlAttr "name" (Plain.document ts) <$ c)
+attributeName _inh (Tree c ts) = tree0 (XmlAttr "name" (Plain.writePlain ts) <$ c)
-- * Class 'Xmlify'
class Xmlify a where
xmlify inh roots =
case Seq.viewl roots of
EmptyL -> mempty
- r@(Tree cr@(Cell _br _er nr) ts) :< rs ->
+ r@(Tree cr@(Cell _sr nr) ts) :< rs ->
case nr of
----------------------
-- NOTE: HeaderColon becomes parent
----------------------
-- NOTE: detect [some text](http://some.url) or [SomeRef]
NodePair PairParen
- | Tree (Cell bb eb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
+ | Tree (Cell sb (NodePair PairBracket)) bracket :< rs' <- Seq.viewl rs ->
(<| xmlify inh rs') $
case bracket of
- (toList -> [unTree -> Cell bl el (NodeToken (TokenLink lnk))]) ->
+ (toList -> [unTree -> Cell sl (NodeToken (TokenLink lnk))]) ->
element "eref" $
- xmlAttrs [Cell bl el ("to",lnk)] <>
+ xmlAttrs [Cell sl ("to",lnk)] <>
xmlify inh ts
_ ->
element "rref" $
- xmlAttrs [Cell bb eb ("to",Plain.document bracket)] <>
+ xmlAttrs [Cell sb ("to",Plain.writePlain bracket)] <>
xmlify inh ts
----------------------
-- NOTE: gather HeaderDash
----------------------
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 r `unionXml`
xmlify inh rs
where
element :: XmlName -> XMLs -> XML
element n = Tree (XmlElem n <$ cr)
instance Xmlify Root where
- xmlify inh tn@(Tree (Cell bn en nod) ts) =
+ xmlify inh tn@(Tree (Cell ss@(sn:|ssn) nod) ts) =
case nod of
- NodeGroup -> xmlify inh ts
----------------------
NodePara ->
case inh_para inh of
[] -> xmlify inh ts
- para:_ -> Seq.singleton $ para inh tn -- para (() <$ cn) $ xmlify inh ts
+ para:_ -> Seq.singleton $ para inh tn
----------------------
NodeHeader hdr ->
case hdr of
element "about" $
xmlify inh' (inh_titles inh) <>
xmlAttrs attrs <>
- xmlify inh' body
+ 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 bn bn ("type", n)) <>
+ 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
_ -> []
}
--
- HeaderBar n _wh ->
- Seq.singleton $
- element "artwork" $
- xmlAttrs (Seq.singleton $ Cell bn bn ("type", n)) <>
- xmlify inh{inh_para=[]} ts
+ 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 bn bn ("type", n)) <>
+ xmlAttrs (attrs `defaultAttr` Cell (sn{span_end=span_end sn}:|ssn) ("type", n)) <>
xmlify inh{inh_para=List.repeat elementPara} body
--
HeaderEqual n _wh ->
HeaderDot n ->
Seq.singleton $
element "li" $
- xmlAttrs (Seq.singleton $ Cell bn bn{pos_column=pos_column bn + int (TL.length n)} ("name", n)) <>
+ 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
+ HeaderDash -> Seq.singleton $ element "li" $ xmlify inh ts
--
- HeaderDashDash -> Seq.singleton $ Tree0 $ cell $ XmlComment $
- -- debug1_ ("TS", ts) $
- -- debug1_ ("RS", (S.evalState (Plain.rackUpLeft ts) Nothing)) $
- Plain.document ts
- -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
- {-
- TreeSeq.mapAlsoNode
- (cell1 . unCell)
- (\_k -> fmap $
- TreeSeq.mapAlsoNode
- (cell1 . unCell)
- (\_k' -> cell1 . unCell)) <$> 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 en en ("id",ident)) attrs) <>
+ 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 p ->
- Seq.singleton $
- element "include" $
- xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
- xmlify inh ts
+ HeaderDotSlash _file -> xmlify inh ts
----------------------
NodePair pair ->
case pair of
- PairBracket | to <- Plain.document ts
+ PairBracket | to <- Plain.writePlain ts
, TL.all (\c -> Char.isAlphaNum c || Char.isSymbol c) to ->
Seq.singleton $
element "rref" $
PairFrenchquote ->
Seq.singleton $
element "q" $
- xmlify inh ts
- {-
- case ts of
- (Seq.viewl -> Tree0 (Cell bl el (TokenPlain l)) :< ls) ->
- case Seq.viewr ls of
- m :> Tree0 (Cell br er (TokenPlain r)) ->
+ 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 $
- Tree0 (Cell bl el (TokenPlain (Text.dropWhile Char.isSpace l)))
- <|(m|>Tree0 (Cell br er (TokenPlain (Text.dropWhileEnd Char.isSpace r))))
- _ ->
- xmlify inh $
- Tree0 (Cell bl el (TokenPlain (Text.dropAround Char.isSpace l))) <| ls
- (Seq.viewr -> rs :> Tree0 (Cell br er (TokenPlain r))) ->
- xmlify inh $
- rs |> Tree0 (Cell br er (TokenPlain (Text.dropAround Char.isSpace r)))
- _ -> xmlify inh ts
- -}
+ rs Seq.|> Tree0 (Cell sr (NodeToken (TokenText (TL.dropAround Char.isSpace r))))
+ _ -> xmlify inh ts
PairHash ->
Seq.singleton $
element "ref" $
- xmlAttrs [cell ("to",Plain.document ts)]
+ xmlAttrs [cell ("to",Plain.writePlain ts)]
PairElem name attrs ->
Seq.singleton $
element (xmlLocalName name) $
cell (xmlLocalName elemAttr_name,elemAttr_value)) <$> attrs) <>
xmlify inh ts
_ ->
- Seq.singleton (Tree0 $ Cell bn bn' $ XmlText open) `unionXml`
+ Seq.singleton (Tree0 $ Cell (sn{span_end=bn'}:|ssn) $ XmlText open) `unionXml`
xmlify inh ts `unionXml`
- Seq.singleton (Tree0 $ Cell en' en $ XmlText close)
+ Seq.singleton (Tree0 $ Cell (sn{span_begin=en'}:|ssn) $ XmlText close)
where
(open, close) = pairBorders pair ts
- bn' = bn{pos_column=pos_column bn + int (TL.length open)}
- en' = en{pos_column=pos_column bn - int (TL.length close)}
+ 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
----------------------
xmlify inh ts
where
cell :: a -> Cell a
- cell = Cell bn en
+ cell = Cell ss
element :: XmlName -> XMLs -> XML
element n = Tree (cell $ XmlElem n)
instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
, "authors"
, "bcp14"
, "br"
+ , "break"
, "call"
, "city"
, "code"
_ -> False
attrs = attr <$> as
attr = \case
- Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
- Cell bp ep (xmlLocalName n, v)
+ 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.document . Seq.singleton
+getAttrId = Plain.writePlain . Seq.singleton
setAttr ::
Cell (XmlName, TL.Text) ->
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)) ) ->
+ ( 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 bx ex tx <> Cell by ey ty) `unionXml`
+ Seq.singleton (Tree0 $ (XmlText <$>) $ Cell ssx tx <> Cell ssy ty) `unionXml`
ys
_ -> x <> y
(Seq.EmptyR, _) -> y
sourcephile / git / doclang.git / blobdiff