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(..))
  14 import Data.Function (($))
  15 import Data.Int (Int)
  16 import Data.Maybe (Maybe(..))
  17 import Data.Monoid (Monoid(..))
  18 import Data.Ord (Ordering(..), Ord(..))
  19 import Data.Semigroup (Semigroup(..))
  20 import Data.Sequence ((|>), (<|), ViewR(..))
  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.Cell
  30 import Language.TCT.Elem
  31 import Language.TCT.Debug
  32
  33 -- * Type 'Root'
  34 -- | A single 'Tree' to rule all the 'Node's simplifies the navigation.
  35 -- For error reporting, each 'Node' is annotated with a 'Cell'
  36 -- spanning over all its content (sub-'Trees' included).
  37 type Root  = Tree  (Cell Node)
  38 type Roots = Trees (Cell Node)
  39
  40 pattern Tree0 :: a -> Tree a
  41 pattern Tree0 a <- Tree a (null -> True)
  42  where  Tree0 a = Tree a mempty
  43
  44 -- * Type 'Node'
  45 data Node
  46  =   NodeHeader !Header  -- ^ node, from first parsing (indentation-sensitive)
  47  |   NodeText   !TL.Text -- ^ leaf verbatim text, from first parsing (indentation-sensitive)
  48  |   NodePair   !Pair    -- ^ node, from second parsing (on some 'NodeText's)
  49  |   NodeToken  !Token   -- ^ leaf, from second parsing (on some 'NodeText's)
  50  |   NodeLower  !Name !ElemAttrs -- ^ node, @<name a=b@
  51  |   NodePara  -- ^ node, gather trees by paragraph,
  52                --   useful to know when to generate a <para> XML node
  53  |   NodeGroup -- ^ node, group trees into a single tree,
  54                --   useful to return many trees when only one is expected
  55  deriving (Eq,Show)
  56
  57 -- * Type 'Header'
  58 data Header
  59  =   HeaderColon !Name !White     -- ^ @name: @
  60  |   HeaderEqual !Name !White     -- ^ @name=@
  61  |   HeaderBar   !Name !White     -- ^ @name|@
  62  |   HeaderGreat !Name !White     -- ^ @name>@
  63  |   HeaderDot   !Name            -- ^ @1. @
  64  |   HeaderDash                   -- ^ @- @
  65  |   HeaderDashDash               -- ^ @-- @
  66  |   HeaderSection  !LevelSection -- ^ @# @
  67  |   HeaderBrackets !Name         -- ^ @[name]@
  68  |   HeaderDotSlash !FilePath     -- ^ @./file @
  69  deriving (Eq, Ord, Show)
  70
  71 -- ** Type 'Name'
  72 type Name = TL.Text
  73
  74 -- ** Type 'LevelSection'
  75 type LevelSection = Int
  76
  77 -- * Type 'Pair'
  78 data Pair
  79  =   PairElem !ElemName !ElemAttrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
  80  |   PairHash        -- ^ @#value#@
  81  |   PairStar        -- ^ @*value*@
  82  |   PairSlash       -- ^ @/value/@
  83  |   PairUnderscore  -- ^ @_value_@
  84  |   PairDash        -- ^ @-value-@
  85  |   PairBackquote   -- ^ @`value`@
  86  |   PairSinglequote -- ^ @'value'@
  87  |   PairDoublequote -- ^ @"value"@
  88  |   PairFrenchquote -- ^ @«value»@
  89  |   PairParen       -- ^ @(value)@
  90  |   PairBrace       -- ^ @{value}@
  91  |   PairBracket     -- ^ @[value]@
  92  deriving (Eq,Ord,Show)
  93 instance Pretty Pair
  94
  95 -- * Type 'Token'
  96 data Token
  97  =   TokenText   !TL.Text
  98  |   TokenEscape !Char
  99  |   TokenLink   !Link
 100  |   TokenTag    !Tag
 101  deriving (Eq,Show)
 102
 103 -- ** Type 'Tag'
 104 type Tag = TL.Text
 105
 106 -- ** Type 'Link'
 107 type Link = TL.Text
 108
 109 -- * Type 'Row'
 110 -- | In normal order: a list of 'Header's, maybe ended by 'Value', all read on the same line.
 111 type Row = [Root]
 112
 113 -- ** Type 'Rows'
 114 -- | In reverse order: a list of nodes in scope
 115 -- (hence to which the next line can append to).
 116 type Rows = [Root]
 117
 118 -- | @appendRow rows row@ appends @row@ to @rows@.
 119 --
 120 -- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending)
 121 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
 122 appendRow :: Rows -> Row -> Rows
 123 appendRow [] row = List.reverse row
 124 appendRow rows [] = rows
 125 appendRow rows@(old@(Tree (Cell bo eo o) os):olds)
 126            row@(new@(Tree (Cell bn en n) ns):news) =
 127         debug2_ "appendRow" ("row",row) ("rows",rows) $
 128         case debug0 "colOld" (pos_column bo) `compare`
 129              debug0 "colNew" (pos_column bn) of
 130          LT -> mergeNodeText lt
 131          EQ ->
 132                 mergeNodeText $
 133                 case (o,n) of
 134                  (_, NodeHeader (HeaderSection secNew))
 135                   | Just (secOld, s0:ss) <- collapseSection (pos_column bn) rows ->
 136                         case debug0 "secOld" secOld `compare`
 137                              debug0 "secNew" secNew of
 138                          LT -> appendRow (new:s0:ss) news
 139                          EQ -> appendRow (new:appendChild ss s0) news
 140                          GT -> gt
 141                  (NodeHeader HeaderSection{}, _) -> lt
 142                  (_, NodeText tn) | TL.null tn -> gt
 143                  (NodePara, _) | not newPara -> lt
 144                  _ | newPara -> gt
 145                  _ -> eq
 146          GT -> gt
 147         where
 148         newPara = pos_line bn - pos_line eo > 1
 149         lt = debug "appendRow/lt" $ List.reverse row <> rows
 150         eq = debug "appendRow/eq" $ appendRow (new : appendChild olds old) news
 151         gt = debug "appendRow/gt" $ appendRow (      appendChild olds old) row
 152
 153         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 154         collapseSection :: ColNum -> Rows -> Maybe (LevelSection,Rows)
 155         collapseSection col xxs@(x:xs) | pos_column (cell_begin (unTree x)) == col =
 156                 case x of
 157                  Tree (unCell -> NodeHeader (HeaderSection lvl)) _ -> Just (lvl, xxs)
 158                  _ -> do
 159                         (lvl, cs) <- collapseSection col xs
 160                         return (lvl, appendChild cs x)
 161         collapseSection _ _ = Nothing
 162
 163         mergeNodeText :: Rows -> Rows
 164         mergeNodeText rs
 165          | newPara = rs
 166          | otherwise =
 167                 case (o,n) of
 168                  (NodeText to, NodeText tn)
 169                         | null os
 170                         , not (TL.null to)
 171                         , not (TL.null tn) ->
 172                         -- debug "appendRow" "action" ("mergeNodeText"::TL.Text) $
 173                         debug0 "mergeNodeText" $
 174                         appendRow (merged : olds) news
 175                         where
 176                         merged = Tree (Cell bo en $ NodeText $ to<>tp<>tn) ns
 177                         tp = fromPad Pos
 178                                  { pos_line   = pos_line   bn - pos_line   eo
 179                                  , pos_column = pos_column bn - pos_column bo
 180                                  }
 181                  _ -> rs
 182
 183 appendChild :: Rows -> Root -> Rows
 184 appendChild rows new@(Tree (Cell bn en n) ns) =
 185         debug2_ "appendChild" ("new",Seq.singleton new) ("rows",rows) $
 186         case rows of
 187          [] -> [new]
 188          old@(Tree (Cell bo eo o) os) : olds ->
 189                 (: olds) $
 190                 if newPara
 191                 then
 192                         case (o,n) of
 193                          (NodePara,NodePara) -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
 194                          (NodePara,_)        -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,Tree (Cell bn en NodePara) $ return new]
 195                          (_,NodePara)        -> Tree (Cell bo en o) $ os|>new
 196                          (NodeText{},_)      -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
 197                          _                   -> Tree (Cell bo en o) $ os|> newTree
 198                 else
 199                         case (o,n) of
 200                          (NodePara,NodePara) -> Tree (Cell bo en NodePara) $ os<>ns
 201                          (NodePara,_)        -> Tree (Cell bo en NodePara) $ os|>new
 202                          (_,NodePara)        -> Tree (Cell bo en NodePara) $ old<|ns
 203                          (NodeText{},_)      -> Tree (Cell bo en NodeGroup) $ Seq.fromList [old,new]
 204                          _ ->
 205                                 case Seq.viewr os of
 206                                  EmptyR -> Tree (Cell bo en o) $ return newTree
 207                                  ls :> Tree (Cell br _er r) rs ->
 208                                         case r of
 209                                          NodePara
 210                                           | pos_column br == pos_column bn
 211                                                       -> Tree (Cell bo en o) $ ls |> Tree (Cell br en NodePara) (rs |> new)
 212                                           | otherwise -> Tree (Cell bo en o) $ os |> newTree
 213                                          _ ->  Tree (Cell bo en o) $ os |> new
 214                 where
 215                 newPara = pos_line bn - pos_line eo > 1
 216                 newTree =
 217                         case n of
 218                          NodeHeader{} -> new
 219                          NodeLower{}  -> new
 220                          _            -> Tree (Cell bn en NodePara) (return new)
 221
 222 collapseRows :: Rows -> Root
 223 collapseRows =
 224         debug1 "collapseRows" "rs" $ \case
 225          [] -> undefined
 226          [child] -> child
 227          child:parents -> collapseRows $ appendChild parents child