binary-tree (empty) → 0.1.0.0
raw patch · 12 files changed
+2177/−0 lines, 12 filesdep +ChasingBottomsdep +HUnitdep +QuickChecksetup-changed
Dependencies added: ChasingBottoms, HUnit, QuickCheck, base, binary-tree, checkers, criterion, deepseq, doctest, ghc-prim, random, test-framework, test-framework-quickcheck2
Files
- ChangeLog.md +3/−0
- LICENSE +21/−0
- README.md +3/−0
- Setup.hs +2/−0
- bench/bench.hs +13/−0
- binary-tree.cabal +102/−0
- doctest/doctests.hs +4/−0
- src/Data/Tree/Binary/Inorder.hs +479/−0
- src/Data/Tree/Binary/Internal.hs +200/−0
- src/Data/Tree/Binary/Leafy.hs +475/−0
- src/Data/Tree/Binary/Preorder.hs +477/−0
- test/Spec.hs +398/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for binary-tree++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Donnacha Oisín Kidney++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,3 @@+[](https://travis-ci.org/oisdk/binary-tree)++# binary-tree
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -0,0 +1,13 @@+module Main (main) where++import Criterion.Main+import System.Random+import Data.Tree.Binary.Preorder++int :: IO Int+int = randomIO++showAtSize n = env (replicateA n int) $ \xs -> bench (show n) $ nf drawTree xs++main :: IO ()+main = defaultMain (map showAtSize [10000, 100000])
+ binary-tree.cabal view
@@ -0,0 +1,102 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a3b5e36c787d0bbc68253ec588dc76870165b6a14b277df261519294744cb379++name: binary-tree+version: 0.1.0.0+description: Please see the README on Github at <https://github.com/oisdk/binary-tree#readme>+homepage: https://github.com/oisdk/binary-tree#readme+bug-reports: https://github.com/oisdk/binary-tree/issues+author: Donnacha Oisín Kidney+maintainer: mail@doisinkidney.com+copyright: 2018 Donnacha Oisín Kidney+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ ChangeLog.md+ README.md++source-repository head+ type: git+ location: https://github.com/oisdk/binary-tree++library+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns+ build-depends:+ base >=4.0 && <5+ , deepseq+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ if impl(ghc)+ build-depends:+ ghc-prim+ exposed-modules:+ Data.Tree.Binary.Inorder+ Data.Tree.Binary.Internal+ Data.Tree.Binary.Leafy+ Data.Tree.Binary.Preorder+ other-modules:+ Paths_binary_tree+ default-language: Haskell2010++test-suite binary-tree-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ ChasingBottoms >=1.2.2+ , HUnit >=1.1+ , QuickCheck >=1.0+ , base >=4.0 && <5+ , binary-tree+ , checkers >=0.1+ , test-framework >=0.1+ , test-framework-quickcheck2 >=0.2.1+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ other-modules:+ Paths_binary_tree+ default-language: Haskell2010++test-suite doctests+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ hs-source-dirs:+ doctest+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -threaded+ build-depends:+ QuickCheck >=1.0+ , base >=4.0 && <5+ , binary-tree+ , doctest >=0.3.0+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ other-modules:+ Paths_binary_tree+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ main-is: bench.hs+ hs-source-dirs:+ bench+ ghc-options: -Wall -fwarn-incomplete-record-updates -fwarn-incomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends:+ base >=4.0 && <5+ , binary-tree+ , criterion >=0.1+ , random >=1.0.0.0+ if impl(ghc >= 8.0)+ ghc-options: -fwarn-redundant-constraints -Wcompat+ other-modules:+ Paths_binary_tree+ default-language: Haskell2010
+ doctest/doctests.hs view
@@ -0,0 +1,4 @@+import Test.DocTest++main :: IO ()+main = doctest ["-isrc", "src/"]
+ src/Data/Tree/Binary/Inorder.hs view
@@ -0,0 +1,479 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif++-- | +-- Module : Data.Tree.Binary.Inorder+-- Description : A simple, generic, inorder binary tree.+-- Copyright : (c) Donnacha Oisín Kidney, 2018+-- License : MIT+-- Maintainer : mail@doisinkidney.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides a simple inorder binary tree, as is needed+-- in several applications. Instances, if sensible, are defined,+-- and generally effort is made to keep the implementation as+-- generic as possible.++module Data.Tree.Binary.Inorder+ ( -- * The tree type+ Tree(..)+ -- * Construction+ , unfoldTree+ , replicate+ , replicateA+ , singleton+ , empty+ , fromList+ -- * Consumption+ , foldTree+ -- * Querying+ , depth+ -- * Display+ , 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(..))++-- | An inorder binary tree.+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__+ {-# INLINABLE fmap #-}+#endif+ x <$ xs = go xs where+ go Leaf = Leaf+ go (Node l _ r) = Node (go l) x (go r)+ {-# INLINE (<$) #-}++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__+ {-# INLINABLE pure #-}+ {-# INLINABLE (<*>) #-}+#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)+ {-# INLINE liftA2 #-}+#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__+ {-# INLINABLE (*>) #-}+ {-# INLINABLE (<*) #-}+#endif+#endif++instance Alternative Tree where+ empty = Leaf+ {-# INLINE empty #-}+#if MIN_VERSION_base(4,9,0)+ (<|>) = (Semigroup.<>)+#else+ (<|>) = mappend+#endif+ {-# INLINE (<|>) #-}++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__+ {-# INLINABLE foldMap #-}+ {-# INLINABLE foldr #-}+ {-# INLINABLE foldl #-}+#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__+ {-# INLINABLE foldr' #-}+ {-# INLINABLE foldl' #-}+#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__+ {-# INLINABLE traverse #-}+#endif++-- | A binary tree with one element.+singleton :: a -> Tree a+singleton x = Node Leaf x Leaf++{-# INLINE singleton #-}+-- | A binary tree with no elements.+empty :: Tree a+empty = Leaf++{-# INLINE empty #-}+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++-- | Fold over a tree.+--+-- prop> foldTree Leaf Node xs === xs+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)+{-# INLINE foldTree #-}++-- | The depth of the tree.+-- +-- >>> depth empty+-- 0+--+-- >>> depth (singleton ())+-- 1+depth :: Tree a -> Int+depth = foldTree 0 (\l _ r -> succ (max l r))++-- | Unfold a tree from a seed.+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' n a@ creates a tree of size @n@ filled @a@.+--+-- >>> putStr (drawTree (replicate 4 ()))+-- ┌()+-- ┌()┘+-- ()┤+-- └()+--+-- prop> \(NonNegative n) -> length (replicate n ()) === n+replicate :: Int -> a -> Tree a+replicate n x = runIdentity (replicateA n (Identity x))++-- | @'replicateA' n a@ replicates the action @a@ @n@ times, trying+-- to balance the result as much as possible. The actions are executed+-- in a preorder traversal (same as the 'Foldable' instance.)+--+-- >>> toList (evalState (replicateA 10 (State (\s -> (s, s + 1)))) 1)+-- [1,2,3,4,5,6,7,8,9,10]+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++{-# SPECIALISE replicateA :: Int -> Identity a -> Identity (Tree a) #-}+{-# SPECIALISE replicateA :: Int -> State s a -> State s (Tree a) #-}++#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__+ {-# INLINABLE (<>) #-}+#endif+#endif++-- | This instance is necessarily inefficient, to obey the monoid laws.+--+-- >>> printTree (fromList [1..6])+-- ┌1+-- ┌2┤+-- │ └3+-- 4┤+-- │ ┌5+-- └6┘+--+-- >>> printTree (fromList [1..6] `mappend` singleton 7)+-- ┌1+-- ┌2┤+-- │ └3+-- 4┤+-- │ ┌5+-- └6┤+-- └7+--+-- 'mappend' distributes over 'toList':+--+-- prop> toList (mappend xs (ys :: Tree Int)) === mappend (toList xs) (toList ys)+instance Monoid (Tree a) where+#if MIN_VERSION_base(4,9,0)+ mappend = (Semigroup.<>)+ {-# INLINE mappend #-}+#else+ mappend Leaf y = y+ mappend (Node l x r) y = Node l x (mappend r y)+#if __GLASGOW_HASKELL__+ {-# INLINABLE mappend #-}+#endif+#endif+ mempty = Leaf++-- | Construct a tree from a list, in an inorder fashion.+--+-- prop> toList (fromList xs) === xs+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))++-- | Convert a tree to a human-readable structural representation.+--+-- >>> putStr (drawTree (fromList [1..7]))+-- ┌1+-- ┌2┤+-- │ └3+-- 4┤+-- │ ┌5+-- └6┤+-- └7+--+drawTree :: Show a => Tree a -> String+drawTree t = drawTreeWith show t ""++-- | Pretty-print a tree with a custom show function.+--+-- >>> putStr (drawTreeWith (const "─") (fromList [1..7]) "")+-- ┌─+-- ┌─┤+-- │ └─+-- ─┤+-- │ ┌─+-- └─┤+-- └─+--+-- >>> putStr (drawTreeWith id (singleton "abc") "")+-- abc+--+-- >>> putStr (drawTreeWith id (Node (singleton "d") "abc" Leaf) "")+-- ┌d+-- abc┘+--+-- >>> putStr (drawTreeWith id (fromList ["abc", "d", "ef", "ghij"]) "")+-- ┌abc+-- ┌d┘+-- ef┤+-- └ghij+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)+ ++-- | Pretty-print a tree.+--+-- >>> printTree (fromList [1..7])+-- ┌1+-- ┌2┤+-- │ └3+-- 4┤+-- │ ┌5+-- └6┤+-- └7+--+-- >>> printTree (singleton 1)+-- 1+--+-- >>> printTree (singleton 1 `mappend` singleton 2)+-- 1┐+-- └2+printTree :: Show a => Tree a -> IO ()+printTree = putStr . drawTree++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Data.Foldable (toList)+-- >>> import Prelude (Num(..), putStr)+-- >>> :{+-- instance Arbitrary a =>+-- Arbitrary (Tree a) where+-- arbitrary = sized go+-- where+-- go 0 = pure Leaf+-- go n+-- | n <= 0 = pure Leaf+-- | otherwise = oneof [pure Leaf, liftA3 Node sub arbitrary sub]+-- where+-- sub = go (n `div` 2)+-- shrink Leaf = []+-- shrink (Node l x r) =+-- Leaf : l : r :+-- [ Node l' x' r'+-- | (l',x',r') <- shrink (l, x, r) ]+-- :}
+ src/Data/Tree/Binary/Internal.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif++-- |+-- Module : Data.Tree.Binary.Internal+-- Description : Common utility functions for the binary-tree package.+-- Copyright : (c) Donnacha Oisín Kidney 2018+-- License : MIT+-- Maintainer : mail@doisinkidney.com+-- Portability : portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- This contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This module exports some utility functions common to both tree modules.+module Data.Tree.Binary.Internal+ ( -- * Drawing Trees+ Drawing(..)+ , toDrawing+ , runDrawing+ , drawTree+ -- * State+ , State(..)+ , evalState+ -- * Reimplementations for older GHCs+ , Identity(..)+ ) where+import Prelude hiding (+#if MIN_VERSION_base(4,8,0)+ Functor(..),Applicative, (<$>), foldMap, Monoid+#endif+ )++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity (..))+#endif++import Control.Applicative (Applicative (pure, (<*>)))+import Data.Functor (Functor (fmap))++bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True = t+{-# INLINE bool #-}++--------------------------------------------------------------------------------+-- Drawing Trees+--------------------------------------------------------------------------------++-- | An abstract representation of a textual drawing of a tree.+data Drawing+ = Nil+ | NewLine !Drawing+ | BottomLeft !Drawing+ | BottomRight !Drawing+ | TopLeft !Drawing+ | TopRight !Drawing+ | Vert !Drawing+ | Split !Drawing+ | Item !String Drawing+ | Padding {-# UNPACK #-} !Int !Drawing++-- | A function to convert a drawing to a string.+runDrawing :: Drawing -> ShowS+runDrawing Nil = showString "╼\n"+runDrawing ys = go ys+ where+ go Nil st = st+ go (NewLine xs) st = '\n' : go xs st+ go (BottomLeft xs) st = '└' : go xs st+ go (BottomRight xs) st = '┘' : go xs st+ go (TopLeft xs) st = '┌' : go xs st+ go (TopRight xs) st = '┐' : go xs st+ go (Vert xs) st = '│' : go xs st+ go (Split xs) st = '┤' : go xs st+ go (Item x xs) st = x ++ go xs st+ go (Padding i xs) st = pad i (go xs st)+ pad 0 = id+ pad n = showChar ' ' . pad (n-1)+{-# INLINE runDrawing #-}+++-- | Given an uncons function for a binary tree, draw the tree in a structured,+-- human-readable way.+drawTree :: (a -> String) -> (t -> Maybe (a, t, t)) -> t -> ShowS+drawTree sf project = runDrawing . toDrawing sf project+{-# INLINE drawTree #-}++-- | Convert a tree to the Drawing type. This function is exposed so that users+-- may replace the call to 'runDrawing' in 'drawTree' with a more efficient+-- implementation that could use (for example) 'Text'.+toDrawing :: (a -> String) -> (t -> Maybe (a, t, t)) -> t -> Drawing+toDrawing sf project = maybe Nil root . project+ where+ go dir k len (x, l, r) = node dir len x (project l) (project r) k++ -- Root special case (no incoming direction)+ root (x, l, r) =+ maybeAp (go True id xlen) ls $+ Item xshw $ endc ls rs $ NewLine $ maybeAp (go False id xlen) rs Nil+ where+ xshw = sf x+ xlen = length xshw+ ls = project l+ rs = project r++ node up i x ls rs k b =+ maybeAp (branch True) ls $+ k $+ pad i $+ bool BottomLeft TopLeft up $+ Item xshw $ endc ls rs $ NewLine $ maybeAp (branch False) rs b+ where+ xshw = sf x+ xlen = length xshw+ branch d+ | d == up = go d (k . pad i) (xlen + 1)+ | otherwise = go d (k . pad i . Vert) xlen+ {-# INLINE branch #-}+ {-# INLINE node #-}++ endc Nothing Nothing b = b+ endc (Just _) Nothing b = BottomRight b+ endc Nothing (Just _) b = TopRight b+ endc (Just _) (Just _) b = Split b+ {-# INLINE endc #-}++ pad i (Padding j xs) = Padding (i+j) xs+ pad i xs = Padding i xs+ {-# INLINE pad #-}++ maybeAp _ Nothing y = y+ maybeAp f (Just x) y = f x y+ {-# INLINE maybeAp #-}+{-# INLINE toDrawing #-}++--------------------------------------------------------------------------------+-- State+--------------------------------------------------------------------------------++-- | A clone of Control.Monad.State.Strict, reimplemented here to avoid the+-- dependency.+newtype State s a = State+ { runState :: s -> (a, s)+ }++instance Functor (State s) where+ fmap f xs =+ State+ (\s ->+ case runState xs s of+ (x, s') -> (f x, s'))+ {-# INLINE fmap #-}++instance Applicative (State s) where+ pure x = State (\s -> (x, s))+ {-# INLINE pure #-}+ fs <*> xs =+ State+ (\s ->+ case runState fs s of+ (f, s') ->+ case runState xs s' of+ (x, s'') -> (f x, s''))+ {-# INLINE (<*>) #-}++-- | Evaluate a stateful action.+evalState :: State s a -> s -> a+evalState xs s = fst (runState xs s)+{-# INLINE evalState #-}++--------------------------------------------------------------------------------+-- Identity+--------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+-- | A clone of Data.Functor.Identity, reimplemented here when it's not yet+-- included in base.+newtype Identity a = Identity {runIdentity :: a}++instance Functor Identity where+ fmap f (Identity x) = Identity (f x)++instance Applicative Identity where+ pure = Identity+ Identity f <*> Identity x = Identity (f x)+#endif
+ src/Data/Tree/Binary/Leafy.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif+++-- |+-- Module : Data.Tree.Binary.Leafy+-- Description : A simple, generic, leafy binary tree.+-- Copyright : (c) Donnacha Oisín Kidney, 2018+-- License : MIT+-- Maintainer : mail@doisinkidney.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides a simple leafy binary tree, as is needed+-- in several applications. Instances, if sensible, are defined,+-- and generally effort is made to keep the implementation as+-- generic as possible.++module Data.Tree.Binary.Leafy+ ( -- * The tree type+ Tree(..)+ -- * Construction+ , unfoldTree+ , replicate+ , replicateA+ , singleton+ , fromList+ -- * Consumption+ , foldTree+ -- * Querying+ , depth+ -- * Display+ , 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++-- | A leafy binary tree.+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__+ {-# INLINABLE fmap #-}+#endif+ x <$ xs = go xs where+ go (Leaf _) = Leaf x+ go (ls :*: rs) = go ls :*: go rs+ {-# INLINE (<$) #-}++instance Applicative Tree where+ pure = Leaf+ {-# INLINE pure #-}+ Leaf f <*> xs = fmap f xs+ (fs :*: gs) <*> xs = (fs <*> xs) :*: (gs <*> xs)+#if __GLASGOW_HASKELL__+ {-# INLINABLE (<*>) #-}+#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+ {-# INLINE liftA2 #-}+#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__+ {-# INLINABLE (*>) #-}+ {-# INLINABLE (<*) #-}+#endif+#endif++instance Monad Tree where+#if !MIN_VERSION_base(4,8,0)+ return = pure+ {-# INLINE return #-}+ (>>) = (*>)+ {-# INLINE (>>) #-}+#endif+ Leaf x >>= f = f x+ (xl :*: xr) >>= f = (xl >>= f) :*: (xr >>= f)+#if __GLASGOW_HASKELL__+ {-# INLINABLE (>>=) #-}+#endif++-- |+-- <http://leventerkok.github.io/papers/erkok-thesis.pdf Erkok, Levent. “Value Recursion in Monadic Computations.” PhD Thesis, Oregon Health & Science University, 2002.>+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__+ {-# INLINABLE (<>) #-}+#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__+ {-# INLINABLE foldr #-}+ {-# INLINABLE foldl #-}+ {-# INLINABLE foldMap #-}+#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__+ {-# INLINABLE foldr' #-}+ {-# INLINABLE foldl' #-}+#endif+#endif++#if MIN_VERSION_base(4,8,0)+ null _ = False+ {-# INLINE null #-}+#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+ {-# INLINABLE traverse #-}+#endif++-- | A binary tree with one element.+singleton :: a -> Tree a+singleton = Leaf+{-# INLINE singleton #-}++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++-- | Fold over a tree.+--+-- prop> foldTree Leaf (:*:) xs === xs+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+{-# INLINE foldTree #-}++-- | The depth of the tree.+--+-- >>> depth (singleton ())+-- 1+depth :: Tree a -> Int+depth = foldTree (const 1) (\x y -> succ (max x y))++-- | Unfold a tree from a seed.+unfoldTree :: (b -> Either a (b, b)) -> b -> Tree a+unfoldTree f = go+ where+ go = either Leaf (\(l,r) -> go l :*: go r) . f++-- | @'replicate' n a@ creates a tree of size @n@ filled with @a@.+--+-- >>> printTree (replicate 4 ())+-- ┌()+-- ┌┤+-- │└()+-- ┤+-- │┌()+-- └┤+-- └()+--+-- prop> \(Positive n) -> length (replicate n ()) === n+replicate :: Int -> a -> Tree a+replicate n x = runIdentity (replicateA n (Identity x))++-- | @'replicateA' n a@ replicates the action @a@ @n@ times, trying+-- to balance the result as much as possible. The actions are executed+-- in the same order as the 'Foldable' instance.+--+-- >>> toList (evalState (replicateA 10 (State (\s -> (s, s + 1)))) 1)+-- [1,2,3,4,5,6,7,8,9,10]+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+{-# SPECIALISE replicateA :: Int -> Identity a -> Identity (Tree a) #-}+{-# SPECIALISE replicateA :: Int -> State s a -> State s (Tree a) #-}++-- | Construct a tree from a list.+--+-- The constructed tree is somewhat, but not totally, balanced.+--+-- >>> printTree (fromList [1,2,3,4])+-- ┌1+-- ┌┤+-- │└2+-- ┤+-- │┌3+-- └┤+-- └4+--+-- >>> printTree (fromList [1,2,3,4,5,6])+-- ┌1+-- ┌┤+-- │└2+-- ┌┤+-- ││┌3+-- │└┤+-- │ └4+-- ┤+-- │┌5+-- └┤+-- └6++#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++-- | Convert a tree to a human-readable structural representation.+--+-- >>> putStr (drawTree (Leaf 1 :*: Leaf 2 :*: Leaf 3))+-- ┌1+-- ┌┤+-- │└2+-- ┤+-- └3+drawTree :: Show a => Tree a -> String+drawTree t = drawTreeWith show t ""++-- | Pretty-print a tree with a custom show function.+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)++-- | Pretty-print a tree+printTree :: Show a => Tree a -> IO ()+printTree = putStr . drawTree++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Data.Foldable (toList, length)+-- >>> import Prelude (Num(..), putStr)+-- >>> import Data.Tree.Binary.Internal (evalState, State(..))+-- >>> :{+-- instance Arbitrary a =>+-- Arbitrary (Tree a) where+-- arbitrary = sized go+-- where+-- go n+-- | n <= 0 = fmap Leaf arbitrary+-- | otherwise = oneof [fmap Leaf arbitrary, liftA2 (:*:) sub sub]+-- where+-- sub = go (n `div` 2)+-- shrink (Leaf x) = fmap Leaf (shrink x)+-- shrink (l :*: r) =+-- l : r :+-- [ l' :*: r'+-- | (l',r') <- shrink (l, r) ]+-- :}
+ src/Data/Tree/Binary/Preorder.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE BangPatterns #-}+#if __GLASGOW_HASKELL__+{-# LANGUAGE DeriveDataTypeable #-}+#endif+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+#if __GLASGOW_HASKELL__ >= 703+{-# LANGUAGE Safe #-}+#endif+++-- |+-- Module : Data.Tree.Binary.Preorder+-- Description : A simple, generic, preorder binary tree.+-- Copyright : (c) Donnacha Oisín Kidney, 2018+-- License : MIT+-- Maintainer : mail@doisinkidney.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides a simple preorder binary tree, as is needed+-- in several applications. Instances, if sensible, are defined,+-- and generally effort is made to keep the implementation as+-- generic as possible.++module Data.Tree.Binary.Preorder+ ( -- * The tree type+ Tree(..)+ -- * Construction+ , unfoldTree+ , replicate+ , replicateA+ , singleton+ , empty+ , fromList+ -- * Consumption+ , foldTree+ -- * Querying+ , depth+ -- * Display+ , 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 (Alternative, Applicative (..),+ liftA2, liftA3)+import qualified Control.Applicative as Alternative (empty, (<|>))++import Control.DeepSeq (NFData (rnf))++import Data.Functor (Functor (fmap, (<$)))+import Data.Monoid (Monoid (mappend, mempty))++#if MIN_VERSION_base(4,6,0)+import Data.Foldable (Foldable (foldMap, foldl, foldl', foldr, foldr'))+#else+import Data.Foldable (Foldable (foldMap, foldl, foldr))+#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 Data.Tree.Binary.Internal (Identity (..), State (..),+ evalState)+import qualified Data.Tree.Binary.Internal as Internal++-- | A preorder binary tree.+data Tree a+ = Leaf+ | Node 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 _ Leaf = Leaf+ fmap f (Node x l r) = Node (f x) (fmap f l) (fmap f r)+#if __GLASGOW_HASKELL__+ {-# INLINABLE fmap #-}+#endif+ x <$ xs = go xs where+ go Leaf = Leaf+ go (Node _ l r) = Node x (go l) (go r)+ {-# INLINE (<$) #-}++instance Applicative Tree where+ pure x = y where y = Node x y y+ Leaf <*> _ = Leaf+ Node _ _ _ <*> Leaf = Leaf+ Node f fl fr <*> Node x xl xr = Node (f x) (fl <*> xl) (fr <*> xr)+#if __GLASGOW_HASKELL__+ {-# INLINABLE pure #-}+ {-# INLINABLE (<*>) #-}+#endif+#if MIN_VERSION_base(4,10,0)+ liftA2 f = go where+ go Leaf _ = Leaf+ go (Node _ _ _) Leaf = Leaf+ go (Node x xl xr) (Node y yl yr) = Node (f x y) (go xl yl) (go xr yr)+ {-# INLINE liftA2 #-}+#endif+#if MIN_VERSION_base(4,2,0)+ Leaf *> _ = Leaf+ Node _ _ _ *> Leaf = Leaf+ Node _ xl xr *> Node y yl yr = Node y (xl *> yl) (xr *> yr)+ Leaf <* _ = Leaf+ Node _ _ _ <* Leaf = Leaf+ Node x xl xr <* Node _ yl yr = Node x (xl <* yl) (xr <* yr)+#if __GLASGOW_HASKELL__+ {-# INLINABLE (*>) #-}+ {-# INLINABLE (<*) #-}+#endif+#endif++instance Alternative Tree where+ empty = Leaf+ {-# INLINE empty #-}+#if MIN_VERSION_base(4,9,0)+ (<|>) = (Semigroup.<>)+#else+ (<|>) = mappend+#endif+ {-# INLINE (<|>) #-}++instance Foldable Tree where+ foldr _ b Leaf = b+ foldr f b (Node x l r) = f x (foldr f (foldr f b r) l)++ foldl _ b Leaf = b+ foldl f b (Node x l r) = foldl f (foldl f (f b x) l) r++ foldMap _ Leaf = mempty+ foldMap f (Node x l r) = f x `mappend` foldMap f l `mappend` foldMap f r++#if __GLASGOW_HASKELL__+ {-# INLINABLE foldMap #-}+ {-# INLINABLE foldr #-}+ {-# INLINABLE foldl #-}+#endif+++#if MIN_VERSION_base(4,6,0)+ foldr' _ !b Leaf = b+ foldr' f !b (Node x l r) = case foldr' f b r of+ !b' -> case foldr' f b' l of+ !b'' -> f x b''++ foldl' _ !b Leaf = b+ foldl' f !b (Node x l r) = case f b x of+ !b' -> case foldl' f b' l of+ !b'' -> foldl' f b'' r+#if __GLASGOW_HASKELL__+ {-# INLINABLE foldr' #-}+ {-# INLINABLE foldl' #-}+#endif+#endif++instance Traversable Tree where+ traverse _ Leaf = pure Leaf+ traverse f (Node x l r) = liftA3 Node (f x) (traverse f l) (traverse f r)+#if __GLASGOW_HASKELL__+ {-# INLINABLE traverse #-}+#endif++-- | A binary tree with one element.+singleton :: a -> Tree a+singleton x = Node x Leaf Leaf++{-# INLINE singleton #-}+-- | A binary tree with no elements.+empty :: Tree a+empty = Leaf++{-# INLINE empty #-}+instance NFData a => NFData (Tree a) where+ rnf Leaf = ()+ rnf (Node x l r) = rnf x `seq` rnf l `seq` rnf r++#if MIN_VERSION_base(4,9,0)+instance Eq1 Tree where+ liftEq _ Leaf Leaf = True+ liftEq eq (Node x xl xr) (Node y yl yr) =+ eq x y && liftEq eq xl yl && liftEq eq xr yr+ liftEq _ _ _ = False++instance Ord1 Tree where+ liftCompare _ Leaf Leaf = EQ+ liftCompare cmp (Node x xl xr) (Node y yl yr) =+ cmp x y `mappend` liftCompare cmp xl yl `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 x l r) =+ showParen (d >= 11) $+ showString "Node " .+ s 11 x . showChar ' ' . go 11 l . 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 rp) (step go) (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 x l r, zs)+ | ("Node", ws) <- lex vs+ , (x, xs) <- rp 11 ws+ , (l, ys) <- go 11 xs+ , (r, zs) <- go 11 ys+ ])+ st+#endif+#endif++-- | Fold over a tree.+--+-- prop> foldTree Leaf Node xs === xs+foldTree :: b -> (a -> b -> b -> b) -> Tree a -> b+foldTree b f = go+ where+ go Leaf = b+ go (Node x l r) = f x (go l) (go r)+{-# INLINE foldTree #-}++-- | The depth of the tree.+--+-- >>> depth empty+-- 0+--+-- >>> depth (singleton ())+-- 1+depth :: Tree a -> Int+depth = foldTree 0 (\_ l r -> succ (max l r))++-- | Unfold a tree from a seed.+unfoldTree :: (b -> Maybe (a, b, b)) -> b -> Tree a+unfoldTree f = go+ where+ go = maybe Leaf (\(x, l, r) -> Node x (go l) (go r)) . f++-- | @'replicate' n a@ creates a tree of size @n@ filled @a@.+--+-- >>> putStr (drawTree (replicate 4 ()))+-- ┌()+-- ┌()┘+-- ()┤+-- └()+--+-- prop> \(NonNegative n) -> length (replicate n ()) === n+replicate :: Int -> a -> Tree a+replicate n x = runIdentity (replicateA n (Identity x))++-- | @'replicateA' n a@ replicates the action @a@ @n@ times, trying+-- to balance the result as much as possible. The actions are executed+-- in a preorder traversal (same as the 'Foldable' instance.)+--+-- >>> toList (evalState (replicateA 10 (State (\s -> (s, s + 1)))) 1)+-- [1,2,3,4,5,6,7,8,9,10]+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 x r (go (d - 1))+ | otherwise = liftA3 Node x r r+ where+ d = m `div` 2+ r = go d++{-# SPECIALISE replicateA :: Int -> Identity a -> Identity (Tree a) #-}+{-# SPECIALISE replicateA :: Int -> State s a -> State s (Tree a) #-}++#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__+ {-# INLINABLE (<>) #-}+#endif+#endif++-- | This instance is necessarily inefficient, to obey the monoid laws.+--+-- >>> printTree (fromList [1..6])+-- ┌3+-- ┌2┤+-- │ └4+-- 1┤+-- │ ┌6+-- └5┘+--+-- >>> printTree (fromList [1..6] `mappend` singleton 7)+-- ┌3+-- ┌2┤+-- │ └4+-- 1┤+-- │ ┌6+-- └5┤+-- └7+--+-- 'mappend' distributes over 'toList':+--+-- prop> toList (mappend xs (ys :: Tree Int)) === mappend (toList xs) (toList ys)+instance Monoid (Tree a) where+#if MIN_VERSION_base(4,9,0)+ mappend = (Semigroup.<>)+ {-# INLINE mappend #-}+#else+ mappend Leaf y = y+ mappend (Node x l r) y = Node x l (mappend r y)+#if __GLASGOW_HASKELL__+ {-# INLINABLE mappend #-}+#endif+#endif+ mempty = Leaf++-- | Construct a tree from a list, in an preorder fashion.+--+-- prop> toList (fromList xs) === xs+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.Preorder.fromList: bug!"+ z:zs -> (z, zs))++-- | Convert a tree to a human-readable structural representation.+--+-- >>> putStr (drawTree (fromList [1..7]))+-- ┌3+-- ┌2┤+-- │ └4+-- 1┤+-- │ ┌6+-- └5┤+-- └7+drawTree :: Show a => Tree a -> String+drawTree t = drawTreeWith show t ""++-- | Pretty-print a tree with a custom show function.+--+-- >>> putStr (drawTreeWith (const "─") (fromList [1..7]) "")+-- ┌─+-- ┌─┤+-- │ └─+-- ─┤+-- │ ┌─+-- └─┤+-- └─+--+-- >>> putStr (drawTreeWith id (singleton "abc") "")+-- abc+--+-- >>> putStr (drawTreeWith id (Node "abc" (singleton "d") Leaf) "")+-- ┌d+-- abc┘+--+-- >>> putStr (drawTreeWith id (fromList ["abc", "d", "ef", "ghij"]) "")+-- ┌ef+-- ┌d┘+-- abc┤+-- └ghij+drawTreeWith :: (a -> String) -> Tree a -> ShowS+drawTreeWith sf = Internal.drawTree sf uncons'+ where+ uncons' Leaf = Nothing+ uncons' (Node x l r) = Just (x, l, r)++-- | Pretty-print a tree.+--+-- >>> printTree (fromList [1..7])+-- ┌3+-- ┌2┤+-- │ └4+-- 1┤+-- │ ┌6+-- └5┤+-- └7+--+-- >>> printTree (singleton 1 `mappend` singleton 2)+-- 1┐+-- └2+printTree :: Show a => Tree a -> IO ()+printTree = putStr . drawTree++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Data.Foldable (toList)+-- >>> import Prelude (Num(..), putStr)+-- >>> :{+-- instance Arbitrary a =>+-- Arbitrary (Tree a) where+-- arbitrary = sized go+-- where+-- go 0 = pure Leaf+-- go n+-- | n <= 0 = pure Leaf+-- | otherwise = oneof [pure Leaf, liftA3 Node arbitrary sub sub]+-- where+-- sub = go (n `div` 2)+-- shrink Leaf = []+-- shrink (Node x l r) =+-- Leaf : l : r :+-- [ Node x' l' r'+-- | (x',l',r') <- shrink (x, l, r) ]+-- :}
+ test/Spec.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Test.QuickCheck+import Test.QuickCheck.Poly+import Test.QuickCheck.Checkers+import Test.QuickCheck.Classes+import Test.ChasingBottoms+import Test.Framework as Framework+import Test.Framework.Providers.QuickCheck2++import qualified Data.Tree.Binary.Preorder as Preorder+import qualified Data.Tree.Binary.Leafy as Leafy+import qualified Data.Tree.Binary.Inorder as Inorder++import Control.Applicative+import Data.Foldable+import Data.Traversable++#if MIN_VERSION_base(4,9,0)+import Data.Functor.Classes+#endif++import Prelude hiding+ ( replicate+#if MIN_VERSION_base(4,8,0)+ ,Functor(..),Foldable(..),Applicative, (<$>), foldMap, Monoid+#else+ ,foldr,foldl+#endif+ )++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 qualified Data.Semigroup as Semigroup+#endif++import Text.Read++--------------------------------------------------------------------------------+-- Lifted Properties+--------------------------------------------------------------------------------+#if MIN_VERSION_base(4,9,0)+eq1Prop ::+ (Eq (f OrdA), Eq1 f, Show (f OrdA), Arbitrary (f OrdA))+ => f OrdA+ -> Property+eq1Prop p =+ forAllShrink arbitrary shrink $ \xs ->+ forAllShrink (oneof [pure xs, arbitrary]) shrink $ \ys ->+ (Lifted xs == Lifted ys) === ((xs `asTypeOf` p) == ys)++ord1Prop ::+ (Ord (f OrdA), Ord1 f, Show (f OrdA), Arbitrary (f OrdA))+ => f OrdA+ -> Property+ord1Prop p =+ forAllShrink arbitrary shrink $ \xs ->+ forAllShrink (oneof [pure xs, arbitrary]) shrink $ \ys ->+ (Lifted xs `compare` Lifted ys) === ((xs `asTypeOf` p) `compare` ys)++showProp :: (Show1 f, Show (f A)) => f () -> f A -> Property+showProp _ xs = show xs === show (Lifted xs)++readProp ::+ (Read1 f, Show (f (f Int)), Read (f Int), EqProp (f (f Int)), Arbitrary (f (f Int)))+ => f (f Int)+ -> Property+readProp p = inverseL reader show+ where+ reader str = runLifted (read str) `asTypeOf` p++liftedProperties+ :: (Ord (f OrdA)+ ,Ord1 f+ ,Show (f OrdA)+ ,Arbitrary (f OrdA)+ ,Show1 f+ ,Arbitrary (f A)+ ,Show (f A)+ ,Read1 f+ ,Show (f (f Int))+ ,Read (f Int)+ ,EqProp (f (f Int))+ ,Arbitrary (f (f Int))+ ,EqProp (f OrdA))+ => (OrdA -> f OrdA) -> Framework.Test+liftedProperties t =+ testGroup+ "Lifted Classes"+ [ testBatch (ord (\x -> oneof [pure x, arbitrary `asTypeOf` conv3 t]))+ , testProperty "eq1" (eq1Prop (t undefined))+ , testProperty "ord1 consistency" (ord1Prop (t undefined))+ , testProperty "show1" (showProp (conv t))+ , testProperty "read1" (readProp (conv2 t))]+ where+ conv :: (OrdA -> f OrdA) -> f ()+ conv = undefined+ conv2 :: (OrdA -> f OrdA) -> f (f Int)+ conv2 = undefined+ conv3 :: (OrdA -> f OrdA) -> Gen (Lifted f OrdA)+ conv3 = undefined+#endif++--------------------------------------------------------------------------------+-- Folds+--------------------------------------------------------------------------------++foldlProp ::+ (Foldable f)+ => f ()+ -> f A+ -> Fun (B, A) B+ -> B+ -> Property+foldlProp _ xs f b =+ foldl (applyFun2 f) b (toList xs) === foldl (applyFun2 f) b xs++foldrProp' ::+ (Foldable f)+ => f ()+ -> f A+ -> Fun (A, B) B+ -> B+ -> Property+foldrProp' _ xs f b = foldr' (applyFun2 f) b xs === foldr (applyFun2 f) b xs++foldlProp' ::+ (Foldable f)+ => f ()+ -> f A+ -> Fun (B, A) B+ -> B+ -> Property+foldlProp' _ xs f b =+ foldl' (applyFun2 f) b xs === foldl (applyFun2 f) b xs++foldMapProp :: Foldable f => f () -> f A -> Fun A [B] -> Property+foldMapProp _ xs f =+ foldMap (applyFun f) (toList xs) === foldMap (applyFun f) xs++indexed :: Traversable f => f a -> (Int, f Int)+indexed = mapAccumL (\a _ -> (a+1, a)) 0++foldrStrictProp :: (Show (f Int), Traversable f) => f () -> f () -> Property+foldrStrictProp _ xs' =+ conjoin+ [ counterexample (unlines [show xs, show ys, show i]) $+ isBottom (foldr' c b xs) === isBottom (foldr' c b ys)+ | b+ -- error "too strict",+ <-+ [0 :: Int]+ , (i, c) <- zip [(-1 :: Int) ..] fns+ ]+ where+ (n, xs) = indexed xs'+ ys = [0 .. n - 1]+ fns =+ const :+ [ \y _ ->+ if x == y+ then error "too strict"+ else y+ | x <- ys+ ]++foldlStrictProp :: (Show (f Int), Traversable f) => f () -> f () -> Property+foldlStrictProp _ xs' =+ conjoin+ [ counterexample (unlines [show xs, show ys, show i]) $+ isBottom (foldl' c b xs) == isBottom (foldl' c b ys)+ | b <- [error "too strict", 0]+ , (i, c) <- zip [(-1 :: Int) ..] fns+ ]+ where+ (n, xs) = indexed xs'+ ys = [(0 :: Int) .. n - 1]+ fns =+ const id :+ [ \_ y ->+ if x == y+ then error "too strict"+ else y+ | x <- ys+ ]++foldProperties+ :: (Arbitrary (f A)+ ,Show (f A)+ ,Show (f Int)+ ,Arbitrary (f ())+ ,Show (f ())+ ,Traversable f)+ => f () -> Framework.Test+foldProperties p =+ testGroup+ "Folds"+ [ testProperty "foldl" (foldlProp p)+ , testProperty "foldr'" (foldrProp' p)+ , testProperty "foldl'" (foldlProp' p)+ , testProperty "foldMap" (foldMapProp p)+ , testProperty "foldrStrict" (foldrStrictProp p)+#if MIN_VERSION_base(4,8,0) || !MIN_VERSION_base(4,6,0)+ , testProperty "foldlStrict" (foldlStrictProp p)+#endif+ ]++++--------------------------------------------------------------------------------+-- Display+--------------------------------------------------------------------------------++endsInNewlineProp :: (a -> String) -> a -> Property+endsInNewlineProp f x =+ maybe (counterexample "shouldn't be empty" False) ('\n' ===) (last' (f x))+ where+ last' =+ foldl'+ (\_ e ->+ Just e)+ Nothing++--------------------------------------------------------------------------------+-- Helper for Checker format+--------------------------------------------------------------------------------++testBatch :: TestBatch -> Framework.Test+testBatch (name, tests) = testGroup name (map (uncurry testProperty) tests)++main :: IO ()+main =+ defaultMain+ [ testGroup+ "Preorder"+ [ testBatch (monoid (Preorder.Leaf :: Preorder.Tree A))+ , testProperty "toList . fromList" (inverseL toList (Preorder.fromList :: [Int] -> Preorder.Tree Int))+#if MIN_VERSION_base(4,9,0)+ , liftedProperties (const Preorder.Leaf)+#endif+ , foldProperties Preorder.Leaf+ , testBatch (functor (undefined :: Preorder.Tree (A, B, C)))+ , testBatch+ ( "applicative"+ , [ (name, test)+ | (name, test) <- snd $ applicative (undefined :: Preorder.Tree (A, B, C))+ , name /= "homomorphism"+ ])+ , testBatch (traversable (undefined :: Preorder.Tree (A, B, [Int])))+ , testBatch (alternative (undefined :: Preorder.Tree A))+ , testProperty "drawTree ends in newline" (endsInNewlineProp (Preorder.drawTree :: Preorder.Tree A -> String))+ ]+ , testGroup+ "Inorder"+ [ testBatch (monoid (Inorder.Leaf :: Inorder.Tree A))+ , testProperty "toList . fromList" (inverseL toList (Inorder.fromList :: [Int] -> Inorder.Tree Int))+#if MIN_VERSION_base(4,9,0)+ , liftedProperties (const Inorder.Leaf)+#endif+ , foldProperties Inorder.Leaf+ , testBatch+ ( "applicative"+ , [ (name, test)+ | (name, test) <- snd $ applicative (undefined :: Inorder.Tree (A, B, C))+ , name /= "homomorphism"+ ])+ , testBatch (functor (undefined :: Inorder.Tree (A, B, C)))+ , testBatch (traversable (undefined :: Inorder.Tree (A, B, [Int])))+ , testBatch (alternative (undefined :: Inorder.Tree A))+ , testProperty "drawTree ends in newline" (endsInNewlineProp (Inorder.drawTree :: Inorder.Tree A -> String))+ ]+ , testGroup+ "Leafy"+ [+#if MIN_VERSION_base(4,9,0)+ testProperty "semigroup" (isAssoc ((Semigroup.<>) :: Leafy.Tree Int -> Leafy.Tree Int -> Leafy.Tree Int) ) ,+#endif+ testProperty "toList . fromList" (inverseL (NonEmpty . toList) (Leafy.fromList . getNonEmpty :: NonEmptyList Int -> Leafy.Tree Int))+#if MIN_VERSION_base(4,9,0)+ , liftedProperties Leafy.Leaf+#endif+ , foldProperties (Leafy.Leaf undefined)+ , testBatch (functor (undefined :: Leafy.Tree (A, B, C)))+ , testBatch (applicative (undefined :: Leafy.Tree (A, B, C)))+ , testBatch (monad (undefined :: Leafy.Tree (A, B, C)))+ , testBatch (monadFunctor (undefined :: Leafy.Tree (A, B)))+ , testBatch (monadApplicative (undefined :: Leafy.Tree (A, B)))+ , testBatch (traversable (undefined :: Leafy.Tree (A, B, [Int])))+ , testProperty "drawTree ends in newline" (endsInNewlineProp (Leafy.drawTree :: Leafy.Tree A -> String))+ ]+ ]++--------------------------------------------------------------------------------+-- Arbitrary Instances+--------------------------------------------------------------------------------+instance Arbitrary a => Arbitrary (Preorder.Tree a) where+ arbitrary = sized go+ where+ go n+ | n <= 0 = pure Preorder.Leaf+ | otherwise =+ oneof [pure Preorder.Leaf, liftA3 Preorder.Node arbitrary sub sub]+ where+ sub = go (n `div` 2)+ shrink Preorder.Leaf = []+ shrink (Preorder.Node x l r) =+ Preorder.Leaf :+ l : r : [Preorder.Node x' l' r' | (x', l', r') <- shrink (x, l, r)]++instance Arbitrary a => Arbitrary (Inorder.Tree a) where+ arbitrary = sized go+ where+ go n+ | n <= 0 = pure Inorder.Leaf+ | otherwise =+ oneof [pure Inorder.Leaf, liftA3 Inorder.Node sub arbitrary sub]+ where+ sub = go (n `div` 2)+ shrink Inorder.Leaf = []+ shrink (Inorder.Node l x r) =+ Inorder.Leaf :+ l : r : [Inorder.Node l' x' r' | (l', x', r') <- shrink (l, x, r)]++instance Arbitrary a => Arbitrary (Leafy.Tree a) where+ arbitrary = sized go+ where+ go n+ | n <= 0 = fmap Leafy.Leaf arbitrary+ | otherwise =+ oneof [fmap Leafy.Leaf arbitrary, liftA2 (Leafy.:*:) sub sub]+ where+ sub = go (n `div` 2)+ shrink (Leafy.Leaf x) = fmap Leafy.Leaf (shrink x)+ shrink (l Leafy.:*: r) =+ l : r : [l' Leafy.:*: r' | (l', r') <- shrink (l, r)]++--------------------------------------------------------------------------------+-- EqProp Instances+--------------------------------------------------------------------------------+instance (Show a, Eq a) => EqProp (Preorder.Tree a) where+ x =-= y =+ whenFail+ (putStrLn (Preorder.drawTree x ++ "\n/=\n" ++ Preorder.drawTree y))+ (x == y)++instance (Show a, Eq a) => EqProp (Inorder.Tree a) where+ x =-= y =+ whenFail+ (putStrLn (Inorder.drawTree x ++ "\n/=\n" ++ Inorder.drawTree y))+ (x == y)++instance (Show a, Eq a) => EqProp (Leafy.Tree a) where+ x =-= y =+ whenFail+ (putStrLn (Leafy.drawTree x ++ "\n/=\n" ++ Leafy.drawTree y))+ (x == y)++instance (Eq a, Show a) => EqProp (NonEmptyList a) where+ (=-=) = (===)+--------------------------------------------------------------------------------+-- Lifted+--------------------------------------------------------------------------------++#if MIN_VERSION_base(4,9,0)+newtype Lifted f a = Lifted { runLifted :: f a }++instance (Eq1 f, Eq a) => Eq (Lifted f a) where+ Lifted xs == Lifted ys = eq1 xs ys++instance (Ord1 f, Ord a) => Ord (Lifted f a) where+ compare (Lifted xs) (Lifted ys) = compare1 xs ys++instance (Show1 f, Show a) => Show (Lifted f a) where+ showsPrec n (Lifted xs) = showsPrec1 n xs+ showList xs = liftShowList showsPrec showList [ x | Lifted x <- xs ]++instance (Read1 f, Read a) => Read (Lifted f a) where+#if MIN_VERSION_base(4,10,0)+ readPrec = fmap Lifted readPrec1+#else+ readsPrec n xs = [ (Lifted x,ys) | (x, ys) <- readsPrec1 n xs ]+#endif++instance EqProp (f a) => EqProp (Lifted f a) where+ Lifted x =-= Lifted y = x =-= y++instance Arbitrary (f a) => Arbitrary (Lifted f a) where+ arbitrary = fmap Lifted arbitrary+ shrink (Lifted xs) = fmap Lifted (shrink xs)+#endif