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 pos0 :: Pos
  88 pos0 = (0,0)
  89
  90 -- ** Type 'Line'
  91 -- | Line in the source file, counting from 1.
  92 type Line = Int
  93 linePos :: Pos -> Line
  94 linePos = fst
  95
  96 -- ** Type 'Column'
  97 -- | Column in the source file, counting from 1.
  98 type Column = Int
  99 columnPos :: Pos -> Column
 100 columnPos  = snd
 101
 102 -- * Type 'Row'
 103 -- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
 104 type Row = [Tree (Cell Key) (Cell Text)]
 105
 106 -- ** Type 'Cell'
 107 -- | NOTE: every 'Cell' as a 'Pos',
 108 --         which is useful to indicate matches/errors/warnings/whatever,
 109 --         or outputing in a format somehow preserving
 110 --         the original input style.
 111 data Cell a = Cell Pos Pos a
 112               deriving (Eq, Show)
 113
 114 unCell :: Cell a -> a
 115 unCell (Cell _ _ a) = a
 116
 117 posCell :: Cell a -> Pos
 118 posCell (Cell pos _ _) = pos
 119
 120 posEndCell :: Cell a -> Pos
 121 posEndCell (Cell _ pos _) = pos
 122
 123 lineCell :: Cell a -> Line
 124 lineCell = fst . posCell
 125 columnCell :: Cell a -> Column
 126 columnCell = snd . posCell
 127
 128 cell0 :: a -> Cell a
 129 cell0 = Cell pos0 pos0
 130
 131 -- * Type 'Key'
 132 data Key = KeyColon Name White     -- ^ @name:@ begin 'Cell'
 133          | KeyEqual Name White     -- ^ @name=@ begin 'Value'
 134          | KeyBar   Name White     -- ^ @name|@ continue 'Value'
 135          | KeyGreat Name White     -- ^ @name>@ continue 'Cell'
 136          | KeyLower Name Attrs     -- ^ @<name a=b@ begin HereDoc
 137          | KeyDash                 -- ^ @- @    begin item
 138          | KeySection LevelSection -- ^ @### @  begin section
 139          deriving (Eq, Show)
 140
 141 -- ** Type 'Name'
 142 type Name = Text
 143
 144 -- ** Type 'LevelSection'
 145 type LevelSection = Int
 146
 147 -- * Type 'Rows'
 148 type Rows = [Tree (Cell Key) (Cell Text)]
 149
 150 -- | @appendRow rows row@ appends @row@ to @rows@.
 151 --
 152 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
 153 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
 154 appendRow :: Rows -> Row -> Rows
 155 appendRow [] row = List.reverse row
 156 appendRow parents [] = parents
 157 appendRow rows@(parent:parents) row@(cell:cells) =
 158         trac ("appendRow: rows=" <> show rows) $
 159         trac ("appendRow: row=" <> show row) $
 160         dbg "appendRow" $
 161         let colParent = columnPos $ posTree parent in
 162         let colRow    = columnPos $ posTree cell in
 163         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
 164          LT ->
 165                 case (dbg "parent" parent,dbg "cell" cell) of
 166                  (Tree0{}, TreeN{}) -> eq
 167                  (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
 168                  (Tree0 p, Tree0 r) -> appendTree0 p r
 169                  _ -> lt
 170          EQ ->
 171                 case (dbg "parent" parent,dbg "cell" cell) of
 172                  (Tree0 p, Tree0 r) -> appendTree0 p r
 173                  (_, TreeN (unCell -> KeySection sectionRow) _)
 174                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
 175                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
 176                          LT -> appendRow (cell:secPar:secPars) cells
 177                          EQ -> appendRow (cell:insertChild secPar secPars) cells
 178                          GT -> gt
 179                  (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
 180                  (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
 181                  (Tree0{}, TreeN{}) -> eq
 182                  (TreeN{}, TreeN{}) -> eq
 183                  (TreeN{}, Tree0{}) -> eq
 184          GT -> gt
 185         where
 186         appendTree0 p r =
 187                 case appendCellText p r of
 188                  Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
 189                  Just c  -> appendRow (Tree0 c : parents) cells
 190         lt = appendRow [] row <> rows
 191         eq = appendRow (cell : insertChild parent parents) cells
 192         gt = appendRow (insertChild parent parents) row
 193         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 194         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 195         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 196                 case x of
 197                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
 198                  _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
 199         collapseSection _ _ = Nothing
 200
 201 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
 202 appendCellText (Cell posPar posEndPar p)
 203                (Cell posRow posEndRow r) =
 204         trac ("appendCellText: p="<>show p) $
 205         trac ("appendCellText: r="<>show r) $
 206         dbg "appendCellText" $
 207         case linePos posRow - linePos posEndPar of
 208          0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 209                 where pad = padding (columnPos posEndPar) (columnPos posRow)
 210          1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 211                 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
 212          _ -> Nothing
 213         where
 214         padding x y = Text.replicate (y - x) " "
 215
 216 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 217 insertChild child ps@[] =
 218         trac ("insertChild: child="<>show child) $
 219         trac ("insertChild: ps="<>show ps) $
 220         dbg "insertChild" $
 221         [child]
 222 insertChild _child (Tree0{}:_) = undefined
 223 insertChild child ps@(TreeN parent treesParent:parents) =
 224         trac ("insertChild: child="<>show child) $
 225         trac ("insertChild: ps="<>show ps) $
 226         dbg "insertChild" $
 227         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 228          LT -> TreeN parent (treesParent |> child) : parents
 229          EQ -> TreeN parent (treesParent |> child) : parents
 230          GT -> undefined
 231
 232 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 233 collapseRows [] = undefined
 234 collapseRows [child] = dbg "collapseRows" $ child
 235 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents