fixed a bug I reported in issue #4 also upgraded to PureScript 0.12

bower.json

@@ -12,13 +12,13 @@
     "url": "git://github.com/dmbfm/purescript-tree.git"
   },
   "dependencies": {
-    "purescript-prelude": "^3.1.0",
-    "purescript-console": "^3.0.0",
-    "purescript-lists": "^4.9.1",
-    "purescript-free": "^4.1.0"
+    "purescript-prelude": "^4.0.1",
+    "purescript-console": "^4.1.0",
+    "purescript-lists": "^5.0.0",
+    "purescript-free": "^5.1.0"
   },
   "devDependencies": {
-    "purescript-psci-support": "^3.0.0",
-    "purescript-spec": "^1.0.0"
+    "purescript-psci-support": "^4.0.0",
+    "purescript-spec": "^3.0.0"
   }
 }

src/Data/Tree.purs

@@ -21,7 +21,7 @@ mkTree = mkCofree
 drawTree :: Tree String -> String
 drawTree t = tailRec go {level: 0, drawn: (head t) <> "\n", current: (tail t)}
   where
-    go :: _ -> Step _ String
+    go :: { current :: Forest String , drawn :: String , level :: Int } -> Step { current :: Forest String , drawn :: String , level :: Int } String
     go {level: l, drawn: s, current: Nil} = Done s
     go {level: l, drawn: s, current: c:cs } = 
       let drawn = (power "       " l) <> "|----> " <> (head c) <> "\n" in
@@ -39,7 +39,7 @@ scanTree f b n =
   let fb = f (head n) b 
   in fb :< (tailRec go {b: fb, current: (tail n), final: Nil})
   where
