Language/TCT/Tree.hs

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