Commit before "lensifying" tree functions

src/Dodge/Tree/Compose.hs

@@ -13,14 +13,18 @@ module Dodge.Tree.Compose
 import Dodge.Tree.Compose.Data
 import Dodge.Tree.Polymorphic
 import Dodge.Base
+
+import Data.Maybe
 import Data.Tree
 import Control.Lens
+import Data.Tree.Lens
+--import Data.Bifunctor
 
 expandTree :: CompTree a -> Tree a
 expandTree (Node root extChildren) = case root of
     Node (UseAll x)     _   -> Node x (map expandTree extChildren)
     Node (UseSome is x) _   -> Node x (map (expandTree . \i -> extChildren !! i) is)
-    Node (UseNone _) _   -> fmap _unCompose root
+    Node (UseNone _)    _   -> fmap _unCompose root
     Node (UseLabel _ _) _   -> fmap _unCompose root
     Node (PassDown x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
     Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
@@ -59,3 +63,37 @@ singleUseNone x = Node (UseNone x) []
 
 changeToPassDown :: ComposingNode a -> ComposingNode a
 changeToPassDown x = PassDown (_unCompose x)
+
+cTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+cTree (Node (_,t) ch) = shiftChildren $ undefined
+
+g :: (a-> Maybe a, Tree a) -> Tree ([Tree a],a) -> [Tree ([Tree a],a)]
+g (f,t) = updateSingleNode (isJust . f . snd) (root . _2 %~ g)
+  where
+    g x = fromMaybe x (f x)
+
+shiftChildren :: Tree ([Tree a],a) -> Tree a
+shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
+
+-- hideous, but it should work
+-- the idea is that the fst argument selects (and edits) a node to which all the
+-- children are attached
+-- the tree is thus built up recursively
+compTree :: Tree (a -> Maybe a, Tree (a,b)) -> Tree b
+compTree (Node (_,t) ch) = attachChildren t $ map (\t' -> (fst $ rootLabel t',compTree t')) ch
+
+chooseAttachNodes :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> [Tree (a,b,[c])]
+chooseAttachNodes (t,z) (Node (x,y,zs) ch) = case t x of
+    Just x' -> Node (x',y,(z:zs)) ch : concatMap (chooseAttachNodes (t,z)) ch
+    Nothing -> concatMap (chooseAttachNodes (t,z)) ch
+
+mAttachToNode :: (a -> Maybe a,c) -> Tree (a,b,[c]) -> Tree (a,b,[c])
+mAttachToNode p t = fromMaybe t $ listToMaybe $ chooseAttachNodes p t
+
+moveToChildren :: Tree (a,b,[Tree b]) -> Tree b
+moveToChildren (Node (_,x,ts) ts') = Node x (map moveToChildren ts' ++ ts)
+
+attachChildren :: Tree (a,b) -> [(a->Maybe a,Tree b)] -> Tree b
+attachChildren t = moveToChildren . foldr mAttachToNode t'
+  where
+    t' = fmap (\(x,y) -> (x,y,[])) t