-    go :: _ -> Step _ (Forest b)
+    go :: { final :: Forest b , current :: Forest a , b :: b } -> Step { final :: Forest b , current :: Forest a , b :: b } (Forest b)
     go {b: b', current: Nil, final: final} = Done final
     go {b: b', current: c:cs, final: final} = 
       let fb' = f (head c) b' 
@@ -52,7 +52,7 @@ scanTreeAccum f b n =
   let fb = f (head n) b 
   in fb.value :< (tailRec go {b: fb.accum , current: (tail n), final: Nil})
   where
-    go :: _ -> Step _ (Forest c)
+    go :: { final :: Forest c , current :: Forest a , b :: b } -> Step { final :: Forest c , current :: Forest a , b :: b } (Forest c)
     go {b: b', current: Nil, final: final} = Done final
     go {b: b', current: c:cs, final: final} = 
       let fb' = f (head c) b' 

src/Data/Tree/Zipper.purs

@@ -2,9 +2,10 @@ module Data.Tree.Zipper where
 
 import Prelude
 
+import Control.Alt ((<|>))
 import Control.Comonad.Cofree (head, tail, (:<))
-import Data.List (List(..), drop, reverse, take, (!!), (:))
-import Data.Maybe (Maybe(..))
+import Data.List (List(Nil), drop, reverse, take, (!!), (:))
+import Data.Maybe (Maybe(Just, Nothing))
 import Data.Tree (Forest, Tree, mkTree, modifyNodeValue, setNodeValue)
 
 -- | The `Loc` type describes the location of a `Node` inside a `Tree`. For this
@@ -229,36 +230,58 @@ delete l@(Loc r) =
 
 -- Searches
 
+ -- | Search down and to the right for the first occurence where the given predicate is true and return the Loc
+findDownWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
+findDownWhere predicate loc | predicate $ value loc = Just loc
+findDownWhere predicate loc = lookNext <|> lookDown
+  where
+    lookNext = next loc >>= findDownWhere predicate
+    lookDown = down loc >>= findDownWhere predicate
+
 -- | Search for the first occurence of the value `a` downwards and to the right.
 findDown :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
-findDown a l@(Loc r) = 
-  if a == (value l) 
-    then (Just l) 
-    else 
-      case next l of
-        Just n -> findDown a n
-        Nothing ->
-          case down l of
-            Just n' -> findDown a n'
-            Nothing -> Nothing            
-
--- | Search for the first occurence of the value `a` upwards and to the left.
+findDown a = findDownWhere ( _ == a)
+
+-- | Search to the left and up for the first occurence where the given predicate is true and return the Loc
+findUpWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a) 
+findUpWhere predicate loc | predicate $ value loc = Just loc
+findUpWhere predicate loc = lookPrev <|> lookUp
+  where
+    lookPrev  = prev loc  >>= findUpWhere predicate
+    lookUp    = up loc    >>= findUpWhere predicate
+
+-- | Search for the first occurence of the value `a` upwards and to the left,
 findUp :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
-findUp a l@(Loc r) = 
-  if a == (value l) 
-    then (Just l) 
-    else 
-      case prev l of
-        Just n -> findUp a n
-        Nothing ->
-          case up l of
-            Just n' -> findUp a n'
-            Nothing -> Nothing            
+findUp a = findUpWhere (_ == a)
+
+-- | Search from the root of the tree for the first occurrence where the given predicate is truen and return the Loc
+findFromRootWhere :: ∀ a. (a -> Boolean) -> Loc a -> Maybe (Loc a)
+findFromRootWhere predicate loc | predicate $ value loc = Just loc
+findFromRootWhere predicate loc = findDownWhere predicate $ root loc
 
 -- | Search for the first occurence of the value `a` starting from the root of
 -- | the tree.
 findFromRoot :: forall a. Eq a => a -> Loc a -> Maybe (Loc a)
-findFromRoot a = (findDown a) <<< root
+findFromRoot a = findFromRootWhere (_ == a)
+
+-- | flattens the Tree into a List depth first.
+flattenLocDepthFirst :: ∀ a. Loc a -> List (Loc a)
+flattenLocDepthFirst loc = loc : (go loc)
+  where
+    go :: Loc a -> List (Loc a)
+    go loc' =
+      let
+        downs = goDir loc' down
+        nexts = goDir loc' next
+      in
+        downs <> nexts
+
+    goDir :: Loc a -> (Loc a -> Maybe (Loc a)) -> List (Loc a)
+    goDir loc' dirFn = case (dirFn loc') of
+      Just l  -> l : go l
+      Nothing -> Nil
+
+
 
 -- Setters and Getters
 node :: forall a. Loc a -> Tree a 

test/Main.purs

@@ -2,19 +2,17 @@ module Test.Main where
 
 import Prelude
 
-import Control.Comonad.Cofree (Cofree, head, (:<))
-import Control.Monad.Eff (Eff)
-import Control.Monad.Eff.Class (liftEff)
-import Control.Monad.Eff.Console (CONSOLE, log)
-import Data.List (List(..), (:))
-import Data.Maybe (fromJust)
-import Data.Tree (Tree, mkTree, scanTree, showTree)
-import Data.Tree.Zipper (down, fromTree, insertAfter, modifyValue, next, toTree)
+import Control.Comonad.Cofree (head, (:<))
+import Data.List (List(Nil), (:))
+import Data.Maybe (Maybe(..), fromJust)
+import Data.Tree (Tree, mkTree, scanTree)
+import Data.Tree.Zipper (down, findDownWhere, findFromRoot, findUp, flattenLocDepthFirst, fromTree, insertAfter, modifyValue, next, toTree, value)
+import Effect (Effect)
 import Partial.Unsafe (unsafePartial)
 import Test.Spec (describe, it)
 import Test.Spec.Assertions (shouldEqual)
 import Test.Spec.Reporter (consoleReporter)
-import Test.Spec.Runner (RunnerEffects, run)
+import Test.Spec.Runner (run)
 
 sampleTree :: Tree Int
 sampleTree = 
@@ -30,7 +28,7 @@ sampleTree =
       )
     : Nil
 
-main :: forall e. Eff (RunnerEffects e) Unit
+main :: Effect Unit
 main = run [consoleReporter] do 
   describe "Tree" do    
 
@@ -139,4 +137,129 @@ main = run [consoleReporter] do
                   )
                 : Nil
       shouldEqual (eq root' result) true
-      shouldEqual (eq root'' result') true
+      shouldEqual (eq root'' result') true
+
+    it "Should findDownWhere with single node" do
+      let tree = 1 :< Nil
+      let loc = fromTree tree
+      shouldEqual (Just 1) ((findDownWhere (_ == 1) loc) <#> value)
+
+    it "Should findDownWhere with 2 nodes and 2 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 2) ((findDownWhere (_ == 2) loc) <#> value)
+
+    it "Should findDownWhere with 3 nodes and 2 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 3) ((findDownWhere (_ == 3) loc) <#> value)
+
+    it "Should findDownWhere with 4 nodes and 2 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 4) ((findDownWhere (_ == 4) loc) <#> value)
+
+    it "Should findDownWhere with 5 nodes and 3 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< 
+                          (5 :< Nil)
+                        : Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 5) ((findDownWhere (_ == 5) loc) <#> value)
+
+    it "Should findDownWhere with 6 nodes and 3 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< 
+                          (5 :< Nil)
+                        : (6 :< Nil)
+                        : Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 6) ((findDownWhere (_ == 6) loc) <#> value)
+
+    it "Should findDownWhere with 7 nodes and 4 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< 
+                          (5 :< Nil)
+                        : (6 :< 
+                              (7 :< Nil) : Nil)
+                        : Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
+
+    it "Should findDownWhere with 8 nodes and 4 levels" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< 
+                          (5 :< Nil)
+                        : (6 :< 
+                              (7 :< Nil) : Nil)
+                        : (8 :< Nil)
+                        : Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 8) ((findDownWhere (_ == 8) loc) <#> value)
+
+    it "Should findDownWhere with 8 nodes and 4 levels with a step back" do
+      let tree = 1 :< 
+                      (2 :< Nil) 
+                    : (3 :< Nil) 
+                    : (4 :< 
+                          (5 :< Nil)
+                        : (6 :< 
+                              (7 :< Nil) : Nil)
+                        : (8 :< Nil)
+                        : Nil) 
+                      : Nil
+      -- log $ showTree tree
+      let loc = fromTree tree
+      shouldEqual (Just 7) ((findDownWhere (_ == 7) loc) <#> value)
+
+    it "Should find 7 from the sampleTree" do
+      shouldEqual (Just 7) (findDownWhere (_ == 7) (fromTree sampleTree) <#> value)
+
+    it "Should find 8 from the sampleTree (the bottom) and then find 1 (the top) with findUp" do
+      let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
+      shouldEqual (Just 1) (findUp 1 eight <#> value)
+
+    it "Should find 8 from the sampleTree (the bottom) but then not find 7 because it would require a downward traversal" do
+      let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
+      shouldEqual Nothing (findUp 7 eight <#> value)
+
+    it "Should find 8 from the sampleTree (the bottom) and then find 7 using findFromRoot" do
+      let eight = unsafePartial $ fromJust $ findDownWhere (_ == 8) $ fromTree sampleTree
+      shouldEqual (Just 7) (findFromRoot 7 eight <#> value)
+
+    it "Should flatten the Tree into a list of locations following a depth first pattern" do
+      let flat = map value $ flattenLocDepthFirst $ fromTree sampleTree
+      --log $ showTree sampleTree
+      --log $ show flat
+      shouldEqual flat (1 : 2 : 3 : 4 : 5 : 6 : 7 : 8 : Nil)
+
+
+