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