{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
#if __GLASGOW_HASKELL__ >= 907
{-# LANGUAGE TypeAbstractions #-}
#endif
-- |
-- Copyright: (c) 2022 Andrew Lelechenko
-- Licence: BSD3
-- Maintainer: Andrew Lelechenko <andrew.lelechenko@gmail.com>
module Main where
import Prelude hiding (Foldable(..))
import Data.Bits (Bits(..), FiniteBits(..), bitDefault)
import Data.Foldable (Foldable(..))
import Data.Int
import Data.List (intersperse)
import Data.Proxy (Proxy(..))
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Text.Builder.Linear.Buffer
import Data.Text.Internal (Text(..))
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder qualified as TB
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Builder.Int (decimal, hexadecimal)
import Data.Text.Lazy.Builder.RealFloat (realFloat)
import Data.Word
import GHC.Generics
import GHC.TypeLits (KnownNat, OrderingI (..), SomeNat (..), cmpNat, natVal, sameNat, someNatVal)
import Numeric.Natural (Natural)
import Test.Tasty
import Test.Tasty.QuickCheck hiding ((><), (.&.))
instance Arbitrary Text where
arbitrary = do
xs ← T.pack <$> arbitrary
d ← (`mod` (T.length xs + 1)) <$> arbitrary
pure $ T.drop d xs
shrink t@(Text arr off len)
= map (T.drop d . T.pack) (shrink ys)
++ map (\d' → T.drop d' $ T.pack $ drop (d - d') ys) (shrink d)
where
xs = T.unpack t
ys = T.unpack (Text arr 0 (off + len))
d = length ys - length xs
data Action
= AppendText Text
| PrependText Text
| AppendChar Char
| PrependChar Char
| AppendChars Word Char
| PrependChars Word Char
| JustifyLeft Word Char
| JustifyRight Word Char
| Center Word Char
| HexInt Int8 Int16 (IntN 30) (IntN 31) Int32 (IntN 33) Int64
| HexWord Word8 Word16 Word32 Word64
| AppendHexI SomeIntN
| PrependHexI SomeIntN
| AppendHexW SomeWordN
| PrependHexW SomeWordN
| DecInt Int8 Int16 (IntN 30) (IntN 31) Int32 (IntN 33) Int64
| DecWord Word8 Word16 (WordN 30) (WordN 31) Word32 (WordN 33) Word64
| AppendDecW Word
| PrependDecW Word
| AppendDecI Int
| PrependDecI Int
| AppendDecI30 (IntN 30)
| PrependDecI30 (IntN 30)
| AppendDouble Double
| PrependDouble Double
| AppendSpaces Word
| PrependSpaces Word
deriving (Eq, Ord, Show, Generic)
instance Arbitrary Action where
arbitrary = oneof
[ AppendText <$> arbitrary
, PrependText <$> arbitrary
, AppendChar <$> arbitraryUnicodeChar
, PrependChar <$> arbitraryUnicodeChar
, AppendChars <$> arbitraryCharCount <*> arbitraryUnicodeChar
, PrependChars <$> arbitraryCharCount <*> arbitraryUnicodeChar
, JustifyLeft <$> arbitraryTotalLength <*> arbitraryUnicodeChar
, JustifyRight <$> arbitraryTotalLength <*> arbitraryUnicodeChar
, Center <$> arbitraryTotalLength <*> arbitraryUnicodeChar
, AppendHexI <$> arbitrary
, PrependHexI <$> arbitrary
, AppendHexW <$> arbitrary
, PrependHexW <$> arbitrary
, AppendDecW <$> arbitraryBoundedIntegral
, PrependDecW <$> arbitraryBoundedIntegral
, AppendDecI <$> arbitraryBoundedIntegral
, PrependDecI <$> arbitraryBoundedIntegral
, AppendDecI30 <$> arbitraryBoundedIntegral
, PrependDecI30 <$> arbitraryBoundedIntegral
, pure $ HexWord minBound minBound minBound minBound
, pure $ HexWord maxBound maxBound maxBound maxBound
, pure $ HexInt minBound minBound minBound minBound minBound minBound minBound
, pure $ HexInt maxBound maxBound maxBound maxBound maxBound maxBound maxBound
, pure $ HexInt 0 0 0 0 0 0 0
, pure $ DecInt minBound minBound minBound minBound minBound minBound minBound
, pure $ DecInt maxBound maxBound maxBound maxBound maxBound maxBound maxBound
, pure $ DecInt 0 0 0 0 0 0 0
, pure $ DecWord minBound minBound minBound minBound minBound minBound minBound
, pure $ DecWord maxBound maxBound maxBound maxBound maxBound maxBound maxBound
, AppendDouble <$> arbitrary
, PrependDouble <$> arbitrary
, AppendSpaces . getNonNegative <$> arbitrary
, PrependSpaces . getNonNegative <$> arbitrary
]
where
arbitraryCharCount = chooseBoundedIntegral (0, 6)
arbitraryTotalLength = chooseBoundedIntegral (3, 20)
shrink = genericShrink
interpretOnText ∷ [Action] → Text → Text
interpretOnText xs z = foldl' go z xs
where
go ∷ Text → Action → Text
go b (AppendText x) = b <> x
go b (PrependText x) = x <> b
go b (AppendChar x) = T.snoc b x
go b (PrependChar x) = T.cons x b
go b (AppendChars n x) = b <> T.replicate (fromIntegral n) (T.singleton x)
go b (PrependChars n x) = T.replicate (fromIntegral n) (T.singleton x) <> b
go b (JustifyLeft n x) = T.justifyLeft (fromIntegral n) x b
go b (JustifyRight n x) = T.justifyRight (fromIntegral n) x b
go b (Center n x) = T.center (fromIntegral n) x b
go b (HexInt r s t u v w x)
= intersperseText
[ hexadecimal (fromIntegral @Int16 @Word16 s)
, hexadecimalI t
, hexadecimal (fromIntegral @Int64 @Word64 x) ]
<> b
<> intersperseText
[ hexadecimal (fromIntegral @Int8 @Word8 r)
, hexadecimalI u
, hexadecimal (fromIntegral @Int32 @Word32 v)
, hexadecimalI w ]
go b (HexWord u v w x)
= intersperseText [hexadecimal u, hexadecimal x]
<> b
<> intersperseText [hexadecimal v, hexadecimal w ]
go b (AppendHexI x) = b <> toStrict (toLazyText (hexadecimalSI x))
go b (PrependHexI x) = toStrict (toLazyText (hexadecimalSI x)) <> b
go b (AppendHexW x) = b <> toStrict (toLazyText (hexadecimalSW x))
go b (PrependHexW x) = toStrict (toLazyText (hexadecimalSW x)) <> b
go b (DecInt r s t u v w x)
= intersperseText [decimal s, decimal t, decimal x]
<> b
<> intersperseText [decimal r, decimal u, decimal v, decimal w]
go b (DecWord r s t u v w x)
= intersperseText [decimal s, decimal t, decimal x]
<> b
<> intersperseText [decimal r, decimal u, decimal v, decimal w]
go b (AppendDecW x) = b <> toStrict (toLazyText (decimal x))
go b (PrependDecW x) = toStrict (toLazyText (decimal x)) <> b
go b (AppendDecI x) = b <> toStrict (toLazyText (decimal x))
go b (PrependDecI x) = toStrict (toLazyText (decimal x)) <> b
go b (AppendDecI30 x) = b <> toStrict (toLazyText (decimal x))
go b (PrependDecI30 x) = toStrict (toLazyText (decimal x)) <> b
go b (AppendDouble x) = b <> toStrict (toLazyText (realFloat x))
go b (PrependDouble x) = toStrict (toLazyText (realFloat x)) <> b
go b (AppendSpaces n) = b <> T.replicate (fromIntegral n) (T.singleton ' ')
go b (PrependSpaces n) = T.replicate (fromIntegral n) (T.singleton ' ') <> b
hexadecimalSI (SomeIntN x) = hexadecimalI x
hexadecimalI ∷ (KnownNat n) ⇒ IntN n → TB.Builder
hexadecimalI x = if x >= 0
then hexadecimal x
else hexadecimal (fromIntegral @_ @Word64 x .&. (shiftL 1 (intSize x) - 1))
hexadecimalSW (SomeWordN x) = hexadecimalW x
hexadecimalW ∷ (KnownNat n) ⇒ WordN n → TB.Builder
hexadecimalW x = if x >= 0
then hexadecimal x
else hexadecimal (fromIntegral @_ @Word64 x .&. (shiftL 1 (intSize x) - 1))
intersperseText ∷ [TB.Builder] → Text
intersperseText bs =
toStrict (toLazyText (mconcat (intersperse (TB.singleton ';') bs)))
interpretOnBuffer ∷ [Action] → Buffer ⊸ Buffer
interpretOnBuffer xs z = foldlIntoBuffer go z xs
where
go ∷ Buffer ⊸ Action → Buffer
go b (AppendText x) = b |> x
go b (PrependText x) = x <| b
go b (AppendChar x) = b |>. x
go b (PrependChar x) = x .<| b
go b (AppendChars n x) = appendChars n x b
go b (PrependChars n x) = prependChars n x b
go b (JustifyLeft n x) = justifyLeft n x b
go b (JustifyRight n x) = justifyRight n x b
go b (Center n x) = center n x b
go b (HexInt r s t u v w x) = s &<| ";"# #<| t &<| ";"# #<| x &<|
(b |>& r |># ";"# |>& u |># ";"# |>& v |># ";"# |>& w)
go b (HexWord u v w x) = u &<| ";"# #<| x &<| (b |>& v |># ";"# |>& w)
go b (AppendHexI x) = case x of {SomeIntN i → b |>& i}
go b (PrependHexI x) = case x of {SomeIntN i → i &<| b}
go b (AppendHexW x) = case x of {SomeWordN i → b |>& i}
go b (PrependHexW x) = case x of {SomeWordN i → i &<| b}
go b (DecInt r s t u v w x) = s $<| ";"# #<| t $<| ";"# #<| x $<| (b |>$ r |># ";"# |>$ u |># ";"# |>$ v |># ";"# |>$ w)
go b (DecWord r s t u v w x) = s $<| ";"# #<| t $<| ";"# #<| x $<| (b |>$ r |># ";"# |>$ u |># ";"# |>$ v |># ";"# |>$ w)
go b (AppendDecW x) = b |>$ x
go b (PrependDecW x) = x $<| b
go b (AppendDecI x) = b |>$ x
go b (PrependDecI x) = x $<| b
go b (AppendDecI30 x) = b |>$ x
go b (PrependDecI30 x) = x $<| b
go b (AppendDouble x) = b |>% x
go b (PrependDouble x) = x %<| b
go b (AppendSpaces n) = b |>… n
go b (PrependSpaces n) = n …<| b
main ∷ IO ()
main = defaultMain $ testGroup "All"
[ testProperty "sequence of actions" prop1
, testProperty "two sequences of actions" prop2
, testProperty "append addr#" prop3
, testProperty "prepend addr#" prop4
, testProperty "bytestring builder" prop5
, testProperty "CSE 1" prop6
, testProperty "CSE 2" prop7
]
prop1 ∷ [Action] → Property
prop1 acts = interpretOnText acts mempty ===
runBuffer (\b → interpretOnBuffer acts b)
prop2 ∷ [Action] → [Action] → Property
prop2 acts1 acts2 = interpretOnText acts1 mempty <> interpretOnText acts2 mempty ===
runBuffer (\b → go (dupBuffer b))
where
go ∷ (# Buffer, Buffer #) ⊸ Buffer
go (# b1, b2 #) = interpretOnBuffer acts1 b1 >< interpretOnBuffer acts2 b2
prop3 :: [Action] → Property
prop3 acts = runBuffer f1 === runBuffer f2
where
addr# = "foo"#
f1, f2 :: Buffer ⊸ Buffer
f1 = \b → interpretOnBuffer acts b |># addr#
f2 = \b → interpretOnBuffer acts b |> T.pack "foo"
prop4 :: [Action] → Property
prop4 acts = runBuffer f1 === runBuffer f2
where
addr# = "foo"#
f1, f2 :: Buffer ⊸ Buffer
f1 = \b → addr# #<| interpretOnBuffer acts b
f2 = \b → T.pack "foo" <| interpretOnBuffer acts b
prop5 ∷ [Action] → Property
prop5 acts = T.encodeUtf8 (interpretOnText acts mempty) ===
runBufferBS (\b → interpretOnBuffer acts b)
prop6 :: Property
prop6 = T.pack "_a_b" ===
runBuffer (\buf -> buf |>. '_' |>. 'a' |>
runBuffer (\buf' -> buf' |>. '_' |>. 'b'))
prop7 :: Property
prop7 =
let !x = runBuffer (\buf -> (buf |>. '_' |>. 'a') |>… 5)
!y = runBuffer (\buf -> (buf |>. '_' |>. 'b') |>… 5)
in (x, y) === (T.pack "_a ", T.pack "_b ")
--------------------------------------------------------------------------------
-- IntN
--------------------------------------------------------------------------------
newtype IntN (n ∷ Natural) = IntN' {unIntN ∷ Int64}
deriving stock (Eq, Ord)
deriving newtype (Enum, Real, Integral)
instance (KnownNat n) ⇒ Show (IntN n) where
showsPrec p (IntN x) = showParen (p > 10)
(\s → mconcat ["IntN @", show (natVal (Proxy @n)), " ", show x, s])
pattern IntN ∷ forall n. (KnownNat n) => Int64 → IntN n
pattern IntN x ← IntN' x where
IntN x = IntN' x'
where
-- If the nth bit is 1, then interpret the value as negative and fill the
-- bits from nth position with 1s. Otherwise clear them to 0s.
size = intSize (Proxy @n)
x' = if testBit x (size - 1)
then x .|. m1
else x .&. m2
m1 = complement ((1 `shiftL` (size - 1)) - 1)
m2 = (1 `shiftL` size) - 1
{-# COMPLETE IntN #-}
intSize ∷ forall p n. (KnownNat n) => p n → Int
intSize _ = fromInteger (natVal (Proxy @n))
instance (KnownNat n) => Arbitrary (IntN n) where
arbitrary =
IntN <$> chooseBoundedIntegral (unIntN @n minBound, unIntN @n maxBound)
shrink = shrinkIntegral
instance (KnownNat n) => Bounded (IntN n) where
minBound = IntN (negate (1 `shiftL` (intSize (Proxy @n) - 1)))
maxBound = IntN ((1 `shiftL` (intSize (Proxy @n) - 1)) - 1)
instance (KnownNat n) => Num (IntN n) where
IntN x + IntN y = IntN (x + y)
IntN x * IntN y = IntN (x * y)
abs (IntN x) = IntN (abs x)
signum = undefined
negate (IntN x) = IntN (negate x)
fromInteger x = IntN (fromInteger x)
instance (KnownNat n) => Bits (IntN n) where
IntN a .&. IntN b = IntN (a .&. b)
IntN a .|. IntN b = IntN (a .|. b)
xor = undefined
complement (IntN x) = IntN (complement x)
shift (IntN x) i = IntN (shift x i)
rotate = undefined
bitSize = const (intSize (Proxy @n))
bitSizeMaybe = const (Just (intSize (Proxy @n)))
isSigned = const True
testBit (IntN x) = testBit x
bit = bitDefault
popCount = undefined
instance (KnownNat n) => FiniteBits (IntN n) where
finiteBitSize = const (intSize (Proxy @n))
data SomeIntN = forall n. (KnownNat n) ⇒ SomeIntN (IntN n)
instance Eq SomeIntN where
SomeIntN (IntN @n1 i1) == SomeIntN (IntN @n2 i2) =
case sameNat (Proxy @n1) (Proxy @n2) of
Just _ → i1 == i2
Nothing → False
instance Ord SomeIntN where
SomeIntN (IntN @n1 i1) `compare` SomeIntN (IntN @n2 i2) =
case cmpNat (Proxy @n1) (Proxy @n2) of
LTI → LT
EQI → compare i1 i2
GTI → GT
instance Show SomeIntN where
show (SomeIntN i) = show i
instance Arbitrary SomeIntN where
arbitrary = do
s <- chooseInt (8, 64)
case someNatVal (toInteger s) of
Just (SomeNat (Proxy ∷ Proxy n)) →
SomeIntN <$> arbitraryBoundedIntegral @(IntN n)
Nothing → error "impossible"
shrink (SomeIntN i) = SomeIntN <$> shrinkIntegral i
--------------------------------------------------------------------------------
-- WordN
--------------------------------------------------------------------------------
newtype WordN (n ∷ Natural) = WordN' { unWordN :: Word64 }
deriving stock (Eq, Ord)
deriving newtype (Enum, Real, Integral)
instance (KnownNat n) ⇒ Show (WordN n) where
showsPrec p (WordN x) = showParen (p > 10)
(\s → mconcat ["WordN @", show (natVal (Proxy @n)), " ", show x, s])
pattern WordN ∷ forall n. (KnownNat n) => Word64 → WordN n
pattern WordN x ← WordN' x where
WordN x = WordN' (x .&. ((1 `shiftL` intSize (Proxy @n)) - 1))
{-# COMPLETE WordN #-}
instance (KnownNat n) => Arbitrary (WordN n) where
arbitrary =
WordN <$> chooseBoundedIntegral (unWordN @n minBound, unWordN @n maxBound)
shrink = shrinkIntegral
instance (KnownNat n) => Bounded (WordN n) where
minBound = WordN' 0
maxBound = WordN ((1 `shiftL` intSize (Proxy @n)) - 1)
instance (KnownNat n) => Num (WordN n) where
WordN x + WordN y = WordN (x + y)
WordN x * WordN y = WordN (x * y)
abs = id
signum = undefined
negate (WordN x) = WordN (negate x)
fromInteger x = WordN (fromInteger x)
instance (KnownNat n) => Bits (WordN n) where
WordN a .&. WordN b = WordN (a .&. b)
WordN a .|. WordN b = WordN (a .|. b)
xor = undefined
complement (WordN x) = WordN (complement x)
shift (WordN x) i = WordN (shift x i)
rotate = undefined
bitSize = const (intSize (Proxy @n))
bitSizeMaybe = const (Just (intSize (Proxy @n)))
isSigned = const False
testBit (WordN x) = testBit x
bit = bitDefault
popCount = undefined
instance (KnownNat n) => FiniteBits (WordN n) where
finiteBitSize = const (intSize (Proxy @n))
data SomeWordN = forall n. (KnownNat n) ⇒ SomeWordN (WordN n)
instance Eq SomeWordN where
SomeWordN (WordN @n1 i1) == SomeWordN (WordN @n2 i2) =
case sameNat (Proxy @n1) (Proxy @n2) of
Just _ → i1 == i2
Nothing → False
instance Ord SomeWordN where
SomeWordN (WordN @n1 i1) `compare` SomeWordN (WordN @n2 i2) =
case cmpNat (Proxy @n1) (Proxy @n2) of
LTI → LT
EQI → compare i1 i2
GTI → GT
instance Show SomeWordN where
show (SomeWordN i) = show i
instance Arbitrary SomeWordN where
arbitrary = do
s <- chooseInt (8, 64)
case someNatVal (toInteger s) of
Just (SomeNat (Proxy ∷ Proxy n)) →
SomeWordN <$> arbitraryBoundedIntegral @(WordN n)
Nothing → error "impossible"
shrink (SomeWordN i) = SomeWordN <$> shrinkIntegral i