Add MonadFix instance for Data.Tree (#451)
authorDavid Feuer <David.Feuer@gmail.com>
Sat, 23 Dec 2017 05:52:13 +0000 (00:52 -0500)
committerGitHub <noreply@github.com>
Sat, 23 Dec 2017 05:52:13 +0000 (00:52 -0500)
* Add a `MonadFix` instance for `Tree`. This is based on an instance for
  a somewhat more general type by G. Allais.
  See [MonadTree.hs](https://gist.github.com/gallais/4c59b949c743c0a85cab55dcb73aaf7c).

* Make `>>=` for `Tree` stricter. Previously, it was too lazy to satisfy the
  `Monad` laws, and that laziness was not particularly valuable.

* Add a small test suite for `Tree`. The `Arbitrary` instance is mediocre,
  and so is the `MonadFix` test, but something definitely seems better than
  nothing!

* Bump QuickCheck version to 2.7.1 for `genericShrink`.

Fixes #452

.travis.yml
Data/Tree.hs
changelog.md
containers.cabal
tests/tree-properties.hs [new file with mode: 0644]

index 450d04f..b775d15 100644 (file)
@@ -31,7 +31,7 @@ install:
  - cabal install --only-dependencies
  # we need to install the test-suite and benchmark deps manually as the cabal
  # solver would otherwise complain about cyclic deps
- - cabal install 'test-framework >= 0.3.3' 'test-framework-quickcheck2 >= 0.2.9' 'QuickCheck >= 2.4.0.1' 'ChasingBottoms' 'HUnit' 'test-framework-hunit'
+ - cabal install 'test-framework >= 0.3.3' 'test-framework-quickcheck2 >= 0.2.9' 'QuickCheck >= 2.7.1' 'ChasingBottoms' 'HUnit' 'test-framework-hunit'
 
  # If we enable benchmarks, we'll need 'criterion >= 0.4.0 && < 1.2'
 
index 8d717d0..5e3c353 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE CPP #-}
 #if __GLASGOW_HASKELL__
 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
@@ -47,6 +48,7 @@ import Data.Traversable (Traversable(traverse))
 #endif
 
 import Control.Monad (liftM)
+import Control.Monad.Fix (MonadFix (..), fix)
 import Data.Sequence (Seq, empty, singleton, (<|), (|>), fromList,
             ViewL(..), ViewR(..), viewl, viewr)
 import Data.Typeable
@@ -173,8 +175,18 @@ instance Applicative Tree where
 
 instance Monad Tree where
     return = pure
-    Node x ts >>= f = Node x' (ts' ++ map (>>= f) ts)
-      where Node x' ts' = f x
+    Node x ts >>= f = case f x of
+        Node x' ts' -> Node x' (ts' ++ map (>>= f) ts)
+
+-- | @since 0.5.11
+instance MonadFix Tree where
+  mfix = mfixTree
+
+mfixTree :: (a -> Tree a) -> Tree a
+mfixTree f
+  | Node a children <- fix (f . rootLabel)
+  = Node a (zipWith (\i _ -> mfixTree ((!! i) . subForest . f))
+                    [0..] children)
 
 instance Traversable Tree where
     traverse f (Node x ts) = liftA2 Node (f x) (traverse (traverse f) ts)
index 87a74a4..d86d351 100644 (file)
@@ -7,6 +7,13 @@
 
 * Add a `MonadFix` instance for `Data.Sequence`.
 
