diff --git a/src/Universum/Container/Class.hs b/src/Universum/Container/Class.hs --- a/src/Universum/Container/Class.hs +++ b/src/Universum/Container/Class.hs @@ -47,8 +47,8 @@ import Data.Coerce (Coercible, coerce) import Data.Kind (Type) -import Prelude hiding (all, and, any, concatMap, elem, foldMap, foldl, foldr, mapM_, notElem, null, or, print, - product, sequence_, sum) +import Prelude hiding (all, and, any, concatMap, elem, foldMap, foldl, foldr, mapM_, notElem, null, + or, print, product, sequence_, sum) import Universum.Applicative (Alternative (..), Const, ZipList (..), pass) import Universum.Base (HasCallStack, Word8) @@ -754,6 +754,7 @@ >>> concatMap (\x -> [x + 1, x + 2]) [1, 2, 3] [2,3,3,4,4,5] +@since 1.8.0 -} concatMap :: Container c => (Element c -> [b]) -> c -> [b] concatMap f = Data.List.concatMap f . toList diff --git a/src/Universum/String/Conversion.hs b/src/Universum/String/Conversion.hs --- a/src/Universum/String/Conversion.hs +++ b/src/Universum/String/Conversion.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module implements type class which allow to have conversion to and @@ -292,6 +291,8 @@ -- Right 123 -- >>> readEither @Text @Int "aa" -- Left "Prelude.read: no parse" +-- +-- @since 1.8.0 readEither :: (ToString a, Read b) => a -> Either Text b readEither = first toText . Text.Read.readEither . toString diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,10 +2,8 @@ ( main ) where -import Test.Tasty (defaultMain) - -import Test.Universum.Property (hedgehogTestTree) +import Test.Tasty +import Tree (tests) main :: IO () -main = do - defaultMain hedgehogTestTree +main = tests >>= defaultMain diff --git a/test/Test/Universum/BoolMProps.hs b/test/Test/Universum/BoolMProps.hs new file mode 100644 --- /dev/null +++ b/test/Test/Universum/BoolMProps.hs @@ -0,0 +1,22 @@ +module Test.Universum.BoolMProps + ( hprop_andM + , hprop_orM + ) where + +import Hedgehog (Gen, Property, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Universum as U + +genBoolList :: Gen [U.Bool] +genBoolList = Gen.list (Range.linear 0 1000) Gen.bool + +hprop_andM :: Property +hprop_andM = property $ do + bs <- forAll genBoolList + U.andM (return <$> bs) === ((return $ U.and bs) :: U.Maybe U.Bool) + +hprop_orM :: Property +hprop_orM = property $ do + bs <- forAll genBoolList + U.orM (return <$> bs) === ((return $ U.or bs) :: U.Maybe U.Bool) diff --git a/test/Test/Universum/ListProps.hs b/test/Test/Universum/ListProps.hs new file mode 100644 --- /dev/null +++ b/test/Test/Universum/ListProps.hs @@ -0,0 +1,35 @@ +module Test.Universum.ListProps + ( hprop_ordNubCorrect + , hprop_hashNubCorrect + , hprop_sortNubCorrect + , hprop_unstableNubCorrect + ) where + +import Data.List (nub) +import Hedgehog (Gen, Property, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Universum as U + +genIntList :: Gen [U.Int] +genIntList = Gen.list (Range.linear 0 10000) Gen.enumBounded + +hprop_ordNubCorrect :: Property +hprop_ordNubCorrect = property $ do + xs <- forAll genIntList + U.ordNub xs === nub xs + +hprop_hashNubCorrect :: Property +hprop_hashNubCorrect = property $ do + xs <- forAll genIntList + U.hashNub xs === nub xs + +hprop_sortNubCorrect :: Property +hprop_sortNubCorrect = property $ do + xs <- forAll genIntList + U.sortNub xs === (U.sort $ nub xs) + +hprop_unstableNubCorrect :: Property +hprop_unstableNubCorrect = property $ do + xs <- forAll genIntList + (U.sort $ U.unstableNub xs) === (U.sort $ nub xs) diff --git a/test/Test/Universum/Property.hs b/test/Test/Universum/Property.hs deleted file mode 100644 --- a/test/Test/Universum/Property.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Universum.Property - ( hedgehogTestTree - ) where - -import Universum - -import Data.List (nub) -import Hedgehog (Gen, MonadGen, Property, assert, forAll, property, (===)) -#if MIN_VERSION_hedgehog(1,0,0) -import Hedgehog (GenBase) -#endif -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.Hedgehog - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as LB -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range -import qualified Universum as U - -hedgehogTestTree :: TestTree -hedgehogTestTree = testGroup "Tests" [stringProps, utfProps, listProps, boolMProps] - -stringProps :: TestTree -stringProps = testGroup "String conversions" - [ testProperty "toString . toText = id" prop_StringToTextAndBack - , testProperty "`toString . toText` for UTF-16 surrogate" - prop_StringToTextAndBackSurrogate - , testProperty "toText . toString = id" prop_TextToStringAndBack - ] - -utfProps :: TestTree -utfProps = testGroup "utf8 conversion property tests" - [ testProperty "String to ByteString invertible" prop_StringToBytes - , testProperty "Text to ByteString invertible" prop_TextToBytes - , testProperty "ByteString to Text or String invertible" prop_BytesTo - ] - -#if MIN_VERSION_hedgehog(1,0,0) -unicode' :: (MonadGen m, GenBase m ~ Identity) => m U.Char -#else -unicode' :: MonadGen m => m U.Char -#endif -unicode' = do - a <- Gen.unicode - if U.elem a ['\65534', '\65535'] - then unicode' - else return a - -utf8String :: Gen U.String -utf8String = Gen.string (Range.linear 0 10000) unicode' - -unicodeAllString :: Gen U.String -unicodeAllString = Gen.string (Range.linear 0 10000) Gen.unicodeAll - -utf8Text :: Gen T.Text -utf8Text = Gen.text (Range.linear 0 10000) unicode' - -unicodeAllText :: Gen T.Text -unicodeAllText = Gen.text (Range.linear 0 10000) Gen.unicodeAll - -utf8Bytes :: Gen B.ByteString -utf8Bytes = Gen.utf8 (Range.linear 0 10000) unicode' - --- "\65534" fails, but this is from BU.toString --- > import qualified Data.ByteString.UTF8 as BU --- > BU.toString (BU.fromString "\65534") == "\65533" --- > True - -prop_StringToTextAndBack :: Property -prop_StringToTextAndBack = property $ do - str <- forAll unicodeAllString - toString (toText str) === str - --- | See comment to this function: --- --- --- While 'String' may contain surrogate UTF-16 code points, actually UTF-8 --- doesn't allow them, as well as 'Text'. 'Data.Text.pack' replaces invalid --- characters with unicode replacement character, so by default --- @toString . toText@ is not identity. --- --- However, we have a rewrite rule by which we /replace/ @toString . toText@ --- occurrences with the identity function. -prop_StringToTextAndBackSurrogate :: Property -prop_StringToTextAndBackSurrogate = property $ do - -- Surrogate character like this one should remain intact - -- Without rewrite rule this string would be transformed to "\9435" - let str = "\xD800" - toString (toText str) === str - -prop_TextToStringAndBack :: Property -prop_TextToStringAndBack = property $ do - txt <- forAll unicodeAllText - toText (toString txt) === txt - -prop_StringToBytes :: Property -prop_StringToBytes = property $ do - str <- forAll utf8String - assert $ str == (decodeUtf8 (encodeUtf8 str :: B.ByteString)) - && str == (decodeUtf8 (encodeUtf8 str :: LB.ByteString)) - - -prop_TextToBytes :: Property -prop_TextToBytes = property $ do - txt <- forAll utf8Text - assert $ txt == (decodeUtf8 (encodeUtf8 txt :: B.ByteString)) - && txt == (decodeUtf8 (encodeUtf8 txt :: LB.ByteString)) - --- "\239\191\190" fails, but this is the same as "\65534" :: String -prop_BytesTo :: Property -prop_BytesTo = property $ do - utf <- forAll utf8Bytes - assert $ utf == (encodeUtf8 (decodeUtf8 utf :: U.String)) - && utf == (encodeUtf8 (decodeUtf8 utf :: T.Text)) - && utf == (encodeUtf8 (decodeUtf8 utf :: LT.Text)) - --- ordNub - -listProps :: TestTree -listProps = testGroup "list function property tests" - [ testProperty "Hedgehog ordNub xs == nub xs" prop_ordNubCorrect - , testProperty "Hedgehog hashNub xs == nub xs" prop_hashNubCorrect - , testProperty "Hedgehog sortNub xs == sort $ nub xs" prop_sortNubCorrect - , testProperty "Hedgehog sort $ unstableNub xs == sort $ nub xs" prop_unstableNubCorrect - ] - -genIntList :: Gen [U.Int] -genIntList = Gen.list (Range.linear 0 10000) Gen.enumBounded - -prop_ordNubCorrect :: Property -prop_ordNubCorrect = property $ do - xs <- forAll genIntList - U.ordNub xs === nub xs - -prop_hashNubCorrect :: Property -prop_hashNubCorrect = property $ do - xs <- forAll genIntList - U.hashNub xs === nub xs - -prop_sortNubCorrect :: Property -prop_sortNubCorrect = property $ do - xs <- forAll genIntList - U.sortNub xs === (U.sort $ nub xs) - -prop_unstableNubCorrect :: Property -prop_unstableNubCorrect = property $ do - xs <- forAll genIntList - (U.sort $ U.unstableNub xs) === (U.sort $ nub xs) - - --- logicM --- this section needs a little more thought - -genBoolList :: Gen [U.Bool] -genBoolList = Gen.list (Range.linear 0 1000) Gen.bool - -boolMProps :: TestTree -boolMProps = testGroup "lifted logic function property tests" - [ testProperty "Hedgehog andM" prop_andM - , testProperty "Hedgehog orM" prop_orM - ] - -prop_andM :: Property -prop_andM = property $ do - bs <- forAll genBoolList - U.andM (return <$> bs) === ((return $ U.and bs) :: U.Maybe U.Bool) - -prop_orM :: Property -prop_orM = property $ do - bs <- forAll genBoolList - U.orM (return <$> bs) === ((return $ U.or bs) :: U.Maybe U.Bool) diff --git a/test/Test/Universum/StringProps.hs b/test/Test/Universum/StringProps.hs new file mode 100644 --- /dev/null +++ b/test/Test/Universum/StringProps.hs @@ -0,0 +1,51 @@ +module Test.Universum.StringProps + ( hprop_StringToTextAndBack + , hprop_StringToTextAndBackSurrogate + , hprop_TextToStringAndBack + ) where + +import Universum + +import qualified Data.Text as T +import Hedgehog (Gen, Property, forAll, property, (===)) +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Universum as U + +unicodeAllString :: Gen U.String +unicodeAllString = Gen.string (Range.linear 0 10000) Gen.unicodeAll + +unicodeAllText :: Gen T.Text +unicodeAllText = Gen.text (Range.linear 0 10000) Gen.unicodeAll + +-- "\65534" fails, but this is from BU.toString +-- > import qualified Data.ByteString.UTF8 as BU +-- > BU.toString (BU.fromString "\65534") == "\65533" +-- > True + +hprop_StringToTextAndBack :: Property +hprop_StringToTextAndBack = property $ do + str <- forAll unicodeAllString + toString (toText str) === str + +-- | See comment to this function: +-- +-- +-- While 'String' may contain surrogate UTF-16 code points, actually UTF-8 +-- doesn't allow them, as well as 'Text'. 'Data.Text.pack' replaces invalid +-- characters with unicode replacement character, so by default +-- @toString . toText@ is not identity. +-- +-- However, we have a rewrite rule by which we /replace/ @toString . toText@ +-- occurrences with the identity function. +hprop_StringToTextAndBackSurrogate :: Property +hprop_StringToTextAndBackSurrogate = property $ do + -- Surrogate character like this one should remain intact + -- Without rewrite rule this string would be transformed to "\9435" + let str = "\xD800" + toString (toText str) === str + +hprop_TextToStringAndBack :: Property +hprop_TextToStringAndBack = property $ do + txt <- forAll unicodeAllText + toText (toString txt) === txt diff --git a/test/Test/Universum/UtfProps.hs b/test/Test/Universum/UtfProps.hs new file mode 100644 --- /dev/null +++ b/test/Test/Universum/UtfProps.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Universum.UtfProps + ( hprop_StringToBytes + , hprop_TextToBytes + , hprop_BytesTo + ) where + +import Universum + +import Hedgehog (Gen, MonadGen, Property, assert, forAll, property) +#if MIN_VERSION_hedgehog(1,0,0) +import Hedgehog (GenBase) +#endif + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Universum as U + +#if MIN_VERSION_hedgehog(1,0,0) +unicode' :: (MonadGen m, GenBase m ~ Identity) => m U.Char +#else +unicode' :: MonadGen m => m U.Char +#endif +unicode' = do + a <- Gen.unicode + if U.elem a ['\65534', '\65535'] + then unicode' + else return a + +utf8String :: Gen U.String +utf8String = Gen.string (Range.linear 0 10000) unicode' + +utf8Text :: Gen T.Text +utf8Text = Gen.text (Range.linear 0 10000) unicode' + +utf8Bytes :: Gen B.ByteString +utf8Bytes = Gen.utf8 (Range.linear 0 10000) unicode' + +hprop_StringToBytes :: Property +hprop_StringToBytes = property $ do + str <- forAll utf8String + assert $ str == (decodeUtf8 (encodeUtf8 str :: B.ByteString)) + && str == (decodeUtf8 (encodeUtf8 str :: LB.ByteString)) + + +hprop_TextToBytes :: Property +hprop_TextToBytes = property $ do + txt <- forAll utf8Text + assert $ txt == (decodeUtf8 (encodeUtf8 txt :: B.ByteString)) + && txt == (decodeUtf8 (encodeUtf8 txt :: LB.ByteString)) + +-- "\239\191\190" fails, but this is the same as "\65534" :: String +hprop_BytesTo :: Property +hprop_BytesTo = property $ do + utf <- forAll utf8Bytes + assert $ utf == (encodeUtf8 (decodeUtf8 utf :: U.String)) + && utf == (encodeUtf8 (decodeUtf8 utf :: T.Text)) + && utf == (encodeUtf8 (decodeUtf8 utf :: LT.Text)) diff --git a/test/Tree.hs b/test/Tree.hs new file mode 100644 --- /dev/null +++ b/test/Tree.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-} diff --git a/universum.cabal b/universum.cabal --- a/universum.cabal +++ b/universum.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: universum -version: 1.8.0 +version: 1.8.1 synopsis: Custom prelude used in Serokell description: See README.md file for more details. homepage: https://github.com/serokell/universum @@ -122,15 +122,21 @@ main-is: Spec.hs other-modules: + Tree Test.Universum.Issue208 - Test.Universum.Property + Test.Universum.StringProps + Test.Universum.UtfProps + Test.Universum.ListProps + Test.Universum.BoolMProps build-depends: universum , bytestring , text , hedgehog , tasty - , tasty-hedgehog < 1.2.0.0 + , tasty-hedgehog + build-tool-depends: + tasty-discover:tasty-discover if impl(ghc >= 8.10.1) ghc-options: -Wno-missing-safe-haskell-mode