{-# 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 (Foldable(..))
-import Data.Function (($), (.), id)
-import Data.Functor ((<$>), (<$))
-import Data.Maybe (Maybe(..), maybe, fromMaybe)
+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.Set (Set)
-import Data.TreeSeq.Strict (Tree(..))
+import Data.TreeSeq.Strict (Tree(..), tree0)
import Data.Tuple (uncurry)
-import Prelude (undefined)
+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.Lazy as TL
import qualified Language.TCT.Write.Plain as Plain
-import qualified System.FilePath as FP
-import Text.Blaze.XML ()
+-- import Language.TCT.Debug
+import Language.TCT.Utils
import Language.TCT hiding (Parser)
-import Language.TCT.Debug
import Language.XML
+import Text.Blaze.XML ()
-xmlDocument :: Roots -> XMLs
-xmlDocument trees =
+-- | 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 trees of
- Tree (unCell -> NodeHeader HeaderSection{}) vs :< ts ->
- case spanlNodeToken vs of
- (titles@(Seq.viewl -> (unTree -> cell_begin -> bp) :< _), vs') ->
- let vs'' =
- case Seq.findIndexL
- (\case
- Tree (unCell -> NodeHeader (HeaderColon "about" _)) _ -> True
- _ -> False) vs' of
- Nothing -> Tree (Cell bp bp $ NodeHeader $ HeaderColon "about" "") mempty <| vs'
- Just{} -> vs' in
+ 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
- , inh_para = List.repeat xmlPara
- } vs'' <>
- xmlify def ts
- _ -> xmlify def trees
- _ -> xmlify def trees
-
-{-
--- * Type 'Xmls'
-type Xmls = S.State State XMLs
-type Xml = S.State State XML
-instance Semigroup Xmls where
- (<>) = liftA2 (<>)
-instance Monoid Xmls where
- mempty = return mempty
- mappend = (<>)
+ } 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 'State'
-data State
- = State
- { state_pos :: Pos
- }
-instance Default State where
- def = State
- { state_pos = pos1
- }
--}
+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 'Inh'
data Inh
= Inh
{ inh_figure :: Bool
- , inh_para :: [Cell () -> XMLs -> XML]
+ , inh_para :: [Inh -> Root -> XML]
, inh_titles :: Roots
}
instance Default Inh where
def = Inh
{ inh_figure = False
- , inh_para = []
+ , inh_para = List.repeat elementPara
, inh_titles = mempty
}
-{-
-newtype Merge a = Merge a
- deriving (Functor)
-instance Semigroup (Merge Roots) where
- (<>) = unionTokens
-instance Monad (Merge Roots) where
- return = Merge
- Merge m >>= f =
- foldMap nn
--}
+-- ** 'inh_para'
+elementPara :: Inh -> Root -> XML
+elementPara inh (Tree c ts) = Tree (XmlElem "para" <$ c) $ xmlify inh ts
+
+elementTitle :: Inh -> Root -> XML
+elementTitle inh (Tree c ts) = Tree (XmlElem "title" <$ c) $ xmlify inh ts
+
+elementName :: Inh -> Root -> XML
+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.writePlain ts) <$ c)
-- * Class 'Xmlify'
class Xmlify a where
xmlify inh roots =
case Seq.viewl roots of
EmptyL -> mempty
- l@(Tree cel@(Cell bp _ep nod) ts) :< rs ->
- case nod of
- NodeHeader (HeaderBar n _wh)
- | (span, rest) <- spanlHeaderBar n roots ->
- let (attrs,body) = partitionAttrs span in
- (<| xmlify inh rest) $
- element "artwork" $
- xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <>
- xmlify inh{inh_para=[]} body
- ----------------------
- NodeHeader (HeaderGreat n _wh)
- | (span, rest) <- spanlHeaderGreat n roots ->
- let (attrs,body) = partitionAttrs span in
- (<| xmlify inh rest) $
- element "artwork" $
- xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", fromMaybe "text/plain" $ mimetype n)) <>
- xmlify inh{inh_para=[]} (debug0 "body" body)
+ 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 n rs
+ | (span, rest) <- spanlHeaderColon rs
, not $ null span ->
- xmlify inh $ Tree cel (ts<>span) <| rest
+ 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" $
- xmlify inh span
+ 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 <$ cel) <> (y <$ cy)) (ts <> ys) <| 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 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.plainDocument bracket)] <>
+ 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 xmlPara}
+ span >>= xmlify inh{inh_para=List.repeat elementPara}
----------------------
- _ | (span,rest) <- spanlItems (\case HeaderDot{} -> True; _ -> False) roots
+ -- 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 xmlPara}
+ 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 <|
+ xmlify inh{inh_para} rs
+ ----------------------
+ -- NOTE: context-free Root
_ ->
- xmlify inh l <>
+ xmlify inh r `unionXml`
xmlify inh rs
where
element :: XmlName -> XMLs -> XML
- element n = tree (XmlElem n <$ cel)
- {-
- t@(Tree (NodePair (PairElem))) :< ts ->
- case inh_para inh of
- [] -> xmlify inh t <> go inh ts
- _ | isTokenElem toks -> xmlify inh t <> go inh ts
- tree0:inh_para ->
- (case Seq.viewl toks of
- EmptyL -> id
- (unTree -> cell_begin -> bp) :< _ -> (tree0 bp (xmlify inh t) <|)) $
- go inh{inh_para} ts
- -}
+ element n = Tree (XmlElem n <$ cr)
instance Xmlify Root where
- xmlify inh (Tree cel@(Cell bp ep 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:inh_para ->
- Seq.singleton $
- para (() <$ cel) $
- xmlify inh{inh_para} ts
+ para:_ -> Seq.singleton $ para inh tn
----------------------
NodeHeader hdr ->
case hdr of
+ --
HeaderSection{} ->
- let (attrs,body) = partitionAttrs ts in
- let inh' = inh
- { inh_para = xmlTitle : List.repeat xmlPara
- , inh_figure = True
- } in
Seq.singleton $
- element "section" $
- xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <>
- xmlify inh' body
- HeaderColon kn _wh ->
+ 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
- let inh' = inh { inh_para =
- case kn of
- "about" -> xmlTitle : xmlTitle : List.repeat xmlPara
- "reference" -> xmlTitle : xmlTitle : List.repeat xmlPara
- "serie" -> List.repeat xmlName
- "author" -> List.repeat xmlName
- "editor" -> List.repeat xmlName
- "org" -> List.repeat xmlName
- _ -> []
- } in
- case () of
- _ | kn == "about" -> xmlAbout inh' cel {-attrs-} body
- _ | inh_figure inh && not (kn`List.elem`elems) ->
+ 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 ep ep ("type",kn)) attrs) <>
+ -- 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 xmlPara} body
- _ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body
+ [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 kn) $
+ element (xmlLocalName n) $
xmlAttrs attrs <>
- xmlify inh' ts
- HeaderGreat n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
- HeaderEqual n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
- HeaderBar n _wh -> Seq.singleton $ element (xmlLocalName n) $ xmlify inh ts
- HeaderDot _n -> 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.plainDocument ts
- -- Plain.text def $ S.evalState (Plain.rackUpLeft ts) Nothing
- {-
- TreeSeq.mapAlsoNode
- (cell1 . unCell)
- (\_k -> fmap $
- TreeSeq.mapAlsoNode
- (cell1 . unCell)
- (\_k' -> cell1 . unCell)) <$> ts
- -}
- HeaderBrackets ident ->
- let inh' = inh{inh_figure = False} in
+ 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 $
- element "reference" $
- xmlAttrs (setAttr (Cell ep ep ("id",ident)) attrs) <>
- xmlify inh'{inh_para = xmlTitle : xmlTitle : List.repeat xmlPara} body
- HeaderDotSlash p ->
+ Tree0 $ cell $ XmlAttr (xmlLocalName n) $
+ Plain.text (Plain.setStart ts def{Plain.state_escape = False}) ts
+ --
+ HeaderDot n ->
Seq.singleton $
- element "include" $
- xmlAttrs [cell ("href",TL.pack $ FP.replaceExtension p "dtc")] <>
+ 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.plainDocument 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.plainDocument 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
_ ->
- let (open, close) = pairBorders pair ts in
- Seq.singleton (Tree0 $ Cell bp bp $ XmlText open) `unionXml`
+ Seq.singleton (Tree0 $ Cell (sn{span_end=bn'}:|ssn) $ XmlText open) `unionXml`
xmlify inh ts `unionXml`
- Seq.singleton (Tree0 $ Cell ep ep $ XmlText close)
+ 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
----------------------
xmlify inh ts
where
cell :: a -> Cell a
- cell = Cell bp ep
+ cell = Cell ss
element :: XmlName -> XMLs -> XML
- element n = tree (cell $ XmlElem n)
-
--- | TODO: add more mimetypes
-mimetype :: TL.Text -> Maybe TL.Text
-mimetype "txt" = Just "text/plain"
-mimetype "plain" = Just "text/plain"
-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
-
-xmlPara :: Cell a -> XMLs -> XML
-xmlPara c = tree (XmlElem "para" <$ c)
-
-xmlTitle :: Cell a -> XMLs -> XML
-xmlTitle c = tree (XmlElem "title" <$ c)
-
-xmlName :: Cell a -> XMLs -> XML
--- xmlName bp (toList -> [unTree -> unCell -> XmlText t]) = Tree0 $ Cell bp bp $ XmlAttr "name" t
-xmlName c = tree (XmlElem "name" <$ c)
+ element n = Tree (cell $ XmlElem n)
+instance Xmlify (Seq (Cell (XmlName,TL.Text))) where
+ xmlify _inh = xmlAttrs
-xmlAbout ::
- Inh ->
- Cell Node ->
- -- Seq (Cell (XmlName, Text)) ->
- Roots -> XMLs
-xmlAbout inh nod body =
- xmlify inh $ Tree nod $
- case Seq.viewl (inh_titles inh) of
- (unTree -> cell_begin -> bt) :< _ ->
- ((<$> inh_titles inh) $ \title ->
- Tree (Cell bt bt $ NodeHeader $ HeaderColon "title" "") $
- Seq.singleton $ title)
- <> body
- _ -> body
-
-xmlAttrs :: Seq (Cell (XmlName,TL.Text)) -> XMLs
-xmlAttrs = (Tree0 . (uncurry XmlAttr <$>) <$>)
-
--- | 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 $ (XmlText <$>) $ Cell bx ex tx <> Cell by ey ty) `unionXml`
- ys
- _ -> x <> y
- (Seq.EmptyR, _) -> y
- (_, Seq.EmptyL) -> x
-
-unionsXml :: Foldable f => f XMLs -> XMLs
-unionsXml = foldl' unionXml mempty
-
-partitionAttrs :: Roots -> (Seq (Cell (XmlName, TL.Text)), Roots)
-partitionAttrs ts = (attrs,cs)
- where
- (as,cs) = (`Seq.partition` ts) $ \case
- Tree (unCell -> NodeHeader (HeaderEqual (TL.null -> False) _wh)) _cs -> True
- _ -> False
- attrs = attr <$> as
- attr = \case
- Tree (Cell bp ep (NodeHeader (HeaderEqual n _wh))) a ->
- Cell bp ep (xmlLocalName n, v)
- where
- v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
- _ -> undefined
-
-spanlHeaderBar :: Name -> Roots -> (Roots, Roots)
-spanlHeaderBar name = first unHeaderBar . debug0 "spanBar" . spanBar
- -- FIXME: use unTree
- where
- unHeaderBar :: Roots -> Roots
- unHeaderBar = (=<<) $ \case
- Tree (unCell -> NodeHeader HeaderBar{}) ts -> ts
- ts -> return ts
- spanBar =
- Seq.spanl $ \case
- Tree (unCell -> NodeHeader (HeaderBar n _)) _ | n == name -> True
- Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True
- _ -> False
-
-spanlHeaderGreat :: Name -> Roots -> (Roots, Roots)
-spanlHeaderGreat name = first unHeaderGreat . debug0 "spanGreat" . spanGreat
- -- FIXME: use unTree
- where
- unHeaderGreat :: Roots -> Roots
- unHeaderGreat = (=<<) $ \case
- Tree (unCell -> NodeHeader HeaderGreat{}) ts -> ts
- ts -> return ts
- spanGreat =
- Seq.spanl $ \case
- Tree (unCell -> NodeHeader (HeaderGreat n _)) _ | n == name -> True
- _ -> False
-
-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
-
-spanlHeaderColon :: Name -> Roots -> (Roots, Roots)
-spanlHeaderColon name =
- Seq.spanl $ \case
- Tree (unCell -> NodeHeader (HeaderBar n _)) _ -> n == name
- Tree (unCell -> NodeHeader (HeaderGreat n _)) _ -> n == name
- _ -> False
-
-spanlBrackets :: Roots -> (Roots, Roots)
-spanlBrackets =
- Seq.spanl $ \case
- Tree (unCell -> NodeHeader HeaderBrackets{}) _ -> True
- _ -> False
-
-spanlNodeToken :: Roots -> (Roots, Roots)
-spanlNodeToken =
- Seq.spanl (\case
- Tree (unCell -> NodeToken{}) _ -> True
- _ -> False)
-
-getAttrId :: Roots -> TL.Text
-getAttrId ts =
- case Seq.viewl ts of
- EmptyL -> ""
- t :< _ -> Plain.plainDocument $ Seq.singleton t
-
-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
+-- * Elements
+-- | Reserved elements' name
elems :: Set TL.Text
elems =
[ "about"
, "authors"
, "bcp14"
, "br"
+ , "break"
, "call"
, "city"
, "code"
, "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
sourcephile / git / doclang.git / blobdiff