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 Data.Semigroup (Semigroup(..))
   6
   7 -- * Type 'BinTree'
   8 -- | /Binary Tree/.
   9 data BinTree a
  10  =   BinTree0 a
  11  |   BinTree2 (BinTree a) (BinTree a)
  12  deriving (Eq, Show)
  13
  14 instance Semigroup (BinTree a) where
  15         (<>) = BinTree2
  16 instance Functor BinTree where
  17         fmap f (BinTree0 a)   = BinTree0 (f a)
  18         fmap f (BinTree2 x y) = BinTree2 (fmap f x) (fmap f y)
  19 instance Applicative BinTree where
  20         pure = BinTree0
  21         BinTree0 f     <*> BinTree0 a   = BinTree0 (f a)
  22         BinTree0 f     <*> BinTree2 x y = BinTree2 (f  <$> x) (f  <$> y)
  23         BinTree2 fx fy <*> a            = BinTree2 (fx <*> a) (fy <*> a)
  24 instance Monad BinTree where
  25         return = BinTree0
  26         BinTree0 a   >>= f = f a
  27         BinTree2 x y >>= f = BinTree2 (x >>= f) (y >>= f)
  28 instance Foldable BinTree where
  29         foldMap f (BinTree0 a)   = f a
  30         foldMap f (BinTree2 x y) = foldMap f x `mappend` foldMap f y
  31         foldr f acc (BinTree0 a)   = f a acc
  32         foldr f acc (BinTree2 x y) = foldr f (foldr f acc y) x
  33         foldl f acc (BinTree0 a)   = f acc a
  34         foldl f acc (BinTree2 x y) = foldl f (foldl f acc x) y
  35 instance Traversable BinTree where
  36         traverse f (BinTree0 a)   = BinTree0 <$> f a
  37         traverse f (BinTree2 x y) = BinTree2 <$> traverse f x <*> traverse f y
  38
  39 -- | Collapse depth-first given 'BinTree' with given function.
  40 --
  41 -- Useful to apply all arguments.
  42 collapseBT :: (a -> a -> a) -> BinTree a -> a
  43 collapseBT _f (BinTree0 x) = x
  44 collapseBT f (BinTree2 x y) = collapseBT f x `f` collapseBT f y