Commit 3eb85d3d authored by Simon Peyton Jones's avatar Simon Peyton Jones

Test Trac #5359

parent 41e5e783
{-# 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)
{-# 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] #-}
......@@ -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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment