-- | Binary tree, useful to build /Abstract Syntax Tree/ (AST)
-- made of applications of tokens.
module Language.Symantic.Grammar.BinTree where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Eq (Eq)
import Data.Foldable (Foldable(..))
import Data.Functor (Functor(..), (<$>))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Traversable (Traversable(..))
import Text.Show (Show)

-- * Type 'BinTree'
-- | /Binary Tree/.
data BinTree a
 =   BinTree0 a
 |   BinTree2 (BinTree a) (BinTree a)
 deriving (Eq, Show)

instance Semigroup (BinTree a) where
	(<>) = BinTree2
instance Functor BinTree where
	fmap f (BinTree0 a)   = BinTree0 (f a)
	fmap f (BinTree2 x y) = BinTree2 (fmap f x) (fmap f y)
instance Applicative BinTree where
	pure = BinTree0
	BinTree0 f     <*> BinTree0 a   = BinTree0 (f a)
	BinTree0 f     <*> BinTree2 x y = BinTree2 (f  <$> x) (f  <$> y)
	BinTree2 fx fy <*> a            = BinTree2 (fx <*> a) (fy <*> a)
instance Monad BinTree where
	return = BinTree0
	BinTree0 a   >>= f = f a
	BinTree2 x y >>= f = BinTree2 (x >>= f) (y >>= f)
instance Foldable BinTree where
	foldMap f (BinTree0 a)   = f a
	foldMap f (BinTree2 x y) = foldMap f x `mappend` foldMap f y
	foldr f acc (BinTree0 a)   = f a acc
	foldr f acc (BinTree2 x y) = foldr f (foldr f acc y) x
	foldl f acc (BinTree0 a)   = f acc a
	foldl f acc (BinTree2 x y) = foldl f (foldl f acc x) y
instance Traversable BinTree where
	traverse f (BinTree0 a)   = BinTree0 <$> f a
	traverse f (BinTree2 x y) = BinTree2 <$> traverse f x <*> traverse f y

-- | Collapse depth-first given 'BinTree' with given function.
--
-- Useful to apply all arguments.
collapseBT :: (a -> a -> a) -> BinTree a -> a
collapseBT _f (BinTree0 x) = x
collapseBT f (BinTree2 x y) = collapseBT f x `f` collapseBT f y