From 189032e27565aaff2c77bb86daae75043abc096a Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 9 Dec 2008 11:20:39 +0000 Subject: [PATCH] Fixed up the full traversal of the tree to allow specification of a default value --- polyplate/Data/Generics/Polyplate.hs | 32 ++++++++++++++++------------ 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/polyplate/Data/Generics/Polyplate.hs b/polyplate/Data/Generics/Polyplate.hs index 25f7bec..032c7ec 100644 --- a/polyplate/Data/Generics/Polyplate.hs +++ b/polyplate/Data/Generics/Polyplate.hs @@ -28,7 +28,7 @@ with this program. If not, see . -- advised. Instead, you should use functions in the "GenPolyplate" module to automatically -- generate source files with the appropriate instances. module Data.Generics.Polyplate (PolyplateM(..), Polyplate(..), - PolyplateSpine(..), FullSpine, transformSpineFull, trimTree, + PolyplateSpine(..), FullSpine(..), transformSpineFull, trimTree, makeRecurseM, RecurseM, makeRecurse, Recurse, makeDescendM, DescendM, makeDescend, Descend, -- makeRecurseQ, RecurseQ, @@ -105,25 +105,29 @@ class PolyplateSpine t o o' a where -- | Used at the type-level by this library to force a full traversal of a data -- structure. You are unlikely to need to use this directly. -data FullSpine = FullSpine +data FullSpine a = FullSpine a -transformSpineFull :: (ConvertSpineOpsToFull o co, ConvertSpineOpsToFull o' co', +transformSpineFull :: (ConvertSpineOpsToFull a o co, ConvertSpineOpsToFull a o' co', PolyplateSpine t co co' a) => - o -> o' -> t -> Tree (Maybe a) -transformSpineFull o o' x - = transformSpineSparse - (convertSpineOpsToFull o) - (convertSpineOpsToFull o') + a -> o -> o' -> t -> Tree a +transformSpineFull def o o' x + = fmap fromJust' $ + transformSpineSparse + (convertSpineOpsToFull def o) + (convertSpineOpsToFull def o') x + where + fromJust' (Just x) = x + fromJust' _ = error "transformSpineFull: internal error" -class ConvertSpineOpsToFull o o' | o -> o' where - convertSpineOpsToFull :: o -> o' +class ConvertSpineOpsToFull a o o' | a o -> o' where + convertSpineOpsToFull :: a -> o -> o' -instance ConvertSpineOpsToFull () FullSpine where - convertSpineOpsToFull _ = FullSpine +instance ConvertSpineOpsToFull a () (FullSpine a) where + convertSpineOpsToFull def _ = FullSpine def -instance ConvertSpineOpsToFull r r' => ConvertSpineOpsToFull (a, r) (a, r') where - convertSpineOpsToFull (f, r) = (f, convertSpineOpsToFull r) +instance ConvertSpineOpsToFull b r r' => ConvertSpineOpsToFull b (a, r) (a, r') where + convertSpineOpsToFull def (f, r) = (f, convertSpineOpsToFull def r) trimTree :: Tree (Maybe a) -> Maybe (Tree (Maybe a)) trimTree tr | isNothing (rootLabel tr) && null trimmedChildren = Nothing