Language/TCT/Tree.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Language.TCT.Tree
   3  ( module Language.TCT.Tree
   4  , Tree(..)
   5  , Trees
   6  ) where
   7
   8 import Data.Eq (Eq(..))
   9 import Data.Function (($))
  10 import Data.Functor ((<$>))
  11 import Data.Maybe (Maybe(..))
  12 import Data.Ord (Ordering(..), Ord(..))
  13 import Data.Semigroup (Semigroup(..))
  14 import Data.Sequence ((|>))
  15 import Data.Text (Text)
  16 import Data.TreeSeq.Strict (Tree(..), Trees)
  17 import Prelude (undefined, Int, Num(..))
  18 import Text.Show (Show(..))
  19 import qualified Data.List as List
  20 import qualified Data.Text as Text
  21 import qualified System.FilePath as FP
  22
  23 import Language.TCT.Cell
  24 import Language.TCT.Elem
  25
  26 -- * Type 'Row'
  27 -- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
  28 type Row = [Tree (Cell Key) (Cell Text)]
  29
  30 -- * Type 'Key'
  31 data Key = KeyColon !Name !White     -- ^ @name: @
  32          | KeyEqual !Name !White     -- ^ @name=@
  33          | KeyBar   !Name !White     -- ^ @name|@
  34          | KeyGreat !Name !White     -- ^ @name>@
  35          | KeyLower !Name !Attrs     -- ^ @<name a=b@
  36          | KeyDot   !Name            -- ^ @1. @
  37          | KeyDash                   -- ^ @- @
  38          | KeyDashDash               -- ^ @-- @
  39          | KeySection  !LevelSection -- ^ @# @
  40          | KeyBrackets !Name         -- ^ @[ name ]@
  41          | KeyDotSlash !PathFile     -- ^ @./file @
  42          deriving (Eq, Ord, Show)
  43
  44 -- ** Type 'Name'
  45 type Name = Text
  46
  47 -- ** Type 'PathFile'
  48 type PathFile = FP.FilePath
  49
  50 -- ** Type 'LevelSection'
  51 type LevelSection = Int
  52
  53 -- * Type 'Rows'
  54 type Rows = [Tree (Cell Key) (Cell Text)]
  55
  56 -- | @appendRow rows row@ appends @row@ to @rows@.
  57 --
  58 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
  59 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
  60 appendRow :: Rows -> Row -> Rows
  61 appendRow [] row = List.reverse row
  62 appendRow parents [] = parents
  63 appendRow rows@(parent:parents) row@(cell:cells) =
  64         trac ("appendRow: rows=" <> show rows) $
  65         trac ("appendRow: row=" <> show row) $
  66         dbg "appendRow" $
  67         let colParent = columnPos $ posTree parent in
  68         let colRow    = columnPos $ posTree cell in
  69         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
  70          LT ->
  71                 case (dbg "parent" parent,dbg "cell" cell) of
  72                  (Tree0{}, TreeN{}) -> eq
  73                  (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
  74                  (Tree0 p, Tree0 r) -> appendTree0 p r
  75                  _ -> lt
  76          EQ ->
  77                 case (dbg "parent" parent,dbg "cell" cell) of
  78                  (Tree0 p, Tree0 r) -> appendTree0 p r
  79                  (_, TreeN (unCell -> KeySection sectionRow) _)
  80                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
  81                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
  82                          LT -> appendRow (cell:secPar:secPars) cells
  83                          EQ -> appendRow (cell:insertChild secPar secPars) cells
  84                          GT -> gt
  85                  (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
  86                  (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
  87                  (Tree0{}, TreeN{}) -> eq
  88                  (TreeN{}, TreeN{}) -> eq
  89                  (TreeN{}, Tree0{}) -> eq
  90          GT -> gt
  91         where
  92         appendTree0 p r =
  93                 case appendCellText p r of
  94                  Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
  95                  Just c  -> appendRow (Tree0 c : parents) cells
  96         lt = appendRow [] row <> rows
  97         eq = appendRow (cell : insertChild parent parents) cells
  98         gt = appendRow (insertChild parent parents) row
  99         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 100         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 101         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 102                 case x of
 103                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
 104                  _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
 105         collapseSection _ _ = Nothing
 106
 107 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
 108 appendCellText (Cell posPar posEndPar p)
 109                (Cell posRow posEndRow r) =
 110         trac ("appendCellText: p="<>show p) $
 111         trac ("appendCellText: r="<>show r) $
 112         dbg "appendCellText" $
 113         case linePos posRow - linePos posEndPar of
 114          0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 115                 where pad = padding (columnPos posEndPar) (columnPos posRow)
 116          1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 117                 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
 118          _ -> Nothing
 119         where
 120         padding x y = Text.replicate (y - x) " "
 121
 122 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 123 insertChild child ps@[] =
 124         trac ("insertChild: child="<>show child) $
 125         trac ("insertChild: ps="<>show ps) $
 126         dbg "insertChild" $
 127         [child]
 128 insertChild _child (Tree0{}:_) = undefined
 129 insertChild child ps@(TreeN parent treesParent:parents) =
 130         trac ("insertChild: child="<>show child) $
 131         trac ("insertChild: ps="<>show ps) $
 132         dbg "insertChild" $
 133         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 134          LT -> TreeN parent (treesParent |> child) : parents
 135          EQ -> TreeN parent (treesParent |> child) : parents
 136          GT -> undefined
 137
 138 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 139 collapseRows []              = undefined
 140 collapseRows [child]         = dbg "collapseRows" $ child
 141 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents