Language/TCT/Tree.hs

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