Added more stuff relating to the spine view in Polyplate, but now reconsidering its necessity

polyplate/Data/Generics/Polyplate.hs

@@ -27,17 +27,19 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 -- Instances of the PolyplateM type-class /can/ be written manually but it's not
 -- 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(..),
+module Data.Generics.Polyplate (PolyplateM(..), Polyplate(..),
+  PolyplateSpine(..), FullSpine, transformSpineFull, trimTree,
   makeRecurseM, RecurseM, makeRecurse, Recurse,
   makeDescendM, DescendM, makeDescend, Descend,
-  makeRecurseQ, RecurseQ,
+--  makeRecurseQ, RecurseQ,
-  makeDescendQ, DescendQ,
+--  makeDescendQ, DescendQ,
   BaseOp, baseOp,
   ExtOpM, extOpM, ExtOp, extOp, OneOpM, OneOp, TwoOpM, TwoOp,
   ExtOpQ, extOpQ, OneOpQ, TwoOpQ) where
 
 import Control.Monad.Identity
 
+import Data.Maybe
 import Data.Tree
 
 -- | The main Polyplate type-class.
@@ -99,8 +101,35 @@ class Monad m => PolyplateM t o o' m where
   -- or breadth-first order.
 
 class PolyplateSpine t o o' a where
-  transformSpine :: o -> o' -> t -> Tree (Maybe a)
+  transformSpineSparse :: o -> o' -> t -> Tree (Maybe a)
 
+-- | 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
+
+transformSpineFull :: (ConvertSpineOpsToFull o co, ConvertSpineOpsToFull o' co',
+  PolyplateSpine t co co' a) =>
+  o -> o' -> t -> Tree (Maybe a)
+transformSpineFull o o' x
+  = transformSpineSparse
+      (convertSpineOpsToFull o)
+      (convertSpineOpsToFull o')
+      x
+
+class ConvertSpineOpsToFull o o' | o -> o' where
+  convertSpineOpsToFull :: o -> o'
+
+instance ConvertSpineOpsToFull () FullSpine where
+  convertSpineOpsToFull _ = FullSpine
+
+instance ConvertSpineOpsToFull r r' => ConvertSpineOpsToFull (a, r) (a, r') where
+  convertSpineOpsToFull (f, r) = (f, convertSpineOpsToFull r)
+
+trimTree :: Tree (Maybe a) -> Maybe (Tree (Maybe a))
+trimTree tr | isNothing (rootLabel tr) && null trimmedChildren = Nothing
+            | otherwise = Just (Node (rootLabel tr) trimmedChildren)
+    where
+      trimmedChildren = mapMaybe trimTree (subForest tr)
 
 -- | A helper class to convert non-monadic transformations into monadic ones in
 -- the Identity monad.
@@ -158,14 +187,17 @@ type Descend opT = forall t. Polyplate t () opT => t -> t
 makeDescend :: opT -> Descend opT
 makeDescend ops = transform () ops
 
+{-
 type RecurseQ a opQ = forall t. PolyplateSpine t opQ () a => t -> Tree (Maybe a)
 type DescendQ a opQ = forall t. PolyplateSpine t () opQ a => t -> Tree (Maybe a)
 
+
 makeRecurseQ :: opQ -> RecurseQ a opQ
 makeRecurseQ ops = transformSpine ops ()
 
 makeDescendQ :: opQ -> DescendQ a opQ
 makeDescendQ ops = transformSpine () ops
+-}
 
 -- | The type of the empty set of operations
 type BaseOp = ()

polyplate/Data/Generics/Polyplate/Schemes.hs

@@ -62,26 +62,35 @@ makeCheckM ops f v
   where
     descend = makeDescend ops
 -}
+checkDepthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m ()
+checkDepthM f = sequence_ . catMaybes . flatten . applyQuery f
 
+checkDepthM2 :: (Monad m, PolyplateSpine t (TwoOpQ (m ()) r s) () (m ())) =>
+  (r -> m ()) -> (s -> m ()) -> t -> m ()
+checkDepthM2 f g = sequence_ . catMaybes . flatten . applyQuery2 f g
+
+
+checkBreadthM :: (Monad m, PolyplateSpine t (OneOpQ (m ()) s) () (m ())) => (s -> m ()) -> t -> m ()
+checkBreadthM f = sequence_ . catMaybes . concat . levels . applyQuery f
 
 applyQuery :: PolyplateSpine t (OneOpQ a s) () a => (s -> a) -> t -> Tree (Maybe a)
-applyQuery qf = makeRecurseQ ops
+applyQuery qf = transformSpineSparse ops ()
   where
     ops = baseOp `extOpQ` qf
 
 applyQuery2 :: PolyplateSpine t (TwoOpQ a sA sB) () a => (sA -> a) -> (sB -> a) -> t -> Tree (Maybe a)
-applyQuery2 qfA qfB = makeRecurseQ ops
+applyQuery2 qfA qfB = transformSpineSparse ops ()
   where
     ops = baseOp `extOpQ` qfA `extOpQ` qfB 
 
 applyListifyDepth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s]
-applyListifyDepth qf = catMaybes . flatten . fmap (fromMaybe Nothing) . makeRecurseQ ops
+applyListifyDepth qf = catMaybes . flatten . fmap (fromMaybe Nothing) . transformSpineSparse ops ()
   where
     qf' x = if qf x then Just x else Nothing
     ops = baseOp `extOpQ` qf'
 
 applyListifyBreadth :: PolyplateSpine t (OneOpQ (Maybe s) s) () (Maybe s) => (s -> Bool) -> t -> [s]
-applyListifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . makeRecurseQ ops
+applyListifyBreadth qf = catMaybes . (concat . levels) . fmap (fromMaybe Nothing) . transformSpineSparse ops ()
   where
     qf' x = if qf x then Just x else Nothing
     ops = baseOp `extOpQ` qf'