Test of lock and key system

src/Dodge/Tree/Compose.hs

@@ -7,19 +7,29 @@ module Dodge.Tree.Compose
     , chainUses
     , useAllAtEnd
     , changeToPassDown
+    , overwriteLabel
     ) where
 import Dodge.Tree.Compose.Data
+import Dodge.Tree.Polymorphic
 import Data.Tree
 
 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 
             $ map (:[]) extChildren ++ repeat []
 
+overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
+overwriteLabel i f t ts = head $ updateSingleNode islabel update t
+  where
+    islabel (UseLabel j _) | i == j = True
+    islabel _ = False
+    update (Node cr _) = Node (f $ _unCompose cr) ts
+
 passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
 passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
 passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts