Language/TCT/Tree.hs

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