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          | KeyDashDash              -- ^ @-- @   begin item
 151          | KeySection !LevelSection -- ^ @### @  begin section
 152          deriving (Eq, Show)
 153
 154 -- ** Type 'Name'
 155 type Name = Text
 156
 157 -- ** Type 'LevelSection'
 158 type LevelSection = Int
 159
 160 -- * Type 'Rows'
 161 type Rows = [Tree (Cell Key) (Cell Text)]
 162
 163 -- | @appendRow rows row@ appends @row@ to @rows@.
 164 --
 165 -- [@rows@] parent 'Rows', from closest to farest (non-strictly descending)
 166 -- [@row@]  next 'Row', from leftest column to rightest (non-stricly ascending)
 167 appendRow :: Rows -> Row -> Rows
 168 appendRow [] row = List.reverse row
 169 appendRow parents [] = parents
 170 appendRow rows@(parent:parents) row@(cell:cells) =
 171         trac ("appendRow: rows=" <> show rows) $
 172         trac ("appendRow: row=" <> show row) $
 173         dbg "appendRow" $
 174         let colParent = columnPos $ posTree parent in
 175         let colRow    = columnPos $ posTree cell in
 176         case dbg "colParent" colParent`compare`dbg "colRow" colRow of
 177          LT ->
 178                 case (dbg "parent" parent,dbg "cell" cell) of
 179                  (Tree0{}, TreeN{}) -> eq
 180                  (Tree0 p, Tree0{}) | Text.null (unCell p) -> eq -- FIXME: useful?
 181                  (Tree0 p, Tree0 r) -> appendTree0 p r
 182                  _ -> lt
 183          EQ ->
 184                 case (dbg "parent" parent,dbg "cell" cell) of
 185                  (Tree0 p, Tree0 r) -> appendTree0 p r
 186                  (_, TreeN (unCell -> KeySection sectionRow) _)
 187                   | Just (sectionParent, secPar:secPars) <- collapseSection colRow rows ->
 188                         case dbg "sectionParent" sectionParent`compare`dbg "sectionRow" sectionRow of
 189                          LT -> appendRow (cell:secPar:secPars) cells
 190                          EQ -> appendRow (cell:insertChild secPar secPars) cells
 191                          GT -> gt
 192                  (TreeN (unCell -> KeySection{}) _, Tree0{}) -> lt
 193                  (TreeN (unCell -> KeySection{}) _, TreeN{}) -> lt
 194                  (Tree0{}, TreeN{}) -> eq
 195                  (TreeN{}, TreeN{}) -> eq
 196                  (TreeN{}, Tree0{}) -> eq
 197          GT -> gt
 198         where
 199         appendTree0 p r =
 200                 case appendCellText p r of
 201                  Nothing -> appendRow (Tree0 r : insertChild (Tree0 p) parents) cells
 202                  Just c  -> appendRow (Tree0 c : parents) cells
 203         lt = appendRow [] row <> rows
 204         eq = appendRow (cell : insertChild parent parents) cells
 205         gt = appendRow (insertChild parent parents) row
 206         -- | Find the first section (if any), returning its level, and the path collapsed upto it.
 207         collapseSection :: Column -> Rows -> Maybe (Int,Rows)
 208         collapseSection col xxs@(x:xs) | columnPos (posTree x) == col =
 209                 case x of
 210                  TreeN (unCell -> KeySection lvl) _ -> Just (lvl,xxs)
 211                  _ -> (\(lvl,cs) -> (lvl,insertChild x cs)) <$> collapseSection col xs
 212         collapseSection _ _ = Nothing
 213
 214 appendCellText :: Cell Text -> Cell Text -> Maybe (Cell Text)
 215 appendCellText (Cell posPar posEndPar p)
 216                (Cell posRow posEndRow r) =
 217         trac ("appendCellText: p="<>show p) $
 218         trac ("appendCellText: r="<>show r) $
 219         dbg "appendCellText" $
 220         case linePos posRow - linePos posEndPar of
 221          0 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 222                 where pad = padding (columnPos posEndPar) (columnPos posRow)
 223          1 -> Just $ Cell posPar posEndRow $ p <> pad <> r
 224                 where pad = "\n" <> padding (columnPos posPar) (columnPos posRow)
 225          _ -> Nothing
 226         where
 227         padding x y = Text.replicate (y - x) " "
 228
 229 insertChild :: Tree (Cell Key) (Cell Text) -> Rows -> Rows
 230 insertChild child ps@[] =
 231         trac ("insertChild: child="<>show child) $
 232         trac ("insertChild: ps="<>show ps) $
 233         dbg "insertChild" $
 234         [child]
 235 insertChild _child (Tree0{}:_) = undefined
 236 insertChild child ps@(TreeN parent treesParent:parents) =
 237         trac ("insertChild: child="<>show child) $
 238         trac ("insertChild: ps="<>show ps) $
 239         dbg "insertChild" $
 240         case dbg "colParent" (columnCell parent)`compare`dbg "colChild" (columnPos $ posTree child) of
 241          LT -> TreeN parent (treesParent |> child) : parents
 242          EQ -> TreeN parent (treesParent |> child) : parents
 243          GT -> undefined
 244
 245 collapseRows :: Rows -> Tree (Cell Key) (Cell Text)
 246 collapseRows []              = undefined
 247 collapseRows [child]         = dbg "collapseRows" $ child
 248 collapseRows (child:parents) = dbg "collapseRows" $ collapseRows $ insertChild child parents