Language/TCT/Tree.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE OverloadedLists #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 module Language.TCT.Tree
   5  ( module Language.TCT.Tree
   6  , Tree(..)
   7  , Trees
   8  ) where
   9
  10 import Control.Monad (Monad(..))
  11 import Data.Eq (Eq(..))
  12 import Data.Function (($))
  13 import Data.Maybe (Maybe(..))
  14 import Data.Ord (Ordering(..), Ord(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.Sequence ((|>))
  17 import Data.Text (Text)
  18 import Data.TreeSeq.Strict (Tree(..), Trees)
  19 import Prelude (undefined, Int, Num(..))
  20 import Text.Show (Show(..))
  21 import qualified Data.List as List
  22 import qualified Data.Text as Text
  23 import qualified System.FilePath as FP
  24 import qualified Data.Sequence as Seq
  25
  26 import Language.TCT.Cell
  27 import Language.TCT.Elem
  28 import Language.TCT.Read.Token
  29 -- import Language.TCT.Token
  30
  31
  32 -- | @appendRow rows row@ appends @row@ to @rows@.
  33 --
  34 -- [@rows@] parent 'Rows', from closest to farthest (non-strictly descending)
  35 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
  36 appendRow :: Rows -> Row -> Rows
  37 appendRow [] row = List.reverse row
  38 appendRow parents [] = parents
  39 appendRow rows@(parent:parents) row@(cell:cells) =
  40         trac ("appendRow: rows=" <> show rows) $
  41         trac ("appendRow: row=" <> show row) $
  42         dbg "appendRow" $
  43         let colParent = columnPos $ posTree parent in
  44         let colRow    = columnPos $ posTree cell in
  45         case dbg "colParent" colParent `compare`
  46              dbg "colRow"    colRow of
  47          LT ->
  48                 case (dbg "parent" parent,dbg "cell" cell) of
  49                  (Tree0{}, TreeN{}) -> eq
  50                  -- (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
  51                  -- (TreeN (unCell -> KeyPara) p, Tree0 r) -> appendTree0 p r
  52                  -- (Tree0 p, Tree0 r) -> appendTree0 p r
  53                  _ | Just x <- appendPara -> x
  54                  _ -> lt
  55          EQ ->
  56                 case (dbg "parent" parent,dbg "cell" cell) of
  57                  _ | Just x <- appendPara -> x
  58                  (_, TreeN (unCell -> KeySection sectionRow) _)
  59                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
  60                         case dbg "sectionParent" sectionParent `compare`
  61                              dbg "sectionRow"    sectionRow of
  62                          LT -> appendRow (cell:secPar:secPars) cells
  63                          EQ -> appendRow (cell:insertChild secPar secPars) cells
  64                          GT -> gt
  65                  (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
  66                  (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
  67                  (Tree0{}, TreeN{}) -> eq
  68                  (TreeN{}, TreeN{}) -> eq
  69                  (TreeN{}, Tree0{}) -> eq
  70          GT -> gt
  71         where
  72         appendPara :: Maybe Rows
  73         appendPara =
  74                 case (parent, cell) of
  75                  ( TreeN (Cell posPar posEndPar KeyPara) pars
  76                   , Tree0 (Cell posRow posEndRow _c) ) ->
  77                         Just $
  78                         if linePos posRow - linePos posEndPar <= 1
  79                         then appendRow (merged : parents) cells
  80                         else appendRow (cell : insertChild parent parents) cells
  81                         where merged = TreeN (Cell posPar posEndRow KeyPara) $ pars |> cell
  82                  ( Tree0 (Cell posPar posEndPar _p)
  83                   , Tree0 (Cell posRow posEndRow _c) ) ->
  84                         Just $
  85                         if linePos posRow - linePos posEndPar <= 1
  86                         then appendRow (merged : parents) cells
  87                         else appendRow (cell : insertChild parent parents) cells
  88                         where merged = TreeN (Cell posPar posEndRow KeyPara) [parent, cell]
  89                  _ -> Nothing
  90
  91         {-
  92         appendTree0 p r =
  93                 case appendCellValue p r of
  94                  Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
  95                  Just t  -> appendRow (t : parents) cells
  96         -}
  97         lt = appendRow [] row <> rows
  98         eq = appendRow (cell : insertChild parent parents) cells
  99         gt = appendRow (insertChild parent parents) row
 100         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 101         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 102         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 103                 case x of
 104                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl, xxs)
 105                  _ -> do
 106                         (lvl, cs) <- collapseSection col xs
 107                         return (lvl, insertChild x cs)
 108         collapseSection _ _ = Nothing
 109
 110 {-
 111 appendCellValue :: Cell Value -> Cell Value -> Tree (Cell Key) (Cell Value)
 112 appendCellValue par@(Cell posPar posEndPar p) row@(Cell posRow posEndRow r) =
 113         trac ("appendCellValue: p="<>show p) $
 114         trac ("appendCellValue: r="<>show r) $
 115         dbg "appendCellValue" $
 116         case linePos posRow - linePos posEndPar of
 117          0 ->
 118                 TreeN (Cell posPar posEndRow KeyPara)
 119                  [ Tree0 par
 120                  , Tree0 row
 121                  ]
 122          1 ->
 123                 TreeN (Cell posPar posEndRow KeyPara)
 124                  [ Tree0 par
 125                  , Tree0 row
 126                  ]
 127          _ -> []
 128         where
 129         padding x y = Text.replicate (y - x) " "
 130         {-
 131         where
 132         pad =
 133                 -- return $ LexemeWhite $ Cell posEndPar posRow $
 134                 -- padding (columnPos posEndPar) (columnPos posRow)
 135         -}
 136         {-
 137         -- return $ Cell posPar posEndRow $ p <> pad <> r
 138         -- return $ Cell posPar posEndRow $ p <> pad <> r
 139         where
 140         pad =
 141                 -- return $ LexemeWhite $ Cell posEndPar posRow $
 142                 -- "\n" <>
 143                 padding (columnPos posPar) (columnPos posRow)
 144         -}
 145 -}
 146
 147 insertChild :: Tree (Cell Key) (Cell Value) -> Rows -> Rows
 148 insertChild child ps@[] =
 149         trac ("insertChild: child="<>show child) $
 150         trac ("insertChild: ps="<>show ps) $
 151         dbg "insertChild" $
 152         [child]
 153 insertChild c@(Tree0 (Cell _bp ep _))
 154             (p@(Tree0 (Cell bp _ep _)):parents) =
 155         TreeN (Cell bp ep KeyPara) [p, c] : parents
 156 insertChild (TreeN (Cell _bp ep _) cs)
 157             (p@(Tree0 (Cell bp _ep _)):parents) =
 158         TreeN (Cell bp ep KeyPara) (p Seq.<| cs) : parents
 159         {-
 160         undefined
 161         -- FIXME: this case may be removed.
 162         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 163          LT -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents
 164          EQ -> TreeN KeyMix (Seq.fromList [Tree0 v, child] treesParent |> child) : parents
 165          GT -> undefined
 166         -}
 167 insertChild child ps@(TreeN parent treesParent:parents) =
 168         trac ("insertChild: child="<>show child) $
 169         trac ("insertChild: ps="<>show ps) $
 170         dbg "insertChild" $
 171         -- FIXME: this case may be removed.
 172         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 173          LT -> TreeN parent (treesParent |> child) : parents
 174          EQ -> TreeN parent (treesParent |> child) : parents
 175          GT -> undefined
 176
 177 collapseRows :: Rows -> Tree (Cell Key) (Cell Value)
 178 collapseRows []              = undefined
 179 collapseRows [child]         = dbg "collapseRows" $ child
 180 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents
 181
 182
 183