[commit: ghc] wip/erikd/heapview: Add tests for heapview (9d765cc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/erikd/heapview
Link       : http://ghc.haskell.org/trac/ghc/changeset/9d765cc94fd43984933e7662a919d9a6e1de2732/ghc

>---------------------------------------------------------------

commit 9d765cc94fd43984933e7662a919d9a6e1de2732
Author: Erik de Castro Lopo <erikd at mega-nerd.com>
Date:   Sat Jan 28 23:23:57 2017 +1100

    Add tests for heapview


>---------------------------------------------------------------

9d765cc94fd43984933e7662a919d9a6e1de2732
 libraries/{base => heapview}/tests/Makefile  |  0
 libraries/heapview/tests/all.T               |  3 ++
 libraries/heapview/tests/heapview_all.hs     | 77 ++++++++++++++++++++++++++++
 libraries/heapview/tests/heapview_all.stdout |  1 +
 4 files changed, 81 insertions(+)

diff --git a/libraries/base/tests/Makefile b/libraries/heapview/tests/Makefile
similarity index 100%
copy from libraries/base/tests/Makefile
copy to libraries/heapview/tests/Makefile
diff --git a/libraries/heapview/tests/all.T b/libraries/heapview/tests/all.T
new file mode 100644
index 0000000..63b7571
--- /dev/null
+++ b/libraries/heapview/tests/all.T
@@ -0,0 +1,3 @@
+setTestOpts(extra_ways(['sanity']))
+
+test('heapview_all', normal, compile_and_run, [''])
diff --git a/libraries/heapview/tests/heapview_all.hs b/libraries/heapview/tests/heapview_all.hs
new file mode 100644
index 0000000..7e4b773
--- /dev/null
+++ b/libraries/heapview/tests/heapview_all.hs
@@ -0,0 +1,77 @@
+{-# LANGUAGE MagicHash, BangPatterns #-}
+{-# OPTIONS_GHC -Wall #-}
+
+import GHC.Exts
+import GHC.HeapView
+import Control.DeepSeq
+
+import System.Environment
+import System.Mem
+
+import Control.Monad
+
+main :: IO ()
+main = do
+    args <- map length `fmap` getArgs
+    let list2 = 4:list
+    (list ++ list2 ++ args) `deepseq` pure ()
+
+    let x = list ++ list2 ++ args
+    performGC
+    getClosureAssert list >>= \ cl ->
+        unless (name cl == ":") $ fail "Wrong name"
+
+    getClosureAssert list2 >>= \ cl -> do
+        eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox list)
+        unless eq $ fail "Doesn't reference list"
+
+    getClosureData args >>= \ cl ->
+        unless (tipe (info cl) == CONSTR_0_1) $
+            fail $ "Not a CONSTR_0_1"
+
+    getClosureData x >>= \ cl ->
+        unless (tipe (info cl) == THUNK_2_0) $ do
+            fail "Not a THUNK_2_0"
+
+
+    let !(I# m) = length args + 42
+    let !(I# m') = length args + 23
+    let f = \ y n -> take (I# m + I# y) n ++ args
+        t = f m' list2
+
+    getClosureData f >>= \ cl -> do
+        unless (tipe (info cl) == FUN_1_1) $ do
+            fail "Not a FUN_1_1"
+        unless (dataArgs cl == [42]) $ do
+            fail "Wrong data arg"
+
+    getClosureData t >>= \ cl -> do
+        unless (tipe (info cl) == THUNK) $ do
+            fail "Not a THUNK"
+        unless (dataArgs cl == [23]) $ do
+            fail "Wrong data arg"
+
+        eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox f)
+        unless eq $ fail "t doesnt reference f"
+
+    let z = id (:) () z
+    z `seq` pure ()
+    performGC
+    getClosureAssert z >>= \ cl -> do
+        eq <- areBoxesEqual (ptrArgs cl !! 1) (asBox z)
+        unless eq $
+            fail "z doesnt reference itself"
+
+    putStrLn "Done. No errors."
+
+
+list :: [Int]
+list = [1,2,3]
+
+
+getClosureAssert :: a -> IO Closure
+getClosureAssert x = do
+    cl <- getClosureData x
+    case cl of
+        ConsClosure {} -> pure cl
+        _ -> fail "Expected ConsClosure"
diff --git a/libraries/heapview/tests/heapview_all.stdout b/libraries/heapview/tests/heapview_all.stdout
new file mode 100644
index 0000000..b747b9b
--- /dev/null
+++ b/libraries/heapview/tests/heapview_all.stdout
@@ -0,0 +1 @@
+Done. No errors.