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