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: 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 sso to <> Cell ssn tn) (os<>ns)
 283                                 -- old
 284                                 --
 285                                 --  new
 286                                  False -> mergeRowIndent (collapseRoot old olds) (shifted:news)
 287                                         where
 288                                         shifted = Tree (Cell (Span fn bnNew en:|sn) $ 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 (Span _fn bn _en:|_sn) 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 (Span _fn bn _en:|_sn) n) _ns):news) ->
 333         case news of
 334          [] -> rows
 335          old@(Tree (Cell (Span _fo bo eo:|_so) 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 (Span _f0 b0 _e0:|_s0) 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 ssn@(Span _fn bn en:|_sn) n) _ns) rows =
 386         debug2_ "collapseRoot" ("new",Seq.singleton new) ("rows",rows) $
 387         case rows of
 388          [] -> return new
 389          old@(Tree (Cell (Span fo bo eo:|so) 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                          _ -> collapse
 404                 -- NOTE: amongst remaining nodes, only adjacent ones may enter an old NodePara.
 405                 --       Note that since a NodePara is never adjacent to another,
 406                 --       it is not nested within another.
 407                  (_, NodePara)
 408                   | isAdjacent ->
 409                         case n of
 410                         -- NOTE: no HeaderSection (even adjacent) within a NodePara
 411                          NodeHeader HeaderSection{} -> collapse2
 412                          _ -> collapse
 413                   | otherwise -> collapse2
 414                  _ -> collapse
 415                 where
 416                 isAdjacent = pos_line bn - pos_line eo <= 1
 417                 para       = Tree (Cell ssn NodePara) (return new) : rows
 418                 collapse   = Tree (Cell (Span fo bo en:|so) o) (os |> new) : olds
 419                 collapse2  = collapseRoot new $ collapseRoot old olds