diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,20 @@ [KaC]: +## 1.1.0.0 (2021-06-10) + +### Breaking + +* Add `Textual` `TLB.Builder` instance and related functions +* Add `Textual` `BSB.Builder` instance and related functions +* Add `Textual` `SBS.ShortByteString` instance and related functions +* Add `RenderDefault` and `ParseDefault` type classes and instances +* Remove `Data.TTC.Instances` + +### Non-Breaking + +* Add `HasCallStack` to unsafe functions + ## 1.0.0.0 (2021-06-03) ### Non-Breaking diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -15,6 +15,7 @@ * [Rendering and Parsing](#rendering-and-parsing) * [Validating Constants](#validating-constants) * [String Type Conversion](#string-type-conversion) + * [Arbitrary Type Conversion](#arbitrary-type-conversion) * [Project](#project) * [Links](#links) * [Dependencies](#dependencies) @@ -24,14 +25,25 @@ ## Overview TTC, an initialism of _Textual Type Classes_, is a library that provides -[`Render`](#render) and -[`Parse`](#parse) type classes for conversion between data types and textual -data types (strings). Use the `Show` and `Read` type classes for -debugging/development, and use the [`Render`](#render) and -[`Parse`](#parse) type classes for your own purposes. The library also -provides a [`Textual`](#textual) type class for conversion between textual -data types as well as functions for validating constants at compile-time. +`Render` and `Parse` type classes for conversion between data types and +textual data types (strings). Use the `Show` and `Read` type classes for +debugging/development, and use the `Render` and `Parse` type classes for your +own purposes. The library also provides a `Textual` type class for conversion +between textual data types as well as functions for validating constants at +compile-time. +Since a type may have at most one instance of a given type class, special care +must be taken when defining type class instances in a shared library. In +particular, orphan instances should generally *not* be used in shared +libraries since they prevent users of the libraries from writing their own +instances. + +`Render` and `Parse` are best used with types that have canonical textual +representations, such as textual identifiers. When there is more than one way +to create a textual representation, such as configurable formatting, using a +normal function is probably more appropriate. Such a function can make use of +the `Textual` type class to support multiple textual data types. + This overview includes a brief introduction of the library. The following resources are also available: @@ -59,21 +71,25 @@ * `String` * Strict `Text` * Lazy `Text` +* `Text` `Builder` * Strict `ByteString` * Lazy `ByteString` +* `ByteString` `Builder` +* `ShortByteString` -Conversion between any of these types is direct; it is not done through a -fixed textual data type (such as `String` or `Text`). The key feature of this -type class is that it has a single type variable, making it easy to write -functions that accept arguments and/or returns values that may be any of the -supported textual data types. +This type class has two key features: +* Type conversion is *not* done through a fixed type (such as `String` or + `Text`). +* It has a single type variable, making it easy to write functions that + accept arguments and/or return values that may be any of the supported + textual data types. + For more details, see the [Textual Type Class][] article. ### `Render` -The `Render` type class renders a data type as a [`Textual`](#textual) data -type: +The `Render` type class renders a data type as a `Textual` data type: ```haskell class Render a where @@ -119,8 +135,7 @@ ### `Parse` -The `Parse` type class parses a data type from a [`Textual`](#textual) data -type: +The `Parse` type class parses a data type from a `Textual` data type: ```haskell class Parse a where @@ -210,21 +225,45 @@ There are a number of libraries that simplify conversion between string types. -The -[string-conversions](https://hackage.haskell.org/package/string-conversions) -and [string-conv](https://hackage.haskell.org/package/string-conv) libraries -have type classes with two type variables. The primary benefit of this -approach is that one can add support for any string type. +The following libraries provide type classes with two type variables. The +primary benefit of this approach is that one can add support for any string +type. The drawback of this approach is that implementations of `Render` and +`Parse` using such a type class would have to be done via a fixed type, +resulting in unnecessary conversion when using other types. -The [text-conversions](https://hackage.haskell.org/package/text-conversions) -library converts between string types via the `Text` type, using `FromText` -and `ToText` type classes. This works well in most cases, but it not optimal -when converting between `ByteString` types. +* [string-conv](https://hackage.haskell.org/package/string-conv) +* [string-conversions](https://hackage.haskell.org/package/string-conversions) -The [textual](https://hackage.haskell.org/package/textual) library -(deprecated) converts between string types via the `String` type, using a -`Textual` type class (which provides a `toString` function) as well as the -standard `IsString` type class (which provides the `fromString` function). +The following library provide type classes with a single type variable, but +conversion is done via a fixed type. + +* [hxt-regex-xmlschema](https://hackage.haskell.org/package/hxt-regex-xmlschema) + has a `StringLike` type class and does conversion via the `String` type +* [ListLike](https://hackage.haskell.org/package/ListLike) has a `StringLike` + type class and does conversion via the `String` type +* [monoid-subclasses](https://hackage.haskell.org/package/monoid-subclasses) + provides a `TextualMonoid` type class that provides an abstract API over + textual types, using `String` as the underlying type +* [stringlike](https://hackage.haskell.org/package/stringlike) converts via + the `Text` type +* [tagsoup](https://hackage.haskell.org/package/tagsoup) has a `StringLike` + type class that provides an abstract API over textual types and a + `castString` function that converts via the `String` type +* [text-conversions](https://hackage.haskell.org/package/text-conversions) + converts via the `Text` type +* [textual](https://hackage.haskell.org/package/textual) (deprecated) + converts via the `String` type + +### Arbitrary Type Conversion + +There are also a number of libraries that provide type classes for conversion +between arbitrary types, including string types. + +* [basement](https://hackage.haskell.org/package/basement) provides type + classes for conversion that may fail as well as conversion that cannot fail +* [convertible](https://hackage.haskell.org/package/convertible) +* [witch](https://hackage.haskell.org/package/witch) provides type classes for + conversion that may fail as well as conversion that cannot fail ## Project diff --git a/src/Data/TTC.hs b/src/Data/TTC.hs --- a/src/Data/TTC.hs +++ b/src/Data/TTC.hs @@ -17,7 +17,9 @@ ------------------------------------------------------------------------------ {-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} #if __GLASGOW_HASKELL__ >= 900 @@ -33,69 +35,81 @@ , toS , toT , toTL + , toTLB , toBS , toBSL + , toBSB + , toSBS -- ** \"From\" Conversions -- $TextualFrom , fromS , fromT , fromTL + , fromTLB , fromBS , fromBSL + , fromBSB + , fromSBS -- ** \"As\" Conversions -- $TextualAs , asS , asT , asTL + , asTLB , asBS , asBSL - -- ** Other Conversions - -- $TextualOther - , toTLB - , fromTLB - , toBSB - , fromBSB - , toSBS - , fromSBS + , asBSB + , asSBS -- * Render , Render(..) + , RenderDefault(..) -- ** Rendering Specific Types -- $RenderSpecific , renderS , renderT , renderTL + , renderTLB , renderBS , renderBSL - , renderTLB , renderBSB , renderSBS -- ** Render Utilities , renderWithShow -- * Parse , Parse(..) + , ParseDefault(..) -- ** Parsing From Specific Types -- $ParseSpecific , parseS , parseT , parseTL + , parseTLB , parseBS , parseBSL + , parseBSB + , parseSBS -- ** 'Maybe' Parsing -- $ParseMaybe , parseMaybe , parseMaybeS , parseMaybeT , parseMaybeTL + , parseMaybeTLB , parseMaybeBS , parseMaybeBSL + , parseMaybeBSB + , parseMaybeSBS -- ** Unsafe Parsing -- $ParseUnsafe , parseUnsafe , parseUnsafeS , parseUnsafeT , parseUnsafeTL + , parseUnsafeTLB , parseUnsafeBS , parseUnsafeBSL + , parseUnsafeBSB + , parseUnsafeSBS -- ** Parse Utilities , parseEnum , parseEnum' @@ -115,7 +129,10 @@ ) where -- https://hackage.haskell.org/package/base +import Data.Int (Int16, Int32, Int64, Int8) import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) import Text.Read (readMaybe) -- https://hackage.haskell.org/package/bytestring @@ -146,22 +163,28 @@ -- * 'String' (@S@) -- * Strict 'T.Text' (@T@) -- * Lazy 'TL.Text' (@TL@) +-- * @Text@ 'TLB.Builder' (@TLB@) -- * Strict 'BS.ByteString' (@BS@) -- * Lazy 'BSL.ByteString' (@BSL@) +-- * @ByteString@ 'BSB.Builder' (@BSB@) +-- * 'SBS.ShortByteString' (@SBS@) -- -- @ByteString@ values are assumed to be UTF-8 encoded text. Invalid bytes -- are replaced with the Unicode replacement character @U+FFFD@. In cases -- where different behavior is required, process @ByteString@ values /before/ -- using this class. -- --- The key feature of this type class is that it has a single type variable, --- making it easy to write functions that accepts arguments and/or returns --- values that may be any of the supported textual data types. +-- This type class has two key features: -- +-- * Type conversion is /not/ done through a fixed type (such as 'String' or +-- 'T.Text'). +-- * It has a single type variable, making it easy to write functions that +-- accept arguments and/or return values that may be any of the supported +-- textual data types. +-- -- Note that support for additional data types cannot be implemented by -- writing instances. Adding support for additional data types would require --- changing the class definition itself. This is the price paid for having --- only one type variable instead of two. +-- changing the class definition itself. -- -- For more details, see the following article: -- @@ -183,6 +206,11 @@ -- @since 0.1.0.0 toTL :: t -> TL.Text + -- | Convert to a @Text@ 'TLB.Builder' + -- + -- @since 1.1.0.0 + toTLB :: t -> TLB.Builder + -- | Convert to a strict 'BS.ByteString' -- -- @since 0.1.0.0 @@ -193,6 +221,16 @@ -- @since 0.1.0.0 toBSL :: t -> BSL.ByteString + -- | Convert to a @ByteString@ 'BSB.Builder' + -- + -- @since 1.1.0.0 + toBSB :: t -> BSB.Builder + + -- | Convert to a 'SBS.ShortByteString' + -- + -- @since 1.1.0.0 + toSBS :: t -> SBS.ShortByteString + -- | Convert between any supported textual data types -- -- @since 0.1.0.0 @@ -202,72 +240,167 @@ toS = id toT = T.pack toTL = TL.pack + toTLB = TLB.fromString toBS = TE.encodeUtf8 . T.pack toBSL = TLE.encodeUtf8 . TL.pack + toBSB = BSB.byteString . TE.encodeUtf8 . T.pack + toSBS = SBS.toShort . TE.encodeUtf8 . T.pack convert = toS {-# INLINE toS #-} {-# INLINE toT #-} {-# INLINE toTL #-} + {-# INLINE toTLB #-} {-# INLINE toBS #-} {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} {-# INLINE convert #-} instance Textual T.Text where toS = T.unpack toT = id toTL = TL.fromStrict + toTLB = TLB.fromText toBS = TE.encodeUtf8 toBSL = TLE.encodeUtf8 . TL.fromStrict + toBSB = BSB.byteString . TE.encodeUtf8 + toSBS = SBS.toShort . TE.encodeUtf8 convert = toT {-# INLINE toS #-} {-# INLINE toT #-} {-# INLINE toTL #-} + {-# INLINE toTLB #-} {-# INLINE toBS #-} {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} {-# INLINE convert #-} instance Textual TL.Text where toS = TL.unpack toT = TL.toStrict toTL = id + toTLB = TLB.fromLazyText toBS = BSL.toStrict . TLE.encodeUtf8 toBSL = TLE.encodeUtf8 + toBSB = BSB.lazyByteString . TLE.encodeUtf8 + toSBS = SBS.toShort . BSL.toStrict . TLE.encodeUtf8 convert = toTL {-# INLINE toS #-} {-# INLINE toT #-} {-# INLINE toTL #-} + {-# INLINE toTLB #-} {-# INLINE toBS #-} {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} {-# INLINE convert #-} +instance Textual TLB.Builder where + toS = TL.unpack . TLB.toLazyText + toT = TL.toStrict . TLB.toLazyText + toTL = TLB.toLazyText + toTLB = id + toBS = BSL.toStrict . TLE.encodeUtf8 . TLB.toLazyText + toBSL = TLE.encodeUtf8 . TLB.toLazyText + toBSB = BSB.lazyByteString . TLE.encodeUtf8 . TLB.toLazyText + toSBS = SBS.toShort . BSL.toStrict . TLE.encodeUtf8 . TLB.toLazyText + convert = toTLB + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toTLB #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} + {-# INLINE convert #-} + instance Textual BS.ByteString where toS = T.unpack . TE.decodeUtf8With TEE.lenientDecode toT = TE.decodeUtf8With TEE.lenientDecode toTL = TLE.decodeUtf8With TEE.lenientDecode . BSL.fromStrict + toTLB = TLB.fromText . TE.decodeUtf8With TEE.lenientDecode toBS = id toBSL = BSL.fromStrict + toBSB = BSB.byteString + toSBS = SBS.toShort convert = toBS {-# INLINE toS #-} {-# INLINE toT #-} {-# INLINE toTL #-} + {-# INLINE toTLB #-} {-# INLINE toBS #-} {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} {-# INLINE convert #-} instance Textual BSL.ByteString where toS = TL.unpack . TLE.decodeUtf8With TEE.lenientDecode toT = TL.toStrict . TLE.decodeUtf8With TEE.lenientDecode toTL = TLE.decodeUtf8With TEE.lenientDecode + toTLB = TLB.fromLazyText . TLE.decodeUtf8With TEE.lenientDecode toBS = BSL.toStrict toBSL = id + toBSB = BSB.lazyByteString + toSBS = SBS.toShort . BSL.toStrict convert = toBSL {-# INLINE toS #-} {-# INLINE toT #-} {-# INLINE toTL #-} + {-# INLINE toTLB #-} {-# INLINE toBS #-} {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} {-# INLINE convert #-} +instance Textual BSB.Builder where + toS = + TL.unpack . TLE.decodeUtf8With TEE.lenientDecode . BSB.toLazyByteString + toT = + TL.toStrict . TLE.decodeUtf8With TEE.lenientDecode . BSB.toLazyByteString + toTL = TLE.decodeUtf8With TEE.lenientDecode . BSB.toLazyByteString + toTLB + = TLB.fromLazyText + . TLE.decodeUtf8With TEE.lenientDecode + . BSB.toLazyByteString + toBS = BSL.toStrict . BSB.toLazyByteString + toBSL = BSB.toLazyByteString + toBSB = id + toSBS = SBS.toShort . BSL.toStrict . BSB.toLazyByteString + convert = toBSB + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toTLB #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} + {-# INLINE convert #-} + +instance Textual SBS.ShortByteString where + toS = T.unpack . TE.decodeUtf8With TEE.lenientDecode . SBS.fromShort + toT = TE.decodeUtf8With TEE.lenientDecode . SBS.fromShort + toTL = TLE.decodeUtf8With TEE.lenientDecode . BSL.fromStrict . SBS.fromShort + toTLB = TLB.fromText . TE.decodeUtf8With TEE.lenientDecode . SBS.fromShort + toBS = SBS.fromShort + toBSL = BSL.fromStrict . SBS.fromShort + toBSB = BSB.byteString . SBS.fromShort + toSBS = id + convert = toSBS + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toTLB #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} + {-# INLINE convert #-} + ------------------------------------------------------------------------------ -- $TextualTo -- @@ -302,6 +435,13 @@ fromTL = convert {-# INLINE fromTL #-} +-- | Convert from a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +fromTLB :: Textual t => TLB.Builder -> t +fromTLB = convert +{-# INLINE fromTLB #-} + -- | Convert from a strict 'BS.ByteString' -- -- @since 0.1.0.0 @@ -316,6 +456,20 @@ fromBSL = convert {-# INLINE fromBSL #-} +-- | Convert from a @ByteString@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +fromBSB :: Textual t => BSB.Builder -> t +fromBSB = convert +{-# INLINE fromBSB #-} + +-- | Convert from a 'SBS.ShortByteString' +-- +-- @since 1.1.0.0 +fromSBS :: Textual t => SBS.ShortByteString -> t +fromSBS = convert +{-# INLINE fromSBS #-} + ------------------------------------------------------------------------------ -- $TextualAs -- @@ -344,6 +498,13 @@ asTL f = f . convert {-# INLINE asTL #-} +-- | Convert an argument to a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +asTLB :: Textual t => (TLB.Builder -> a) -> t -> a +asTLB f = f . convert +{-# INLINE asTLB #-} + -- | Convert an argument to a strict 'BS.ByteString' -- -- @since 0.1.0.0 @@ -358,51 +519,19 @@ asBSL f = f . convert {-# INLINE asBSL #-} ------------------------------------------------------------------------------- --- $TextualOther --- --- These functions are used to convert to/from the following other textual --- data types: --- --- * @Text@ 'TLB.Builder' (@TLB@) --- * @ByteString@ 'BSB.Builder' (@BSB@) --- * 'SBS.ShortByteString' (@SBS@) - --- | Convert to a @Text@ 'TLB.Builder' --- --- @since 0.1.0.0 -toTLB :: Textual t => t -> TLB.Builder -toTLB = TLB.fromLazyText . convert - --- | Convert from a @Text@ 'TLB.Builder' --- --- @since 0.1.0.0 -fromTLB :: Textual t => TLB.Builder -> t -fromTLB = convert . TLB.toLazyText - --- | Convert to a @ByteString@ 'BSB.Builder' --- --- @since 0.1.0.0 -toBSB :: Textual t => t -> BSB.Builder -toBSB = BSB.lazyByteString . convert - --- | Convert from a @ByteString@ 'BSB.Builder' --- --- @since 0.1.0.0 -fromBSB :: Textual t => BSB.Builder -> t -fromBSB = convert . BSB.toLazyByteString - --- | Convert to a 'SBS.ShortByteString' +-- | Convert an argument to a @ByteString@ 'TLB.Builder' -- --- @since 0.1.0.0 -toSBS :: Textual t => t -> SBS.ShortByteString -toSBS = SBS.toShort . convert +-- @since 1.1.0.0 +asBSB :: Textual t => (BSB.Builder -> a ) -> t -> a +asBSB f = f . convert +{-# INLINE asBSB #-} --- | Convert from a 'SBS.ShortByteString' +-- | Convert an argument to a 'SBS.ShortByteString' -- --- @since 0.1.0.0 -fromSBS :: Textual t => SBS.ShortByteString -> t -fromSBS = convert . SBS.fromShort +-- @since 1.1.0.0 +asSBS :: Textual t => (SBS.ShortByteString -> a) -> t -> a +asSBS f = f . convert +{-# INLINE asSBS #-} ------------------------------------------------------------------------------ -- $Render @@ -411,8 +540,19 @@ -- -- There are no default instances for the 'Render' type class, so that all -- instances can be customized per project when desired. Instances for some --- basic data types are available in "Data.TTC.Instances". +-- basic data types are defined for the 'RenderDefault' type class, however, +-- and you can load the 'Render' instance as follows: -- +-- @ +-- instance TTC.Render Int +-- @ +-- +-- Since a type may have at most one instance of a given type class, special +-- care must be taken when defining type class instances in a shared library. +-- In particular, orphan instances should generally not be used in shared +-- libraries since they prevent users of the libraries from writing their own +-- instances. +-- -- See the @uname@ and @prompt@ example programs in the @examples@ directory. -- -- For more details, see the following article: @@ -422,7 +562,79 @@ class Render a where render :: Textual t => a -> t + default render :: (RenderDefault a, Textual t) => a -> t + render = renderDefault + ------------------------------------------------------------------------------ + +-- | The 'RenderDefault' type class provides some default 'Render' instances. +-- +-- * The 'Char' instance renders a single-character string. +-- * Numeric type instances all render using the 'Show' instance. +-- * Textual type instances all convert to the target 'Textual' data type. +-- +-- @since 1.1.0.0 +class RenderDefault a where + renderDefault :: Textual t => a -> t + +instance RenderDefault Char where + renderDefault c = fromS [c] + +instance RenderDefault Double where + renderDefault = renderWithShow + +instance RenderDefault Float where + renderDefault = renderWithShow + +instance RenderDefault Int where + renderDefault = renderWithShow + +instance RenderDefault Int8 where + renderDefault = renderWithShow + +instance RenderDefault Int16 where + renderDefault = renderWithShow + +instance RenderDefault Int32 where + renderDefault = renderWithShow + +instance RenderDefault Int64 where + renderDefault = renderWithShow + +instance RenderDefault Integer where + renderDefault = renderWithShow + +instance RenderDefault Word where + renderDefault = renderWithShow + +instance RenderDefault Word8 where + renderDefault = renderWithShow + +instance RenderDefault Word16 where + renderDefault = renderWithShow + +instance RenderDefault Word32 where + renderDefault = renderWithShow + +instance RenderDefault Word64 where + renderDefault = renderWithShow + +instance RenderDefault String where + renderDefault = fromS + +instance RenderDefault BSL.ByteString where + renderDefault = fromBSL + +instance RenderDefault BS.ByteString where + renderDefault = fromBS + +instance RenderDefault TL.Text where + renderDefault = fromTL + +instance RenderDefault T.Text where + renderDefault = fromT + +------------------------------------------------------------------------------ -- $RenderSpecific -- -- These functions are equivalent to 'render', but they specify the type being @@ -450,6 +662,13 @@ renderTL = render {-# INLINE renderTL #-} +-- | Render to a @Text@ 'TLB.Builder' +-- +-- @since 0.4.0.0 +renderTLB :: Render a => a -> TLB.Builder +renderTLB = render +{-# INLINE renderTLB #-} + -- | Render to a strict 'BS.ByteString' -- -- @since 0.1.0.0 @@ -464,25 +683,18 @@ renderBSL = render {-# INLINE renderBSL #-} --- | Render to a @Text@ 'TLB.Builder' --- --- @since 0.4.0.0 -renderTLB :: Render a => a -> TLB.Builder -renderTLB = TLB.fromLazyText . renderTL -{-# INLINE renderTLB #-} - -- | Render to a @ByteString@ 'BSB.Builder' -- -- @since 0.4.0.0 renderBSB :: Render a => a -> BSB.Builder -renderBSB = BSB.lazyByteString . renderBSL +renderBSB = render {-# INLINE renderBSB #-} -- | Render to a 'SBS.ShortByteString' -- -- @since 0.4.0.0 renderSBS :: Render a => a -> SBS.ShortByteString -renderSBS = SBS.toShort . renderBS +renderSBS = render {-# INLINE renderSBS #-} ------------------------------------------------------------------------------ @@ -502,8 +714,19 @@ -- -- There are no default instances for the 'Parse' type class, so that all -- instances can be customized per project when desired. Instances for some --- basic data types are available in "Data.TTC.Instances". +-- basic data types are defined for the 'ParseDefault' type class, however, +-- and you can load the 'Parse' instance as follows: -- +-- @ +-- instance TTC.Parse Int +-- @ +-- +-- Since a type may have at most one instance of a given type class, special +-- care must be taken when defining type class instances in a shared library. +-- In particular, orphan instances should generally not be used in shared +-- libraries since they prevent users of the libraries from writing their own +-- instances. +-- -- See the @uname@ and @prompt@ example programs in the @examples@ directory. -- -- For more details, see the following article: @@ -513,6 +736,9 @@ class Parse a where parse :: (Textual t, Textual e) => t -> Either e a + default parse :: (Textual t, Textual e, ParseDefault a) => t -> Either e a + parse = parseDefault + -- This function is equivalent to 'parse' with the error type fixed to -- 'String', used internally when the error is ignored. -- @@ -522,6 +748,77 @@ {-# INLINE parse' #-} ------------------------------------------------------------------------------ + +-- | The 'ParseDefault' type class provides some default 'Parse' instances. +-- +-- * The 'Char' instance parses single-character strings. +-- * Numeric type instances all parse using the 'Read' instance. +-- * Textual type instances all convert from the source 'Textual' data type. +-- +-- @since 1.1.0.0 +class ParseDefault a where + parseDefault :: (Textual t, Textual e) => t -> Either e a + +instance ParseDefault Char where + parseDefault = asS $ \case + [c] -> Right c + _cs -> Left $ fromS "invalid Char" + +instance ParseDefault Double where + parseDefault = parseWithRead' "Double" + +instance ParseDefault Float where + parseDefault = parseWithRead' "Float" + +instance ParseDefault Int where + parseDefault = parseWithRead' "Int" + +instance ParseDefault Int8 where + parseDefault = parseWithRead' "Int8" + +instance ParseDefault Int16 where + parseDefault = parseWithRead' "Int16" + +instance ParseDefault Int32 where + parseDefault = parseWithRead' "Int32" + +instance ParseDefault Int64 where + parseDefault = parseWithRead' "Int64" + +instance ParseDefault Integer where + parseDefault = parseWithRead' "Integer" + +instance ParseDefault Word where + parseDefault = parseWithRead' "Word" + +instance ParseDefault Word8 where + parseDefault = parseWithRead' "Word8" + +instance ParseDefault Word16 where + parseDefault = parseWithRead' "Word16" + +instance ParseDefault Word32 where + parseDefault = parseWithRead' "Word32" + +instance ParseDefault Word64 where + parseDefault = parseWithRead' "Word64" + +instance ParseDefault String where + parseDefault = Right . toS + +instance ParseDefault BSL.ByteString where + parseDefault = Right . toBSL + +instance ParseDefault BS.ByteString where + parseDefault = Right . toBS + +instance ParseDefault TL.Text where + parseDefault = Right . toTL + +instance ParseDefault T.Text where + parseDefault = Right . toT + +------------------------------------------------------------------------------ -- $ParseSpecific -- -- These functions are equivalent to 'parse', but they specify the type being @@ -549,6 +846,13 @@ parseTL = parse {-# INLINE parseTL #-} +-- | Parse from a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +parseTLB :: (Parse a, Textual e) => TLB.Builder -> Either e a +parseTLB = parse +{-# INLINE parseTLB #-} + -- | Parse from a strict 'BS.ByteString' -- -- @since 0.3.0.0 @@ -563,6 +867,20 @@ parseBSL = parse {-# INLINE parseBSL #-} +-- | Parse from a @ByteString@ 'BSB.Builder' +-- +-- @since 1.1.0.0 +parseBSB :: (Parse a, Textual e) => BSB.Builder -> Either e a +parseBSB = parse +{-# INLINE parseBSB #-} + +-- | Parse from a 'SBS.ShortByteString' +-- +-- @since 1.1.0.0 +parseSBS :: (Parse a, Textual e) => SBS.ShortByteString -> Either e a +parseSBS = parse +{-# INLINE parseSBS #-} + ------------------------------------------------------------------------------ -- $ParseMaybe -- @@ -599,6 +917,13 @@ parseMaybeTL = parseMaybe {-# INLINE parseMaybeTL #-} +-- | Parse from a @Text@ 'TLB.Builder' to a 'Maybe' type +-- +-- @since 1.1.0.0 +parseMaybeTLB :: Parse a => TLB.Builder -> Maybe a +parseMaybeTLB = parseMaybe +{-# INLINE parseMaybeTLB #-} + -- | Parse from a strict 'BS.ByteString' to a 'Maybe' type -- -- @since 0.3.0.0 @@ -613,6 +938,20 @@ parseMaybeBSL = parseMaybe {-# INLINE parseMaybeBSL #-} +-- | Parse from a @ByteString@ 'BSB.Builder' to a 'Maybe' type +-- +-- @since 1.1.0.0 +parseMaybeBSB :: Parse a => BSB.Builder -> Maybe a +parseMaybeBSB = parseMaybe +{-# INLINE parseMaybeBSB #-} + +-- | Parse from a 'SBS.ShortByteString' to a 'Maybe' type +-- +-- @since 1.1.0.0 +parseMaybeSBS :: Parse a => SBS.ShortByteString -> Maybe a +parseMaybeSBS = parseMaybe +{-# INLINE parseMaybeSBS #-} + ------------------------------------------------------------------------------ -- $ParseUnsafe -- @@ -625,44 +964,65 @@ -- | Unsafely parse -- -- @since 0.1.0.0 -parseUnsafe :: (Parse a, Textual t) => t -> a +parseUnsafe :: (HasCallStack, Parse a, Textual t) => t -> a parseUnsafe = either (error . ("parseUnsafe: " ++)) id . parse {-# INLINE parseUnsafe #-} -- | Unsafely parse to a 'String' -- -- @since 0.1.0.0 -parseUnsafeS :: Parse a => String -> a +parseUnsafeS :: (HasCallStack, Parse a) => String -> a parseUnsafeS = parseUnsafe {-# INLINE parseUnsafeS #-} -- | Unsafely parse to strict 'T.Text' -- -- @since 0.1.0.0 -parseUnsafeT :: Parse a => T.Text -> a +parseUnsafeT :: (HasCallStack, Parse a) => T.Text -> a parseUnsafeT = parseUnsafe {-# INLINE parseUnsafeT #-} -- | Unsafely parse to lazy 'TL.Text' -- -- @since 0.1.0.0 -parseUnsafeTL :: Parse a => TL.Text -> a +parseUnsafeTL :: (HasCallStack, Parse a) => TL.Text -> a parseUnsafeTL = parseUnsafe {-# INLINE parseUnsafeTL #-} +-- | Unsafely parse to a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +parseUnsafeTLB :: (HasCallStack, Parse a) => TLB.Builder -> a +parseUnsafeTLB = parseUnsafe +{-# INLINE parseUnsafeTLB #-} + -- | Unsafely parse to a strict 'BS.ByteString' -- -- @since 0.1.0.0 -parseUnsafeBS :: Parse a => BS.ByteString -> a +parseUnsafeBS :: (HasCallStack, Parse a) => BS.ByteString -> a parseUnsafeBS = parseUnsafe {-# INLINE parseUnsafeBS #-} -- | Unsafely parse to a lazy 'BSL.ByteString' -- -- @since 0.1.0.0 -parseUnsafeBSL :: Parse a => BSL.ByteString -> a +parseUnsafeBSL :: (HasCallStack, Parse a) => BSL.ByteString -> a parseUnsafeBSL = parseUnsafe {-# INLINE parseUnsafeBSL #-} + +-- | Unsafely parse to a @ByteString@ 'BSB.Builder' +-- +-- @since 1.1.0.0 +parseUnsafeBSB :: (HasCallStack, Parse a) => BSB.Builder -> a +parseUnsafeBSB = parseUnsafe +{-# INLINE parseUnsafeBSB #-} + +-- | Unsafely parse to a 'SBS.ShortByteString' +-- +-- @since 1.1.0.0 +parseUnsafeSBS :: (HasCallStack, Parse a) => SBS.ShortByteString -> a +parseUnsafeSBS = parseUnsafe +{-# INLINE parseUnsafeSBS #-} ------------------------------------------------------------------------------ -- $ParseUtils diff --git a/src/Data/TTC/Instances.hs b/src/Data/TTC/Instances.hs deleted file mode 100644 --- a/src/Data/TTC/Instances.hs +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module : Data.TTC.Instances --- Description : instances for basic data types --- Copyright : Copyright (c) 2019-2021 Travis Cardwell --- License : MIT --- --- This module defines TTC 'TTC.Render' and 'TTC.Parse' instances for some --- basic data types. The definitions for the numeric data types are --- implemented using the 'Show' and 'Read' instances. The definitions for the --- character and textual data types are implemented without quoting. --- --- To use these instances, explicitly import them as follows: --- --- @ --- import Data.TTC.Instances () --- @ ------------------------------------------------------------------------------- - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} - -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Data.TTC.Instances () where - --- https://hackage.haskell.org/package/base -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) - --- https://hackage.haskell.org/package/bytestring -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL - --- https://hackage.haskell.org/package/text -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - --- (ttc) -import qualified Data.TTC as TTC - ------------------------------------------------------------------------------- - -instance TTC.Parse Char where - parse = TTC.asS $ \case - [c] -> Right c - _cs -> Left $ TTC.fromS "invalid Char" - -instance TTC.Render Char where - render c = TTC.fromS [c] - ------------------------------------------------------------------------------- - -instance TTC.Parse Double where - parse = TTC.parseWithRead' "Double" - -instance TTC.Render Double where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Float where - parse = TTC.parseWithRead' "Float" - -instance TTC.Render Float where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Int where - parse = TTC.parseWithRead' "Int" - -instance TTC.Render Int where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Int8 where - parse = TTC.parseWithRead' "Int8" - -instance TTC.Render Int8 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Int16 where - parse = TTC.parseWithRead' "Int16" - -instance TTC.Render Int16 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Int32 where - parse = TTC.parseWithRead' "Int32" - -instance TTC.Render Int32 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Int64 where - parse = TTC.parseWithRead' "Int64" - -instance TTC.Render Int64 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Integer where - parse = TTC.parseWithRead' "Integer" - -instance TTC.Render Integer where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Word where - parse = TTC.parseWithRead' "Word" - -instance TTC.Render Word where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Word8 where - parse = TTC.parseWithRead' "Word8" - -instance TTC.Render Word8 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Word16 where - parse = TTC.parseWithRead' "Word16" - -instance TTC.Render Word16 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Word32 where - parse = TTC.parseWithRead' "Word32" - -instance TTC.Render Word32 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse Word64 where - parse = TTC.parseWithRead' "Word64" - -instance TTC.Render Word64 where - render = TTC.renderWithShow - ------------------------------------------------------------------------------- - -instance TTC.Parse String where - parse = Right . TTC.toS - -instance TTC.Render String where - render = TTC.fromS - ------------------------------------------------------------------------------- - -instance TTC.Parse BSL.ByteString where - parse = Right . TTC.toBSL - -instance TTC.Render BSL.ByteString where - render = TTC.fromBSL - ------------------------------------------------------------------------------- - -instance TTC.Parse BS.ByteString where - parse = Right . TTC.toBS - -instance TTC.Render BS.ByteString where - render = TTC.fromBS - ------------------------------------------------------------------------------- - -instance TTC.Parse TL.Text where - parse = Right . TTC.toTL - -instance TTC.Render TL.Text where - render = TTC.fromTL - ------------------------------------------------------------------------------- - -instance TTC.Parse T.Text where - parse = Right . TTC.toT - -instance TTC.Render T.Text where - render = TTC.fromT diff --git a/test/Data/TTC/Instances/Test.hs b/test/Data/TTC/Instances/Test.hs deleted file mode 100644 --- a/test/Data/TTC/Instances/Test.hs +++ /dev/null @@ -1,336 +0,0 @@ -module Data.TTC.Instances.Test (tests) where - --- https://hackage.haskell.org/package/base -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) - --- https://hackage.haskell.org/package/bytestring -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BSL - --- https://hackage.haskell.org/package/tasty -import Test.Tasty (TestTree, testGroup) - --- https://hackage.haskell.org/package/tasty-hunit -import Test.Tasty.HUnit ((@=?), testCase) - --- https://hackage.haskell.org/package/text -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - --- (ttc) -import qualified Data.TTC as TTC -import Data.TTC.Instances () - -{-# ANN module "HLint: ignore Reduce duplication" #-} - ------------------------------------------------------------------------------- --- $TestData - -xS :: String -xS = "test テスト" - -xT :: T.Text -xT = TTC.convert "test テスト" - -xTL :: TL.Text -xTL = TTC.convert "test テスト" - -xBS :: BS.ByteString -xBS = TTC.convert "test テスト" - -xBSL :: BSL.ByteString -xBSL = TTC.convert "test テスト" - ------------------------------------------------------------------------------- - -testChar :: TestTree -testChar = testGroup "Char" - [ testCase "Render" $ "*" @=? TTC.render '*' - , testCase "Parse.OK" $ Just '*' @=? TTC.parseMaybe "*" - , testCase "Parse.empty" $ Left "invalid Char" @=? - (TTC.parse "" :: Either String Char) - , testCase "Parse.multiple" $ Left "invalid Char" @=? - (TTC.parse "**" :: Either String Char) - ] - -testDouble :: TestTree -testDouble = testGroup "Double" - [ testCase "Render" $ s @=? TTC.render x - , testCase "Parse.OK" $ Just x' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Double" @=? - (TTC.parse "invalid" :: Either String Double) - ] - where - x :: Double - x = 3.14159 - - s :: String - s = show x - - x' :: Double - x' = read s - -testFloat :: TestTree -testFloat = testGroup "Float" - [ testCase "Render" $ s @=? TTC.render x - , testCase "Parse.OK" $ Just x' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Float" @=? - (TTC.parse "invalid" :: Either String Float) - ] - where - x :: Float - x = 3.14159 - - s :: String - s = show x - - x' :: Float - x' = read s - -testInt :: TestTree -testInt = testGroup "Int" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Int" @=? - (TTC.parse "invalid" :: Either String Int) - ] - where - n :: Int - n = 42 - - s :: String - s = show n - - n' :: Int - n' = read s - -testInt8 :: TestTree -testInt8 = testGroup "Int8" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Int8" @=? - (TTC.parse "invalid" :: Either String Int8) - ] - where - n :: Int8 - n = 42 - - s :: String - s = show n - - n' :: Int8 - n' = read s - -testInt16 :: TestTree -testInt16 = testGroup "Int16" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Int16" @=? - (TTC.parse "invalid" :: Either String Int16) - ] - where - n :: Int16 - n = 42 - - s :: String - s = show n - - n' :: Int16 - n' = read s - -testInt32 :: TestTree -testInt32 = testGroup "Int32" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Int32" @=? - (TTC.parse "invalid" :: Either String Int32) - ] - where - n :: Int32 - n = 42 - - s :: String - s = show n - - n' :: Int32 - n' = read s - -testInt64 :: TestTree -testInt64 = testGroup "Int64" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Int64" @=? - (TTC.parse "invalid" :: Either String Int64) - ] - where - n :: Int64 - n = 42 - - s :: String - s = show n - - n' :: Int64 - n' = read s - -testInteger :: TestTree -testInteger = testGroup "Integer" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Integer" @=? - (TTC.parse "invalid" :: Either String Integer) - ] - where - n :: Integer - n = 42 - - s :: String - s = show n - - n' :: Integer - n' = read s - -testWord :: TestTree -testWord = testGroup "Word" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Word" @=? - (TTC.parse "invalid" :: Either String Word) - ] - where - n :: Word - n = 42 - - s :: String - s = show n - - n' :: Word - n' = read s - -testWord8 :: TestTree -testWord8 = testGroup "Word8" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Word8" @=? - (TTC.parse "invalid" :: Either String Word8) - ] - where - n :: Word8 - n = 42 - - s :: String - s = show n - - n' :: Word8 - n' = read s - -testWord16 :: TestTree -testWord16 = testGroup "Word16" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Word16" @=? - (TTC.parse "invalid" :: Either String Word16) - ] - where - n :: Word16 - n = 42 - - s :: String - s = show n - - n' :: Word16 - n' = read s - -testWord32 :: TestTree -testWord32 = testGroup "Word32" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Word32" @=? - (TTC.parse "invalid" :: Either String Word32) - ] - where - n :: Word32 - n = 42 - - s :: String - s = show n - - n' :: Word32 - n' = read s - -testWord64 :: TestTree -testWord64 = testGroup "Word64" - [ testCase "Render" $ s @=? TTC.render n - , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s - , testCase "Parse.invalid" $ Left "invalid Word64" @=? - (TTC.parse "invalid" :: Either String Word64) - ] - where - n :: Word64 - n = 42 - - s :: String - s = show n - - n' :: Word64 - n' = read s - -testString :: TestTree -testString = testGroup "String" - [ testCase "Render" $ xS @=? TTC.render xS - , testCase "Parse.empty" $ Just "" @=? TTC.parseMaybe "" - , testCase "Parse.nonempty" $ Just xS @=? TTC.parseMaybe xS - ] - -testBSL :: TestTree -testBSL = testGroup "BSL.ByteString" - [ testCase "Render" $ xS @=? TTC.render xBSL - , testCase "Parse.empty" $ Just BSL.empty @=? TTC.parseMaybe "" - , testCase "Parse.nonempty" $ Just xBSL @=? TTC.parseMaybe xS - ] - -testBS :: TestTree -testBS = testGroup "BS.ByteString" - [ testCase "Render" $ xS @=? TTC.render xBS - , testCase "Parse.empty" $ Just BS.empty @=? TTC.parseMaybe "" - , testCase "Parse.nonempty" $ Just xBS @=? TTC.parseMaybe xS - ] - -testTL :: TestTree -testTL = testGroup "TL.Text" - [ testCase "Render" $ xS @=? TTC.render xTL - , testCase "Parse.empty" $ Just TL.empty @=? TTC.parseMaybe "" - , testCase "Parse.nonempty" $ Just xTL @=? TTC.parseMaybe xS - ] - -testT :: TestTree -testT = testGroup "T.Text" - [ testCase "Render" $ xS @=? TTC.render xT - , testCase "Parse.empty" $ Just T.empty @=? TTC.parseMaybe "" - , testCase "Parse.nonempty" $ Just xT @=? TTC.parseMaybe xS - ] - ------------------------------------------------------------------------------- - -tests :: TestTree -tests = testGroup "Data.TTC.Instances" - [ testChar - , testDouble - , testFloat - , testInt - , testInt8 - , testInt16 - , testInt32 - , testInt64 - , testInteger - , testWord - , testWord8 - , testWord16 - , testWord32 - , testWord64 - , testString - , testBSL - , testBS - , testTL - , testT - ] diff --git a/test/Data/TTC/Test.hs b/test/Data/TTC/Test.hs --- a/test/Data/TTC/Test.hs +++ b/test/Data/TTC/Test.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Data.TTC.Test (tests) where -- https://hackage.haskell.org/package/base import Control.Exception (ErrorCall, Exception, evaluate, handle) import Control.Monad (when) +import Data.Int (Int16, Int32, Int64, Int8) import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) import Text.Read (readMaybe) -- https://hackage.haskell.org/package/bytestring @@ -35,10 +41,78 @@ import TestString (TestString(TestString)) ------------------------------------------------------------------------------ +-- $Instances + +instance TTC.Render Char +instance TTC.Parse Char + +instance TTC.Render Double +instance TTC.Parse Double + +instance TTC.Render Float +instance TTC.Parse Float + +instance TTC.Render Int +instance TTC.Parse Int + +instance TTC.Render Int8 +instance TTC.Parse Int8 + +instance TTC.Render Int16 +instance TTC.Parse Int16 + +instance TTC.Render Int32 +instance TTC.Parse Int32 + +instance TTC.Render Int64 +instance TTC.Parse Int64 + +instance TTC.Render Integer +instance TTC.Parse Integer + +instance TTC.Render Word +instance TTC.Parse Word + +instance TTC.Render Word8 +instance TTC.Parse Word8 + +instance TTC.Render Word16 +instance TTC.Parse Word16 + +instance TTC.Render Word32 +instance TTC.Parse Word32 + +instance TTC.Render Word64 +instance TTC.Parse Word64 + +instance TTC.Render String +instance TTC.Parse String + +instance TTC.Render BSL.ByteString +instance TTC.Parse BSL.ByteString + +instance TTC.Render BS.ByteString +instance TTC.Parse BS.ByteString + +instance TTC.Render TL.Text +instance TTC.Parse TL.Text + +instance TTC.Render T.Text +instance TTC.Parse T.Text + +------------------------------------------------------------------------------ + +instance Eq BSB.Builder where + x == y = BSB.toLazyByteString x == BSB.toLazyByteString y + +instance Show BSB.Builder where + show = show . BSB.toLazyByteString + +------------------------------------------------------------------------------ -- $HelperFunctions assertRaises - :: (Exception e, Show a) + :: (HasCallStack, Exception e, Show a) => Proxy e -> a -> Assertion @@ -59,15 +133,15 @@ xTL :: TL.Text xTL = "test テスト" +xTLB :: TLB.Builder +xTLB = "test テスト" + xBS :: BS.ByteString xBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" xBSL :: BSL.ByteString xBSL = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" -xTLB :: TLB.Builder -xTLB = "test テスト" - xBSB :: BSB.Builder xBSB = "test テスト" @@ -83,12 +157,23 @@ xiTL :: TL.Text xiTL = "test \xfffd" +xiTLB :: TLB.Builder +xiTLB = "test \xfffd" + xiBS :: BS.ByteString xiBS = "test \xe3" xiBSL :: BSL.ByteString xiBSL = "test \xe3" +xiBSB :: BSB.Builder +xiBSB = "test \xfffd" + +xiSBS :: SBS.ShortByteString +xiSBS = "test \xfffd" + +------------------------------------------------------------------------------ + newtype PosInt = PosInt Int deriving Eq @@ -117,14 +202,17 @@ answerTL :: TL.Text answerTL = "42" +answerTLB :: TLB.Builder +answerTLB = "42" + answerBS :: BS.ByteString answerBS = "42" answerBSL :: BSL.ByteString answerBSL = "42" -answerTLB :: TLB.Builder -answerTLB = "42" +answerBSB :: BSB.Builder +answerBSB = "42" answerSBS :: SBS.ShortByteString answerSBS = "42" @@ -135,6 +223,8 @@ data IntError = IntInvalid deriving (Eq, Show) +------------------------------------------------------------------------------ + data Color = Red | Green @@ -167,12 +257,23 @@ redTL :: TL.Text redTL = "red" +redTLB :: TLB.Builder +redTLB = "red" + redBS :: BS.ByteString redBS = "red" redBSL :: BSL.ByteString redBSL = "red" +redBSB :: BSB.Builder +redBSB = "red" + +redSBS :: SBS.ShortByteString +redSBS = "red" + +------------------------------------------------------------------------------ + newtype PartialParser = PartialParser String deriving (Eq, Show) @@ -189,10 +290,15 @@ [ testCase "S" $ xS @=? TTC.toS xS , testCase "T" $ xS @=? TTC.toS xT , testCase "TL" $ xS @=? TTC.toS xTL + , testCase "TLB" $ xS @=? TTC.toS xTLB , testCase "BS" $ xS @=? TTC.toS xBS , testCase "BS/invalid" $ xiS @=? TTC.toS xiBS , testCase "BSL" $ xS @=? TTC.toS xBSL , testCase "BSL/invalid" $ xiS @=? TTC.toS xiBSL + , testCase "BSB" $ xS @=? TTC.toS xBSB + , testCase "BSB/invalid" $ xiS @=? TTC.toS xiBSB + , testCase "SBS" $ xS @=? TTC.toS xSBS + , testCase "SBS/invalid" $ xiS @=? TTC.toS xiSBS ] testToT :: TestTree @@ -200,10 +306,15 @@ [ testCase "S" $ xT @=? TTC.toT xS , testCase "T" $ xT @=? TTC.toT xT , testCase "TL" $ xT @=? TTC.toT xTL + , testCase "TLB" $ xT @=? TTC.toT xTLB , testCase "BS" $ xT @=? TTC.toT xBS , testCase "BS/invalid" $ xiT @=? TTC.toT xiBS , testCase "BSL" $ xT @=? TTC.toT xBSL , testCase "BSL/invalid" $ xiT @=? TTC.toT xiBSL + , testCase "BSB" $ xT @=? TTC.toT xBSB + , testCase "BSB/invalid" $ xiT @=? TTC.toT xiBSB + , testCase "SBS" $ xT @=? TTC.toT xSBS + , testCase "SBS/invalid" $ xiT @=? TTC.toT xiSBS ] testToTL :: TestTree @@ -211,19 +322,43 @@ [ testCase "S" $ xTL @=? TTC.toTL xS , testCase "T" $ xTL @=? TTC.toTL xT , testCase "TL" $ xTL @=? TTC.toTL xTL + , testCase "TLB" $ xTL @=? TTC.toTL xTLB , testCase "BS" $ xTL @=? TTC.toTL xBS , testCase "BS/invalid" $ xiTL @=? TTC.toTL xiBS , testCase "BSL" $ xTL @=? TTC.toTL xBSL , testCase "BSL/invalid" $ xiTL @=? TTC.toTL xiBSL + , testCase "BSB" $ xTL @=? TTC.toTL xBSB + , testCase "BSB/invalid" $ xiTL @=? TTC.toTL xiBSB + , testCase "SBS" $ xTL @=? TTC.toTL xSBS + , testCase "SBS/invalid" $ xiTL @=? TTC.toTL xiSBS ] +testToTLB :: TestTree +testToTLB = testGroup "toTLB" + [ testCase "S" $ xTLB @=? TTC.toTLB xS + , testCase "T" $ xTLB @=? TTC.toTLB xT + , testCase "TL" $ xTLB @=? TTC.toTLB xTL + , testCase "TLB" $ xTLB @=? TTC.toTLB xTLB + , testCase "BS" $ xTLB @=? TTC.toTLB xBS + , testCase "BS/invalid" $ xiTLB @=? TTC.toTLB xiBS + , testCase "BSL" $ xTLB @=? TTC.toTLB xBSL + , testCase "BSL/invalid" $ xiTLB @=? TTC.toTLB xiBSL + , testCase "BSB" $ xTLB @=? TTC.toTLB xBSB + , testCase "BSB/invalid" $ xiTLB @=? TTC.toTLB xiBSB + , testCase "SBS" $ xTLB @=? TTC.toTLB xSBS + , testCase "SBS/invalid" $ xiTLB @=? TTC.toTLB xiSBS + ] + testToBS :: TestTree testToBS = testGroup "toBS" [ testCase "S" $ xBS @=? TTC.toBS xS , testCase "T" $ xBS @=? TTC.toBS xT , testCase "TL" $ xBS @=? TTC.toBS xTL + , testCase "TLB" $ xBS @=? TTC.toBS xTLB , testCase "BS" $ xBS @=? TTC.toBS xBS , testCase "BSL" $ xBS @=? TTC.toBS xBSL + , testCase "BSB" $ xBS @=? TTC.toBS xBSB + , testCase "SBS" $ xBS @=? TTC.toBS xSBS ] testToBSL :: TestTree @@ -231,37 +366,103 @@ [ testCase "S" $ xBSL @=? TTC.toBSL xS , testCase "T" $ xBSL @=? TTC.toBSL xT , testCase "TL" $ xBSL @=? TTC.toBSL xTL + , testCase "TLB" $ xBSL @=? TTC.toBSL xTLB , testCase "BS" $ xBSL @=? TTC.toBSL xBS , testCase "BSL" $ xBSL @=? TTC.toBSL xBSL + , testCase "BSB" $ xBSL @=? TTC.toBSL xBSB + , testCase "SBS" $ xBSL @=? TTC.toBSL xSBS ] +testToBSB :: TestTree +testToBSB = testGroup "toBSB" + [ testCase "S" $ xBSB @=? TTC.toBSB xS + , testCase "T" $ xBSB @=? TTC.toBSB xT + , testCase "TL" $ xBSB @=? TTC.toBSB xTL + , testCase "TLB" $ xBSB @=? TTC.toBSB xTLB + , testCase "BS" $ xBSB @=? TTC.toBSB xBS + , testCase "BSL" $ xBSB @=? TTC.toBSB xBSL + , testCase "BSB" $ xBSB @=? TTC.toBSB xBSB + , testCase "SBS" $ xBSB @=? TTC.toBSB xSBS + ] + +testToSBS :: TestTree +testToSBS = testGroup "toSBS" + [ testCase "S" $ xSBS @=? TTC.toSBS xS + , testCase "T" $ xSBS @=? TTC.toSBS xT + , testCase "TL" $ xSBS @=? TTC.toSBS xTL + , testCase "TLB" $ xSBS @=? TTC.toSBS xTLB + , testCase "BS" $ xSBS @=? TTC.toSBS xBS + , testCase "BSL" $ xSBS @=? TTC.toSBS xBSL + , testCase "BSB" $ xSBS @=? TTC.toSBS xBSB + , testCase "SBS" $ xSBS @=? TTC.toSBS xSBS + ] + testConvert :: TestTree testConvert = testGroup "convert" [ testCase "S->S" $ xS @=? TTC.convert xS , testCase "S->T" $ xT @=? TTC.convert xS , testCase "S->TL" $ xTL @=? TTC.convert xS + , testCase "S->TLB" $ xTLB @=? TTC.convert xS , testCase "S->BS" $ xBS @=? TTC.convert xS , testCase "S->BSL" $ xBSL @=? TTC.convert xS + , testCase "S->BSB" $ xBSB @=? TTC.convert xS + , testCase "S->SBS" $ xSBS @=? TTC.convert xS , testCase "T->S" $ xS @=? TTC.convert xT , testCase "T->T" $ xT @=? TTC.convert xT , testCase "T->TL" $ xTL @=? TTC.convert xT + , testCase "T->TLB" $ xTLB @=? TTC.convert xT , testCase "T->BS" $ xBS @=? TTC.convert xT , testCase "T->BSL" $ xBSL @=? TTC.convert xT + , testCase "T->BSB" $ xBSB @=? TTC.convert xT + , testCase "T->SBS" $ xSBS @=? TTC.convert xT , testCase "TL->S" $ xS @=? TTC.convert xTL , testCase "TL->T" $ xT @=? TTC.convert xTL , testCase "TL->TL" $ xTL @=? TTC.convert xTL + , testCase "TL->TLB" $ xTLB @=? TTC.convert xTL , testCase "TL->BS" $ xBS @=? TTC.convert xTL , testCase "TL->BSL" $ xBSL @=? TTC.convert xTL + , testCase "TL->BSB" $ xBSB @=? TTC.convert xTL + , testCase "TL->SBS" $ xSBS @=? TTC.convert xTL + , testCase "TLB->S" $ xS @=? TTC.convert xTLB + , testCase "TLB->T" $ xT @=? TTC.convert xTLB + , testCase "TLB->TL" $ xTL @=? TTC.convert xTLB + , testCase "TLB->TLB" $ xTLB @=? TTC.convert xTLB + , testCase "TLB->BS" $ xBS @=? TTC.convert xTLB + , testCase "TLB->BSL" $ xBSL @=? TTC.convert xTLB + , testCase "TLB->BSB" $ xBSB @=? TTC.convert xTLB + , testCase "TLB->SBS" $ xSBS @=? TTC.convert xTLB , testCase "BS->S" $ xS @=? TTC.convert xBS , testCase "BS->T" $ xT @=? TTC.convert xBS , testCase "BS->TL" $ xTL @=? TTC.convert xBS + , testCase "BS->TLB" $ xTLB @=? TTC.convert xBS , testCase "BS->BS" $ xBS @=? TTC.convert xBS , testCase "BS->BSL" $ xBSL @=? TTC.convert xBS + , testCase "BS->BSB" $ xBSB @=? TTC.convert xBS + , testCase "BS->SBS" $ xSBS @=? TTC.convert xBS , testCase "BSL->S" $ xS @=? TTC.convert xBSL , testCase "BSL->T" $ xT @=? TTC.convert xBSL , testCase "BSL->TL" $ xTL @=? TTC.convert xBSL + , testCase "BSL->TLB" $ xTLB @=? TTC.convert xBSL , testCase "BSL->BS" $ xBS @=? TTC.convert xBSL , testCase "BSL->BSL" $ xBSL @=? TTC.convert xBSL + , testCase "BSL->BSB" $ xBSB @=? TTC.convert xBSL + , testCase "BSL->SBS" $ xSBS @=? TTC.convert xBSL + , testCase "BSB->S" $ xS @=? TTC.convert xBSB + , testCase "BSB->T" $ xT @=? TTC.convert xBSB + , testCase "BSB->TL" $ xTL @=? TTC.convert xBSB + , testCase "BSB->TLB" $ xTLB @=? TTC.convert xBSB + , testCase "BSB->BS" $ xBS @=? TTC.convert xBSB + , testCase "BSB->BSL" $ xBSL @=? TTC.convert xBSB + , testCase "BSB->BSB" $ xBSB @=? TTC.convert xBSB + , testCase "BSB->SBS" $ xSBS @=? TTC.convert xBSB + , testCase "SBS->S" $ xS @=? TTC.convert xSBS + , testCase "SBS->T" $ xT @=? TTC.convert xSBS + , testCase "SBS->TL" $ xTL @=? TTC.convert xSBS + , testCase "SBS->TLB" $ xTLB @=? TTC.convert xSBS + , testCase "SBS->BS" $ xBS @=? TTC.convert xSBS + , testCase "SBS->BSL" $ xBSL @=? TTC.convert xSBS + , testCase "SBS->BSB" $ xBSB @=? TTC.convert xSBS + , testCase "SBS->SBS" $ xSBS @=? TTC.convert xSBS ] testFromS :: TestTree @@ -269,8 +470,11 @@ [ testCase "S" $ xS @=? TTC.fromS xS , testCase "T" $ xT @=? TTC.fromS xS , testCase "TL" $ xTL @=? TTC.fromS xS + , testCase "TLB" $ xTLB @=? TTC.fromS xS , testCase "BS" $ xBS @=? TTC.fromS xS , testCase "BSL" $ xBSL @=? TTC.fromS xS + , testCase "BSB" $ xBSB @=? TTC.fromS xS + , testCase "SBS" $ xSBS @=? TTC.fromS xS ] testFromT :: TestTree @@ -278,8 +482,11 @@ [ testCase "S" $ xS @=? TTC.fromT xT , testCase "T" $ xT @=? TTC.fromT xT , testCase "TL" $ xTL @=? TTC.fromT xT + , testCase "TLB" $ xTLB @=? TTC.fromT xT , testCase "BS" $ xBS @=? TTC.fromT xT , testCase "BSL" $ xBSL @=? TTC.fromT xT + , testCase "BSB" $ xBSB @=? TTC.fromT xT + , testCase "SBS" $ xSBS @=? TTC.fromT xT ] testFromTL :: TestTree @@ -287,17 +494,35 @@ [ testCase "S" $ xS @=? TTC.fromTL xTL , testCase "T" $ xT @=? TTC.fromTL xTL , testCase "TL" $ xTL @=? TTC.fromTL xTL + , testCase "TLB" $ xTLB @=? TTC.fromTL xTL , testCase "BS" $ xBS @=? TTC.fromTL xTL , testCase "BSL" $ xBSL @=? TTC.fromTL xTL + , testCase "BSB" $ xBSB @=? TTC.fromTL xTL + , testCase "SBS" $ xSBS @=? TTC.fromTL xTL ] +testFromTLB :: TestTree +testFromTLB = testGroup "fromTLB" + [ testCase "S" $ xS @=? TTC.fromTLB xTLB + , testCase "T" $ xT @=? TTC.fromTLB xTLB + , testCase "TL" $ xTL @=? TTC.fromTLB xTLB + , testCase "TLB" $ xTLB @=? TTC.fromTLB xTLB + , testCase "BS" $ xBS @=? TTC.fromTLB xTLB + , testCase "BSL" $ xBSL @=? TTC.fromTLB xTLB + , testCase "BSB" $ xBSB @=? TTC.fromTLB xTLB + , testCase "SBS" $ xSBS @=? TTC.fromTLB xTLB + ] + testFromBS :: TestTree testFromBS = testGroup "fromBS" [ testCase "S" $ xS @=? TTC.fromBS xBS , testCase "T" $ xT @=? TTC.fromBS xBS , testCase "TL" $ xTL @=? TTC.fromBS xBS + , testCase "TLB" $ xTLB @=? TTC.fromBS xBS , testCase "BS" $ xBS @=? TTC.fromBS xBS , testCase "BSL" $ xBSL @=? TTC.fromBS xBS + , testCase "BSB" $ xBSB @=? TTC.fromBS xBS + , testCase "SBS" $ xSBS @=? TTC.fromBS xBS ] testFromBSL :: TestTree @@ -305,17 +530,47 @@ [ testCase "S" $ xS @=? TTC.fromBSL xBSL , testCase "T" $ xT @=? TTC.fromBSL xBSL , testCase "TL" $ xTL @=? TTC.fromBSL xBSL + , testCase "TLB" $ xTLB @=? TTC.fromBSL xBSL , testCase "BS" $ xBS @=? TTC.fromBSL xBSL , testCase "BSL" $ xBSL @=? TTC.fromBSL xBSL + , testCase "BSB" $ xBSB @=? TTC.fromBSL xBSL + , testCase "SBS" $ xSBS @=? TTC.fromBSL xBSL ] +testFromBSB :: TestTree +testFromBSB = testGroup "fromBSB" + [ testCase "S" $ xS @=? TTC.fromBSB xBSB + , testCase "T" $ xT @=? TTC.fromBSB xBSB + , testCase "TL" $ xTL @=? TTC.fromBSB xBSB + , testCase "TLB" $ xTLB @=? TTC.fromBSB xBSB + , testCase "BS" $ xBS @=? TTC.fromBSB xBSB + , testCase "BSL" $ xBSL @=? TTC.fromBSB xBSB + , testCase "BSB" $ xBSB @=? TTC.fromBSB xBSB + , testCase "SBS" $ xSBS @=? TTC.fromBSB xBSB + ] + +testFromSBS :: TestTree +testFromSBS = testGroup "fromSBS" + [ testCase "S" $ xS @=? TTC.fromSBS xSBS + , testCase "T" $ xT @=? TTC.fromSBS xSBS + , testCase "TL" $ xTL @=? TTC.fromSBS xSBS + , testCase "TLB" $ xTLB @=? TTC.fromSBS xSBS + , testCase "BS" $ xBS @=? TTC.fromSBS xSBS + , testCase "BSL" $ xBSL @=? TTC.fromSBS xSBS + , testCase "BSB" $ xBSB @=? TTC.fromSBS xSBS + , testCase "SBS" $ xSBS @=? TTC.fromSBS xSBS + ] + testAsS :: TestTree testAsS = testGroup "asS" [ testCase "S" $ xS @=? TTC.asS id xS , testCase "T" $ xS @=? TTC.asS id xT , testCase "TL" $ xS @=? TTC.asS id xTL + , testCase "TLB" $ xS @=? TTC.asS id xTLB , testCase "BS" $ xS @=? TTC.asS id xBS , testCase "BSL" $ xS @=? TTC.asS id xBSL + , testCase "BSB" $ xS @=? TTC.asS id xBSB + , testCase "SBS" $ xS @=? TTC.asS id xSBS ] testAsT :: TestTree @@ -323,8 +578,11 @@ [ testCase "S" $ xT @=? TTC.asT id xS , testCase "T" $ xT @=? TTC.asT id xT , testCase "TL" $ xT @=? TTC.asT id xTL + , testCase "TLB" $ xT @=? TTC.asT id xTLB , testCase "BS" $ xT @=? TTC.asT id xBS , testCase "BSL" $ xT @=? TTC.asT id xBSL + , testCase "BSB" $ xT @=? TTC.asT id xBSB + , testCase "SBS" $ xT @=? TTC.asT id xSBS ] testAsTL :: TestTree @@ -332,17 +590,35 @@ [ testCase "S" $ xTL @=? TTC.asTL id xS , testCase "T" $ xTL @=? TTC.asTL id xT , testCase "TL" $ xTL @=? TTC.asTL id xTL + , testCase "TLB" $ xTL @=? TTC.asTL id xTLB , testCase "BS" $ xTL @=? TTC.asTL id xBS , testCase "BSL" $ xTL @=? TTC.asTL id xBSL + , testCase "BSB" $ xTL @=? TTC.asTL id xBSB + , testCase "SBS" $ xTL @=? TTC.asTL id xSBS ] +testAsTLB :: TestTree +testAsTLB = testGroup "asTLB" + [ testCase "S" $ xTLB @=? TTC.asTLB id xS + , testCase "T" $ xTLB @=? TTC.asTLB id xT + , testCase "TL" $ xTLB @=? TTC.asTLB id xTL + , testCase "TLB" $ xTLB @=? TTC.asTLB id xTLB + , testCase "BS" $ xTLB @=? TTC.asTLB id xBS + , testCase "BSL" $ xTLB @=? TTC.asTLB id xBSL + , testCase "BSB" $ xTLB @=? TTC.asTLB id xBSB + , testCase "SBS" $ xTLB @=? TTC.asTLB id xSBS + ] + testAsBS :: TestTree testAsBS = testGroup "asBS" [ testCase "S" $ xBS @=? TTC.asBS id xS , testCase "T" $ xBS @=? TTC.asBS id xT , testCase "TL" $ xBS @=? TTC.asBS id xTL + , testCase "TLB" $ xBS @=? TTC.asBS id xTLB , testCase "BS" $ xBS @=? TTC.asBS id xBS , testCase "BSL" $ xBS @=? TTC.asBS id xBSL + , testCase "BSB" $ xBS @=? TTC.asBS id xBSB + , testCase "SBS" $ xBS @=? TTC.asBS id xSBS ] testAsBSL :: TestTree @@ -350,28 +626,36 @@ [ testCase "S" $ xBSL @=? TTC.asBSL id xS , testCase "T" $ xBSL @=? TTC.asBSL id xT , testCase "TL" $ xBSL @=? TTC.asBSL id xTL + , testCase "TLB" $ xBSL @=? TTC.asBSL id xTLB , testCase "BS" $ xBSL @=? TTC.asBSL id xBS , testCase "BSL" $ xBSL @=? TTC.asBSL id xBSL + , testCase "BSB" $ xBSL @=? TTC.asBSL id xBSB + , testCase "SBS" $ xBSL @=? TTC.asBSL id xSBS ] -testToTLB :: TestTree -testToTLB = testCase "toTLB" $ xTLB @=? TTC.toTLB xS - -testFromTLB :: TestTree -testFromTLB = testCase "fromTLB" $ xS @=? TTC.fromTLB xTLB - -testToBSB :: TestTree -testToBSB = testCase "toBSB" $ - BSB.toLazyByteString xBSB @=? BSB.toLazyByteString (TTC.toBSB xS) - -testFromBSB :: TestTree -testFromBSB = testCase "fromBSB" $ xS @=? TTC.fromBSB xBSB - -testToSBS :: TestTree -testToSBS = testCase "toSBS" $ xSBS @=? TTC.toSBS xS +testAsBSB :: TestTree +testAsBSB = testGroup "asBSB" + [ testCase "S" $ xBSB @=? TTC.asBSB id xS + , testCase "T" $ xBSB @=? TTC.asBSB id xT + , testCase "TL" $ xBSB @=? TTC.asBSB id xTL + , testCase "TLB" $ xBSB @=? TTC.asBSB id xTLB + , testCase "BS" $ xBSB @=? TTC.asBSB id xBS + , testCase "BSL" $ xBSB @=? TTC.asBSB id xBSL + , testCase "BSB" $ xBSB @=? TTC.asBSB id xBSB + , testCase "SBS" $ xBSB @=? TTC.asBSB id xSBS + ] -testFromSBS :: TestTree -testFromSBS = testCase "fromSBS" $ xS @=? TTC.fromSBS xSBS +testAsSBS :: TestTree +testAsSBS = testGroup "asSBS" + [ testCase "S" $ xSBS @=? TTC.asSBS id xS + , testCase "T" $ xSBS @=? TTC.asSBS id xT + , testCase "TL" $ xSBS @=? TTC.asSBS id xTL + , testCase "TLB" $ xSBS @=? TTC.asSBS id xTLB + , testCase "BS" $ xSBS @=? TTC.asSBS id xBS + , testCase "BSL" $ xSBS @=? TTC.asSBS id xBSL + , testCase "BSB" $ xSBS @=? TTC.asSBS id xBSB + , testCase "SBS" $ xSBS @=? TTC.asSBS id xSBS + ] ------------------------------------------------------------------------------ -- $Render @@ -381,10 +665,49 @@ [ testCase "S" $ answerS @=? TTC.render answer , testCase "T" $ answerT @=? TTC.render answer , testCase "TL" $ answerTL @=? TTC.render answer + , testCase "TLB" $ answerTLB @=? TTC.render answer , testCase "BS" $ answerBS @=? TTC.render answer , testCase "BSL" $ answerBSL @=? TTC.render answer + , testCase "BSB" $ answerBSB @=? TTC.render answer + , testCase "SBS" $ answerSBS @=? TTC.render answer ] +testRenderDefault :: TestTree +testRenderDefault = testGroup "RenderDefault" + [ testCase "Char" $ "*" @=? TTC.renderS '*' + , let x = 3.14159 :: Double + in testCase "Double" $ show x @=? TTC.renderS x + , let x = 3.14159 :: Float + in testCase "Float" $ show x @=? TTC.renderS x + , let n = 42 :: Int + in testCase "Int" $ show n @=? TTC.renderS n + , let n = 42 :: Int8 + in testCase "Int8" $ show n @=? TTC.renderS n + , let n = 42 :: Int16 + in testCase "Int16" $ show n @=? TTC.renderS n + , let n = 42 :: Int32 + in testCase "Int32" $ show n @=? TTC.renderS n + , let n = 42 :: Int64 + in testCase "Int64" $ show n @=? TTC.renderS n + , let n = 42 :: Integer + in testCase "Integer" $ show n @=? TTC.renderS n + , let w = 42 :: Word + in testCase "Word" $ show w @=? TTC.renderS w + , let w = 42 :: Word8 + in testCase "Word8" $ show w @=? TTC.renderS w + , let w = 42 :: Word16 + in testCase "Word16" $ show w @=? TTC.renderS w + , let w = 42 :: Word32 + in testCase "Word32" $ show w @=? TTC.renderS w + , let w = 42 :: Word64 + in testCase "Word64" $ show w @=? TTC.renderS w + , testCase "String" $ xS @=? TTC.renderS xS + , testCase "BSL.ByteString" $ xS @=? TTC.renderS xBSL + , testCase "BS.ByteString" $ xS @=? TTC.renderS xBS + , testCase "TL.Text" $ xS @=? TTC.renderS xTL + , testCase "T.Text" $ xS @=? TTC.renderS xT + ] + testRenderS :: TestTree testRenderS = testCase "renderS" $ answerS @=? TTC.renderS answer @@ -394,15 +717,15 @@ testRenderTL :: TestTree testRenderTL = testCase "renderTL" $ answerTL @=? TTC.renderTL answer +testRenderTLB :: TestTree +testRenderTLB = testCase "renderTLB" $ answerTLB @=? TTC.renderTLB answer + testRenderBS :: TestTree testRenderBS = testCase "renderBS" $ answerBS @=? TTC.renderBS answer testRenderBSL :: TestTree testRenderBSL = testCase "renderBSL" $ answerBSL @=? TTC.renderBSL answer -testRenderTLB :: TestTree -testRenderTLB = testCase "renderTLB" $ answerTLB @=? TTC.renderTLB answer - testRenderBSB :: TestTree testRenderBSB = testCase "renderBSB" $ answerBSL @=? BSB.toLazyByteString (TTC.renderBSB answer) @@ -415,8 +738,11 @@ [ testCase "S" $ answerS @=? TTC.renderWithShow answerZ , testCase "T" $ answerT @=? TTC.renderWithShow answerZ , testCase "TL" $ answerTL @=? TTC.renderWithShow answerZ + , testCase "TLB" $ answerTLB @=? TTC.renderWithShow answerZ , testCase "BS" $ answerBS @=? TTC.renderWithShow answerZ , testCase "BSL" $ answerBSL @=? TTC.renderWithShow answerZ + , testCase "BSB" $ answerBSB @=? TTC.renderWithShow answerZ + , testCase "SBS" $ answerSBS @=? TTC.renderWithShow answerZ ] ------------------------------------------------------------------------------ @@ -427,37 +753,180 @@ [ testCase "S" $ Just answer @=? TTC.parseMaybe answerS , testCase "T" $ Just answer @=? TTC.parseMaybe answerT , testCase "TL" $ Just answer @=? TTC.parseMaybe answerTL + , testCase "TLB" $ Just answer @=? TTC.parseMaybe answerTLB , testCase "BS" $ Just answer @=? TTC.parseMaybe answerBS , testCase "BSL" $ Just answer @=? TTC.parseMaybe answerBSL + , testCase "BSB" $ Just answer @=? TTC.parseMaybe answerBSB + , testCase "SBS" $ Just answer @=? TTC.parseMaybe answerSBS , testCase "negative" $ Left "not positive" @=? (TTC.parse ('-' : answerS) :: Either String PosInt) , testCase "invalid" $ Left "not an integer" @=? (TTC.parse ('a' : answerS) :: Either String PosInt) ] +testParseDefault :: TestTree +testParseDefault = testGroup "ParseDefault" + [ let parse = TTC.parse :: String -> Either String Char + in testGroup "Char" + [ testCase "OK" $ Right '*' @=? parse "*" + , testCase "empty" $ Left "invalid Char" @=? parse "" + , testCase "multiple" $ Left "invalid Char" @=? parse "**" + ] + , let parse = TTC.parse :: String -> Either String Double + s = show (3.14159 :: Double) + in testGroup "Double" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Double" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Float + s = show (3.14159 :: Float) + in testGroup "Float" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Float" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Int + s = show (42 :: Int) + in testGroup "Int" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Int" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Int8 + s = show (42 :: Int8) + in testGroup "Int8" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Int8" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Int16 + s = show (42 :: Int16) + in testGroup "Int16" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Int16" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Int32 + s = show (42 :: Int32) + in testGroup "Int32" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Int32" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Int64 + s = show (42 :: Int64) + in testGroup "Int64" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Int64" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Integer + s = show (42 :: Integer) + in testGroup "Integer" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Integer" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Word + s = show (42 :: Word) + in testGroup "Word" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Word" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Word8 + s = show (42 :: Word8) + in testGroup "Word8" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Word8" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Word16 + s = show (42 :: Word16) + in testGroup "Word16" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Word16" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Word32 + s = show (42 :: Word32) + in testGroup "Word32" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Word32" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String Word64 + s = show (42 :: Word64) + in testGroup "Word64" + [ testCase "OK" $ Right (read s) @=? parse s + , testCase "invalid" $ Left "invalid Word64" @=? parse "invalid" + ] + , let parse = TTC.parse :: String -> Either String String + in testGroup "String" + [ testCase "empty" $ Right "" @=? parse "" + , testCase "nonempty" $ Right xS @=? parse xS + ] + , let parse = TTC.parse :: String -> Either String BSL.ByteString + in testGroup "BSL.ByteString" + [ testCase "empty" $ Right BSL.empty @=? parse "" + , testCase "nonempty" $ Right xBSL @=? parse xS + ] + , let parse = TTC.parse :: String -> Either String BS.ByteString + in testGroup "BS.ByteString" + [ testCase "empty" $ Right BS.empty @=? parse "" + , testCase "nonempty" $ Right xBS @=? parse xS + ] + , let parse = TTC.parse :: String -> Either String TL.Text + in testGroup "TL.Text" + [ testCase "empty" $ Right TL.empty @=? parse "" + , testCase "nonempty" $ Right xTL @=? parse xS + ] + , let parse = TTC.parse :: String -> Either String T.Text + in testGroup "T.Text" + [ testCase "empty" $ Right T.empty @=? parse "" + , testCase "nonempty" $ Right xT @=? parse xS + ] + ] + testParseS :: TestTree -testParseS = testCase "parseS" $ Just answer @=? TTC.parseMaybeS answerS +testParseS = + let parseS = TTC.parseS :: String -> Either String PosInt + in testCase "parseS" $ Right answer @=? parseS answerS testParseT :: TestTree -testParseT = testCase "parseT" $ Just answer @=? TTC.parseMaybeT answerT +testParseT = + let parseT = TTC.parseT :: T.Text -> Either String PosInt + in testCase "parseT" $ Right answer @=? parseT answerT testParseTL :: TestTree -testParseTL = testCase "parseTL" $ Just answer @=? TTC.parseMaybeTL answerTL +testParseTL = + let parseTL = TTC.parseTL :: TL.Text -> Either String PosInt + in testCase "parseTL" $ Right answer @=? parseTL answerTL +testParseTLB :: TestTree +testParseTLB = + let parseTLB = TTC.parseTLB :: TLB.Builder -> Either String PosInt + in testCase "parseTLB" $ Right answer @=? parseTLB answerTLB + testParseBS :: TestTree -testParseBS = testCase "parseBS" $ Just answer @=? TTC.parseMaybeBS answerBS +testParseBS = + let parseBS = TTC.parseBS :: BS.ByteString -> Either String PosInt + in testCase "parseBS" $ Right answer @=? parseBS answerBS testParseBSL :: TestTree testParseBSL = - testCase "parseBSL" $ Just answer @=? TTC.parseMaybeBSL answerBSL + let parseBSL = TTC.parseBSL :: BSL.ByteString -> Either String PosInt + in testCase "parseBSL" $ Right answer @=? parseBSL answerBSL +testParseBSB :: TestTree +testParseBSB = + let parseBSB = TTC.parseBSB :: BSB.Builder -> Either String PosInt + in testCase "parseBSB" $ Right answer @=? parseBSB answerBSB + +testParseSBS :: TestTree +testParseSBS = + let parseSBS = TTC.parseSBS :: SBS.ShortByteString -> Either String PosInt + in testCase "parseSBS" $ Right answer @=? parseSBS answerSBS + testParseMaybe :: TestTree testParseMaybe = testGroup "parseMaybe" [ testCase "S" $ Just answer @=? TTC.parseMaybe answerS , testCase "T" $ Just answer @=? TTC.parseMaybe answerT , testCase "TL" $ Just answer @=? TTC.parseMaybe answerTL + , testCase "TLB" $ Just answer @=? TTC.parseMaybe answerTLB , testCase "BS" $ Just answer @=? TTC.parseMaybe answerBS , testCase "BSL" $ Just answer @=? TTC.parseMaybe answerBSL + , testCase "BSB" $ Just answer @=? TTC.parseMaybe answerBSB + , testCase "SBS" $ Just answer @=? TTC.parseMaybe answerSBS -- successful 'parseMaybe' does not have any error type conversion: , testCase "noerror" $ Just (PartialParser "test") @=? TTC.parseMaybe ("test" :: String) @@ -479,6 +948,10 @@ testParseMaybeTL = testCase "parseMaybeTL" $ Just answer @=? TTC.parseMaybeTL answerTL +testParseMaybeTLB :: TestTree +testParseMaybeTLB = testCase "parseMaybeTLB" $ + Just answer @=? TTC.parseMaybeTLB answerTLB + testParseMaybeBS :: TestTree testParseMaybeBS = testCase "parseMaybeBS" $ Just answer @=? TTC.parseMaybeBS answerBS @@ -487,13 +960,24 @@ testParseMaybeBSL = testCase "parseMaybeBSL" $ Just answer @=? TTC.parseMaybeBSL answerBSL +testParseMaybeBSB :: TestTree +testParseMaybeBSB = testCase "parseMaybeBSB" $ + Just answer @=? TTC.parseMaybeBSB answerBSB + +testParseMaybeSBS :: TestTree +testParseMaybeSBS = testCase "parseMaybeSBS" $ + Just answer @=? TTC.parseMaybeSBS answerSBS + testParseUnsafe :: TestTree testParseUnsafe = testGroup "parseUnsafe" [ testCase "S" $ answer @=? TTC.parseUnsafe answerS , testCase "T" $ answer @=? TTC.parseUnsafe answerT , testCase "TL" $ answer @=? TTC.parseUnsafe answerTL + , testCase "TLB" $ answer @=? TTC.parseUnsafe answerTLB , testCase "BS" $ answer @=? TTC.parseUnsafe answerBS , testCase "BSL" $ answer @=? TTC.parseUnsafe answerBSL + , testCase "BSB" $ answer @=? TTC.parseUnsafe answerBSB + , testCase "SBS" $ answer @=? TTC.parseUnsafe answerSBS , testCase "negative" $ assertRaises (Proxy :: Proxy ErrorCall) (TTC.parseUnsafe ('-' : answerS) :: PosInt) , testCase "invalid" $ assertRaises (Proxy :: Proxy ErrorCall) @@ -512,6 +996,10 @@ testParseUnsafeTL = testCase "parseUnsafeTL" $ answer @=? TTC.parseUnsafeTL answerTL +testParseUnsafeTLB :: TestTree +testParseUnsafeTLB = testCase "parseUnsafeTLB" $ + answer @=? TTC.parseUnsafeTLB answerTLB + testParseUnsafeBS :: TestTree testParseUnsafeBS = testCase "parseUnsafeBS" $ answer @=? TTC.parseUnsafeBS answerBS @@ -520,41 +1008,59 @@ testParseUnsafeBSL = testCase "parseUnsafeBSL" $ answer @=? TTC.parseUnsafeBSL answerBSL +testParseUnsafeBSB :: TestTree +testParseUnsafeBSB = testCase "parseUnsafeBSB" $ + answer @=? TTC.parseUnsafeBSB answerBSB + +testParseUnsafeSBS :: TestTree +testParseUnsafeSBS = testCase "parseUnsafeSBS" $ + answer @=? TTC.parseUnsafeSBS answerSBS + testParseWithRead :: TestTree testParseWithRead = testGroup "parseWithRead" [ testCase "S" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerS , testCase "T" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerT , testCase "TL" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerTL + , testCase "TLB" $ + Right answerZ @=? TTC.parseWithRead IntInvalid answerTLB , testCase "BS" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerBS , testCase "BSL" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerBSL + , testCase "BSB" $ + Right answerZ @=? TTC.parseWithRead IntInvalid answerBSB + , testCase "SBS" $ + Right answerZ @=? TTC.parseWithRead IntInvalid answerSBS , testCase "invalid" $ Left IntInvalid @=? (TTC.parseWithRead IntInvalid ('a' : answerS) :: Either IntError Int) ] testParseWithRead' :: TestTree testParseWithRead' = testGroup "parseWithRead'" - [ testCase "S" $ Right answerZ @=? - (TTC.parseWithRead' "Int" answerS :: Either String Int) - , testCase "T" $ Right answerZ @=? - (TTC.parseWithRead' "Int" answerT :: Either String Int) - , testCase "TL" $ Right answerZ @=? - (TTC.parseWithRead' "Int" answerTL :: Either String Int) - , testCase "BS" $ Right answerZ @=? - (TTC.parseWithRead' "Int" answerBS :: Either String Int) - , testCase "BSL" $ Right answerZ @=? - (TTC.parseWithRead' "Int" answerBSL :: Either String Int) - , testCase "invalid" $ Left "invalid Int" @=? - (TTC.parseWithRead' "Int" ('a' : answerS) :: Either String Int) + [ testCase "S" $ Right answerZ @=? parseWithRead' answerS + , testCase "T" $ Right answerZ @=? parseWithRead' answerT + , testCase "TL" $ Right answerZ @=? parseWithRead' answerTL + , testCase "TLB" $ Right answerZ @=? parseWithRead' answerTLB + , testCase "BS" $ Right answerZ @=? parseWithRead' answerBS + , testCase "BSL" $ Right answerZ @=? parseWithRead' answerBSL + , testCase "BSB" $ Right answerZ @=? parseWithRead' answerBSB + , testCase "SBS" $ Right answerZ @=? parseWithRead' answerSBS + , testCase "invalid" $ + Left "invalid Int" @=? parseWithRead' ('a' : answerS) ] + where + parseWithRead' :: TTC.Textual t => t -> Either String Int + parseWithRead' = TTC.parseWithRead' "Int" testMaybeParseWithRead :: TestTree testMaybeParseWithRead = testGroup "maybeParseWithRead" [ testCase "S" $ Just answerZ @=? TTC.maybeParseWithRead answerS , testCase "T" $ Just answerZ @=? TTC.maybeParseWithRead answerT , testCase "TL" $ Just answerZ @=? TTC.maybeParseWithRead answerTL + , testCase "TLB" $ Just answerZ @=? TTC.maybeParseWithRead answerTLB , testCase "BS" $ Just answerZ @=? TTC.maybeParseWithRead answerBS , testCase "BSL" $ Just answerZ @=? TTC.maybeParseWithRead answerBSL + , testCase "BSB" $ Just answerZ @=? TTC.maybeParseWithRead answerBSB + , testCase "SBS" $ Just answerZ @=? TTC.maybeParseWithRead answerSBS , testCase "invalid" $ Nothing @=? (TTC.maybeParseWithRead ('a' : answerS) :: Maybe Int) ] @@ -564,8 +1070,11 @@ [ testCase "S" $ Right Red @=? parse False False redS , testCase "T" $ Right Red @=? parse False False redT , testCase "TL" $ Right Red @=? parse False False redTL + , testCase "TLB" $ Right Red @=? parse False False redTLB , testCase "BS" $ Right Red @=? parse False False redBS , testCase "BSL" $ Right Red @=? parse False False redBSL + , testCase "BSB" $ Right Red @=? parse False False redBSB + , testCase "SBS" $ Right Red @=? parse False False redSBS , testCase "CI" $ Right Red @=? parse True False ("Red" :: String) , testCase "!CI" $ Left ColorInvalid @=? parse False False ("Red" :: String) @@ -583,8 +1092,11 @@ [ testCase "S" $ Right Red @=? parse False False redS , testCase "T" $ Right Red @=? parse False False redT , testCase "TL" $ Right Red @=? parse False False redTL + , testCase "TLB" $ Right Red @=? parse False False redTLB , testCase "BS" $ Right Red @=? parse False False redBS , testCase "BSL" $ Right Red @=? parse False False redBSL + , testCase "BSB" $ Right Red @=? parse False False redBSB + , testCase "SBS" $ Right Red @=? parse False False redSBS , testCase "CI" $ Right Red @=? parse True False ("Red" :: String) , testCase "!CI" $ Left "invalid Color" @=? parse False False ("Red" :: String) @@ -646,57 +1158,71 @@ [ testToS , testToT , testToTL + , testToTLB , testToBS , testToBSL + , testToBSB + , testToSBS , testConvert , testFromS , testFromT , testFromTL + , testFromTLB , testFromBS , testFromBSL + , testFromBSB + , testFromSBS , testAsS , testAsT , testAsTL + , testAsTLB , testAsBS , testAsBSL - , testToTLB - , testFromTLB - , testToBSB - , testFromBSB - , testToSBS - , testFromSBS + , testAsBSB + , testAsSBS ] , testGroup "Render" [ testRender + , testRenderDefault , testRenderS , testRenderT , testRenderTL + , testRenderTLB , testRenderBS , testRenderBSL - , testRenderTLB , testRenderBSB , testRenderSBS , testRenderWithShow ] , testGroup "Parse" [ testParse + , testParseDefault , testParseS , testParseT , testParseTL + , testParseTLB , testParseBS , testParseBSL + , testParseBSB + , testParseSBS , testParseMaybe , testParseMaybeS , testParseMaybeT , testParseMaybeTL + , testParseMaybeTLB , testParseMaybeBS , testParseMaybeBSL + , testParseMaybeBSB + , testParseMaybeSBS , testParseUnsafe , testParseUnsafeS , testParseUnsafeT , testParseUnsafeTL + , testParseUnsafeTLB , testParseUnsafeBS , testParseUnsafeBSL + , testParseUnsafeBSB + , testParseUnsafeSBS , testParseWithRead , testParseWithRead' , testMaybeParseWithRead diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,12 +5,10 @@ -- (ttc:test) import qualified Data.TTC.Test -import qualified Data.TTC.Instances.Test ------------------------------------------------------------------------------ main :: IO () main = defaultMain $ testGroup "test" [ Data.TTC.Test.tests - , Data.TTC.Instances.Test.tests ] diff --git a/ttc.cabal b/ttc.cabal --- a/ttc.cabal +++ b/ttc.cabal @@ -1,5 +1,5 @@ name: ttc -version: 1.0.0.0 +version: 1.1.0.0 category: Data, Text synopsis: Textual Type Classes description: @@ -41,7 +41,6 @@ hs-source-dirs: src exposed-modules: Data.TTC - , Data.TTC.Instances build-depends: base >=4.7 && <5 , bytestring >=0.10.8 && <0.12 @@ -61,7 +60,6 @@ main-is: Spec.hs other-modules: Data.TTC.Test - , Data.TTC.Instances.Test , TestString build-depends: base