symantic-grammar/Language/Symantic/Grammar/BinTree.hs

   1 -- | Binary tree, useful to build /Abstract Syntax Tree/ (AST)
   2 -- made of applications of tokens.
   3 module Language.Symantic.Grammar.BinTree where
   4
   5 import Control.Applicative (Applicative(..))
   6 import Control.Monad (Monad(..))
   7 import Data.Eq (Eq)
   8 import Data.Foldable (Foldable(..))
   9 import Data.Functor (Functor(..), (<$>))
  10 import Data.Monoid (Monoid(..))
  11 import Data.Semigroup (Semigroup(..))
  12 import Data.Traversable (Traversable(..))
  13 import Text.Show (Show)
  14
  15 -- * Type 'BinTree'
  16 -- | /Binary Tree/.
  17 data BinTree a
  18  =   BinTree0 a
  19  |   BinTree2 (BinTree a) (BinTree a)
  20  deriving (Eq, Show)
  21
  22 instance Semigroup (BinTree a) where
  23         (<>) = BinTree2
  24 instance Functor BinTree where
  25         fmap f (BinTree0 a)   = BinTree0 (f a)
  26         fmap f (BinTree2 x y) = BinTree2 (fmap f x) (fmap f y)
  27 instance Applicative BinTree where
  28         pure = BinTree0
  29         BinTree0 f     <*> BinTree0 a   = BinTree0 (f a)
  30         BinTree0 f     <*> BinTree2 x y = BinTree2 (f  <$> x) (f  <$> y)
  31         BinTree2 fx fy <*> a            = BinTree2 (fx <*> a) (fy <*> a)
  32 instance Monad BinTree where
  33         return = BinTree0
  34         BinTree0 a   >>= f = f a
  35         BinTree2 x y >>= f = BinTree2 (x >>= f) (y >>= f)
  36 instance Foldable BinTree where
  37         foldMap f (BinTree0 a)   = f a
  38         foldMap f (BinTree2 x y) = foldMap f x `mappend` foldMap f y
  39         foldr f acc (BinTree0 a)   = f a acc
  40         foldr f acc (BinTree2 x y) = foldr f (foldr f acc y) x
  41         foldl f acc (BinTree0 a)   = f acc a
  42         foldl f acc (BinTree2 x y) = foldl f (foldl f acc x) y
  43 instance Traversable BinTree where
  44         traverse f (BinTree0 a)   = BinTree0 <$> f a
  45         traverse f (BinTree2 x y) = BinTree2 <$> traverse f x <*> traverse f y
  46
  47 -- | Collapse depth-first given 'BinTree' with given function.
  48 --
  49 -- Useful to apply all arguments.
  50 collapseBT :: (a -> a -> a) -> BinTree a -> a
  51 collapseBT _f (BinTree0 x) = x
  52 collapseBT f (BinTree2 x y) = collapseBT f x `f` collapseBT f y