LowLevel.hs

-- | Test low-level operations

{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-imports #-}

#ifdef MIN_VERSION_tasty_inspection_testing
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -O -dsuppress-all -dno-suppress-type-signatures -fplugin=Test.Tasty.Inspection.Plugin #-}
#endif

module Tests.Properties.LowLevel (testLowLevel) where

import Prelude hiding (head, tail)
import Control.Applicative ((<$>), pure)
import Control.Exception as E (SomeException, catch, evaluate)
import Data.Functor.Identity (Identity(..))
import Data.Int (Int32, Int64)
import Data.Text.Foreign
import Data.Text.Internal (Text(..), mul, mul32, mul64, safe)
import Data.Word (Word8, Word16, Word32)
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (testCase, assertEqual)
import Test.Tasty.QuickCheck (testProperty)
import Test.QuickCheck hiding ((.&.))
import Tests.QuickCheckUtils
import Tests.Utils
import qualified Data.Text as T
import qualified Data.Text.Foreign as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
import qualified Data.Text.IO.Utf8 as TU
import qualified System.IO as IO

#ifdef MIN_VERSION_tasty_inspection_testing
import Test.Tasty.Inspection (inspectObligations, hasNoTypes, doesNotUseAnyOf)
import qualified Data.Text.Internal.Fusion as S
import qualified Data.Text.Internal.Fusion.Common as S
import qualified GHC.CString as GHC
#endif

mulRef :: (Integral a, Bounded a) => a -> a -> Maybe a
mulRef a b
  | ab < bot || ab > top = Nothing
  | otherwise            = Just (fromIntegral ab)
  where ab  = fromIntegral a * fromIntegral b
        top = fromIntegral (maxBound `asTypeOf` a) :: Integer
        bot = fromIntegral (minBound `asTypeOf` a) :: Integer

eval :: (a -> b -> c) -> a -> b -> Maybe c
eval f a b = unsafePerformIO $
  (Just <$> evaluate (f a b)) `E.catch` (\(_::SomeException) -> pure Nothing)

t_mul32 :: Int32 -> Int32 -> Property
t_mul32 a b = mulRef a b === eval mul32 a b

t_mul64 :: Int64 -> Int64 -> Property
t_mul64 a b = mulRef a b === eval mul64 a b

t_mul :: Int -> Int -> Property
t_mul a b = mulRef a b === eval mul a b

-- Misc.

t_dropWord8 m t = dropWord8 m t `T.isSuffixOf` t
t_takeWord8 m t = takeWord8 m t `T.isPrefixOf` t
t_take_drop_8 (Small n) t = T.append (takeWord8 n t) (dropWord8 n t) === t
t_use_from t = ioProperty $ (==t) <$> useAsPtr t fromPtr
t_use_from0 t = ioProperty $ do
  let t' = t `T.snoc` '\0'
  (== T.takeWhile (/= '\0') t') <$> useAsPtr t' (const . fromPtr0)

t_peek_cstring t = T.all (/= '\0') t ==> ioProperty $ do
  roundTrip <- T.withCString t T.peekCString
  assertEqual "cstring" t roundTrip

t_peek_cstring_len t = ioProperty $ do
  roundTrip <- T.withCStringLen t T.peekCStringLen
  assertEqual "cstring_len" t roundTrip

t_copy t = T.copy t === t

t_literal_length1 = assertEqual xs (length xs) byteLen
  where
    xs = "\0\1\0\1\0"
    Text _ _ byteLen = T.pack xs
t_literal_length2 = assertEqual xs (length xs) byteLen
  where
    xs = "\1\2\3\4\5"
    Text _ _ byteLen = T.pack xs
t_literal_surrogates = assertEqual xs (T.pack xs) (T.pack ys)
  where
    ys = "\xd7ff \xd800 \xdbff \xdc00 \xdfff \xe000"
    xs = map safe ys

#ifdef MIN_VERSION_tasty_inspection_testing
t_literal_foo :: Text
t_literal_foo = T.pack "foo"
#endif

-- Input and output.

-- t_put_get = write_read T.unlines T.filter put get
--   where put h = withRedirect h IO.stdout . T.putStr
--         get h = withRedirect h IO.stdin T.getContents
-- tl_put_get = write_read TL.unlines TL.filter put get
--   where put h = withRedirect h IO.stdout . TL.putStr
--         get h = withRedirect h IO.stdin TL.getContents

inputOutput :: TestTree
inputOutput = testGroup "input-output" [
    testProperty "t_write_read" $ write_read arbitrary shrink (T.replace "\n" "\r\n") T.hPutStr T.hGetContents,
    testProperty "tl_write_read" $ write_read arbitrary shrink (TL.replace "\n" "\r\n") TL.hPutStr TL.hGetContents,
    testProperty "t_write_read_line" $ write_read genTLine shrinkTLine (`T.append` "\r") T.hPutStrLn T.hGetLine,
    testProperty "tl_write_read_line" $ write_read genTLLine shrinkTLLine (`TL.append` "\r") TL.hPutStrLn TL.hGetLine,
    -- Note: Data.Text.IO.Utf8 does NO newline translation
    testProperty "utf8_write_read" $ write_read arbitrary shrink id TU.hPutStr TU.hGetContents,
    testProperty "utf8_write_read_line" $ write_read genTLine shrinkTLine id TU.hPutStrLn TU.hGetLine
    -- These tests are subject to I/O race conditions
    -- testProperty "t_put_get" t_put_get,
    -- testProperty "tl_put_get" tl_put_get
  ]

genTLine :: Gen T.Text
genTLine = T.filter (`notElem` ("\r\n" :: String)) <$> arbitrary

genTLLine :: Gen TL.Text
genTLLine = TL.filter (`notElem` ("\r\n" :: String)) <$> arbitrary

shrinkTLine :: T.Text -> [T.Text]
shrinkTLine = filter (T.all (/= '\n')) . shrink

shrinkTLLine :: TL.Text -> [TL.Text]
shrinkTLLine = filter (TL.all (/= '\n')) . shrink

testLowLevel :: TestTree
testLowLevel =
  testGroup "lowlevel" [
    testGroup "mul" [
      testProperty "t_mul" t_mul,
      testProperty "t_mul32" t_mul32,
      testProperty "t_mul64" t_mul64
    ],

    testGroup "misc" [
      testProperty "t_dropWord8" t_dropWord8,
      testProperty "t_takeWord8" t_takeWord8,
      testProperty "t_take_drop_8" t_take_drop_8,
      testProperty "t_use_from" t_use_from,
      testProperty "t_use_from0" t_use_from0,
      testProperty "t_copy" t_copy,
      testProperty "t_peek_cstring" t_peek_cstring,
      testProperty "t_peek_cstring_len" t_peek_cstring_len,
      testCase "t_literal_length1" t_literal_length1,
      testCase "t_literal_length2" t_literal_length2,
      testCase "t_literal_surrogates" t_literal_surrogates
#ifdef MIN_VERSION_tasty_inspection_testing
        -- Hack to force GHC to keep the binding around until this is fixed: https://gitlab.haskell.org/ghc/ghc/-/issues/26436
      , let _unused = 't_literal_foo in
        $(inspectObligations
        [ (`hasNoTypes` [''Char, ''[]])
        , (`doesNotUseAnyOf` ['T.pack, 'S.unstream, 'T.map, 'safe, 'S.streamList])
        , (`doesNotUseAnyOf` ['GHC.unpackCString#, 'GHC.unpackCStringUtf8#])
        , (`doesNotUseAnyOf` ['T.unpackCString#, 'T.unpackCStringAscii#])
        ]
        't_literal_foo)
#endif
    ],

    inputOutput
  ]