Data/TreeSeq/Strict.hs

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 module Data.TreeSeq.Strict where
   5
   6 import Control.Applicative (Applicative(..))
   7 import Control.Monad (Monad(..))
   8 import Data.Bool
   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
  23
  24 -- * Type 'Tree'
  25 data Tree a
  26  =   Tree { unTree   :: !a
  27           , subTrees :: !(Trees a)
  28           }
  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
  37         return = pure
  38         Tree a ts >>= f =
  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
  46
  47 tree0 :: a -> Tree a
  48 tree0 a = Tree a mempty
  49
  50 isTree0 :: Tree a -> Bool
  51 isTree0 (Tree _ ts) = null ts
  52
  53 isTreeN :: Tree a -> Bool
  54 isTreeN (Tree _ ts) = not (null ts)
  55
  56 -- * Type 'Trees'
  57 type Trees a = Seq (Tree a)
  58
  59 -- * Type 'Pretty'
  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
  65
  66 prettyTree :: Show a => Tree a -> TL.Text
  67 prettyTree = TL.unlines . pretty
  68
  69 prettyTrees :: Show a => Trees a -> TL.Text
  70 prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
  71
  72 pretty :: Show a => Tree a -> [TL.Text]
  73 pretty (Tree a ts0) = TL.pack (show a) : prettySubTrees ts0
  74         where
  75         prettySubTrees s =
  76                 case Seq.viewl s of
  77                  Seq.EmptyL -> []
  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)