+* Add a `MonadFix` instance for `Data.Tree`.
+
+* Make `>>=` for `Data.Tree` strict in the result of its second argument;
+  being too lazy here is almost useless, and violates one of the monad identity
+  laws. Specifically, `return () >>= \_ -> undefined` should always be
+  `undefined`, but this was not the case.
+
 * Add `lookupMin` and `lookupMax` to `Data.IntMap` (Thanks, bwroga!)
 
 * Update for recent and upcoming GHC and Cabal versions (Thanks, Herbert
@@ -14,6 +21,8 @@
 
 * Improve documentation (Thanks, Oleg Grenrus and Benjamin Hodgson!)
 
+* Add a (very incomplete) test suite for `Data.Tree`.
+
 * Add Haddock `@since` annotations for changes made since version
   0.5.4 (Thanks, Simon Jakobi!)
 
index 51964d6..e28f196 100644 (file)
@@ -274,7 +274,7 @@ Test-suite map-lazy-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2,
@@ -308,7 +308,7 @@ Test-suite map-strict-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2,
@@ -329,7 +329,7 @@ Test-suite bitqueue-properties
     include-dirs: include
 
     build-depends:
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-quickcheck2
 
@@ -355,7 +355,7 @@ Test-suite set-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2,
@@ -384,7 +384,7 @@ Test-suite intmap-lazy-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2
@@ -412,7 +412,7 @@ Test-suite intmap-strict-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2
@@ -439,7 +439,7 @@ Test-suite intset-properties
 
     build-depends:
         HUnit,
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-hunit,
         test-framework-quickcheck2
@@ -477,7 +477,7 @@ Test-suite deprecated-properties
     include-dirs: include
 
     build-depends:
-        QuickCheck,
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-quickcheck2
 
@@ -497,7 +497,26 @@ Test-suite seq-properties
     include-dirs: include
 
     build-depends:
-        QuickCheck,
+        QuickCheck >= 2.7.1,
+        test-framework,
+        test-framework-quickcheck2,
+        transformers
+
+Test-suite tree-properties
+    hs-source-dirs: tests, .
+    main-is: tree-properties.hs
+    other-modules:
+        Data.Tree
+    type: exitcode-stdio-1.0
+    cpp-options: -DTESTING
+
+    build-depends: base >= 4.3 && < 5, array, deepseq >= 1.2 && < 1.5, ghc-prim
+    ghc-options: -O2
+    other-extensions: CPP, BangPatterns
+    include-dirs: include
+
+    build-depends:
+        QuickCheck >= 2.7.1,
         test-framework,
         test-framework-quickcheck2,
         transformers
@@ -525,7 +544,7 @@ test-suite map-strictness-properties
     base >= 4.3 && < 5,
     ChasingBottoms,
     deepseq >= 1.2 && < 1.5,
-    QuickCheck >= 2.4.0.1,
+    QuickCheck >= 2.7.1,
     ghc-prim,
     test-framework >= 0.3.3,
     test-framework-quickcheck2 >= 0.2.9
@@ -553,7 +572,7 @@ test-suite intmap-strictness-properties
     base >= 4.3 && < 5,
     ChasingBottoms,
     deepseq >= 1.2 && < 1.5,
-    QuickCheck >= 2.4.0.1,
+    QuickCheck >= 2.7.1,
     ghc-prim,
     test-framework >= 0.3.3,
     test-framework-quickcheck2 >= 0.2.9
@@ -578,7 +597,7 @@ test-suite intset-strictness-properties
     base >= 4.3 && < 5,
     ChasingBottoms,
     deepseq >= 1.2 && < 1.5,
-    QuickCheck >= 2.4.0.1,
+    QuickCheck >= 2.7.1,
     ghc-prim,
     test-framework >= 0.3.3,
     test-framework-quickcheck2 >= 0.2.9
diff --git a/tests/tree-properties.hs b/tests/tree-properties.hs
new file mode 100644 (file)
index 0000000..5e406df
--- /dev/null
@@ -0,0 +1,106 @@
+{-# LANGUAGE CPP #-}
+
+import Data.Tree as T
+
+import Control.Applicative (Const(Const, getConst), pure, (<$>), (<*>), liftA2)
+
+import Test.Framework
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+import Test.QuickCheck.Function (Fun (..), apply)
+import Test.QuickCheck.Poly (A, B, C)
+import Control.Monad.Fix (MonadFix (..))
+import Control.Monad (ap)
+
+default (Int)
+
+main :: IO ()
+main = defaultMain
+         [
+           testProperty "monad_id1"                prop_monad_id1
+         , testProperty "monad_id2"                prop_monad_id2
+         , testProperty "monad_assoc"              prop_monad_assoc
+         , testProperty "ap_ap"                    prop_ap_ap
+         , testProperty "ap_liftA2"                prop_ap_liftA2
+         , testProperty "monadFix_ls"              prop_monadFix_ls
+         ]
+
+{--------------------------------------------------------------------
+  Arbitrary trees
+--------------------------------------------------------------------}
+
+
+-- This instance isn't balanced very well; the trees will probably tend
+-- to lean left. But it's better than nothing and we can fix it later.
+instance Arbitrary a => Arbitrary (Tree a) where
+  arbitrary = sized (fmap snd . arbtree)
+    where
+      arbtree :: Arbitrary a => Int -> Gen (Int, Tree a)
+      arbtree 0 = fmap ((,) 1) $ Node <$> arbitrary <*> pure []
+      arbtree n = do
+        root <- arbitrary
+        num_children <- choose (0, n - 1)
+        (st, tl) <- go num_children
+        return (1+st, Node root tl)
+
+      go 0 = pure (0, [])
+      go n = do
+        (sh, hd) <- arbtree n
+        (st, tl) <- go (n - sh)
+        pure (sh + st, hd : tl)
+
+-- genericShrink only became available when generics did, so it's
+-- not available under GHC 7.0.
+#if __GLASGOW_HASKELL__ >= 704
+  shrink = genericShrink
+#endif
+
+----------------------------------------------------------------
+-- Unit tests
+----------------------------------------------------------------
+
+----------------------------------------------------------------
+-- QuickCheck
+----------------------------------------------------------------
+
+apply2 :: Fun (a, b) c -> a -> b -> c
+apply2 f a b = apply f (a, b)
+
+prop_ap_ap :: Tree (Fun A B) -> Tree A -> Property
+prop_ap_ap fs xs = (apply <$> fs <*> xs) === ((apply <$> fs) `ap` xs)
+
+prop_ap_liftA2 :: Fun (A, B) C -> Tree A -> Tree B -> Property
+prop_ap_liftA2 f as bs = (apply2 f <$> as <*> bs) === liftA2 (apply2 f) as bs
+
+prop_monad_id1 :: Tree A -> Property
+prop_monad_id1 t = (t >>= pure) === t
+
+prop_monad_id2 :: A -> Fun A (Tree B) -> Property
+prop_monad_id2 a f = (pure a >>= apply f) === apply f a
+
+prop_monad_assoc :: Tree A -> Fun A (Tree B) -> Fun B (Tree C) -> Property
+prop_monad_assoc ta atb btc =
+  ((ta >>= apply atb) >>= apply btc)
+  ===
+  (ta >>= \a -> apply atb a >>= apply btc)
+
+-- The left shrinking law
+--
+-- This test is kind of wonky and unprincipled, because it's
+-- rather tricky to construct test cases!
+-- This is the most important MonadFix law to test because it's the
+-- least intuitive by far, and because it's the only one that's
+-- sensitive to the Monad instance.
+prop_monadFix_ls :: Int -> Tree Int -> Fun Int (Tree Int) -> Property
+prop_monadFix_ls val ta ti =
+  fmap ($val) (mfix (\x -> ta >>= \y -> f x y))
+  ===
+  fmap ($val) (ta >>= \y -> mfix (\x -> f x y))
+  where
+    fact :: Int -> (Int -> Int) -> Int -> Int
+    fact x _ 0 = x + 1
+    fact x f n = x + n * f ((n - 1) `mod` 23)
+
+    f :: (Int -> Int) -> Int -> Tree (Int -> Int)
+    f q y = let t = apply ti y
+            in fmap (\w -> fact w q) t