Data/TreeSeq/Strict.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 module Data.TreeSeq.Strict where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Control.DeepSeq (NFData(..))
   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.String (String)
  17 import Data.Traversable (Traversable(..))
  18 import GHC.Generics (Generic)
  19 import Prelude (seq)
  20 import Text.Show (Show(..))
  21 import qualified Data.List as List
  22 import qualified Data.Sequence as Seq
  23
  24 -- * Type 'Tree'
  25 data Tree a
  26  =   Tree { unTree   :: !a
  27           , subTrees :: !(Trees a)
  28           }
  29  deriving (Eq, Ord, Show, Generic)
  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 instance NFData a => NFData (Tree a) where
  47         rnf (Tree a ts) = rnf a `seq` rnf ts
  48
  49 tree0 :: a -> Tree a
  50 tree0 a = Tree a mempty
  51
  52 isTree0 :: Tree a -> Bool
  53 isTree0 (Tree _ ts) = null ts
  54
  55 isTreeN :: Tree a -> Bool
  56 isTreeN (Tree _ ts) = not (null ts)
  57
  58 -- * Type 'Trees'
  59 type Trees a = Seq (Tree a)
  60
  61 prettyTree :: Show a => Tree a -> String
  62 prettyTree = List.unlines . pretty
  63
  64 prettyTrees :: Show a => Trees a -> String
  65 prettyTrees = foldr (\t acc -> prettyTree t <> "\n" <> acc) ""
  66
  67 pretty :: Show a => Tree a -> [String]
  68 pretty (Tree a ts0) = show a : prettySubTrees ts0
  69         where
  70         shift first other = List.zipWith (<>) $ first : List.repeat other
  71         prettySubTrees s =
  72                 case Seq.viewl s of
  73                  Seq.EmptyL -> []
  74                  t:<ts | Seq.null ts -> "|" : shift "`- " "   " (pretty t)
  75                        | otherwise   -> "|" : shift "+- " "|  " (pretty t) <> prettySubTrees ts