#if __GLASGOW_HASKELL__
#endif
#if __GLASGOW_HASKELL__ >= 702
#endif
#if __GLASGOW_HASKELL__ >= 703
#endif
module Data.Tree.Binary.Leafy
(
Tree(..)
, unfoldTree
, replicate
, replicateA
, singleton
, 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 Control.Applicative (Applicative(..), liftA2, (*>))
import Control.DeepSeq (NFData(rnf))
import Data.Monoid (Monoid(mappend))
import Data.Functor (Functor(fmap, (<$)))
#if MIN_VERSION_base(4,8,0)
import Data.Foldable (Foldable(foldl, foldr, foldMap, foldl', foldr', null))
#elif 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 Control.Monad.Fix (MonadFix(mfix), fix)
#if MIN_VERSION_base(4,4,0)
import Control.Monad.Zip (MonadZip (..))
#endif
import qualified Data.Tree.Binary.Internal as Internal
import Data.Tree.Binary.Internal (Identity(..), State)
#if __GLASGOW_HASKELL__ >= 800
import GHC.Stack (HasCallStack)
#endif
infixl 5 :*:
data Tree a
= Leaf a
| Tree 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 f (Leaf x) = Leaf (f x)
fmap f (xs :*: ys) = fmap f xs :*: fmap f ys
#if __GLASGOW_HASKELL__
#endif
x <$ xs = go xs where
go (Leaf _) = Leaf x
go (ls :*: rs) = go ls :*: go rs
instance Applicative Tree where
pure = Leaf
Leaf f <*> xs = fmap f xs
(fs :*: gs) <*> xs = (fs <*> xs) :*: (gs <*> xs)
#if __GLASGOW_HASKELL__
#endif
#if MIN_VERSION_base(4,10,0)
liftA2 f = go where
go (Leaf x) ys = fmap (f x) ys
go (xl :*: xr) ys = go xl ys :*: go xr ys
#endif
#if MIN_VERSION_base(4,2,0)
Leaf _ *> ys = ys
(xl :*: xr) *> ys = (xl *> ys) :*: (xr *> ys)
Leaf x <* ys = x <$ ys
(xl :*: xr) <* ys = (xl <* ys) :*: (xr <* ys)
#if __GLASGOW_HASKELL__
#endif
#endif
instance Monad Tree where
#if !MIN_VERSION_base(4,8,0)
return = pure
(>>) = (*>)
#endif
Leaf x >>= f = f x
(xl :*: xr) >>= f = (xl >>= f) :*: (xr >>= f)
#if __GLASGOW_HASKELL__
#endif
instance MonadFix Tree where
mfix f =
case fix (f . unLeaf) of
Leaf x -> Leaf x
_ :*: _ -> mfix (lc . f) :*: mfix (rc . f)
where
unLeaf (Leaf x) = x
unLeaf _ =
#if __GLASGOW_HASKELL__ >= 800
errorWithoutStackTrace
#else
error
#endif
"Data.Tree.Binary.Leafy.mfix: :*: encountered, expected Leaf"
lc (x :*: _) = x
lc _ =
#if __GLASGOW_HASKELL__ >= 800
errorWithoutStackTrace
#else
error
#endif
"Data.Tree.Binary.Leafy.mfix: Leaf encountered, expected :*:"
rc (_ :*: y) = y
rc _ =
#if __GLASGOW_HASKELL__ >= 800
errorWithoutStackTrace
#else
error
#endif
"Data.Tree.Binary.Leafy.mfix: Leaf encountered, expected :*:"
#if MIN_VERSION_base(4,4,0)
instance MonadZip Tree where
mzipWith f = go
where
go (Leaf x) (Leaf y) = Leaf (f x y)
go (xl :*: xr) (yl :*: yr) = go xl yl :*: go xr yr
go (Leaf x) (yl :*: yr) = fmap (f x) yl :*: fmap (f x) yr
go (xl :*: xr) (Leaf y) = fmap (flip f y) xl :*: fmap (flip f y) xr
munzip (Leaf (x, y)) = (Leaf x, Leaf y)
munzip (xs :*: ys) = (xl :*: yl, xr :*: yr)
where
(xl, xr) = munzip xs
(yl, yr) = munzip ys
#endif
#if MIN_VERSION_base(4,9,0)
instance Semigroup.Semigroup (Tree a) where
xs@(Leaf _) <> ys = xs :*: ys
(xl :*: xr) <> ys = xl :*: (xr Semigroup.<> ys)
#if __GLASGOW_HASKELL__
#endif
#endif
instance Foldable Tree where
foldr f b (Leaf x) = f x b
foldr f b (xs :*: ys) = foldr f (foldr f b ys) xs
foldl f b (Leaf x) = f b x
foldl f b (xs :*: ys) = foldl f (foldl f b xs) ys
foldMap f (Leaf x) = f x
foldMap f (xs :*: ys) = foldMap f xs `mappend` foldMap f ys
#if __GLASGOW_HASKELL__
#endif
#if MIN_VERSION_base(4,6,0)
foldr' f !b (Leaf x) = f x b
foldr' f !b (xs :*: ys) = case foldr' f b ys of
!b' -> foldr' f b' xs
foldl' f !b (Leaf x) = f b x
foldl' f !b (xs :*: ys) = case foldl' f b xs of
!b' -> foldl' f b' ys
#if __GLASGOW_HASKELL__
#endif
#endif
#if MIN_VERSION_base(4,8,0)
null _ = False
#endif
instance Traversable Tree where
traverse f (Leaf x) = fmap Leaf (f x)
traverse f (xs :*: ys) = liftA2 (:*:) (traverse f xs) (traverse f ys)
#if __GLASGOW_HASKELL
#endif
singleton :: a -> Tree a
singleton = Leaf
instance NFData a => NFData (Tree a) where
rnf (Leaf x) = rnf x
rnf (xs :*: ys) = rnf xs `seq` rnf ys
#if MIN_VERSION_base(4,9,0)
instance Eq1 Tree where
liftEq eq (Leaf x) (Leaf y) = eq x y
liftEq eq (xl :*: xr) (yl :*: yr) = liftEq eq xl yl && liftEq eq xr yr
liftEq _ _ _ = False
instance Ord1 Tree where
liftCompare cmp (Leaf x) (Leaf y) = cmp x y
liftCompare cmp (xl :*: xr) (yl :*: yr) =
liftCompare cmp xl yl `mappend` liftCompare cmp xr yr
liftCompare _ (Leaf _) (_ :*: _) = LT
liftCompare _ (_ :*: _) (Leaf _) = GT
instance Show1 Tree where
liftShowsPrec s _ = go
where
go d (Leaf x) = showParen (d >= 11) $ showString "Leaf " . s 11 x
go d (xs :*: ys) =
showParen (d > 5) $ go 6 xs . showString " :*: " . go 6 ys
instance Read1 Tree where
#if MIN_VERSION_base(4,10,0) && __GLASGOW_HASKELL__
liftReadPrec rp _ = go
where
go =
parens $
prec 10 (expect' (Ident "Leaf") *> fmap Leaf (step rp)) +++
prec 5 (liftA2 (:*:) (step go) (expect' (Symbol ":*:") *> step go))
expect' = lift . expect
liftReadListPrec = liftReadListPrecDefault
#else
liftReadsPrec rp _ = go
where
go p st =
readParen
(p > 10)
(\xs -> [(Leaf x, zs) | ("Leaf", ys) <- lex xs, (x, zs) <- rp 11 ys])
st ++
readParen
(p > 5)
(\ws ->
[ (x :*: y, zs)
| (x, xs) <- go 6 ws
, (":*:", ys) <- lex xs
, (y, zs) <- go 6 ys
])
st
#endif
#endif
foldTree :: (a -> b) -> (b -> b -> b) -> Tree a -> b
foldTree b f = go
where
go (Leaf x) = b x
go (xs :*: ys) = go xs `f` go ys
depth :: Tree a -> Int
depth = foldTree (const 1) (\x y -> succ (max x y))
unfoldTree :: (b -> Either a (b, b)) -> b -> Tree a
unfoldTree f = go
where
go = either Leaf (\(l,r) -> go l :*: 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 <= 1 = fmap Leaf x
| even m = liftA2 (:*:) r r
| otherwise = liftA2 (:*:) r (go (d+1))
where
d = m `div` 2
r = go d
#if __GLASGOW_HASKELL__ >= 800
fromList :: HasCallStack => [a] -> Tree a
#else
fromList :: [a] -> Tree a
#endif
fromList [] = error "Data.Tree.Binary.Leafy.fromList: empty list!"
fromList (x':xs') = go x' xs'
where
go x [] = Leaf x
go a (b:l) = go' (Leaf a :*: Leaf b) (pairMap l)
pairMap (x:y:rest) = (Leaf x :*: Leaf y) : pairMap rest
pairMap [] = []
pairMap [x] = [Leaf x]
go' x [] = x
go' a (b:l) = go' (a :*: b) (pairs l)
pairs (x:y:rest) = (x :*: y) : pairs rest
pairs xs = xs
drawTree :: Show a => Tree a -> String
drawTree t = drawTreeWith show t ""
drawTreeWith :: (a -> String) -> Tree a -> ShowS
drawTreeWith sf = Internal.drawTree (maybe "" sf) (fmap uncons') . Just
where
uncons' (xl :*: xr) = (Nothing, Just xl, Just xr)
uncons' (Leaf x) = (Just x, Nothing, Nothing)
printTree :: Show a => Tree a -> IO ()
printTree = putStr . drawTree