module DataTreeView.StrictTypes(
module Data.Tree,
module Data.Monoid,
StrictList,
ToStrictList(..),
fromStrictList,
StrictTree,StrictForest,
ToStrictTree(..),ToStrictForest(..),
modifyValue, modifyChildren,
nodeValue,nodeChildren,fromStrictTree,fromStrictForest) where
import Data.Typeable
import Data.Monoid
import Prelude hiding(drop)
import Data.Tree
import Data.Foldable(Foldable)
import Data.Traversable(Traversable)
import Data.Data
import Data.List(unfoldr)
import Data.ListLike
data StrictList a = SNil | SCons !a !(StrictList a)
deriving(Show,Typeable,Data,Functor,Foldable,Traversable)
class ToStrictList x a where
strictList :: x -> StrictList a
instance ToStrictList a a where
strictList x = SCons x SNil
instance ToStrictList [a] a where
strictList = Prelude.foldr SCons SNil
instance ToStrictList x a => ToStrictList (a, x) a where
strictList (a,x) = SCons a (strictList x)
instance ToStrictList (StrictList a) a where
strictList = id
fromStrictList :: StrictList a -> [a]
fromStrictList = unfoldr f
where
f SNil = Nothing
f (SCons x xs) = Just (x,xs)
instance FoldableLL (StrictList a) a where
foldl' f z0 xs0 = lgo z0 xs0
where lgo z SNil = z
lgo z (SCons x xs) = let z' = f z x in z' `seq` lgo z' xs
foldl f z0 xs0 = lgo z0 xs0
where lgo z SNil = z
lgo z (SCons x xs) = lgo (f z x) xs
foldr f z0 = go
where go SNil = z0
go (SCons x xs) = f x (go xs)
instance ListLike (StrictList a) a where
singleton = strictList
head (SCons x _) = x
head _ = error "`head' on empty StrictList"
tail (SCons _ xs) = xs
tail _ = error "`tail on empty StrictList"
drop n xs | n < 0 = error "Strict.drop: n<0"
| otherwise = go n xs
where
go 0 xs' = xs'
go n' (SCons _ xs'') = go (pred n') xs''
go _ SNil = SNil
null (SCons _ _) = False
null SNil = True
instance Monoid (StrictList a) where
mempty = SNil
mappend SNil !b = b
mappend (SCons a1 a2) !b = SCons a1 (mappend a2 b)
data StrictTree a = SNode !a !(StrictForest a) deriving(Show,Typeable,Data,Functor,Foldable,Traversable)
type StrictForest a = StrictList (StrictTree a)
class ToStrictTree x a where
strictTree :: x -> StrictTree a
instance ToStrictTree a a where
strictTree = flip SNode SNil
instance ToStrictTree (Tree a) a where
strictTree (Node a ts) = SNode a (strictForest ts :: StrictForest a)
instance ToStrictForest y a => ToStrictTree (a, y) a where
strictTree (a,y) = SNode a (strictForest y)
instance ToStrictTree (StrictTree a) a where
strictTree = id
class ToStrictForest y a where
strictForest :: y -> StrictForest a
instance (ToStrictTree x a) => ToStrictForest [x] a where
strictForest = strictList . fmap (strictTree :: x -> StrictTree a)
instance (ToStrictTree x a) => ToStrictForest (StrictList x) a where
strictForest = strictList . fmap (strictTree :: x -> StrictTree a)
instance ToStrictForest (StrictForest a) a where
strictForest = id
nodeValue :: StrictTree a -> a
nodeValue (SNode a _) = a
nodeChildren :: StrictTree t -> [StrictTree t]
nodeChildren (SNode _ ts) = fromStrictList ts
modifyValue :: StrictTree a -> (a -> a) -> StrictTree a
modifyValue (SNode a ts) f = SNode (f a) ts
modifyChildren
:: StrictTree a -> (StrictForest a -> StrictForest a) -> StrictTree a
modifyChildren (SNode a ts) f = SNode a (f ts)
fromStrictForest :: StrictForest a -> Forest a
fromStrictForest = fmap fromStrictTree . fromStrictList
fromStrictTree :: StrictTree a -> Tree a
fromStrictTree = unfoldTree f
where
f (SNode a ts) = (a, fromStrictList ts)