Data/TreeSeq/Strict.hs

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