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 closed 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 ps@(parent:parents) rs@(row:rows) =
 153         trac ("appendRow: ps=" <> show ps) $
 154         trac ("appendRow: rs=" <> show rs) $
 155         dbg "appendRow" $
 156         let colParent = columnPos $ posTree parent in
 157         let colRow    = columnPos $ posTree row in
 158         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
 159          LT ->
 160                 case (dbg "parent" parent,dbg "row" row) 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 "row" row) of
 167                  (Tree0 p, Tree0 r) -> appendTree0 p r
 168                  (_, TreeN (unCell -> KeySection sectionRow) _)
 169                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow ps ->
 170                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
 171                          LT -> appendRow (row:secPar:secPars) rows
 172                          EQ -> appendRow (row:insertChild secPar secPars) rows
 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 = appendRow (Tree0 (appendCellText p r):parents) rows
 182         lt = appendRow [] rs <> ps
 183         eq = appendRow (row:insertChild parent parents) rows
 184         gt = appendRow (insertChild parent parents) rs
 185         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 186         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 187         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 188                 case x of
 189                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
 190                  _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
 191         collapseSection _ _ = Nothing
 192
 193 appendCellText :: Cell Text -> Cell Text -> Cell Text
 194 appendCellText (Cell posPar posEndPar p)
 195                (Cell posRow posEndRow r) =
 196         trac ("appendCellText: p="<>show p) $
 197         trac ("appendCellText: r="<>show r) $
 198         dbg "appendCellText" $
 199         Cell posPar posEndRow $ p <> pad <> r
 200         where
 201         pad =
 202                 let ns = linePos posRow - linePos posEndPar in
 203                 if ns == 0
 204                 then padding (columnPos posEndPar) (columnPos posRow)
 205                 else Text.replicate ns "\n" <> padding (columnPos posPar) (columnPos posRow)
 206         padding x y = Text.replicate (y - x) " "
 207
 208 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 209 insertChild child ps@[] =
 210         trac ("insertChild: child="<>show child) $
 211         trac ("insertChild: ps="<>show ps) $
 212         dbg "insertChild" $
 213         [child]
 214 insertChild _child (Tree0{}:_) = undefined
 215 insertChild child ps@(TreeN parent treesParent:parents) =
 216         trac ("insertChild: child="<>show child) $
 217         trac ("insertChild: ps="<>show ps) $
 218         dbg "insertChild" $
 219         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 220          LT -> TreeN parent (treesParent |> child) : parents
 221          EQ -> TreeN parent (treesParent |> child) : parents
 222          GT -> undefined
 223
 224 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 225 collapseRows [] = undefined
 226 collapseRows [child] = dbg "collapseRows" $ child
 227 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents
 228
 229 -- * Type 'TCT'
 230 type TCT a = Trees (Cell Key) a