-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
-module Language.TCT.Tree where
+module Language.TCT.Tree
+ ( module Language.TCT.Tree
+ , Tree(..)
+ , Trees
+ ) where
-import Control.Applicative (Applicative(..))
-import Data.Bool
import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..))
-import Data.Foldable (foldr)
-import Data.Function (($), (.))
-import Data.Functor (Functor, (<$>))
+import Data.Function (($))
+import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
import Data.Ord (Ordering(..), Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.Sequence (Seq, ViewL(..), (|>))
+import Data.Sequence ((|>))
import Data.Text (Text)
-import Data.Traversable (Traversable(..))
+import Data.TreeSeq.Strict (Tree(..), Trees)
import Prelude (undefined, Int, Num(..))
import Text.Show (Show(..))
import qualified Data.List as List
-import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified System.FilePath as FP
+import Language.TCT.Cell
import Language.TCT.Elem
--- * Type 'Tree'
-data Tree k a
- = TreeN k (Trees k a)
- | Tree0 a
- deriving (Eq, Show, Functor)
-
-instance Traversable (Tree k) where
- traverse f (Tree0 a) = Tree0 <$> f a
- traverse f (TreeN k ts) = TreeN k <$> traverse (traverse f) ts
- sequenceA (Tree0 a) = Tree0 <$> a
- sequenceA (TreeN k ts) = TreeN k <$> traverse sequenceA ts
-instance Foldable (Tree k) where
- foldMap f (TreeN _k ts) = foldMap (foldMap f) ts
- foldMap f (Tree0 k) = f k
-
-isTree0 :: Tree k a -> Bool
-isTree0 Tree0{} = True
-isTree0 _ = False
-
-mapTreeWithKey :: (Maybe k -> a -> b) -> Tree k a -> Tree k b
-mapTreeWithKey = go Nothing
- where
- go _k f (TreeN k ts) = TreeN k (go (Just k) f <$> ts)
- go k f (Tree0 a) = Tree0 (f k a)
-
-mapTreeKey :: (k -> l) -> (Maybe k -> a -> b) -> Tree k a -> Tree l b
-mapTreeKey fk fv = go Nothing
- where
- go _k (TreeN k ts) = TreeN (fk k) $ go (Just k) <$> ts
- go k (Tree0 a) = Tree0 (fv k a)
-
-traverseTreeWithKey :: Applicative f => (Maybe k -> a -> f b) -> Tree k a -> f (Tree k b)
-traverseTreeWithKey = go Nothing
- where
- go _p f (TreeN k ts) = TreeN k <$> traverse (go (Just k) f) ts
- go p f (Tree0 a) = Tree0 <$> f p a
-
--- ** Type 'Trees'
-type Trees k a = Seq (Tree k a)
-
-newtype PrettyTree k a = PrettyTree (Trees k a)
-instance (Show k, Show a) => Show (PrettyTree k a) where
- show (PrettyTree t) = Text.unpack $ prettyTrees t
-
-prettyTree :: (Show k, Show a) => Tree k a -> Text
-prettyTree = Text.unlines . pretty
-
-prettyTrees :: (Show k, Show a) => Trees k a -> Text
-prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
-
-pretty :: (Show k, Show a) => Tree k a -> [Text]
-pretty (Tree0 a) = [Text.pack (show a)]
-pretty (TreeN k ts0) = Text.pack (show k) : prettySubTrees ts0
- where
- prettySubTrees s =
- case Seq.viewl s of
- Seq.EmptyL -> []
- t:<ts | Seq.null ts -> "|" : shift "`- " " " (pretty t)
- | otherwise -> "|" : shift "+- " "| " (pretty t) <> prettySubTrees ts
- shift first other = List.zipWith (<>) (first : List.repeat other)
-
--- * Type 'Pos'
-data Pos = Pos {-# UNPACK #-} !Line {-# UNPACK #-} !Column
- deriving (Eq, Show)
-
-posTree :: Tree (Cell k) (Cell a) -> Pos
-posTree (TreeN c _) = posCell c
-posTree (Tree0 c) = posCell c
-
-posEndTree :: Tree (Cell k) (Cell a) -> Pos
-posEndTree (TreeN c _) = posEndCell c
-posEndTree (Tree0 c) = posEndCell c
-
-pos0 :: Pos
-pos0 = Pos 0 0
-pos1 :: Pos
-pos1 = Pos 1 1
-
--- ** Type 'Line'
--- | Line in the source file, counting from 1.
-type Line = Int
-linePos :: Pos -> Line
-linePos (Pos l _) = l
-
--- ** Type 'Column'
--- | Column in the source file, counting from 1.
-type Column = Int
-columnPos :: Pos -> Column
-columnPos (Pos _ c) = c
-
-- * Type 'Row'
-- | A list of 'Key's, maybe ended by 'Value', all read on the same 'Line'.
type Row = [Tree (Cell Key) (Cell Text)]
--- ** Type 'Cell'
--- | NOTE: every 'Cell' as a 'Pos',
--- which is useful to indicate matches/errors/warnings/whatever,
--- or outputing in a format somehow preserving
--- the original input style.
-data Cell a = Cell {-# UNPACK #-} !Pos {-# UNPACK #-} !Pos a
- deriving (Eq, Show)
-
-unCell :: Cell a -> a
-unCell (Cell _ _ a) = a
-
-posCell :: Cell a -> Pos
-posCell (Cell pos _ _) = pos
-posEndCell :: Cell a -> Pos
-posEndCell (Cell _ pos _) = pos
-
-lineCell :: Cell a -> Line
-lineCell = linePos . posCell
-columnCell :: Cell a -> Column
-columnCell = columnPos . posCell
-
-cell0 :: a -> Cell a
-cell0 = Cell pos0 pos0
-cell1 :: a -> Cell a
-cell1 = Cell pos1 pos1
-
-- * Type 'Key'
data Key = KeyColon !Name !White -- ^ @name: @
| KeyEqual !Name !White -- ^ @name=@
| KeySection !LevelSection -- ^ @# @
| KeyBrackets !Name -- ^ @[ name ]@
| KeyDotSlash !PathFile -- ^ @./file @
- deriving (Eq, Show)
+ deriving (Eq, Ord, Show)
-- ** Type 'Name'
type Name = Text