Language/TCT/Tree.hs

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