]> Git — Sourcephile - haskell/symantic.git/blob - symantic-grammar/Language/Symantic/Grammar/BinTree.hs
Fix symantic-grammar test.
[haskell/symantic.git] / 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