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