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