rose-trees 0.0.1.1 → 0.0.2

raw patch · 13 files changed

+752/−60 lines, 13 filesdep +criteriondep +mtldep +rose-treesdep −data-defaultdep −hspecdep −pseudo-triedep ~basesetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion, mtl, rose-trees, semigroupoids, sets, tasty, tasty-quickcheck, witherable

Dependencies removed: data-default, hspec, pseudo-trie, transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Setup.hs +0/−2
• bench/Bench.hs +18/−0
• bench/Data/Tree/KnuthBench.hs +50/−0
• bench/Data/Tree/SetBench.hs +47/−0
• bench/Data/TreeBench.hs +49/−0
• rose-trees.cabal +51/−7
• src/Data/Tree/Knuth.hs +131/−27
• src/Data/Tree/Knuth/Forest.hs +196/−0
• src/Data/Tree/Rose.hs +44/−20
• src/Data/Tree/Rose/Internal.hs +0/−3
• src/Data/Tree/Set.hs +107/−0
• test/Data/Tree/RoseSpec.hs +46/−0
• test/Spec.hs +13/−1

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,18 @@+module Main where++import qualified Data.Tree+import           Data.TreeBench+import           Data.Tree.SetBench+import           Data.Tree.KnuthBench+import           Criterion.Main+++++main = defaultMain+  [ bgroup "Trees"+    [ data_tree_bench+    , data_settree_bench+    , data_knuthtree_bench+    ]+  ]

