Language/TCT/Tree.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Language.TCT.Tree where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Data.Bool
   7 import Data.Eq (Eq(..))
   8 import Data.Foldable (Foldable(..))
   9 import Data.Foldable (foldr)
  10 import Data.Function (($), (.))
  11 import Data.Functor (Functor, (<$>))
  12 import Data.Maybe (Maybe(..))
  13 import Data.Ord (Ordering(..), Ord(..))
  14 import Data.Semigroup (Semigroup(..))
  15 import Data.Sequence (Seq, ViewL(..), (|>))
  16 import Data.Text (Text)
  17 import Data.Traversable (Traversable(..))
  18 import Data.Tuple (fst,snd)
  19 import Prelude (undefined, Int, Num(..))
  20 import Text.Show (Show(..))
  21 import qualified Data.List as List
  22 import qualified Data.Sequence as Seq
  23 import qualified Data.Text as Text
  24
  25 import Language.TCT.Elem
  26
  27 -- * Type 'Tree'
  28 data Tree k a
  29  =   TreeN k (Trees k a)
  30  |   Tree0 a
  31  deriving (Eq, Show, Functor)
  32
  33 instance Traversable (Tree k) where
  34         traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
  35         traverse f (Tree0 a)    = Tree0 <$> f a
  36 instance Foldable (Tree k) where
  37         foldMap f (TreeN _k ts) = foldMap (foldMap f) ts
  38         foldMap f (Tree0 k)     = f k
  39
  40 mapTreeWithKey :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
  41 mapTreeWithKey = go Nothing
  42         where
  43         go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
  44         go k f (Tree0 a) = Tree0 (f k a)
  45
  46 traverseTreeWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
  47 traverseTreeWithKey = go Nothing
  48         where
  49         go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
  50         go p  f (Tree0 a)    = Tree0 <$> f p a
  51
  52 -- ** Type 'Trees'
  53 type Trees k a = Seq (Tree k a)
  54
  55 newtype PrettyTree k a = PrettyTree (Trees k a)
  56 instance (Show k, Show a) => Show (PrettyTree k a) where
  57         show (PrettyTree t) = Text.unpack $ prettyTrees t
  58
  59 prettyTree :: (Show k, Show a) => Tree k a -> Text
  60 prettyTree = Text.unlines . pretty
  61
  62 prettyTrees :: (Show k, Show a) => Trees k a -> Text
  63 prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
  64
  65 pretty :: (Show k, Show a) => Tree k a -> [Text]
  66 pretty (Tree0 a) = [Text.pack (show a)]
  67 pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
  68         where
  69         prettySubTrees s =
  70                 case Seq.viewl s of
  71                  Seq.EmptyL -> []
  72                  t:<ts | Seq.null ts -> "|" : shift "`- " "   " (pretty t)
  73                        | otherwise   -> "|" : shift "+- " "|  " (pretty t) <> prettySubTrees ts
  74         shift first other = List.zipWith (<>) (first : List.repeat other)
  75
  76 -- * Type 'Pos'
  77 type Pos = (Line,Column)
  78
  79 posTree :: Tree (Cell k) (Cell a) -> Pos
  80 posTree (TreeN c _) = posCell c
  81 posTree (Tree0 c)   = posCell c
  82
  83 posEndTree :: Tree (Cell k) (Cell a) -> Pos
  84 posEndTree (TreeN c _) = posEndCell c
  85 posEndTree (Tree0 c)   = posEndCell c
  86
  87
  88 -- ** Type 'Line'
  89 -- | Line in the source file, counting from 1.
  90 type Line = Int
  91 linePos :: Pos -> Line
  92 linePos = fst
  93
  94 -- ** Type 'Column'
  95 -- | Column in the source file, counting from 1.
  96 type Column = Int
  97 columnPos :: Pos -> Column
  98 columnPos  = snd
  99
 100 -- * Type 'Row'
 101 -- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
 102 type Row = [Tree (Cell Key) (Cell Text)]
 103
 104 -- ** Type 'Cell'
 105 -- | NOTE: every 'Cell' as a 'Pos',
 106 --         which is useful to indicate matches/errors/warnings/whatever,
 107 --         or outputing in a format somehow preserving
 108 --         the original input style.
 109 data Cell a = Cell Pos Pos a
 110               deriving (Eq, Show)
 111
 112 unCell :: Cell a -> a
 113 unCell (Cell _ _ a) = a
 114
 115 posCell :: Cell a -> Pos
 116 posCell (Cell pos _ _) = pos
 117
 118 posEndCell :: Cell a -> Pos
 119 posEndCell (Cell _ pos _) = pos
 120
 121 lineCell :: Cell a -> Line
 122 lineCell = fst . posCell
 123 columnCell :: Cell a -> Column
 124 columnCell = snd . posCell
 125
 126 -- * Type 'Key'
 127 data Key = KeyColon Name White     -- ^ @name:@ begin 'Cell'
 128          | KeyEqual Name White     -- ^ @name=@ begin 'Value'
 129          | KeyBar   Name White     -- ^ @name|@ continue 'Value'
 130          | KeyGreat Name White     -- ^ @name>@ continue 'Cell'
 131          | KeyLower Name Attrs     -- ^ @<name a=b@ begin HereDoc
 132          | KeyDash                 -- ^ @- @    begin item
 133          | KeySection LevelSection -- ^ @### @  begin section
 134          deriving (Eq, Show)
 135
 136 -- ** Type 'Name'
 137 type Name = Text
 138
 139 -- ** Type 'LevelSection'
 140 type LevelSection = Int
 141
 142 -- * Type 'Rows'
 143 type Rows = [Tree (Cell Key) (Cell Text)]
 144
 145 -- | @appendRow rows row@ appends @row@ to @rows@.
 146 --
 147 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
 148 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
 149 appendRow :: Rows -> Row -> Rows
 150 appendRow [] row = List.reverse row
 151 appendRow parents [] = parents
 152 appendRow rows@(parent:parents) row@(cell:cells) =
 153         trac ("appendRow: rows=" <> show rows) $
 154         trac ("appendRow: row=" <> show row) $
 155         dbg "appendRow" $
 156         let colParent = columnPos $ posTree parent in
 157         let colRow    = columnPos $ posTree cell in
 158         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
 159          LT ->
 160                 case (dbg "parent" parent,dbg "cell" cell) of
 161                  (Tree0{}, TreeN{}) -> eq
 162                  (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
 163                  (Tree0 p, Tree0 r) -> appendTree0 p r
 164                  _ -> lt
 165          EQ ->
 166                 case (dbg "parent" parent,dbg "cell" cell) of
 167                  (Tree0 p, Tree0 r) -> appendTree0 p r
 168                  (_, TreeN (unCell -> KeySection sectionRow) _)
 169                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
 170                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
 171                          LT -> appendRow (cell:secPar:secPars) cells
 172                          EQ -> appendRow (cell:insertChild secPar secPars) cells
 173                          GT -> gt
 174                  (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
 175                  (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
 176                  (Tree0{}, TreeN{}) -> eq
 177                  (TreeN{}, TreeN{}) -> eq
 178                  (TreeN{}, Tree0{}) -> eq
 179          GT -> gt
 180         where
 181         appendTree0 p r =
 182                 case appendCellText p r of
 183                  Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
 184                  Just c  -> appendRow (Tree0 c : parents) cells
 185         lt = appendRow [] row <> rows
 186         eq = appendRow (cell : insertChild parent parents) cells
 187         gt = appendRow (insertChild parent parents) row
 188         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 189         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 190         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 191                 case x of
 192                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
 193                  _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
 194         collapseSection _ _ = Nothing
 195
 196 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
 197 appendCellText (Cell posPar posEndPar p)
 198                (Cell posRow posEndRow r) =
 199         trac ("appendCellText: p="<>show p) $
 200         trac ("appendCellText: r="<>show r) $
 201         dbg "appendCellText" $
 202         case linePos posRow - linePos posEndPar of
 203          0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 204                 where pad = padding (columnPos posEndPar) (columnPos posRow)
 205          1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 206                 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
 207          _ -> Nothing
 208         where
 209         padding x y = Text.replicate (y - x) " "
 210
 211 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 212 insertChild child ps@[] =
 213         trac ("insertChild: child="<>show child) $
 214         trac ("insertChild: ps="<>show ps) $
 215         dbg "insertChild" $
 216         [child]
 217 insertChild _child (Tree0{}:_) = undefined
 218 insertChild child ps@(TreeN parent treesParent:parents) =
 219         trac ("insertChild: child="<>show child) $
 220         trac ("insertChild: ps="<>show ps) $
 221         dbg "insertChild" $
 222         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 223          LT -> TreeN parent (treesParent |> child) : parents
 224          EQ -> TreeN parent (treesParent |> child) : parents
 225          GT -> undefined
 226
 227 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 228 collapseRows [] = undefined
 229 collapseRows [child] = dbg "collapseRows" $ child
 230 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents
 231
 232 -- * Type 'TCT'
 233 type TCT a = Trees (Cell Key) a