[commit: ghc] master: Add test T9407 (Windows) (225afc4)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/225afc4ace4dff4ae52ac2147942cdeeb76fc723/ghc

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

commit 225afc4ace4dff4ae52ac2147942cdeeb76fc723
Author: Rik Steenkamp <rik at ewps.nl>
Date:   Wed Jan 20 12:39:00 2016 +0100

    Add test T9407 (Windows)
    
    Add test for #9407. The test is only run on Windows 64bit, as this is
    where the problem occurred.
    
    Reviewed by: thomie
    
    Differential Revision: https://phabricator.haskell.org/D1806


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

225afc4ace4dff4ae52ac2147942cdeeb76fc723
 testsuite/tests/numeric/should_run/T9407.hs     | 55 +++++++++++++++++++++++++
 testsuite/tests/numeric/should_run/T9407.stdout |  1 +
 testsuite/tests/numeric/should_run/all.T        |  5 +++
 3 files changed, 61 insertions(+)

diff --git a/testsuite/tests/numeric/should_run/T9407.hs b/testsuite/tests/numeric/should_run/T9407.hs
new file mode 100644
index 0000000..8e6b4fe
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T9407.hs
@@ -0,0 +1,55 @@
+data Vec3 = Vec3 !Double !Double !Double
+    deriving (Show)
+
+infixl 6 ^+^, ^-^
+infixr 7 *^, <.>
+
+negateV :: Vec3 -> Vec3
+negateV (Vec3 x y z) = Vec3 (-x) (-y) (-z)
+
+(^+^), (^-^) :: Vec3 -> Vec3 -> Vec3
+Vec3 x1 y1 z1 ^+^ Vec3 x2 y2 z2 = Vec3 (x1 + x2) (y1 + y2) (z1 + z2)
+v ^-^ v' = v ^+^ negateV v'
+
+(*^) :: Double -> Vec3 -> Vec3
+s *^ Vec3 x y z = Vec3 (s * x) (s * y) (s * z)
+
+(<.>) :: Vec3 -> Vec3 -> Double
+Vec3 x1 y1 z1 <.> Vec3 x2 y2 z2 = x1 * x2 + y1 * y2 + z1 * z2
+
+magnitudeSq :: Vec3 -> Double
+magnitudeSq v = v <.> v
+
+normalized :: Vec3 -> Vec3
+normalized v = (1 / sqrt (magnitudeSq v)) *^ v
+
+class Surface s where
+    intersectSurfaceWithRay :: s -> Vec3 -> Vec3 -> Maybe Vec3
+
+data Sphere = Sphere Vec3 Double
+
+instance Surface Sphere where
+    intersectSurfaceWithRay (Sphere c r) o d =
+        let c' = c ^-^ o
+            b = c' <.> d
+            det = b^2 - magnitudeSq c' + r^2
+            det' = sqrt det
+            t1 = b - det'
+            t2 = b + det'
+
+            returnIntersection t =
+                let x = o ^+^ t *^ d
+                in Just (normalized (x ^-^ c))
+        in if det < 0 then Nothing
+           else if t1 > 1e-6 then returnIntersection t1
+           else if t2 > 1e-6 then returnIntersection t2
+           else Nothing
+
+iappend :: Maybe Vec3 -> Maybe Vec3 -> Maybe Vec3
+Nothing `iappend` i2 = i2
+i1 `iappend` _ = i1
+
+main :: IO ()
+main = print $ foldl combine Nothing [Sphere (Vec3 0 0 0) 1]
+  where combine accum surf = accum `iappend`
+            intersectSurfaceWithRay surf (Vec3 0 0 5) (Vec3 0 0 (-1))
diff --git a/testsuite/tests/numeric/should_run/T9407.stdout b/testsuite/tests/numeric/should_run/T9407.stdout
new file mode 100644
index 0000000..03535cc
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T9407.stdout
@@ -0,0 +1 @@
+Just (Vec3 0.0 0.0 1.0)
\ No newline at end of file
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 7ebdd44..b097c7f 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -62,6 +62,11 @@ test('T7233', normal, compile_and_run, [''])
 test('NumDecimals', normal, compile_and_run, [''])
 test('T8726', normal, compile_and_run, [''])
 test('CarryOverflow', omit_ways(['ghci']), compile_and_run, [''])
+test('T9407', [
+     unless(opsys('mingw32') and wordsize(64), skip),
+     only_ways(['optasm'])
+     ],
+     compile_and_run, [''])
 test('T9810', normal, compile_and_run, [''])
 test('T10011', normal, compile_and_run, [''])
 test('T10962', omit_ways(['ghci']), compile_and_run, [''])