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 Control.Monad (Monad(..))
  10 import Data.Eq (Eq(..))
  11 import Data.Function (($))
  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 farthest (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                  _ -> do
 106                         (lvl, cs) <- collapseSection col xs
 107                         return (lvl, insertChild x cs)
 108         collapseSection _ _ = Nothing
 109
 110 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
 111 appendCellText (Cell posPar posEndPar p)
 112                (Cell posRow posEndRow r) =
 113         trac ("appendCellText: p="<>show p) $
 114         trac ("appendCellText: r="<>show r) $
 115         dbg "appendCellText" $
 116         case linePos posRow - linePos posEndPar of
 117          0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 118                 where pad = padding (columnPos posEndPar) (columnPos posRow)
 119          1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 120                 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
 121          _ -> Nothing
 122         where
 123         padding x y = Text.replicate (y - x) " "
 124
 125 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 126 insertChild child ps@[] =
 127         trac ("insertChild: child="<>show child) $
 128         trac ("insertChild: ps="<>show ps) $
 129         dbg "insertChild" $
 130         [child]
 131 insertChild _child (Tree0{}:_) = undefined
 132 insertChild child ps@(TreeN parent treesParent:parents) =
 133         trac ("insertChild: child="<>show child) $
 134         trac ("insertChild: ps="<>show ps) $
 135         dbg "insertChild" $
 136         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 137          LT -> TreeN parent (treesParent |> child) : parents
 138          EQ -> TreeN parent (treesParent |> child) : parents
 139          GT -> undefined
 140
 141 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 142 collapseRows []              = undefined
 143 collapseRows [child]         = dbg "collapseRows" $ child
 144 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents