1 files changed, 56 insertions, 0 deletions
diff --git a/testsuite/tests/simplCore/should_compile/simpl011.hs b/testsuite/tests/simplCore/should_compile/simpl011.hs
new file mode 100644
index 0000000000..c660394e92
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/simpl011.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables, KindSignatures,
+             MultiParamTypeClasses, FunctionalDependencies #-}
+
+-- This one triggered a bug in the indirection-shorting 
+-- machinery, which gave a core-lint error
+
+module MHashTable (STHashTable, new, update) where
+
+import Data.Int             (Int32)
+import Control.Monad.ST     (ST)
+import Data.STRef           (STRef)
+import Data.Array.ST        (STArray)
+import Data.Array.MArray    (writeArray)
+
+class Monad m => MutHash arr ref m | arr -> m, ref -> m
+                                   , arr -> ref, ref -> arr where
+    newMHArray  :: (Int32, Int32) -> a -> m (arr Int32 a)
+    readMHArray :: arr Int32 a -> Int32 -> m a
+    writeMHArray:: arr Int32 a -> Int32 -> a -> m ()
+
+    newMHRef    :: a -> m (ref a)
+    readMHRef   :: ref a -> m a
+    writeMHRef  :: ref a -> a -> m ()
+
+instance MutHash (STArray s) (STRef s) (ST s) where
+    newMHArray  = undefined
+    readMHArray = undefined
+    writeMHArray= writeArray
+
+    newMHRef    = undefined
+    readMHRef   = undefined
+    writeMHRef  = undefined
+
+type STHashTable s key val = HashTable key val (STArray s) (STRef s) (ST s)
+
+newtype HashTable key val arr ref m = HashTable (ref (HT key val arr ref m))
+
+data HT key val arr (ref :: * -> *) (m :: * -> *) = HT { dir :: (arr Int32 (arr Int32 [(key,val)])) }
+
+new :: forall arr ref m key val. (MutHash arr ref m) => m (HashTable key val arr ref m)
+new = do
+  (dir::arr Int32 (arr Int32 [(key,val)]))  <- newMHArray (0,0) undefined
+  (segment::arr Int32 [(key,val)])          <- return undefined
+  return (undefined :: HashTable key val arr ref m)
+
+{-# RULES "update/ST" update = updateST #-}
+updateST:: STHashTable s k v -> k -> v -> ST s Bool
+updateST= update'
+
+update  :: (MutHash arr ref m)
+        => HashTable key val arr ref m -> key -> val -> m Bool
+update  = update'
+
+update' :: (MutHash arr ref m)
+        => HashTable key val arr ref m -> key -> val -> m Bool
+update' _ _ _ = return False