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