Tree breadcrumb interconversion test

tree-test.hs

{-# LANGUAGE FlexibleInstances #-}

import Data.Tree

import Test.QuickCheck
import Control.Applicative
import Data.List
import Data.Function
import Control.Monad
import Data.Maybe

main = putStrLn $ drawTree tree

tree = Node "Hello" [Node "hoge" [Node "hage" [],Node "hige" []]]

-- Breadcrumb represents the path from a root to a leaf.
-- A tree is equivalent to a list of breadcrumbs.
data Breadcrumb a = Breadcrumb {
	nodes :: [a]
}

instance Show a => Show (Breadcrumb a) where
	show (Breadcrumb ns) = intercalate "->" $ map show ns

breadcrumbs :: Tree a -> [Breadcrumb a]
breadcrumbs (Node n []) = [Breadcrumb [n]]
breadcrumbs (Node n cs) = map (append' n) $ concatMap breadcrumbs cs
	where
	append' :: a -> Breadcrumb a -> Breadcrumb a
	append' a (Breadcrumb ns) = Breadcrumb (a:ns)


fromBreadcrumbs ::  (Eq a, Ord a) => [Breadcrumb a] -> Tree a
fromBreadcrumbs bs =
	let ns = fromBreadcrumbs' bs
	in Node (rootLabel $ head ns) (sortBy (compare `on` rootLabel) $ concatMap subForest ns)

fromBreadcrumbs' :: (Eq a, Ord a) => [Breadcrumb a] -> Forest a
fromBreadcrumbs' xss =
	let
	spl [] = Nothing
	spl (x:xs) = Just (x,xs)
	nss = sortAndGroup $ catMaybes $ map (spl . nodes) xss
	mkC :: Ord a => [(a,[a])] -> Forest a
	mkC cs = fromBreadcrumbs' $ map (Breadcrumb . snd) cs
	in
	map (\ns -> Node (fst $ head ns) (mkC ns)) nss

sortAndGroup :: (Eq a, Ord a) => [(a,[a])] -> [[(a,[a])]]
sortAndGroup xss = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ xss


-- QuickCheck

instance (Eq a, Arbitrary a) => Arbitrary (Tree a) where
	arbitrary = do
		node <- arbitrary 
		n <- choose (0,2)
		cs <- replicateM n arbitrary
		return $ Node node (nubBy ((==) `on` rootLabel) cs)

sortTree :: Ord a => Tree a -> Tree a
sortTree (Node n []) = Node n []
sortTree (Node n cs) =
	let
	cs' = map sortTree cs
	in
	Node n (sortBy (compare `on` rootLabel) cs')

prop_tree :: Tree String -> Bool
prop_tree tree = (fromBreadcrumbs . breadcrumbs) tree == sortTree tree

test = do
	quickCheckWith stdArgs{maxSuccess=100} prop_tree