@@ -0,0 +1,50 @@+{-# LANGUAGE+    FlexibleContexts+  #-}++module Data.Tree.KnuthBench (data_knuthtree_bench) where++import Prelude hiding (elem)+import Data.Monoid+import Data.Tree.Knuth+import qualified Data.Tree.Knuth.Forest as F+import Control.Monad.State+import Criterion+++newNode :: MonadState Int m => F.KnuthForest Int -> m (KnuthTree Int)+newNode xs = do x <- get+                modify (+1)+                return $ KnuthTree (x, xs)++-- makeWith :: Int -> Int -> Int -> State Int (Tree Int)+makeWith d w r | d <= 1 || w <= 1 = return F.Nil+               | otherwise = do ws <- makeWith d (w-1) r+                                xs <- makeWith (d-1) (floor $ fromIntegral w / r) r+                                x <- get+                                modify (+1)+                                return $ F.Fork x xs ws++tree1 = evalState (makeWith 1 1 2 >>= newNode) 1+tree2 = evalState (makeWith 2 2 2 >>= newNode) 1+tree3 = evalState (makeWith 3 3 2 >>= newNode) 1+tree4 = evalState (makeWith 4 4 2 >>= newNode) 1+tree5 = evalState (makeWith 5 5 2 >>= newNode) 1+++data_knuthtree_bench = bgroup "Data.Tree.Knuth"+  [ bgroup "depth"+    [ bench "1" $ whnf (elem 1) tree1+    , bench "2" $ whnf (elem 2) tree2+    , bench "3" $ whnf (elem 5) tree3+    , bench "4" $ whnf (elem 18) tree4+    , bench "5" $ whnf (elem 23) tree5+    ]+  , bgroup "width"+    [ bench "1" $ whnf (elem 1) tree1+    , bench "2" $ whnf (elem 2) tree2+    , bench "3" $ whnf (elem 6) tree3+    , bench "4" $ whnf (elem 20) tree4+    , bench "5" $ whnf (elem 25) tree5+    ]+  ]

@@ -0,0 +1,47 @@+{-# LANGUAGE+    FlexibleContexts+  #-}++module Data.Tree.SetBench (data_settree_bench) where++import Prelude hiding (elem)+import Data.Monoid+import qualified Data.Set as Set+import Data.Tree.Set+import Control.Monad.State+import Criterion+++newNode :: MonadState Int m => Set.Set (SetTree Int) -> m (SetTree Int)+newNode xs = do x <- get+                modify (+1)+                return $ SetTree x xs++-- makeWith :: Int -> Int -> Int -> State Int (Tree Int)+makeWith d w r | d <= 1 = newNode Set.empty+               | otherwise = do xs <- replicateM w $ makeWith (d-1) (floor $ fromIntegral w / r) r+                                newNode $ Set.fromList xs++tree1 = evalState (makeWith 1 1 2) 1+tree2 = evalState (makeWith 2 2 2) 1+tree3 = evalState (makeWith 3 3 2) 1+tree4 = evalState (makeWith 4 4 2) 1+tree5 = evalState (makeWith 5 5 2) 1+++data_settree_bench = bgroup "Data.Tree.Set"+  [ bgroup "depth"+    [ bench "1" $ whnf (elem 1) tree1+    , bench "2" $ whnf (elem 2) tree2+    , bench "3" $ whnf (elem 5) tree3+    , bench "4" $ whnf (elem 18) tree4+    , bench "5" $ whnf (elem 23) tree5+    ]+  , bgroup "width"+    [ bench "1" $ whnf (elem 1) tree1+    , bench "2" $ whnf (elem 2) tree2+    , bench "3" $ whnf (elem 6) tree3+    , bench "4" $ whnf (elem 20) tree4+    , bench "5" $ whnf (elem 25) tree5+    ]+  ]

@@ -0,0 +1,49 @@+{-# LANGUAGE+    FlexibleContexts+  #-}++module Data.TreeBench (data_tree_bench) where++import Data.Monoid+import Data.Tree+import Data.Tree.Rose+import Control.Monad.State+import Criterion+++newNode :: MonadState Int m => [Tree Int] -> m (Tree Int)+newNode xs = do x <- get+                modify (+1)+                return $ Node x xs++-- makeWith :: Int -> Int -> Int -> State Int (Tree Int)+makeWith d w r | d <= 1 = newNode []+               | otherwise = do xs <- replicateM w $ makeWith (d-1) (floor $ (fromIntegral w) / r) r+                                newNode xs++tree1 = evalState (makeWith 1 1 2) 1+tree2 = evalState (makeWith 2 2 2) 1+tree3 = evalState (makeWith 3 3 2) 1+tree4 = evalState (makeWith 4 4 2) 1+tree5 = evalState (makeWith 5 5 2) 1+++data_tree_bench = bgroup "Data.Tree"+  [ bgroup "depth"+    [ bench "1" $ whnf (elemT 1) tree1+    , bench "2" $ whnf (elemT 2) tree2+    , bench "3" $ whnf (elemT 5) tree3+    , bench "4" $ whnf (elemT 18) tree4+    , bench "5" $ whnf (elemT 23) tree5+    ]+  , bgroup "width"+    [ bench "1" $ whnf (elemT 1) tree1+    , bench "2" $ whnf (elemT 2) tree2+    , bench "3" $ whnf (elemT 6) tree3+    , bench "4" $ whnf (elemT 20) tree4+    , bench "5" $ whnf (elemT 25) tree5+    ]+  ]++elemT :: Eq a => a -> Tree a -> Bool+elemT x (Node y ys) = x == y || getAny (foldMap (Any . elemT x) ys)

@@ -1,5 +1,5 @@ Name:                   rose-trees-Version:                0.0.1.1+Version:                0.0.2 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -8,6 +8,7 @@ -- Description: Cabal-Version:          >= 1.10 Build-Type:             Simple+Category:               Data, Tree  Library   Default-Language:     Haskell2010@@ -15,13 +16,18 @@   GHC-Options:          -Wall   Exposed-Modules:      Data.Tree.Rose                         Data.Tree.Knuth-  Other-Modules:        Data.Tree.Rose.Internal-  Build-Depends:        base >= 4 && < 5+                        Data.Tree.Knuth.Forest+                        Data.Tree.Set+  Build-Depends:        base >= 4.6 && < 5                       , containers                       , semigroups-                      , data-default-                      , pseudo-trie-                      , transformers+                      , semigroupoids+                      , witherable+                      , sets+                      , QuickCheck+                      , quickcheck-instances+                      , mtl+                      , criterion  Test-Suite spec   Type:                 exitcode-stdio-1.0@@ -30,10 +36,48 @@                       , test   Ghc-Options:          -Wall   Main-Is:              Spec.hs+  Other-Modules:        Data.Tree.Knuth+                        Data.Tree.Knuth.Forest+                        Data.Tree.Rose+                        Data.Tree.Set+                        Data.Tree.RoseSpec   Build-Depends:        base-                      , hspec+                      , rose-trees+                      , witherable+                      , containers+                      , semigroups+                      , semigroupoids+                      , sets+                      , tasty+                      , tasty-quickcheck                       , QuickCheck                       , quickcheck-instances++Benchmark bench+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  Hs-Source-Dirs:       src+                      , bench+  Ghc-Options:          -Wall+  Main-Is:              Bench.hs+  Other-Modules:        Data.Tree.Knuth+                        Data.Tree.Knuth.Forest+                        Data.Tree.Rose+                        Data.Tree.Set+                        Data.TreeBench+                        Data.Tree.SetBench+                        Data.Tree.KnuthBench+  Build-Depends:        base+                      , rose-trees+                      , witherable+                      , containers+                      , semigroups+                      , semigroupoids+                      , sets+                      , QuickCheck+                      , quickcheck-instances+                      , mtl+                      , criterion  Source-Repository head   Type:                 git

@@ -1,36 +1,140 @@-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE+    DeriveFunctor+  , DeriveFoldable+  , DeriveTraversable+  , GeneralizedNewtypeDeriving+  , MultiParamTypeClasses+  , FlexibleInstances+  #-} +-- |+-- Module      : Data.Tree.Knuth+-- Copyright   : (c) 2014, 2015 Athan Clark+--+-- License     : BSD-style+-- Maintainer  : athan.clark@gmail.com+-- Stability   : experimental+-- Portability : GHC+--+-- An implementation of+-- <https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree left-child, right-sibling binary trees>.+ module Data.Tree.Knuth where -import Prelude hiding (foldr)-import Data.Monoid-import Data.Foldable+import qualified Data.Tree.Knuth.Forest as KF -data KnuthForest a = Fork { node :: a-                          , children :: (KnuthForest a)-                          , siblings :: (KnuthForest a) }-                   | Nil-  deriving (Show, Eq, Functor)+import Data.Semigroup+import Data.Foldable as F+import Data.Maybe+import qualified Data.Set.Class as Sets+import Control.Applicative+import Control.Monad -appendSibling :: KnuthForest a -> KnuthForest a -> KnuthForest a-appendSibling Nil _ = Nil-appendSibling (Fork x xc Nil) y = Fork x xc y-appendSibling (Fork x xc xs) y = Fork x xc $ appendSibling xs y+import Test.QuickCheck -instance Monoid (KnuthForest a) where-  mempty = Nil-  mappend = appendSibling -instance Foldable KnuthForest where-  foldr f acc Nil = acc-  foldr f acc (Fork x xc xs) =-    foldr f (foldr f (f x acc) xs) xc+newtype KnuthTree a = KnuthTree { unKnuthTree :: (a, KF.KnuthForest a) }+  deriving (Show, Eq, Functor, Foldable, Traversable) -newtype KnuthTree a = KnuthTree { unKnuthTree :: (a, KnuthForest a) }-  deriving (Show, Eq, Functor)+instance Arbitrary a => Arbitrary (KnuthTree a) where+  arbitrary = do+    x <- arbitrary+    xs <- arbitrary+    return $ KnuthTree (x,xs) --- | Breadth-first-instance Foldable KnuthTree where-  foldr f acc (KnuthTree (x, xs)) = foldr f (f x acc) xs+firstTree :: KF.KnuthForest a -> Maybe (KnuthTree a)+firstTree KF.Nil = Nothing+firstTree (KF.Fork x xc _) = Just $ KnuthTree (x,xc)+++instance Applicative KnuthTree where+  pure x = KnuthTree (x,KF.Nil)+  (KnuthTree (f,fs)) <*> (KnuthTree (x,xs)) = KnuthTree (f x,fs <*> xs)++instance Monad KnuthTree where+  return x = KnuthTree (x,KF.Nil)+  (KnuthTree (x,xs)) >>= f =+    let (KnuthTree (y,_)) = f x+    in KnuthTree (y,xs >>= (snd . unKnuthTree . f))++instance Semigroup (KnuthTree a) where+  (<>) = union++instance Sets.HasSize (KnuthTree a) where+  size = size++instance Sets.HasSingleton a (KnuthTree a) where+  singleton = singleton++instance Sets.HasUnion (KnuthTree a) where+  union = union++-- ** Query+size :: KnuthTree a -> Int+size (KnuthTree (_,xs)) = 1 + KF.size xs++elem :: Eq a => a -> KnuthTree a -> Bool+elem x (KnuthTree (y,ys)) = x == y || KF.elem x ys++isSubtreeOf :: Eq a => KnuthTree a -> KnuthTree a -> Bool+isSubtreeOf xss yss@(KnuthTree (_,ys)) = xss == yss || go ys+  where+    go KF.Nil = False+    go zss@(KF.Fork x xc xs) = xss == fromJust (firstTree zss) || go xs || go xc++-- | Bottom-up depth-first+isSubtreeOf' :: Eq a => KnuthTree a -> KnuthTree a -> Bool+isSubtreeOf' xss yss@(KnuthTree (_,ys)) = go ys || xss == yss+  where+    go KF.Nil = False+    go zss@(KF.Fork x xc xs) = go xc || go xs || xss == fromJust (firstTree zss)++isProperSubtreeOf :: Eq a => KnuthTree a -> KnuthTree a -> Bool+isProperSubtreeOf xss (KnuthTree (_,ys)) = go ys+  where+    go KF.Nil = False+    go zss@(KF.Fork x xc xs) = xss == fromJust (firstTree zss) || go xs || go xc++-- | Bottom-up depth-first+isProperSubtreeOf' :: Eq a => KnuthTree a -> KnuthTree a -> Bool+isProperSubtreeOf' xss (KnuthTree (_,ys)) = go ys+  where+    go KF.Nil = False+    go zss@(KF.Fork x xc xs) = go xc || go xs || xss == fromJust (firstTree zss)++isChildOf :: Eq a => a -> KnuthTree a -> Bool+isChildOf x (KnuthTree (_,ys)) = KF.isChildOf x ys++isDescendantOf :: Eq a => a -> KnuthTree a -> Bool+isDescendantOf x (KnuthTree (y,ys)) = x == y || KF.isDescendantOf x ys++isProperDescendantOf :: Eq a => a -> KnuthTree a -> Bool+isProperDescendantOf x (KnuthTree (_,ys)) = KF.isDescendantOf x ys++-- ** Construction++singleton :: a -> KnuthTree a+singleton x = KnuthTree (x,KF.Nil)++delete :: Eq a => a -> KnuthTree a -> Maybe (KnuthTree a)+delete x (KnuthTree (y,ys)) | x == y = Nothing+                            | otherwise = Just $ KnuthTree (y, KF.delete x ys)++-- ** Combination++union :: KnuthTree a -> KnuthTree a -> KnuthTree a+union (KnuthTree (_,xs)) (KnuthTree (y,ys)) = KnuthTree (y, KF.union xs ys)++intersection :: Eq a => KnuthTree a -> KnuthTree a -> Maybe (KnuthTree a)+intersection (KnuthTree (x,xs)) (KnuthTree (y,ys)) = do+  guard $ x == y+  return $ KnuthTree (y,KF.intersection xs ys)++difference :: Eq a => KnuthTree a -> KnuthTree a -> Maybe (KnuthTree a)+difference xss@(KnuthTree (x,xs)) (KnuthTree (y,ys)) = do+  guard $ x /= y+  return $ KnuthTree (x,go ys)+  where+    go KF.Nil = KF.Nil+    go zss@(KF.Fork x xc xs) | xss == fromJust (firstTree zss) = KF.Nil+                             | otherwise = KF.Fork x (go xc) (go xs)

@@ -0,0 +1,196 @@+{-# LANGUAGE+    DeriveFunctor+  , MultiParamTypeClasses+  , FlexibleInstances+  #-}++module Data.Tree.Knuth.Forest where++import Prelude hiding (foldr, elem)+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Data.Foldable hiding (elem)+import Data.Witherable+import Data.Traversable+import qualified Data.Set.Class as Sets+import Control.Applicative+import Control.Monad++import Test.QuickCheck+++-- * Forest++data KnuthForest a = Fork { kNode :: a+                          , kChildren :: KnuthForest a+                          , kSiblings :: KnuthForest a }+                   | Nil+  deriving (Show, Eq, Functor)++instance Arbitrary a => Arbitrary (KnuthForest a) where+  arbitrary = oneof [ return Nil+                    , liftA3 Fork arbitrary arbitrary arbitrary+                    ]+++-- | Siblings before children+instance Ord a => Ord (KnuthForest a) where+  compare (Fork x xc xs) (Fork y yc ys) =+    compare x y <> compare xs ys <> compare xc yc+  compare Nil Nil = EQ+  compare Nil _ = LT+  compare _ Nil = GT++-- | Zippy+instance Applicative KnuthForest where+  pure x = Fork x Nil Nil+  Nil <*> _ = Nil+  _ <*> Nil = Nil+  (Fork f fc fs) <*> (Fork x xc xs) =+    Fork (f x) (fc <*> xc) (fs <*> xs)++instance Alternative KnuthForest where+  empty = Nil+  (<|>) = union++-- | Breadth-first+instance Monad KnuthForest where+  return x = Fork x Nil Nil+  Nil >>= _ = Nil+  (Fork x xc xs) >>= f = f x `union` (xs >>= f) `union` (xc >>= f)++instance MonadPlus KnuthForest where+  mzero = Nil+  mplus = union++instance Semigroup (KnuthForest a) where+  (<>) = union++instance Monoid (KnuthForest a) where+  mempty = Nil+  mappend = union++-- | Breadth-first+instance Foldable KnuthForest where+  foldr _ acc Nil = acc+  foldr f acc (Fork x xc xs) =+    foldr f (foldr f (f x acc) xs) xc++instance Traversable KnuthForest where+  sequenceA Nil = pure Nil+  sequenceA (Fork x xc xs) = liftA3 Fork x (sequenceA xc) (sequenceA xs)++instance Witherable KnuthForest where+  catMaybes Nil = Nil+  catMaybes (Fork mx xc xs) = case mx of+    Nothing -> Nil+    Just x -> Fork x (catMaybes xc) (catMaybes xs)++instance Sets.HasUnion (KnuthForest a) where+  union = union++instance Eq a => Sets.HasIntersection (KnuthForest a) where+  intersection = intersection++instance Eq a => Sets.HasDifference (KnuthForest a) where+  difference = difference++instance Sets.HasSize (KnuthForest a) where+  size = size++instance Sets.HasEmpty (KnuthForest a) where+  empty = Nil++instance Sets.HasSingleton a (KnuthForest a) where+  singleton = singleton++instance Eq a => Sets.HasDelete a (KnuthForest a) where+  delete = delete++-- ** Query++size :: KnuthForest a -> Int+size Nil = 0+size (Fork _ xc xs) = 1 + size xc + size xs++-- Breadth-first+elem :: Eq a => a -> KnuthForest a -> Bool+elem _ Nil = False+elem x (Fork y yc ys) = x == y || elem x ys || elem x yc++-- Top-down, breadth-first+isSubforestOf :: Eq a => KnuthForest a -> KnuthForest a -> Bool+isSubforestOf Nil _ = True+isSubforestOf xss yss@(Fork _ yc ys) =+  xss == yss || isSubforestOf xss ys || isSubforestOf xss yc+isSubforestOf _ Nil = False++-- Bottom-up, depth-first+isSubforestOf' :: Eq a => KnuthForest a -> KnuthForest a -> Bool+isSubforestOf' Nil _ = True+isSubforestOf' xss yss@(Fork _ yc ys) =+  isSubforestOf xss yc || isSubforestOf xss ys || xss == yss+isSubforestOf' _ Nil = False++-- | No siblings+isProperSubforestOf :: Eq a => KnuthForest a -> KnuthForest a -> Bool+isProperSubforestOf Nil _ = True+isProperSubforestOf xss (Fork _ yc _) = isSubforestOf xss yc+isProperSubforestOf _ Nil = False++-- | Depth-first+isProperSubforestOf' :: Eq a => KnuthForest a -> KnuthForest a -> Bool+isProperSubforestOf' Nil _ = True+isProperSubforestOf' xss (Fork _ yc _) = isSubforestOf' xss yc+isProperSubforestOf' _ Nil = False++isSiblingOf :: Eq a => a -> KnuthForest a -> Bool+isSiblingOf _ Nil = False+isSiblingOf x (Fork y _ ys) = x == y || isSiblingOf x ys++-- | depth of one+isChildOf :: Eq a => a -> KnuthForest a -> Bool+isChildOf _ Nil = False+isChildOf x (Fork _ yc ys) = isSiblingOf x yc || isChildOf x ys+++isDescendantOf :: Eq a => a -> KnuthForest a -> Bool+isDescendantOf _ Nil = False+isDescendantOf x (Fork y yc _) = x == y || isDescendantOf x yc++isProperDescendantOf :: Eq a => a -> KnuthForest a -> Bool+isProperDescendantOf _ Nil = False+isProperDescendantOf x (Fork _ yc _) = isDescendantOf x yc+++-- ** Construction++singleton :: a -> KnuthForest a+singleton x = Fork x Nil Nil++delete :: Eq a => a -> KnuthForest a -> KnuthForest a+delete _ Nil = Nil+delete x (Fork y yc ys) | x == y = Nil+                        | otherwise = Fork y (delete x yc) (delete x ys)++-- ** Combination++union :: KnuthForest a -> KnuthForest a -> KnuthForest a+union Nil y = y+union (Fork x xc Nil) y = Fork x xc y+union (Fork x xc xs) y = Fork x xc $ union xs y++intersection :: Eq a => KnuthForest a -> KnuthForest a -> KnuthForest a+intersection Nil _ = Nil+intersection _ Nil = Nil+intersection (Fork x xc xs) (Fork y yc ys)+  | x == y = Fork y (intersection xc yc) (intersection xs ys)+  | otherwise = Nil++-- | Removes the possible subtree on the right, from the left.+difference :: Eq a => KnuthForest a -> KnuthForest a -> KnuthForest a+difference Nil _ = Nil+difference x Nil = x+difference (Fork x xc xs) yss@(Fork y _ _)+  | x == y = Nil+  | otherwise = Fork x (difference xc yss) (difference xs yss)

@@ -1,32 +1,56 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE+    TypeFamilies+  , KindSignatures+  , MultiParamTypeClasses+  , FunctionalDependencies+  , FlexibleInstances+  #-}  module Data.Tree.Rose where -import Data.Tree.Rose.Internal- import Data.Tree (Tree (Node)) import Data.Tree.Knuth-import Data.Trie.Pseudo hiding (Nil)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Default-import Data.Functor.Identity+import Data.Tree.Knuth.Forest as KF+import Data.Tree.Set+import qualified Data.Set as Set -class RoseTree (c :: * -> *) (u :: * -> *) (t :: * -> *) | c -> u, c -> t where-  (@->) :: t a -> u (c a) -> c a +type family Head (x :: *) :: *+type family Tail (y :: *) :: *++class RoseTree (c :: * -> *) where+  (@->) :: Head (c a) -> Tail (c a) -> c a+ infixr 9 @-> -instance RoseTree Tree [] Identity where-  (@->) (Identity x) xs = Node x xs -newtype PT t a = PT (t, Maybe a)+-- Data.Tree+type instance Head (Tree a) = a+type instance Tail (Tree a) = [Tree a] -instance Default t => RoseTree (PseudoTrie t) NonEmpty (PT t) where-  (@->) (PT x) xs = More x xs+instance RoseTree Tree where+  (@->) = Node -instance RoseTree KnuthForest Identity Identity where-  (@->) (Identity x) (Identity xs) = Fork x xs Nil++-- Data.Tree.Knuth.Forest+type instance Head (KnuthForest a) = a+type instance Tail (KnuthForest a) = KnuthForest a++instance RoseTree KnuthForest where+  x @-> xs = Fork x xs Nil+++-- Data.Tree.Knuth+type instance Head (KnuthTree a) = a+type instance Tail (KnuthTree a) = KnuthForest a++instance RoseTree KnuthTree where+  x @-> xs = KnuthTree (x,xs)+++-- Data.Tree.Set+type instance Head (SetTree a) = a+type instance Tail (SetTree a) = Set.Set (SetTree a)++instance RoseTree SetTree where+  (@->) = SetTree

@@ -1,3 +0,0 @@-module Data.Tree.Rose.Internal-    (-    ) where

@@ -0,0 +1,107 @@+{-# LANGUAGE+    DeriveFoldable+  , FlexibleInstances+  , MultiParamTypeClasses+  #-}++module Data.Tree.Set where++import Prelude hiding (map, elem, filter)+import qualified Data.Set as Set+import qualified Data.Foldable as F+import qualified Data.Maybe as M+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Data.Semigroup.Foldable+import qualified Data.Set.Class as Sets+import Control.Applicative+import Control.Monad++import Test.QuickCheck+import Test.QuickCheck.Instances+++data SetTree a = SetTree+  { sNode     :: a+  , sChildren :: Set.Set (SetTree a)+  } deriving (Show, Eq, Ord, Foldable)++instance (Ord a, Arbitrary a) => Arbitrary (SetTree a) where+  arbitrary = liftA2 SetTree arbitrary arbitrary++instance Foldable1 SetTree where+  fold1 (SetTree x xs) = F.foldr (\a acc -> sNode a <> acc) x xs++instance Sets.HasSize (SetTree a) where+  size = size++instance Sets.HasSingleton a (SetTree a) where+  singleton = singleton+++-- * Query++-- | set-like alias for @isDescendantOf@.+elem :: Eq a => a -> SetTree a -> Bool+elem = isDescendantOf++size :: SetTree a -> Int+size (SetTree _ xs) = 1 + getSum (F.foldMap (Sum . size) xs)++isChildOf :: Eq a => a -> SetTree a -> Bool+isChildOf x (SetTree _ ys) =+  getAny $ F.foldMap (Any . (x ==) . sNode) ys++isDescendantOf :: Eq a => a -> SetTree a -> Bool+isDescendantOf x (SetTree y ys) =+  (x == y) || getAny (F.foldMap (Any . isDescendantOf x) ys)++-- | Heirarchical analogue to subseteq.+isSubtreeOf :: Eq a => SetTree a -> SetTree a -> Bool+isSubtreeOf xss yss@(SetTree _ ys) =+  xss == yss || getAny (F.foldMap (Any . isSubtreeOf xss) ys)++-- | Bottom-up version+isSubtreeOf' :: Eq a => SetTree a -> SetTree a -> Bool+isSubtreeOf' xss yss@(SetTree _ ys) =+  getAny (F.foldMap (Any . isSubtreeOf' xss) ys) || xss == yss++isProperSubtreeOf :: Eq a => SetTree a -> SetTree a -> Bool+isProperSubtreeOf xss (SetTree _ ys) =+  getAny $ F.foldMap (Any . isSubtreeOf xss) ys++-- | Bottom-up version+isProperSubtreeOf' :: Eq a => SetTree a -> SetTree a -> Bool+isProperSubtreeOf' xss (SetTree _ ys) =+  getAny $ F.foldMap (Any . isSubtreeOf' xss) ys++eqHead :: Eq a => SetTree a -> SetTree a -> Bool+eqHead (SetTree x _) (SetTree y _) = x == y++-- * Construction++insertChild :: Ord a => SetTree a -> SetTree a -> SetTree a+insertChild x (SetTree y ys) = SetTree y $ Set.insert x ys++delete :: Eq a => a -> SetTree a -> Maybe (SetTree a)+delete x = filter (/= x)++singleton :: a -> SetTree a+singleton x = SetTree x Set.empty++-- * Filtering++filter :: Eq a => (a -> Bool) -> SetTree a -> Maybe (SetTree a)+filter p (SetTree x xs) = do+  guard $ p x+  return $ SetTree x $ Set.fromAscList $ M.mapMaybe (filter p) $ Set.toAscList xs++-- * Mapping++map :: Ord b => (a -> b) -> SetTree a -> SetTree b+map f (SetTree x xs) = SetTree (f x) $ Set.map (map f) xs++mapMaybe :: Eq b => (a -> Maybe b) -> SetTree a -> Maybe (SetTree b)+mapMaybe p (SetTree x xs) = do+  x' <- p x+  return $ SetTree x' $ Set.fromAscList $ M.mapMaybe (mapMaybe p) $ Set.toAscList xs

@@ -0,0 +1,46 @@+module Data.Tree.RoseSpec where++import Data.Tree.Rose++import Data.Monoid+import qualified Data.Tree as T+import qualified Data.Set as Set+import qualified Data.Tree.Set as S+import qualified Data.Tree.Knuth as K+import qualified Data.Tree.Knuth.Forest as KF+++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.QuickCheck+import Test.QuickCheck.Instances+++spec :: TestTree+spec = testGroup "Testing trees..."+  [ testGroup "Data.Tree"+    [ QC.testProperty "element after construction" prop_cons_exists_Tree+    ]+  , testGroup "Data.Tree.Set"+    [ QC.testProperty "element after construction" prop_cons_exists_SetTree+    ]+  , testGroup "Data.Tree.Knuth"+    [ QC.testProperty "element after construction" prop_cons_exists_KnuthTree+    ]+  ]++newtype TreeWithElem t e = TreeWithElem {unTreeWithElem :: (e, t e)}+++prop_cons_exists_Tree :: Int -> [T.Tree Int] -> Bool+prop_cons_exists_Tree x xs = elem' x $ x @-> xs+  where elem' x (T.Node y ys) = x == y || getAny (foldMap (Any . elem' x) ys)++prop_cons_exists_SetTree :: Int -> Set.Set (S.SetTree Int) -> Bool+prop_cons_exists_SetTree x xs = S.elem x $ x @-> xs++prop_cons_exists_KnuthTree :: Int -> KF.KnuthForest Int -> Bool+prop_cons_exists_KnuthTree x xs = K.elem x $ x @-> xs+++-- instance (Arbitrary e

@@ -1,1 +1,13 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+module Main where++import Data.Tree.RoseSpec++import Test.Tasty+++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Testing..."+  [spec]