#if __GLASGOW_HASKELL__
#endif
#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 703
#endif
module Data.Tree.Binary.Inorder
(
Tree(..)
, unfoldTree
, replicate
, replicateA
, singleton
, empty
, fromList
, foldTree
, depth
, drawTree
, drawTreeWith
, printTree
) where
import Prelude hiding
( replicate
#if MIN_VERSION_base(4,8,0)
,Functor(..),Foldable(..),Applicative, (<$>), foldMap, Monoid
#else
,foldr,foldl
#endif
)
import Data.List (length)
import Control.Applicative (Applicative(..), Alternative, liftA2, liftA3)
import qualified Control.Applicative as Alternative (empty, (<|>))
import Control.DeepSeq (NFData(rnf))
import Data.Monoid (Monoid(mappend, mempty))
import Data.Functor (Functor(fmap, (<$)))
#if MIN_VERSION_base(4,6,0)
import Data.Foldable (Foldable(foldl, foldr, foldMap, foldl', foldr'))
#else
import Data.Foldable (Foldable(foldl, foldr, foldMap))
#endif
#if MIN_VERSION_base(4,9,0)
import Data.Functor.Classes
import qualified Data.Semigroup as Semigroup
#endif
import Data.Traversable (Traversable(traverse))
import Data.Typeable (Typeable)
#if __GLASGOW_HASKELL__ >= 706
import GHC.Generics (Generic, Generic1)
#elif __GLASGOW_HASKELL__ >= 702
import GHC.Generics (Generic)
#endif
import Text.Read
#if __GLASGOW_HASKELL__
import Data.Data (Data)
#if MIN_VERSION_base(4,10,0)
import Text.Read.Lex (expect)
#endif
#endif
import qualified Data.Tree.Binary.Internal as Internal
import Data.Tree.Binary.Internal (State(..), evalState, Identity(..))
data Tree a
= Leaf
| Node (Tree a)
a
(Tree a)
deriving (Show, Read, Eq, Ord
#if __GLASGOW_HASKELL__ >= 706
, Typeable, Data, Generic, Generic1
#elif __GLASGOW_HASKEL__ >= 702
, Typeable, Data, Generic
#elif __GLASGOW_HASKELL__
, Typeable, Data
#endif
)
instance Functor Tree where
fmap _ Leaf = Leaf
fmap f (Node l x r) = Node (fmap f l) (f x) (fmap f r)
#if __GLASGOW_HASKELL__
#endif
x <$ xs = go xs where
go Leaf = Leaf
go (Node l _ r) = Node (go l) x (go r)
instance Applicative Tree where
pure x = y where y = Node y x y
Leaf <*> _ = Leaf
Node _ _ _ <*> Leaf = Leaf
Node fl f fr <*> Node xl x xr = Node (fl <*> xl) (f x) (fr <*> xr)
#if __GLASGOW_HASKELL__
#endif
#if MIN_VERSION_base(4,10,0)
liftA2 f = go where
go Leaf _ = Leaf
go (Node _ _ _) Leaf = Leaf
go (Node xl x xr) (Node yl y yr) = Node (go xl yl) (f x y) (go xr yr)
#endif
#if MIN_VERSION_base(4,2,0)
Leaf *> _ = Leaf
Node _ _ _ *> Leaf = Leaf
Node xl _ xr *> Node yl y yr = Node (xl *> yl) y (xr *> yr)
Leaf <* _ = Leaf
Node _ _ _ <* Leaf = Leaf
Node xl x xr <* Node yl _ yr = Node (xl <* yl) x (xr <* yr)
#if __GLASGOW_HASKELL__
#endif
#endif
instance Alternative Tree where
empty = Leaf
#if MIN_VERSION_base(4,9,0)
(<|>) = (Semigroup.<>)
#else
(<|>) = mappend
#endif
instance Foldable Tree where
foldr _ b Leaf = b
foldr f b (Node l x r) = foldr f (f x (foldr f b r)) l
foldl _ b Leaf = b
foldl f b (Node l x r) = foldl f (f (foldl f b l) x) r
foldMap _ Leaf = mempty
foldMap f (Node l x r) = foldMap f l `mappend` f x `mappend` foldMap f r
#if __GLASGOW_HASKELL__
#endif
#if MIN_VERSION_base(4,6,0)
foldr' _ !b Leaf = b
foldr' f !b (Node l x r) = case foldr' f b r of
!b' -> case f x b' of
!b'' -> foldr' f b'' l
foldl' _ !b Leaf = b
foldl' f !b (Node l x r) = case foldl' f b l of
!b' -> case f b' x of
!b'' -> foldl' f b'' r
#if __GLASGOW_HASKELL__
#endif
#endif
instance Traversable Tree where
traverse _ Leaf = pure Leaf
traverse f (Node l x r) = liftA3 Node (traverse f l) (f x) (traverse f r)
#if __GLASGOW_HASKELL__
#endif
singleton :: a -> Tree a
singleton x = Node Leaf x Leaf
empty :: Tree a
empty = Leaf
instance NFData a => NFData (Tree a) where
rnf Leaf = ()
rnf (Node l x r) = rnf l `seq` rnf x `seq` rnf r
#if MIN_VERSION_base(4,9,0)
instance Eq1 Tree where
liftEq _ Leaf Leaf = True
liftEq eq (Node xl x xr) (Node yl y yr) =
liftEq eq xl yl && eq x y && liftEq eq xr yr
liftEq _ _ _ = False
instance Ord1 Tree where
liftCompare _ Leaf Leaf = EQ
liftCompare cmp (Node xl x xr) (Node yl y yr) =
liftCompare cmp xl yl `mappend` cmp x y `mappend` liftCompare cmp xr yr
liftCompare _ Leaf _ = LT
liftCompare _ _ Leaf = GT
instance Show1 Tree where
liftShowsPrec s _ = go
where
go _ Leaf = showString "Leaf"
go d (Node l x r) =
showParen (d >= 11) $
showString "Node " .
go 11 l . showChar ' ' . s 11 x . showChar ' ' . go 11 r
instance Read1 Tree where
#if MIN_VERSION_base(4,10,0) && __GLASGOW_HASKELL__
liftReadPrec rp _ = go
where
go =
parens $
(Leaf <$ expect' (Ident "Leaf")) +++
prec
10
(expect' (Ident "Node") *> liftA3 Node (step go) (step rp) (step go))
expect' = lift . expect
liftReadListPrec = liftReadListPrecDefault
#else
liftReadsPrec rp _ = go
where
go p st =
[(Leaf, xs) | ("Leaf", xs) <- lex st] ++
readParen
(p > 10)
(\vs ->
[ (Node l x r, zs)
| ("Node", ws) <- lex vs
, (l, xs) <- go 11 ws
, (x, ys) <- rp 11 xs
, (r, zs) <- go 11 ys
])
st
#endif
#endif
foldTree :: b -> (b -> a -> b -> b) -> Tree a -> b
foldTree b f = go
where
go Leaf = b
go (Node l x r) = f (go l) x (go r)
depth :: Tree a -> Int
depth = foldTree 0 (\l _ r -> succ (max l r))
unfoldTree :: (b -> Maybe (b, a, b)) -> b -> Tree a
unfoldTree f = go
where
go = maybe Leaf (\(l, x, r) -> Node (go l) x (go r)) . f
replicate :: Int -> a -> Tree a
replicate n x = runIdentity (replicateA n (Identity x))
replicateA :: Applicative f => Int -> f a -> f (Tree a)
replicateA n x = go n
where
go m
| m <= 0 = pure Leaf
| even m = liftA3 Node r x (go (d 1))
| otherwise = liftA3 Node r x r
where
d = m `div` 2
r = go d
#if MIN_VERSION_base(4,9,0)
instance Semigroup.Semigroup (Tree a) where
Leaf <> y = y
Node x l r <> y = Node x l (r Semigroup.<> y)
#if __GLASGOW_HASKELL__
#endif
#endif
instance Monoid (Tree a) where
#if MIN_VERSION_base(4,9,0)
mappend = (Semigroup.<>)
#else
mappend Leaf y = y
mappend (Node l x r) y = Node l x (mappend r y)
#if __GLASGOW_HASKELL__
#endif
#endif
mempty = Leaf
fromList :: [a] -> Tree a
fromList xs = evalState (replicateA n u) xs
where
n = length xs
u =
State
(\ys ->
case ys of
[] ->
#if __GLASGOW_HASKELL__ >= 800
errorWithoutStackTrace
#else
error
#endif
"Data.Tree.Binary.Inorder.fromList: bug!"
z:zs -> (z, zs))
drawTree :: Show a => Tree a -> String
drawTree t = drawTreeWith show t ""
drawTreeWith :: (a -> String) -> Tree a -> ShowS
drawTreeWith sf = Internal.drawTree sf uncons'
where
uncons' Leaf = Nothing
uncons' (Node l x r) = Just (x, l, r)
printTree :: Show a => Tree a -> IO ()
printTree = putStr . drawTree