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