[commit: ghc] ghc-8.2: testsuite: Add testcase for #13429 (366a5b7)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/366a5b7d5226517fa3d499f393d52e59c5b8c29e/ghc

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

commit 366a5b7d5226517fa3d499f393d52e59c5b8c29e
Author: Ben Gamari <ben at smart-cactus.org>
Date:   Thu Mar 23 23:03:54 2017 -0400

    testsuite: Add testcase for #13429
    
    (cherry picked from commit be8122ab72aeec509b5ce4b4f05fbc5cdb77bf5a)


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

366a5b7d5226517fa3d499f393d52e59c5b8c29e
 testsuite/tests/simplCore/should_compile/T13429.hs | 114 +++++++++++++++++++++
 testsuite/tests/simplCore/should_compile/all.T     |   1 +
 2 files changed, 115 insertions(+)

diff --git a/testsuite/tests/simplCore/should_compile/T13429.hs b/testsuite/tests/simplCore/should_compile/T13429.hs
new file mode 100644
index 0000000..cc9b4d2
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T13429.hs
@@ -0,0 +1,114 @@
+{-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+module Loop (Array(..), Image(..), X, promote, correlate) where
+import           Data.Maybe (fromMaybe)
+
+data Kernel e = Kernel Int Int !(Vector (Int, Int, e)) deriving (Show)
+
+
+toKernel :: Array X e => Image X e -> Kernel e
+toKernel img =
+  Kernel m2 n2 $ filter (\(_, _, x) -> x /= 0) $ imap addIx $ toVector img
+  where
+    (m, n) = dims img
+    (m2, n2) = (m `div` 2, n `div` 2)
+    addIx k (PixelX x) =
+      let (i, j) = toIx n k
+      in (i - m2, j - n2, x)
+
+correlate :: Array cs e => Image X e -> Image cs e -> Image cs e
+correlate kernelImg imgM = makeImage (dims imgM) stencil
+  where
+    !(Kernel kM2 kN2 kernelV) = toKernel kernelImg
+    kLen = length kernelV
+    stencil (i, j) =
+      loop 0 (promote 0) $ \ k acc ->
+        let (iDelta, jDelta, x) = kernelV !! k
+            imgPx = index imgM (i + iDelta, j + jDelta)
+        in liftPx2 (+) acc (liftPx (x *) imgPx)
+    loop init' initAcc f = go init' initAcc
+      where
+        go step acc =
+          if step < kLen
+            then go (step + 1) (f step acc)
+            else acc
+{-# INLINE correlate #-}
+
+
+
+-- | A Pixel family with a color space and a precision of elements.
+data family Pixel cs e :: *
+
+
+class (Eq e, Num e) => ColorSpace cs e where
+  promote :: e -> Pixel cs e
+  liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e
+  liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e
+
+
+
+data family Image cs e :: *
+
+class ColorSpace cs e => Array cs e where
+  dims :: Image cs e -> (Int, Int)
+  makeImage :: (Int, Int) -> ((Int, Int) -> Pixel cs e) -> Image cs e
+  toVector :: Image cs e -> Vector (Pixel cs e)
+  index :: Image cs e -> (Int, Int) -> Pixel cs e
+
+fromIx :: Int -> (Int, Int) -> Int
+fromIx n (i, j) = n * i + j
+
+toIx :: Int -> Int -> (Int, Int)
+toIx n k = divMod k n
+
+instance (Show (Pixel cs e), ColorSpace cs e, Array cs e) =>
+         Show (Image cs e) where
+  show img =
+    let (m, n) = dims img
+    in "<Image " ++ show m ++ "x" ++ show n ++ ">: " ++ show (toVector img)
+
+
+data X = X
+
+newtype instance Pixel X e = PixelX e
+
+instance Show e => Show (Pixel X e) where
+  show (PixelX e) = "Pixel: " ++ show e
+
+
+instance (Eq e, Num e) => ColorSpace X e where
+  promote = PixelX
+  liftPx f (PixelX g) = PixelX (f g)
+  liftPx2 f (PixelX g1) (PixelX g2) = PixelX (f g1 g2)
+
+
+data instance Image X e = VImage Int Int (Vector (Pixel X e))
+
+instance ColorSpace X e => Array X e where
+  dims (VImage m n _) = (m, n)
+  makeImage (m, n) f = VImage m n $ generate (m * n) (f . toIx n)
+  toVector (VImage _ _ v) = v
+  index (VImage _ n v) ix = fromMaybe (promote 0) (v !? (fromIx n ix))
+
+
+-- Vector emulation
+
+type Vector a = [a]
+
+imap :: (Num a, Enum a) => (a -> b -> c) -> [b] -> [c]
+imap f = zipWith f [0..]
+
+(!?) :: [a] -> Int -> Maybe a
+(!?) ls i
+  | i < 0 || i >= length ls = Nothing
+  | otherwise = Just (ls !! i)
+
+generate :: (Ord t, Num t) => t -> (t -> a) -> [a]
+generate n f = go (n-1) [] where
+  go i acc | i < 0 = acc
+           | otherwise = go (i-1) (f i : acc)
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 98d7d79..d6a539e 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -252,3 +252,4 @@ test('T13338', only_ways(['optasm']), compile, ['-dcore-lint'])
 test('T13367', normal, run_command, ['$MAKE -s --no-print-directory T13367'])
 test('T13417', normal, compile, ['-O'])
 test('T13413', normal, compile, [''])
+test('T13429', normal, compile, [''])