1
exercism fetch haskell pov

test/Tests.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
{-# LANGUAGE TupleSections #-}

import Data.Foldable     (for_)
import Data.Function     (on)
import Data.Tree         (Tree(Node), rootLabel)
import Data.List         (sort)
import Test.Hspec        (Spec, describe, it, shouldBe)
import Test.Hspec.Runner (configFastFail, defaultConfig, hspecWith)

import POV (fromPOV, tracePathBetween)

main :: IO ()
main = hspecWith defaultConfig {configFastFail = True} specs

specs :: Spec
specs = do

    describe "fromPOV" $ do

      let cases =
            [ ("reparenting singleton"        , singleton , Just singleton')
            , ("reparenting with sibling"     , simple    , Just simple'   )
            , ("reparenting flat"             , flat      , Just flat'     )
            , ("reparenting nested"           , nested    , Just nested'   )
            , ("reparenting kids"             , kids      , Just kids'     )
            , ("reparenting cousins"          , cousins   , Just cousins'  )
            , ("from POV of non-existent node", leaf "foo", Nothing        ) ]

          rootShouldMatch  = shouldBe `on` fmap rootLabel
          edgesShouldMatch = shouldBe `on` fmap (sort . toEdges)

          test (name, input, output) = describe name $ do
            it "correct root"  $ fromPOV "x" input `rootShouldMatch`  output
            it "correct edges" $ fromPOV "x" input `edgesShouldMatch` output

          in for_ cases test

      describe "Should not be able to find a missing node" $

        let cases = [ ("singleton", singleton)
                    , ("flat"     , flat     )
                    , ("kids"     , kids     )
                    , ("nested"   , nested   )
                    , ("cousins"  , cousins  ) ]

            test (name, g) = it name $ fromPOV "NOT THERE" g `shouldBe` Nothing

            in for_ cases test

    describe "tracePathBetween" $ do

      it "Can find path from x -> parent" $
        tracePathBetween "x" "parent" simple
        `shouldBe` Just [ "x"
                        , "parent" ]

      it "Can find path from x -> sibling" $
        tracePathBetween "x" "b" flat
        `shouldBe` Just [ "x"
                        , "root"
                        , "b"    ]

      it "Can trace a path from x -> cousin" $
        tracePathBetween "x" "cousin-1" cousins
        `shouldBe` Just [ "x"
                        , "parent"
                        , "grandparent"
                        , "uncle"
                        , "cousin-1"    ]

      it "Can find path from nodes other than x" $
        tracePathBetween "a" "c" flat
        `shouldBe` Just [ "a"
                        , "root"
                        , "c"    ]

      it "Cannot trace if destination does not exist" $
        tracePathBetween "x" "NOT THERE" cousins
        `shouldBe` Nothing

      it "Cannot trace if source does not exist" $
        tracePathBetween "NOT THERE" "x" cousins
        `shouldBe` Nothing

-- Functions used in the tests.

leaf :: a -> Tree a
leaf v = Node v []

-- In the trees we're making, we don't care about the ordering of children.
-- This is significant when rerooting on nodes that have a parent and children.
-- The former parent can go either before or after the former children.
-- Either choice would be correct in the context of this problem.
-- So all we need to check is:
-- 1) The graph is actually rooted on the requested node.
-- 2) The sorted edge list is correct.
-- This function helps check the second condition.

toEdges :: Ord a => Tree a -> [(a, a)]
toEdges (Node r ts) = map ((r,) . rootLabel) ts ++ concatMap toEdges ts

-- Trees used in the tests.

singleton , simple , flat , kids , nested , cousins  :: Tree String
singleton', simple', flat', kids', nested', cousins' :: Tree String

singleton = leaf "x"

singleton' = leaf "x"

simple = Node "parent"
             [ leaf "x"
             , leaf "sibling"
             ]

simple' = Node "x"
              [ Node "parent"
                    [ leaf "sibling"
                    ]
              ]

flat = Node "root"
           [ leaf "a"
           , leaf "b"
           , leaf "x"
           , leaf "c"
           ]

flat' = Node "x"
            [ Node "root"
                  [ leaf "a"
                  , leaf "b"
                  , leaf "c"
                  ]
            ]

kids = Node "root"
           [ Node "x"
                 [ leaf "kid-0"
                 , leaf "kid-1"
                 ]
           ]

kids' = Node "x"
            [ leaf "kid-0"
            , leaf "kid-1"
            , leaf "root"
            ]

nested = Node "level-0"
             [ Node "level-1"
                   [ Node "level-2"
                         [ Node "level-3"
                               [ leaf "x"
                               ]
                         ]
                   ]
             ]

nested' = Node "x"
              [ Node "level-3"
                    [ Node "level-2"
                          [ Node "level-1"
                                [ leaf "level-0"
                                ]
                          ]
                    ]
              ]

cousins = Node "grandparent"
              [ Node "parent"
                    [ Node "x"
                          [ leaf "kid-a"
                          , leaf "kid-b"
                          ]
                    , leaf "sibling-0"
                    , leaf "sibling-1"
                    ]
              , Node "uncle"
                    [ leaf "cousin-0"
                    , leaf "cousin-1"
                    ]
              ]

cousins' = Node "x"
               [ leaf "kid-a"
               , leaf "kid-b"
               , Node "parent"
                     [ leaf "sibling-0"
                     , leaf "sibling-1"
                     , Node "grandparent"
                           [ Node "uncle"
                                 [ leaf "cousin-0"
                                 , leaf "cousin-1"
                                 ]
                           ]
                     ]
               ]