-- This is the main entry point to build 'Rows' by accumulating 'Row' into them.
mergeRow :: Rows -> Row -> Rows
mergeRow rows row =
- debug2_ "mergeRow" ("news",row) ("olds",rows) $
+ debug2_ "mergeRow" ("news",List.reverse row) ("olds",rows) $
mergeRowPrefix 0 rows $ List.reverse row
-- | Merge by considering matching prefixes.
, _old@(Tree (Cell _bo eo _o) _os):_olds ) ->
case collapseRowsWhile isCollapsable rows of
[] -> mergeRowIndent rows row
- head@(unTree -> Cell bh _eh h) : olds' ->
+ head@(unTree -> ch@(Cell bh _eh h)) : olds' ->
case (n,h) of
-- NOTE: zipping: when new is HeaderGreat, collapse last line downto col
-- then check if there is a matching HeaderGreat,
-- if so, discard new and restart with a col advanced to new's beginning
- (NodeHeader hn@HeaderGreat{}, NodeHeader hh@HeaderGreat{})
+ (NodeHeader HeaderGreat{}, NodeHeader HeaderGreat{})
+ | isAdjacent && isMatching ch -> discard
+ {-
| pos_column bn == pos_column bh
, isAdjacent
- , hn == hh -> discard
+ , hn == hh
+ -}
-- NOTE: same for HeaderBar
- (NodeHeader hn@HeaderBar{}, NodeHeader hh@HeaderBar{})
- | pos_column bn == pos_column bh
- , isAdjacent
- , hn == hh -> discard
+ (NodeHeader HeaderBar{}, NodeHeader HeaderBar{})
+ | isAdjacent && isMatching ch -> discard
-- NOTE: collapsing: any other new aligned or on the right of an adjacent head
-- makes it collapse entirely
(_, NodeHeader HeaderGreat{})
isAdjacent = pos_line bn - pos_line eo <= 1
discard = debug "mergeRowPrefix/discard" $ mergeRowPrefix (pos_column bh) rows news
collapse = debug "mergeRowPrefix/collapse" $ mergeRowPrefix col (collapseRoot head olds') row
- where
- isCollapsable = -- debug2 "mergeRowPrefix/isCollapsable" "new" "old" $
- \_new@(unTree -> Cell bn _en _n) _old@(unTree -> Cell bo eo _o) ->
- (pos_line bn - pos_line eo <= 1) && -- adjacent
- col < pos_column bo -- righter than col
+ where
+ isMatching (Cell bh _eh h) =
+ pos_column bn == pos_column bh &&
+ n == h
+ isCollapsable = debug2 "mergeRowPrefix/isCollapsable" "new" "old" $
+ \_t0@(unTree -> c0@(Cell b0 _e0 _n0)) _t1@(unTree -> Cell b1 e1 _n1) ->
+ not (isMatching c0) &&
+ (pos_line b0 - pos_line e1 <= 1) && -- adjacent
+ col < pos_column b1 -- righter than col
-- | Merge by considering indentation.
mergeRowIndent :: Rows -> Row -> Rows
, not isVerbatim -> collapse
| isAdjacent -> merge $ Tree (NodeText <$> Cell bo eo to <> Cell bn en tn) (os<>ns)
-- NOTE: HeaderSection can parent Nodes at the same level
- (NodeHeader (HeaderSection lvlNew), _)
- | rows'@(sec:olds') <- collapseRowsWhile isCollapsable rows
- , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec ->
+ (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
if debug0 "mergeRowIndent/lvlNew" lvlNew
> debug0 "mergeRowIndent/lvlOld" lvlOld
- then -- # sec
- -- ## new
- {-concat using sec-} List.reverse row <> rows'
- else -- ## sec or # sec
- -- # new # new
- {-collapse using sec-} mergeRowIndent (collapseRoot sec olds') row
+ -- # old
+ -- ## new
+ then concat
+ -- ## old or # old
+ -- # new # new
+ else collapse
+ -- NOTE: old is no HeaderSection, then collapse to any older and loop
+ (NodeHeader HeaderSection{}, _)
+ -- | rows'@(sec:olds') <- collapseSection (pos_column bn) rows
+ | rows'@(sec:_) <- collapseRowsWhile isCollapsable rows
+ , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec ->
+ mergeRowIndent rows' row
where
- isCollapsable = -- debug2 "mergeRowIndent/isCollapsable" "new" "old" $
- \_new _old@(unTree -> Cell bt _et t) ->
- case t of
+ isCollapsable = debug2 "mergeRowIndent/isCollapsable" "new" "old" $
+ \_t0@(unTree -> Cell b0 _e0 n0) _t1 ->
+ case n0 of
NodeHeader HeaderSection{} -> False
- _ -> pos_column bt == pos_column bn
+ _ -> pos_column bn == pos_column b0
-- NOTE: in case of alignment, HeaderSection is parent
(_, NodeHeader HeaderSection{}) -> concat
--
-- before calling 'mergeRowIndent' on it to get the given 'Rows'.
collapseRows :: Rows -> Roots
collapseRows rows =
+ debug1_ "collapseRows" ("rows",rows) $
case collapseRowsWhile (\_new _old -> True) rows of
[t] -> subTrees t
_ -> undefined
-- NOTE: subTrees returns the children of the updated initRows
+-- | Collapse downto any last HeaderSection, returning it and its level.
+collapseSection :: ColNum -> Rows -> Rows
+collapseSection col = debug1 "collapseSection" "rows" go
+ where
+ go rows@(new@(unTree -> Cell bn _en n):olds)
+ | col <= pos_column bn =
+ case n of
+ NodeHeader HeaderSection{} -> rows
+ _ -> collapseSection col $ collapseRoot new $ go olds
+ go _ = mempty
+
collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows
collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case
[] -> mempty
old@(Tree (Cell bo eo o) _os):olds
| not $ test new old -> rows
| otherwise ->
- case debug0 "colNew" (pos_column bn) `compare`
- debug0 "colOld" (pos_column bo) of
+ case debug0 "collapseRowsWhile/colNew" (pos_column bn) `compare`
+ debug0 "collapseRowsWhile/colOld" (pos_column bo) of
-- NOTE: new is vertically aligned
EQ ->
case (n,o) of
-- NOTE: HeaderSection can parent Nodes at the same level
- (NodeHeader (HeaderSection lvlNew), _)
- | sec:olds' <- collapseRowsWhile isCollapsable news
- , (unTree -> unCell -> NodeHeader (HeaderSection lvlOld)) <- sec ->
+ (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
if debug0 "collapseRowsWhile/lvlNew" lvlNew
> debug0 "collapseRowsWhile/lvlOld" lvlOld
- then -- # sec
- -- ## new
- collapseRowsWhile test $ collapseRoot new $ sec:olds'
- else -- ## sec or # sec
- -- # new # new
- collapseRowsWhile test $ new:collapseRoot sec olds'
+ -- # old
+ -- ## new
+ then collapse
+ -- ## old or # old
+ -- # new # new
+ else
+ debug "collapseRowsWhile/replace" $
+ collapseRowsWhile test $ (new:) $ collapseRoot old olds
+ -- NOTE: old is no HeaderSection, then collapse to any older and loop
+ (NodeHeader HeaderSection{}, _)
+ | news'@(sec:_) <- debug0 "collapseRowsWhile/section" $ collapseRowsWhile isCollapsable news
+ , (unTree -> unCell -> NodeHeader HeaderSection{}) <- sec ->
+ collapseRowsWhile test news'
where
- isCollapsable =
- \_new _old@(unTree -> Cell bt _et t) ->
- case t of
+ isCollapsable = debug2 "collapseRowsWhile/isCollapsable" "new" "old" $
+ \_t0@(unTree -> Cell b0 _e0 n0) _t1 ->
+ case n0 of
NodeHeader HeaderSection{} -> False
- _ -> pos_column bt == pos_column bn
+ _ -> pos_column bn == pos_column b0
-- NOTE: in case of alignment, HeaderSection is parent
- (_, NodeHeader HeaderSection{}) -> collapse
+ (_, NodeHeader HeaderSection{}) -> debug "collapseRowsWhile/section/parent" collapse
-- NOTE: merge within old NodePara.
- (_, NodePara{}) | isAdjacent -> collapse
+ (_, NodePara) | isAdjacent -> collapse
--
_ -> collapse2
-- NOTE: new is either on the left or on the right
_ -> collapse
where
isAdjacent = pos_line bn - pos_line eo <= 1
- collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new news
- collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old olds
+ collapse = debug "collapseRowsWhile/collapse" $ collapseRowsWhile test $ collapseRoot new $ news
+ collapse2 = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old $ olds
-- | Put a 'Root' as a child of the head 'Root'.
--
[] -> return new
old@(Tree (Cell bo eo o) os) : olds ->
case (n,o) of
- -- NOTE: never put a child into NodeText
+ -- NOTE: no child into NodeText
(_, NodeText{}) -> collapse2
-- NOTE: NodeText can begin a NodePara
(NodeText tn, _) | not $ TL.null tn ->
_ -> collapse
-- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara.
-- Note that since a NodePara is never adjacent to another,
- -- it is not nested within into another.
- -- Note that an adjacent HeaderSection can enter a NodePara.
- (_, NodePara) | isAdjacent -> collapse
- | otherwise -> collapse2
+ -- it is not nested within another.
+ (_, NodePara)
+ | isAdjacent ->
+ case n of
+ -- NOTE: no HeaderSection (even adjacent) within a NodePara
+ NodeHeader HeaderSection{} -> collapse2
+ _ -> collapse
+ | otherwise -> collapse2
_ -> collapse
where
isAdjacent = pos_line bn - pos_line eo <= 1
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..))
import Data.Function (($), (.))
-import Data.Functor ((<$>), (<$))
+import Data.Functor ((<$>), (<$), ($>))
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.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 Text.Blaze.XML ()
import Language.TCT hiding (Parser)
--- import Language.TCT.Debug
+import Language.TCT.Debug
import Language.XML
-- | Main entry point
xmlDocument doc =
-- (`S.evalState` def) $
case Seq.viewl doc of
- Tree (unCell -> NodeHeader HeaderSection{}) body :< foot ->
- case Seq.viewl body of
- title@(unTree -> Cell bt et NodePara{}) :< content ->
+ sec@(Tree (unCell -> NodeHeader HeaderSection{}) _body) :< foot ->
+ let (titles, content) = partitionSection sec in
+ case Seq.viewl titles of
+ (unTree -> Cell bt et _) :< _ ->
xmlify def
- { inh_titles = return title
+ { inh_titles = titles
, inh_figure = True
} contentWithAbout <>
xmlify def foot
_ -> xmlify def doc
_ -> xmlify def doc
+partitionSection :: Root -> (Roots, Roots)
+partitionSection (Tree (unCell -> NodeHeader (HeaderSection lvlPar)) body) =
+ case Seq.viewl body of
+ EmptyL -> mempty
+ title@(unTree -> Cell _bt 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
+ | lvlSub <= lvlPar
+ , pos_line bs - pos_line ep <= 1 ->
+ let (subs, ts') = spanlSubtitles es rs in
+ (sub <| subs, ts')
+ _ -> (mempty, ts)
+
{-
-- * Type 'Xmls'
type Xmls = S.State State XMLs
go inh{inh_para} ts
-}
instance Xmlify Root where
- xmlify inh (Tree cel@(Cell bp ep nod) ts) =
+ xmlify inh tr@(Tree cel@(Cell bp ep nod) ts) =
case nod of
NodeGroup -> xmlify inh ts
----------------------
case hdr of
--
HeaderSection{} ->
- let (attrs,body) = partitionAttrs ts in
Seq.singleton $
- element "section" $
- xmlAttrs (attrs `defaultAttr` Cell ep ep ("id",getAttrId body)) <>
- xmlify inh' body
+ element "section" $ head <> xmlify inh' body
where
+ (titles, content) = partitionSection tr
+ (attrs, body) = partitionAttrs content
+ head =
+ case Seq.viewl titles of
+ EmptyL -> mempty
+ title@(unTree -> ct) :< subtitles ->
+ xmlAttrs (attrs `defaultAttr` (ct $> ("id",getAttrId title))) <>
+ aliases
+ where
+ aliases =
+ subtitles >>= \subtitle@(unTree -> cs) ->
+ return $
+ Tree (cs $> XmlElem "alias") $
+ xmlAttrs (return $ cs $> ("id",getAttrId subtitle))
inh' = inh
{ inh_para = xmlTitle : List.repeat xmlPara
, inh_figure = True
_ | inh_figure inh && not (n`List.elem`elems) ->
Seq.singleton $
element "figure" $
- xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <>
+ -- xmlAttrs (setAttr (Cell ep ep ("type",n)) attrs) <>
+ xmlAttrs (attrs `defaultAttr` Cell bp bp ("type", n)) <>
case toList body of
[Tree0{}] -> xmlify inh'{inh_para = List.repeat xmlPara} body
_ -> xmlify inh'{inh_para = xmlTitle : List.repeat xmlPara} body
v = Plain.text (Plain.setStart a def{Plain.state_escape = False}) a
_ -> undefined
-getAttrId :: Roots -> TL.Text
-getAttrId ts =
- case Seq.viewl ts of
- EmptyL -> ""
- t :< _ -> Plain.plainDocument $ Seq.singleton t
+getAttrId :: Root -> TL.Text
+getAttrId = Plain.plainDocument . Seq.singleton
setAttr ::
Cell (XmlName, TL.Text) ->
sourcephile / git / doclang.git / commitdiff