Data/TreeSeq/Strict.hs

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