{-# 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"
, "authors"
, "bcp14"
, "br"
+ , "break"
, "call"
, "city"
, "code"
, "q"
, "ref"
, "reference"
+ , "references"
, "region"
- , "rl"
, "rref"
, "sc"
, "section"
, "tof"
, "tr"
, "tt"
+ , "u"
, "ul"
, "uri"
, "version"
, "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