Language/TCT/Tree.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE PatternSynonyms #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 module Language.TCT.Tree
   5  ( module Language.TCT.Tree
   6  , Tree(..), Trees
   7  ) where
   8
   9 import Control.Monad (Monad(..))
  10 import Data.Bool
  11 import Data.Char (Char)
  12 import Data.Eq (Eq(..))
  13 import Data.Foldable (Foldable(..), any)
  14 import Data.Function (($))
  15 import Data.Functor ((<$>))
  16 import Data.Int (Int)
  17 import Data.List.NonEmpty (NonEmpty(..))
  18 import Data.Monoid (Monoid(..))
  19 import Data.Ord (Ordering(..), Ord(..))
  20 import Data.Semigroup (Semigroup(..))
  21 import Data.Sequence ((|>))
  22 import Data.TreeSeq.Strict (Tree(..), Trees)
  23 import Prelude (undefined, Num(..))
  24 import System.FilePath (FilePath)
  25 import Text.Show (Show(..))
  26 import qualified Data.List as List
  27 import qualified Data.Sequence as Seq
  28 import qualified Data.Text.Lazy as TL
  29
  30 import Language.TCT.Utils
  31 import Language.TCT.Cell
  32 import Language.TCT.Elem
  33 import Language.TCT.Debug
  34
  35 -- * Type 'Root'
  36 -- | A single 'Tree' to rule all the 'Node's
  37 -- simplifies greatly the navigation and transformations,
  38 -- especially because the later XML or DTC output
  39 -- are themselves a single tree-like data structure.
  40 --
  41 -- Also, having a single 'Tree' is easier to merge
  42 -- XML coming from the first parsing phase (eg. @('NodeHeader' ('HeaderEqual' "li" ""))@),
  43 -- and XML coming from the second parsing phase (eg. @NodePair (PairElem "li" [])@).
  44 --
  45 -- For error reporting, each 'Node' is annotated with a 'Cell'
  46 -- spanning over all its content (sub-'Trees' included).
  47 type Root  = Tree  (Cell Node)
  48 type Roots = Trees (Cell Node)
  49
  50 pattern Tree0 :: a -> Tree a
  51 pattern Tree0 a <- Tree a (null -> True)
  52  where  Tree0 a = Tree a mempty
  53
  54 -- * Type 'Node'
  55 data Node
  56  =   NodeHeader !Header  -- ^ node, from first parsing (indentation-sensitive)
  57  |   NodeText   !TL.Text -- ^ leaf verbatim text, from first parsing (indentation-sensitive)
  58  |   NodePair   !Pair    -- ^ node, from second parsing (on some 'NodeText's)
  59  |   NodeToken  !Token   -- ^ leaf, from second parsing (on some 'NodeText's)
  60  |   NodeLower  !Name !ElemAttrs -- ^ node, @<name a=b@
  61  |   NodePara  -- ^ node, gather trees by paragraph,
  62                --   useful to know when to generate a <para> XML node
  63  deriving (Eq,Show)
  64 instance Pretty Node
  65
  66 -- * Type 'Header'
  67 data Header
  68  =   HeaderColon    !Name !White  -- ^ @name: @
  69  |   HeaderEqual    !Name !White  -- ^ @name=@
  70  |   HeaderBar      !Name !White  -- ^ @name|@
  71  |   HeaderGreat    !Name !White  -- ^ @name>@
  72  |   HeaderBrackets !Name         -- ^ @[name]@
  73  |   HeaderDot      !Name         -- ^ @1. @
  74  |   HeaderDash                   -- ^ @- @
  75  |   HeaderDashDash               -- ^ @-- @
  76  |   HeaderSection  !LevelSection -- ^ @# @
  77  |   HeaderDotSlash !FilePath     -- ^ @./file @
  78  deriving (Eq, Ord, Show)
  79 instance Pretty Header
  80
  81 -- ** Type 'Name'
  82 type Name = TL.Text
  83
  84 -- ** Type 'LevelSection'
  85 type LevelSection = Int
  86
  87 -- * Type 'Pair'
  88 data Pair
  89  =   PairElem !ElemName !ElemAttrs -- ^ @\<name a0=v0 a1=v1>text\</name>@
  90  |   PairHash        -- ^ @\#text#@
  91  |   PairStar        -- ^ @*text*@
  92  |   PairSlash       -- ^ @/text/@
  93  |   PairUnderscore  -- ^ @_value_@
  94  |   PairDash        -- ^ @-text-@
  95  |   PairBackquote   -- ^ @`text`@
  96  |   PairSinglequote -- ^ @'text'@
  97  |   PairDoublequote -- ^ @"text"@
  98  |   PairFrenchquote -- ^ @«text»@
  99  |   PairParen       -- ^ @(text)@
 100  |   PairBrace       -- ^ @{text}@
 101  |   PairBracket     -- ^ @[text]@
 102  deriving (Eq,Ord,Show)
 103 instance Pretty Pair
 104
 105 -- * Type 'Token'
 106 data Token
 107  =   TokenText   !TL.Text
 108  |   TokenEscape !Char
 109  |   TokenLink   !Link
 110  |   TokenTag    !Tag
 111  deriving (Eq,Show)
 112
 113 -- ** Type 'Tag'
 114 type Tag = TL.Text
 115
 116 -- ** Type 'Link'
 117 type Link = TL.Text
 118
 119 -- * Type 'Row'
 120 -- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line.
 121 type Row = [Root]
 122
 123 -- ** Type 'Rows'
 124 -- | In reverse order: a list of nodes in scope
 125 -- (hence to which the next line can append to).
 126 type Rows = [Root]
 127
 128 -- | Having an initial 'Root' simplifies 'mergeRowIndent':
 129 -- one can always put the last 'Root' as a child to a previous one.
 130 -- This 'Root' just has to be discarded by 'collapseRows'.
 131 initRows :: Rows
 132 initRows = [Tree0 $ Cell (Span "" p p :| []) $ NodeHeader HeaderDash]
 133         where p = Pos{pos_line= -1, pos_column=0}
 134          -- NOTE: such that any following 'Root'
 135          -- is 'NodePara' if possible, and always a child.
 136
 137 -- | @mergeRow rows row@ append @row@ into @rows@, while merging what has to be.
 138 --
 139 -- * [@rows@] is old 'Rows', its |Root|s' 'cell_begin' are descending (non-strictly),
 140 --            they MAY span over multilines, and they can be many from a single line.
 141 -- * [@row@]  is new 'Row',  its |Root|s' 'cell_begin' are descending (non-strictly),
 142 --            they MUST span only over a single and entire line.
 143 --
 144 -- This is the main entry point to build 'Rows' by accumulating 'Row' into them.
 145 mergeRow :: Rows -> Row -> Rows
 146 mergeRow rows row =
 147         debug2_ "mergeRow" ("news",List.reverse row) ("olds",rows) $
 148         mergeRowPrefix 0 rows $ List.reverse row
 149
 150 -- | Merge by considering matching prefixes.
 151 --
 152 -- 'HeaderGreat' and 'HeaderBar' work, not on indentation,
 153 -- but on their vertical alignment as prefixes.
 154 -- Hence, each new 'Row' has those prefixes zipped into a single one
 155 -- when they match, are aligned and adjacent.
 156 mergeRowPrefix :: ColNum -> Rows -> Row -> Rows
 157 mergeRowPrefix col rows row =
 158         debug3_ "mergeRowPrefix" ("col",col) ("news",row) ("olds",rows) $
 159         case (row,rows) of
 160          ([], _) -> rows
 161          (_, []) -> undefined -- NOTE: cannot happen with initRows
 162          ( _new@(Tree (Cell (Span _fn bn _en:|_sn) n) _ns):news
 163           , _old@(Tree (Cell (Span _fo _bo eo:|_so) _o) _os):_olds ) ->
 164                 case collapseRowsWhile isCollapsable rows of
 165                  [] -> mergeRowIndent rows row
 166                  head@(unTree -> ch@(Cell (Span _fh bh _eh:|_sh) h)) : olds' ->
 167                         case (n,h) of
 168                         -- NOTE: zipping: when new is HeaderGreat, collapse last line downto col
 169                         -- then check if there is a matching HeaderGreat,
 170                         -- if so, discard new and restart with a col advanced to new's beginning
 171                          (NodeHeader HeaderGreat{}, NodeHeader HeaderGreat{})
 172                           | isAdjacent && isMatching ch -> discard
 173                         -- NOTE: same for HeaderBar
 174                          (NodeHeader HeaderBar{}, NodeHeader HeaderBar{})
 175                           | isAdjacent && isMatching ch -> discard
 176                         -- NOTE: collapsing: any other new aligned or on the right of an adjacent head
 177                         -- makes it collapse entirely
 178                          (_, NodeHeader HeaderGreat{})
 179                           | col < pos_column bh -> collapse
 180                         -- NOTE: same for HeaderBar
 181                          (_, NodeHeader HeaderBar{})
 182                           | col < pos_column bh -> collapse
 183                          _ -> debug "mergeRowPrefix/indent" $ mergeRowIndent rows row
 184                         where
 185                         isAdjacent = pos_line bn - pos_line eo <= 1
 186                         discard  = debug "mergeRowPrefix/discard"  $ mergeRowPrefix (pos_column bh) rows news
 187                         collapse = debug "mergeRowPrefix/collapse" $ mergeRowPrefix col (collapseRoot head olds') row
 188                 where
 189                 isMatching (Cell (Span _fh bh _eh:|_sh) h) =
 190                         pos_column bn == pos_column bh &&
 191                         n == h
 192                 isCollapsable = debug2 "mergeRowPrefix/isCollapsable" "new" "old" $
 193                  \_t0@(unTree -> c0@(Cell (Span _f0 b0 _e0:|_s0) _n0))
 194                   _t1@(unTree -> Cell (Span _f1 b1 e1:|_s1) _n1) ->
 195                         not (isMatching c0) &&
 196                         (pos_line b0 - pos_line e1 <= 1) && -- adjacent
 197                         col < pos_column b1                 -- righter than col
 198
 199 -- | Merge by considering indentation.
 200 mergeRowIndent :: Rows -> Row -> Rows
 201 mergeRowIndent rows row =
 202         debug2_ "mergeRowIndent" ("news",row) ("olds",rows) $
 203         case (row,rows) of
 204          ([], _) -> rows
 205          (_, []) -> undefined -- NOTE: cannot happen with initRows
 206          ( new@(Tree (Cell ssn@(Span fn bn en:|sn) n) ns):news
 207           ,old@(Tree (Cell sso@(Span fo bo eo:|so) o) os):olds ) ->
 208                 case debug0 "mergeRowIndent/colNew" (pos_column bn) `compare`
 209                      debug0 "mergeRowIndent/colOld" (pos_column bo) of
 210                 -- NOTE: new is on the left
 211                  LT ->
 212                         case (n,o) of
 213                         -- NOTE: merge adjacent NodeText
 214                          --  first
 215                          -- second
 216                          (NodeText tn, NodeText to)
 217                           | TL.null tn || TL.null to
 218                           , not isVerbatim -> collapse
 219                           | isAdjacent && isIndented -> merge $ Tree t (os<>ns)
 220                                 where
 221                                         t      = NodeText <$> Cell (Span fo boNew eo:|so) (indent<>to) <> Cell ssn tn
 222                                         boNew  = bo{pos_column=pos_column bn}
 223                                         indent = TL.replicate (int64 $ pos_column bo - pos_column bn) " "
 224                                         -- | Whether the horizontal delta is made of spaces
 225                                         isIndented =
 226                                                 debug0 "mergeRowIndent/isIndented" $
 227                                                 case olds of
 228                                                  [] -> True
 229                                                  (unTree -> (cell_spans -> (span_end -> ep) :| _)) : _ ->
 230                                                         case pos_line ep `compare` pos_line bo of
 231                                                          LT -> True
 232                                                          EQ -> pos_column ep <= pos_column bn
 233                                                          _  -> False
 234                          _ -> collapse
 235                 -- NOTE: new is vertically aligned
 236                  EQ ->
 237                         case (n,o) of
 238                         -- NOTE: preserve all NodeText "", but still split into two NodePara
 239                          (NodeText tn, NodeText to)
 240                           | TL.null tn || TL.null to
 241                           , not isVerbatim -> collapse
 242                           | isAdjacent -> merge $ Tree (NodeText <$> Cell sso to <> Cell ssn tn) (os<>ns)
 243                         -- NOTE: HeaderSection can parent Nodes at the same level
 244                          (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
 245                                 if debug0 "mergeRowIndent/lvlNew" lvlNew
 246                                  > debug0 "mergeRowIndent/lvlOld" lvlOld
 247                                 -- # old
 248                                 -- ## new
 249                                 then concat
 250                                 -- ## old  or  # old
 251                                 -- # new       # new
 252                                 else collapse
 253                         -- NOTE: old is no HeaderSection, then collapse to any older and loop
 254                          (NodeHeader HeaderSection{}, _)
 255                           | rows'@(sec:_) <- collapseRowsWhile isCollapsable rows
 256                           , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec ->
 257                                  mergeRowIndent rows' row
 258                                 where
 259                                 isCollapsable = debug2 "mergeRowIndent/isCollapsable" "new" "old" $
 260                                  \_t0@(unTree -> Cell (Span _f0 b0 _e0:|_ss0) n0) _t1 ->
 261                                         case n0 of
 262                                          NodeHeader HeaderSection{} -> False
 263                                          _ -> pos_column bn == pos_column b0
 264                         -- NOTE: in case of alignment, HeaderSection is parent
 265                          (_, NodeHeader HeaderSection{}) -> concat
 266                         --
 267                          _ -> replace
 268                 -- NOTE: new is on the right
 269                  GT ->
 270                         case (n,o) of
 271                         -- NOTE: keep NodeText "" out of old NodePara
 272                          (NodeText "", NodePara) -> collapse
 273                         -- NOTE: merge adjacent NodeText
 274                          (NodeText tn, NodeText to) ->
 275                                 case isAdjacent of
 276                                  _ | TL.null tn || TL.null to
 277                                    , not isVerbatim -> collapse
 278                                 -- old
 279                                 --  new
 280                                  True -> merge $ Tree (NodeText <$> Cell sso to <> Cell ssn tn) (os<>ns)
 281                                 -- old
 282                                 --
 283                                 --  new
 284                                  False -> mergeRowIndent (collapseRoot old olds) (shifted:news)
 285                                         where
 286                                         shifted = Tree (Cell (Span fn bnNew en:|sn) $ NodeText $ indent<>tn) (os<>ns)
 287                                         bnNew   = bn{pos_column=pos_column bo}
 288                                         indent  = TL.replicate (int64 $ pos_column bn - pos_column bo) " "
 289                         --
 290                          _ -> concat
 291                 where
 292                 isAdjacent = pos_line bn - pos_line eo <= 1
 293                 -- | Whether a parent semantic want new to stay a NodeText
 294                 isVerbatim = any p rows
 295                         where
 296                         p (unTree -> (unCell -> NodeHeader HeaderBar{})) = True
 297                         p _ = False
 298                 concat   = debug "mergeRowIndent/concat"   $ List.reverse row <> rows
 299                 merge m  = debug "mergeRowIndent/merge"    $ mergeRowIndent (m : olds) news
 300                 collapse = debug "mergeRowIndent/collapse" $ mergeRowIndent (collapseRoot old olds) row
 301                 replace  = debug "mergeRowIndent/replace"  $ mergeRowIndent (new : collapseRoot old olds) news
 302
 303 -- | Like 'mergeRowIndent', but without maintaining the appending,
 304 -- hence collapsing all the 'Root's of the given 'Rows'.
 305 --
 306 -- NOTE: 'initRows' MUST have been the first 'Rows'
 307 -- before calling 'mergeRowIndent' on it to get the given 'Rows'.
 308 collapseRows :: Rows -> Roots
 309 collapseRows rows =
 310         debug1_ "collapseRows" ("rows",rows) $
 311         case collapseRowsWhile (\_new _old -> True) rows of
 312          [t] -> subTrees t
 313          _ -> undefined
 314         -- NOTE: subTrees returns the children of the updated initRows
 315
 316 -- | Collapse downto any last HeaderSection, returning it and its level.
 317 collapseSection :: ColNum -> Rows -> Rows
 318 collapseSection col = debug1 "collapseSection" "rows" go
 319         where
 320         go rows@(new@(unTree -> Cell (Span _fn bn _en:|_sn) n):olds)
 321          | col <= pos_column bn =
 322                 case n of
 323                  NodeHeader HeaderSection{} -> rows
 324                  _ -> collapseSection col $ collapseRoot new $ go olds
 325         go _ = mempty
 326
 327 collapseRowsWhile :: (Root -> Root -> Bool) -> Rows -> Rows
 328 collapseRowsWhile test = debug1 "collapseRowsWhile" "rows" $ \case
 329  [] -> mempty
 330  rows@(new@(Tree (Cell (Span _fn bn _en:|_sn) n) _ns):news) ->
 331         case news of
 332          [] -> rows
 333          old@(Tree (Cell (Span _fo bo eo:|_so) o) _os):olds
 334           | not $ test new old -> rows
 335           | otherwise ->
 336                 case debug0 "collapseRowsWhile/colNew" (pos_column bn) `compare`
 337                      debug0 "collapseRowsWhile/colOld" (pos_column bo) of
 338                 -- NOTE: new is vertically aligned
 339                  EQ ->
 340                         case (n,o) of
 341                         -- NOTE: HeaderSection can parent Nodes at the same level
 342                          (NodeHeader (HeaderSection lvlNew), NodeHeader (HeaderSection lvlOld)) ->
 343                                 if debug0 "collapseRowsWhile/lvlNew" lvlNew
 344                                  > debug0 "collapseRowsWhile/lvlOld" lvlOld
 345                                 -- # old
 346                                 -- ## new
 347                                 then collapse
 348                                 -- ## old  or  # old
 349                                 -- # new       # new
 350                                 else
 351                                         debug "collapseRowsWhile/replace" $
 352                                         collapseRowsWhile test $ (new:) $ collapseRoot old olds
 353                         -- NOTE: old is no HeaderSection, then collapse to any older and loop
 354                          (NodeHeader HeaderSection{}, _)
 355                           | news'@(sec:_) <- debug0 "collapseRowsWhile/section" $ collapseRowsWhile isCollapsable news
 356                           , (unTree -> (unCell -> NodeHeader HeaderSection{})) <- sec ->
 357                                 collapseRowsWhile test news'
 358                                 where
 359                                 isCollapsable = debug2 "collapseRowsWhile/isCollapsable" "new" "old" $
 360                                  \_t0@(unTree -> Cell (Span _f0 b0 _e0:|_s0) n0) _t1 ->
 361                                         case n0 of
 362                                          NodeHeader HeaderSection{} -> False
 363                                          _ -> pos_column bn == pos_column b0
 364                         -- NOTE: in case of alignment, HeaderSection is parent
 365                          (_, NodeHeader HeaderSection{}) -> debug "collapseRowsWhile/section/parent" collapse
 366                         -- NOTE: merge within old NodePara.
 367                          (_, NodePara) | isAdjacent -> collapse
 368                         --
 369                          _ -> collapse2
 370                 -- NOTE: new is either on the left or on the right
 371                  _ -> collapse
 372                 where
 373                 isAdjacent = pos_line bn - pos_line eo <= 1
 374                 collapse   = debug "collapseRowsWhile/collapse"  $ collapseRowsWhile test $ collapseRoot new $ news
 375                 collapse2  = debug "collapseRowsWhile/collapse2" $ collapseRowsWhile test $ collapseRoot new $ collapseRoot old $ olds
 376
 377 -- | Put a 'Root' as a child of the head 'Root'.
 378 --
 379 -- NOTE: 'collapseRoot' is where 'NodePara' may be introduced.
 380 --
 381 -- NOTE: any NodeText/NodeText merging must have been done before.
 382 collapseRoot :: Root -> Rows -> Rows
 383 collapseRoot new@(Tree (Cell ssn@(Span _fn bn en:|_sn) n) _ns) rows =
 384         debug2_ "collapseRoot" ("new",Seq.singleton new) ("rows",rows) $
 385         case rows of
 386          [] -> return new
 387          old@(Tree (Cell (Span fo bo eo:|so) o) os) : olds ->
 388                 case (n,o) of
 389                 -- NOTE: no child into NodeText
 390                  (_, NodeText{}) -> collapse2
 391                 -- NOTE: NodeText can begin a NodePara
 392                  (NodeText tn, _) | not $ TL.null tn ->
 393                         case o of
 394                         -- NOTE: no NodePara within those
 395                          NodeHeader HeaderEqual{} -> collapse
 396                          NodeHeader HeaderBar{} -> collapse
 397                          NodeHeader HeaderDashDash{} -> collapse
 398                         -- NOTE: NodePara within those
 399                          NodePara | not isAdjacent -> para
 400                          NodeHeader{} -> para
 401                          _ -> collapse
 402                 -- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara.
 403                 --       Note that since a NodePara is never adjacent to another,
 404                 --       it is not nested within another.
 405                  (_, NodePara)
 406                   | isAdjacent ->
 407                         case n of
 408                         -- NOTE: no HeaderSection (even adjacent) within a NodePara
 409                          NodeHeader HeaderSection{} -> collapse2
 410                          _ -> collapse
 411                   | otherwise -> collapse2
 412                  _ -> collapse
 413                 where
 414                 isAdjacent = pos_line bn - pos_line eo <= 1
 415                 para       = Tree (Cell ssn NodePara) (return new) : rows
 416                 collapse   = Tree (Cell (Span fo bo en:|so) o) (os |> new) : olds
 417                 collapse2  = collapseRoot new $ collapseRoot old olds