Test Trac #5359

3 files changed, 153 insertions, 1 deletions

diff --git a/testsuite/tests/simplCore/should_compile/T5359a.hs b/testsuite/tests/simplCore/should_compile/T5359a.hs
new file mode 100644
index 0000000000..058b2af08a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T5359a.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE BangPatterns, Rank2Types, MagicHash, UnboxedTuples #-}
+
+module T5359a (linesT) where
+
+import GHC.Base
+import GHC.Word
+import GHC.ST (ST(..), runST)
+
+nullT :: Text -> Bool
+nullT (Text _ _ len) = len <= 0
+{-# INLINE [1] nullT #-}
+
+spanT :: (Char -> Bool) -> Text -> (Text, Text)
+spanT p t@(Text arr off len) = (textP arr off k, textP arr (off+k) (len-k))
+  where k = loop 0
+        loop !i | i >= len || not (p c) = i
+                | otherwise             = loop (i+d)
+            where Iter c d              = iter t i
+{-# INLINE spanT #-}
+
+linesT :: Text -> [Text]
+linesT ps | nullT ps  = []
+          | otherwise = h : if nullT t
+                            then []
+                            else linesT (unsafeTail t)
+    where (h,t) = spanT (/= '\n') ps
+{-# INLINE linesT #-}
+
+unsafeTail :: Text -> Text
+unsafeTail t@(Text arr off len) = Text arr (off+d) (len-d)
+  where d = iter_ t 0
+{-# INLINE unsafeTail #-}
+
+data Iter = Iter {-# UNPACK #-} !Char {-# UNPACK #-} !Int
+
+iter :: Text -> Int -> Iter
+iter (Text arr _ _) i = Iter (unsafeChrT m) 1
+  where m = unsafeIndex arr i
+{-# INLINE iter #-}
+
+iter_ :: Text -> Int -> Int
+iter_ (Text arr off _) i | m < 0xD800 || m > 0xDBFF = 1
+                         | otherwise                = 2
+  where m = unsafeIndex arr (off+i)
+{-# INLINE iter_ #-}
+
+data Text = Text {-# UNPACK #-}!Array {-# UNPACK #-}!Int {-# UNPACK #-}!Int
+
+text :: Array -> Int -> Int -> Text
+text arr off len = Text arr off len
+{-# INLINE text #-}
+
+emptyT :: Text
+emptyT = Text empty 0 0
+{-# INLINE [1] emptyT #-}
+
+textP :: Array -> Int -> Int -> Text
+textP arr off len | len == 0  = emptyT
+                  | otherwise = text arr off len
+{-# INLINE textP #-}
+
+unsafeChrT :: Word16 -> Char
+unsafeChrT (W16# w#) = C# (chr# (word2Int# w#))
+{-# INLINE unsafeChrT #-}
+
+data Array = Array ByteArray#
+
+data MArray s = MArray (MutableByteArray# s)
+
+new :: forall s. Int -> ST s (MArray s)
+new n@(I# len#)
+  | n < 0 || n /= 0 = error $ "Data.Text.Array.new: size overflow"
+  | otherwise = ST $ \s1# ->
+       case newByteArray# len# s1# of
+         (# s2#, marr# #) -> (# s2#, MArray marr# #)
+{-# INLINE new #-}
+
+unsafeFreeze :: MArray s -> ST s Array
+unsafeFreeze (MArray maBA) = ST $ \s# -> (# s#, Array (unsafeCoerce# maBA) #)
+{-# INLINE unsafeFreeze #-}
+
+unsafeIndex :: Array -> Int -> Word16
+unsafeIndex (Array aBA) (I# i#) =
+    case indexWord16Array# aBA i# of r# -> (W16# r#)
+{-# INLINE unsafeIndex #-}
+
+empty :: Array
+empty = runST (new 0 >>= unsafeFreeze)
diff --git a/testsuite/tests/simplCore/should_compile/T5359b.hs b/testsuite/tests/simplCore/should_compile/T5359b.hs
new file mode 100644
index 0000000000..6348defdd1
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T5359b.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeOperators #-}
+
+module T5359b where
+
+-----------------------------------------------------------------------------
+-- Base
+-----------------------------------------------------------------------------
+infixr 5 :+:
+infixr 6 :*:
+
+data U       = U              
+data a :+: b = L a | R b      
+data a :*: b = a :*: b        
+newtype Rec a   = Rec a       
+
+class Representable a where
+  type Rep a
+  to   :: Rep a -> a
+  from :: a -> Rep a
+
+
+data Tree = Leaf | Bin Int Tree Tree
+
+instance Representable Tree where
+  type Rep Tree =     U
+                      :+: (Rec Int :*: Rec Tree :*: Rec Tree)
+
+  from (Bin x l r) = R ((Rec x :*: Rec l :*: Rec r))
+  from Leaf        = L (U)
+
+  to (R ((Rec x :*: (Rec l) :*: (Rec r)))) = Bin x l r
+  to (L (U))                               = Leaf
+
+--------------------------------------------------------------------------------
+-- Generic enum
+--------------------------------------------------------------------------------
+
+class Enum' a where
+  enum' :: [a]
+
+instance Enum' U where enum' = undefined
+instance (Enum' a) => Enum' (Rec a) where enum' = undefined
+instance (Enum' f, Enum' g) => Enum' (f :+: g) where enum' = undefined
+instance (Enum' f, Enum' g) => Enum' (f :*: g) where enum' = undefined
+
+
+-- This INLINE pragma is essential for the bug
+{-# INLINE genum #-}
+genum :: (Representable a, Enum' (Rep a)) => [a]
+-- The definition of genum is essential for the bug
+genum = map to enum'
+
+
+instance Enum' Tree where enum' = genum
+instance Enum' Int  where enum' = []
+
+-- This SPECIALISE pragma is essential for the bug
+{-# SPECIALISE genum :: [Tree] #-}
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 7b416ece7b..123c8f4077 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -124,4 +124,6 @@ test('T5168',
 
 test('T5329', normal, compile, [''])
 test('T5303', reqlib('mtl'), compile, [''])   # Coercion-optimiation test
-test('T5342', normal, compile, [''])  # Lint error with -prof
+test('T5342', normal, compile, [''])   # Lint error with -prof
+test('T5359a', normal, compile, [''])  # Lint error with -O (OccurAnal)
+test('T5359b', normal, compile, [''])  # Lint error with -O (OccurAnal)