1 {-# LANGUAGE BangPatterns #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 module Data.TreeSeq.Strict where
6 import Control.Applicative (Applicative(..))
7 import Control.Monad (Monad(..))
9 import Data.Eq (Eq(..))
10 import Data.Foldable (Foldable(..))
11 import Data.Foldable (foldr)
12 import Data.Function (($), (.))
13 import Data.Functor (Functor(..), (<$>))
14 import Data.Monoid (Monoid(..))
15 import Data.Ord (Ord(..))
16 import Data.Semigroup (Semigroup(..))
17 import Data.Sequence (Seq, ViewL(..))
18 import Data.Traversable (Traversable(..))
19 import Text.Show (Show(..))
20 import qualified Data.List as List
21 import qualified Data.Sequence as Seq
22 import qualified Data.Text.Lazy as TL
27 , subTrees :: !(Trees a)
29 deriving (Eq, Ord, Show)
30 instance Functor Tree where
31 fmap f (Tree a ts) = Tree (f a) (fmap (fmap f) ts)
32 instance Applicative Tree where
33 pure a = Tree a mempty
34 Tree f tfs <*> ta@(Tree a tas) =
35 Tree (f a) (fmap (f <$>) tas <> fmap (<*> ta) tfs)
36 instance Monad Tree where
39 Tree a' (ts' <> fmap (>>= f) ts)
40 where Tree a' ts' = f a
41 instance Foldable Tree where
42 foldMap f (Tree a ts) = f a `mappend` foldMap (foldMap f) ts
43 instance Traversable Tree where
44 traverse f (Tree a ts) = Tree <$> f a <*> traverse (traverse f) ts
45 sequenceA (Tree a ts) = Tree <$> a <*> traverse sequenceA ts
48 tree0 a = Tree a mempty
50 isTree0 :: Tree a -> Bool
51 isTree0 (Tree _ ts) = null ts
53 isTreeN :: Tree a -> Bool
54 isTreeN (Tree _ ts) = not (null ts)
57 type Trees a = Seq (Tree a)
60 newtype Pretty a = Pretty a
61 instance Show a => Show (Pretty (Trees a)) where
62 show (Pretty t) = TL.unpack $ prettyTrees t
63 instance Show a => Show (Pretty (Tree a)) where
64 show (Pretty t) = TL.unpack $ prettyTree t
66 prettyTree :: Show a => Tree a -> TL.Text
67 prettyTree = TL.unlines . pretty
69 prettyTrees :: Show a => Trees a -> TL.Text
70 prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
72 pretty :: Show a => Tree a -> [TL.Text]
73 pretty (Tree a ts0) = TL.pack (show a) : prettySubTrees ts0
78 t:<ts | Seq.null ts -> "|" : shift "`- " " " (pretty t)
79 | otherwise -> "|" : shift "+- " "| " (pretty t) <> prettySubTrees ts
80 shift first other = List.zipWith (<>) (first : List.repeat other)