diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,10 @@ -# `ttc-haskell` Changelog +# `ttc` Changelog This project follows the [Haskell package versioning policy][PVP], with versions in `A.B.C.D` format. `A` may be incremented arbitrarily for non-technical reasons, but [semantic versioning][SemVer] is otherwise followed, where `A.B` is the major version, `C` is the minor version, and `D` -is the patch version. Initial development uses versions `0.0.0.D`, for which +is the patch version. Initial development uses versions `0.0.C.D`, for which every version is considered breaking. [PVP]: @@ -23,6 +23,27 @@ * Changes are listed in arbitrary order and present tense. [KaC]: + +## 1.5.0.0 (2025-01-02) + +### Breaking + +* Change type argument order for easier use with `TypeApplications` +* Add `RenderDefault` `Bool` instance +* Add `ParseDefault` `Bool` instance +* Add missing `RenderDefault` and `ParseDefault` instances for `TLB.Builder`, + `ST.ShortText`, `BSB.Builder`, and `SBS.ShortByteString` +* Remove support for GHC 8.6, constraining lower bounds +* Remove support for GHC 8.4, constraining lower bounds +* Remove support for GHC 8.2, constraining lower bounds +* Change minimal Cabal from 1.24 to 3.0 + +### Non-Breaking + +* Add `Data.TTC.Wrapper` module +* Add Template Haskell functions for loading default instances +* Bump `base` dependency version upper bound +* Bump `template-haskell` dependency version upper bound ## 1.4.0.0 (2023-12-03) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License -Copyright (c) 2019-2023 Travis Cardwell +Copyright (c) 2019-2025 Travis Cardwell Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,32 +6,20 @@ [![Stackage LTS](https://stackage.org/package/ttc/badge/lts)](https://stackage.org/package/ttc) [![Stackage Nightly](https://stackage.org/package/ttc/badge/nightly)](https://stackage.org/nightly/package/ttc) -* [Overview](#overview) - * [`Textual`](#textual) - * [`Render`](#render) - * [`Parse`](#parse) - * [Constant Validation](#constant-validation) -* [Related Work](#related-work) - * [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) - * [Tags](#tags) - * [Contribution](#contribution) - * [License](#license) - ## Overview TTC, an initialism of _Textual Type Classes_, is a library that provides `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 +own purposes. The library also provides various ways to validate constants at compile-time. +This package (`ttc`) uses a `Textual` type class for conversion between +textual data types. This package uses simple types and compiles quickly, but +the supported textual data types are fixed. It is not possible for users to +add support for additional textual data types. + 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 @@ -53,7 +41,7 @@ 2. [Render and Parse][] 3. [Validated Constants][] 4. [Best Practices][] -* The [examples][] directory in the GitHub repository contains usage examples. +* The [`ttc-examples`][] directory in the repository contains usage examples. [API documentation]: [series of articles]: @@ -61,7 +49,7 @@ [Render and Parse]: [Validated Constants]: [Best Practices]: -[examples]: +[`ttc-examples`]: ### `Textual` @@ -186,160 +174,8 @@ For more details, see the [Validated Constants][] article. -## Related Work - -### Rendering and Parsing - -The [relude][] library has polymorphic versions of `show` and `readEither` in -`Relude.String.Conversion`, as well as various type classes for converting -between string types. This does not encourage using `Show` and `Read` -instances with syntactically valid Haskell syntax, and it encourages the using -of the `String` data type. - -The [rio][] library has a `Display` type class with a similar goal as -`TTC.Render`. Since the library encourages a uniform usage of textual data -types, `Display` only provides functions for rendering to `Text` and a builder -format. It does not have a type class similar to `TTC.Parse`. - -The [text-display][] library defines a `Display` type class intended to render -user-facing text. It uses a `Builder` type internally and renders to a `Text` -value. - -Harry Garrood has an interesting series of blog posts about type classes and -`Show`: - -* [Down with Show! Part 1: Rules of thumb for when to use a type class][] -* [Down with Show! Part 2: What's wrong with the Show type class][] -* [Down with Show! Part 3: A replacement for Show][] - -[relude]: -[rio]: -[text-display]: -[Down with Show! Part 1: Rules of thumb for when to use a type class]: -[Down with Show! Part 2: What's wrong with the Show type class]: -[Down with Show! Part 3: A replacement for Show]: - -### Validating Constants - -The [qq-literals][] library creates a `QuasiQuoter` from a parse function of -type `String -> Either String a`. The functionality is similar to TTC's -`mkUntypedValidQQ` function. The `mkUntypedValidQQ` function allows the user -to choose the name of the `QuasiQuoter` because a name like `valid` is -preferred when used via a qualified import while a name like `username` may be -preferred when not using qualified imports. Note that `mkUntypedValidQQ` also -splices in an explicit type signature. - -The [validated-literals][] library has a `Validate` type class that is similar -to `TTC.Parse` but supports conversion between arbitrary types, not just from -textual data types. Template Haskell functions are provided to perform -validation at compile-time. Result types must either have `Lift` instances or -equivalent implementations. - -Chris Done posted [a gist][] about implementing statically checked overloaded -strings. - -[qq-literals]: -[validated-literals]: -[a gist]: - -### String Type Conversion - -There are a number of libraries that simplify conversion between string types. - -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. - -* [string-conv][] -* [string-conversions][] - -The following library provide type classes with a single type variable, but -conversion is done via a fixed type. - -* [hxt-regex-xmlschema][] has a `StringLike` type class and does conversion - via the `String` type -* [ListLike][] has a `StringLike` type class and does conversion via the - `String` type -* [monoid-subclasses][] provides a `TextualMonoid` type class that provides an - abstract API over textual types, using `String` as the underlying type -* [stringlike][] converts via the `Text` type -* [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][] converts via the `Text` type -* [textual][] (deprecated) converts via the `String` type - -[string-conv]: -[string-conversions]: -[hxt-regex-xmlschema]: -[ListLike]: -[monoid-subclasses]: -[stringlike]: -[tagsoup]: -[text-conversions]: -[textual]: - -### Arbitrary Type Conversion - -There are also a number of libraries that provide type classes for conversion -between arbitrary types, including string types. - -* [basement][] provides type classes for conversion that may fail as well as - conversion that cannot fail -* [convertible][] -* [witch][] provides type classes for conversion that may fail as well as - conversion that cannot fail - -[basement]: -[convertible]: -[witch]: - ## Project -### Links - -* Hackage: -* Stackage: -* Flora: -* GitHub: -* GitHub Actions CI: - -### Branches - -The `main` branch is reserved for releases. It may be considered stable, and -`HEAD` is always the latest release. - -The `develop` branch is the primary development branch. It contains changes -that have not yet been released, and it is not necessarily stable. - -[Hackage revisions][] are made for metadata changes, such as relaxation of -constraints when new versions of dependencies are released. The `ttc.cabal` -metadata in the `main` branch may therefore not match that of Hackage. The -`ttc.cabal` metadata in the `develop` branch may match, *unless* work is being -done on a new release that contains other changes. - -[Hackage revisions]: - -### Tags - -All releases are tagged in the `main` branch. Release tags are signed using -the [`security@extrema.is` GPG key][]. - -[`security@extrema.is` GPG key]: - -### Contribution - -Issues and feature requests are tracked on GitHub: - - -Issues may also be submitted via email to . - -### License - -This project is released under the [MIT License][] as specified in the -[`LICENSE`][] file. +See the [project README][] for general project information. -[MIT License]: -[`LICENSE`]: +[project README]: diff --git a/src/Data/TTC.hs b/src/Data/TTC.hs --- a/src/Data/TTC.hs +++ b/src/Data/TTC.hs @@ -1,1994 +1,2301 @@ ------------------------------------------------------------------------------ -- | -- Module : Data.TTC --- Description : textual type classes --- Copyright : Copyright (c) 2019-2023 Travis Cardwell --- License : MIT --- --- TTC, an initialism of /Textual Type Classes/, is a library that provides --- type classes for conversion between data types and textual data types --- (strings). --- --- This library is meant to be imported qualified, as follows: --- --- @ --- import qualified Data.TTC as TTC --- @ ------------------------------------------------------------------------------- - -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -#if __GLASGOW_HASKELL__ >= 900 -{-# LANGUAGE ExplicitForAll #-} -#endif - -module Data.TTC - ( -- * Textual - Textual - , convert - -- ** \"To\" Conversions - -- $TextualTo - , toS - , toT - , toTL - , toTLB - , toST - , toBS - , toBSL - , toBSB - , toSBS - -- ** \"From\" Conversions - -- $TextualFrom - , fromS - , fromT - , fromTL - , fromTLB - , fromST - , fromBS - , fromBSL - , fromBSB - , fromSBS - -- ** \"As\" Conversions - -- $TextualAs - , asS - , asT - , asTL - , asTLB - , asST - , asBS - , asBSL - , asBSB - , asSBS - -- * Render - , Render(..) - , RenderDefault(..) - -- ** Rendering Specific Types - -- $RenderSpecific - , renderS - , renderT - , renderTL - , renderTLB - , renderST - , renderBS - , renderBSL - , renderBSB - , renderSBS - -- ** Render Utilities - , renderWithShow - -- * Parse - , Parse(..) - , ParseDefault(..) - -- ** Parsing From Specific Types - -- $ParseSpecific - , parseS - , parseT - , parseTL - , parseTLB - , parseST - , parseBS - , parseBSL - , parseBSB - , parseSBS - -- ** 'Maybe' Parsing - -- $ParseMaybe - , parseMaybe - , parseMaybeS - , parseMaybeT - , parseMaybeTL - , parseMaybeTLB - , parseMaybeST - , parseMaybeBS - , parseMaybeBSL - , parseMaybeBSB - , parseMaybeSBS - -- ** 'MonadFail' Parsing - -- $ParseOrFail - , parseOrFail - , parseOrFailS - , parseOrFailT - , parseOrFailTL - , parseOrFailTLB - , parseOrFailST - , parseOrFailBS - , parseOrFailBSL - , parseOrFailBSB - , parseOrFailSBS - -- ** Unsafe Parsing - -- $ParseUnsafe - , parseUnsafe - , parseUnsafeS - , parseUnsafeT - , parseUnsafeTL - , parseUnsafeTLB - , parseUnsafeST - , parseUnsafeBS - , parseUnsafeBSL - , parseUnsafeBSB - , parseUnsafeSBS - -- ** Parse With A Single Error Message - -- $ParseWithASingleErrorMessage - , withError - , withErrorS - , withErrorT - , withErrorTL - , withErrorTLB - , withErrorST - , withErrorBS - , withErrorBSL - , withErrorBSB - , withErrorSBS - -- ** Parse With An Error Prefix - -- $ParseWithAnErrorPrefix - , prefixError - , prefixErrorS - , prefixErrorT - , prefixErrorTL - , prefixErrorTLB - , prefixErrorST - , prefixErrorBS - , prefixErrorBSL - , prefixErrorBSB - , prefixErrorSBS - -- ** Parse Enums - , parseEnum - , parseEnum' - -- ** Read Instances - , parseWithRead - , parseWithRead' - , maybeParseWithRead - , readsEnum - , readsWithParse - -- ** Constant Validation - -- $ParseValid - , valid - , validOf - , mkValid - , untypedValidOf - , mkUntypedValid - , mkUntypedValidQQ - ) where - --- https://hackage.haskell.org/package/base -#if __GLASGOW_HASKELL__ <= 806 -import Control.Monad.Fail (MonadFail) -#endif -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Proxy (Proxy(Proxy), asProxyTypeOf) -import Data.String (IsString(fromString)) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Stack (HasCallStack) -import Text.Read (readMaybe) - --- https://hackage.haskell.org/package/bytestring -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Short as SBS - --- https://hackage.haskell.org/package/template-haskell -import qualified Language.Haskell.TH as TH -import qualified Language.Haskell.TH.Quote as Q -import qualified Language.Haskell.TH.Syntax as THS - --- https://hackage.haskell.org/package/text -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Encoding.Error as TEE -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB -import qualified Data.Text.Lazy.Encoding as TLE - --- https://hackage.haskell.org/package/text-short -import qualified Data.Text.Short as ST - ------------------------------------------------------------------------------- --- $Textual - --- | The 'Textual' type class is used to convert between the following textual --- data types: --- --- * 'String' (@S@) --- * Strict 'T.Text' (@T@) --- * Lazy 'TL.Text' (@TL@) --- * @Text@ 'TLB.Builder' (@TLB@) --- * 'ST.ShortText' (@ST@) --- * Strict 'BS.ByteString' (@BS@) --- * Lazy 'BSL.ByteString' (@BSL@) --- * @ByteString@ 'BSB.Builder' (@BSB@) (Note: @Data.Binary.Builder@ --- re-exports this type, so TTC can be used with @binary@ as well.) --- * '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. --- --- 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. --- --- For more details, see the following article: --- --- --- @since 0.1.0.0 -class Textual t where - -- | Convert to a 'String' - -- - -- @since 0.1.0.0 - toS :: t -> String - - -- | Convert to strict 'T.Text' - -- - -- @since 0.1.0.0 - toT :: t -> T.Text - - -- | Convert to lazy 'TL.Text' - -- - -- @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 'ST.ShortText' - -- - -- @since 1.4.0.0 - toST :: t -> ST.ShortText - - -- | Convert to a strict 'BS.ByteString' - -- - -- @since 0.1.0.0 - toBS :: t -> BS.ByteString - - -- | Convert to a lazy 'BS.ByteString' - -- - -- @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 - convert :: Textual t' => t' -> t - -instance Textual String where - toS = id - toT = T.pack - toTL = TL.pack - toTLB = TLB.fromString - toST = ST.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 toST #-} - {-# 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 - toST = ST.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 toST #-} - {-# 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 - toST = ST.fromText . TL.toStrict - 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 toST #-} - {-# 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 - toST = ST.fromText . TL.toStrict . TLB.toLazyText - 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 toST #-} - {-# INLINE toBS #-} - {-# INLINE toBSL #-} - {-# INLINE toBSB #-} - {-# INLINE toSBS #-} - {-# INLINE convert #-} - -instance Textual ST.ShortText where - toS = ST.toString - toT = ST.toText - toTL = TL.fromStrict . ST.toText - toTLB = TLB.fromText . ST.toText - toST = id - toBS = ST.toByteString - toBSL = BSL.fromStrict . ST.toByteString - toBSB = BSB.byteString . ST.toByteString - toSBS = ST.toShortByteString - convert = toST - {-# INLINE toS #-} - {-# INLINE toT #-} - {-# INLINE toTL #-} - {-# INLINE toTLB #-} - {-# INLINE toST #-} - {-# 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 - toST = ST.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 toST #-} - {-# 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 - toST = ST.fromText . TL.toStrict . 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 toST #-} - {-# 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 - toST - = ST.fromText - . TL.toStrict - . 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 toST #-} - {-# 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 - toST = ST.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 toST #-} - {-# INLINE toBS #-} - {-# INLINE toBSL #-} - {-# INLINE toBSB #-} - {-# INLINE toSBS #-} - {-# INLINE convert #-} - ------------------------------------------------------------------------------- --- $TextualTo --- --- These functions are equivalent to 'convert', but they specify the type --- being converted to. Use them to avoid having to write type annotations in --- cases where the type is ambiguous. - --- $TextualFrom --- --- These functions are equivalent to 'convert', but they specify the type --- being converted from. Use them to avoid having to write type annotations --- in cases where the type is ambiguous. - --- | Convert from a 'String' --- --- @since 0.1.0.0 -fromS :: Textual t => String -> t -fromS = convert -{-# INLINE fromS #-} - --- | Convert from strict 'T.Text' --- --- @since 0.1.0.0 -fromT :: Textual t => T.Text -> t -fromT = convert -{-# INLINE fromT #-} - --- | Convert from lazy 'TL.Text' --- --- @since 0.1.0.0 -fromTL :: Textual t => TL.Text -> t -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 'ST.ShortText' --- --- @since 1.4.0.0 -fromST :: Textual t => ST.ShortText -> t -fromST = convert -{-# INLINE fromST #-} - --- | Convert from a strict 'BS.ByteString' --- --- @since 0.1.0.0 -fromBS :: Textual t => BS.ByteString -> t -fromBS = convert -{-# INLINE fromBS #-} - --- | Convert from a lazy 'BSL.ByteString' --- --- @since 0.1.0.0 -fromBSL :: Textual t => BSL.ByteString -> t -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 --- --- These functions are used to convert a 'Textual' argument of a function to a --- specific type. Use them to reduce boilerplate in small function --- definitions. - --- | Convert an argument to a 'String' --- --- @since 0.1.0.0 -asS :: Textual t => (String -> a) -> t -> a -asS f = f . convert -{-# INLINE asS #-} - --- | Convert an argument to strict 'T.Text' --- --- @since 0.1.0.0 -asT :: Textual t => (T.Text -> a) -> t -> a -asT f = f . convert -{-# INLINE asT #-} - --- | Convert an argument to lazy 'TL.Text' --- --- @since 0.1.0.0 -asTL :: Textual t => (TL.Text -> a) -> t -> a -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 'ST.ShortText' --- --- @since 1.4.0.0 -asST :: Textual t => (ST.ShortText -> a) -> t -> a -asST f = f . convert -{-# INLINE asST #-} - --- | Convert an argument to a strict 'BS.ByteString' --- --- @since 0.1.0.0 -asBS :: Textual t => (BS.ByteString -> a) -> t -> a -asBS f = f . convert -{-# INLINE asBS #-} - --- | Convert an argument to a lazy 'BSL.ByteString' --- --- @since 0.1.0.0 -asBSL :: Textual t => (BSL.ByteString -> a) -> t -> a -asBSL f = f . convert -{-# INLINE asBSL #-} - --- | Convert an argument to a @ByteString@ 'TLB.Builder' --- --- @since 1.1.0.0 -asBSB :: Textual t => (BSB.Builder -> a ) -> t -> a -asBSB f = f . convert -{-# INLINE asBSB #-} - --- | Convert an argument to a 'SBS.ShortByteString' --- --- @since 1.1.0.0 -asSBS :: Textual t => (SBS.ShortByteString -> a) -> t -> a -asSBS f = f . convert -{-# INLINE asSBS #-} - ------------------------------------------------------------------------------- --- $Render - --- | The 'Render' type class renders a data type as a textual data type. --- --- 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 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: --- --- --- @since 0.1.0.0 -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 --- rendered to. Use them to avoid having to write type annotations in cases --- where the type is ambiguous. - --- | Render to a 'String' --- --- @since 0.1.0.0 -renderS :: Render a => a -> String -renderS = render -{-# INLINE renderS #-} - --- | Render to strict 'T.Text' --- --- @since 0.1.0.0 -renderT :: Render a => a -> T.Text -renderT = render -{-# INLINE renderT #-} - --- | Render to lazy 'TL.Text' --- --- @since 0.1.0.0 -renderTL :: Render a => a -> TL.Text -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 'ST.ShortText' --- --- @since 1.4.0.0 -renderST :: Render a => a -> ST.ShortText -renderST = render -{-# INLINE renderST #-} - --- | Render to a strict 'BS.ByteString' --- --- @since 0.1.0.0 -renderBS :: Render a => a -> BS.ByteString -renderBS = render -{-# INLINE renderBS #-} - --- | Render to a lazy 'BSL.ByteString' --- --- @since 0.1.0.0 -renderBSL :: Render a => a -> BSL.ByteString -renderBSL = render -{-# INLINE renderBSL #-} - --- | Render to a @ByteString@ 'BSB.Builder' --- --- @since 0.4.0.0 -renderBSB :: Render a => a -> BSB.Builder -renderBSB = render -{-# INLINE renderBSB #-} - --- | Render to a 'SBS.ShortByteString' --- --- @since 0.4.0.0 -renderSBS :: Render a => a -> SBS.ShortByteString -renderSBS = render -{-# INLINE renderSBS #-} - ------------------------------------------------------------------------------- --- $RenderUtils - --- | Render a value to a textual data type using the 'Show' instance --- --- @since 0.1.0.0 -renderWithShow :: (Show a, Textual t) => a -> t -renderWithShow = convert . show -{-# INLINE renderWithShow #-} - ------------------------------------------------------------------------------- --- $Parse - --- | The 'Parse' type class parses a data type from a textual data type. --- --- 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 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: --- --- --- @since 0.3.0.0 -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. --- --- @since 0.3.0.0 -parse' :: (Parse a, Textual t) => t -> Either String a -parse' = parse -{-# 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 --- parsed from. Use them to avoid having to write type annotations in cases --- where the type is ambiguous. - --- | Parse from a 'String' --- --- @since 0.3.0.0 -parseS :: (Parse a, Textual e) => String -> Either e a -parseS = parse -{-# INLINE parseS #-} - --- | Parse from strict 'T.Text' --- --- @since 0.3.0.0 -parseT :: (Parse a, Textual e) => T.Text -> Either e a -parseT = parse -{-# INLINE parseT #-} - --- | Parse from lazy 'TL.Text' --- --- @since 0.3.0.0 -parseTL :: (Parse a, Textual e) => TL.Text -> Either e a -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 'ST.ShortText' --- --- @since 1.4.0.0 -parseST :: (Parse a, Textual e) => ST.ShortText -> Either e a -parseST = parse -{-# INLINE parseST #-} - --- | Parse from a strict 'BS.ByteString' --- --- @since 0.3.0.0 -parseBS :: (Parse a, Textual e) => BS.ByteString -> Either e a -parseBS = parse -{-# INLINE parseBS #-} - --- | Parse from a lazy 'BSL.ByteString' --- --- @since 0.3.0.0 -parseBSL :: (Parse a, Textual e) => BSL.ByteString -> Either e a -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 --- --- The 'parseMaybe' function parses to a 'Maybe' type instead of an 'Either' --- type. The rest of the functions are equivalent to 'parseMaybe', but they --- specify the type being parsed from. Use them to avoid having to write type --- annotations in cases where the type is ambiguous. - --- | Parse to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybe :: (Parse a, Textual t) => t -> Maybe a -parseMaybe = either (const Nothing) Just . parse' -{-# INLINE parseMaybe #-} - --- | Parse from a 'String' to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybeS :: Parse a => String -> Maybe a -parseMaybeS = parseMaybe -{-# INLINE parseMaybeS #-} - --- | Parse from strict 'T.Text' to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybeT :: Parse a => T.Text -> Maybe a -parseMaybeT = parseMaybe -{-# INLINE parseMaybeT #-} - --- | Parse from lazy 'TL.Text' to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybeTL :: Parse a => TL.Text -> Maybe a -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 'ST.ShortText' to a 'Maybe' type --- --- @since 1.4.0.0 -parseMaybeST :: Parse a => ST.ShortText -> Maybe a -parseMaybeST = parseMaybe -{-# INLINE parseMaybeST #-} - --- | Parse from a strict 'BS.ByteString' to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybeBS :: Parse a => BS.ByteString -> Maybe a -parseMaybeBS = parseMaybe -{-# INLINE parseMaybeBS #-} - --- | Parse from a lazy 'BSL.ByteString' to a 'Maybe' type --- --- @since 0.3.0.0 -parseMaybeBSL :: Parse a => BSL.ByteString -> Maybe a -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 #-} - ------------------------------------------------------------------------------- --- $ParseOrFail --- --- The 'parseOrFail' function fails using 'MonadFail' on error instead of --- using an 'Either' type. The rest of the functions are equivalent to --- 'parseOrFail', but they specify the type being parsed from. Use them to --- avoid having to write type annotations in cases where the type is --- ambiguous. - --- | Parse or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFail :: (MonadFail m, Parse a, Textual t) => t -> m a -parseOrFail = either fail pure . parse -{-# INLINE parseOrFail #-} - --- | Parse from a 'String' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailS :: (MonadFail m, Parse a) => String -> m a -parseOrFailS = parseOrFail -{-# INLINE parseOrFailS #-} - --- | Parse from strict 'T.Text' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailT :: (MonadFail m, Parse a) => T.Text -> m a -parseOrFailT = parseOrFail -{-# INLINE parseOrFailT #-} - --- | Parse from lazy 'TL.Text' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailTL :: (MonadFail m, Parse a) => TL.Text -> m a -parseOrFailTL = parseOrFail -{-# INLINE parseOrFailTL #-} - --- | Parse from a @Text@ 'TLB.Builder' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailTLB :: (MonadFail m, Parse a) => TLB.Builder -> m a -parseOrFailTLB = parseOrFail -{-# INLINE parseOrFailTLB #-} - --- | Parse from a 'ST.ShortText' or fail using 'MonadFail' --- --- @since 1.4.0.0 -parseOrFailST :: (MonadFail m, Parse a) => ST.ShortText -> m a -parseOrFailST = parseOrFail -{-# INLINE parseOrFailST #-} - --- | Parse from a strict 'BS.ByteString' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailBS :: (MonadFail m, Parse a) => BS.ByteString -> m a -parseOrFailBS = parseOrFail -{-# INLINE parseOrFailBS #-} - --- | Parse from a lazy 'BSL.ByteString' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailBSL :: (MonadFail m, Parse a) => BSL.ByteString -> m a -parseOrFailBSL = parseOrFail -{-# INLINE parseOrFailBSL #-} - --- | Parse from a @ByteString@ 'BSB.Builder' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailBSB :: (MonadFail m, Parse a) => BSB.Builder -> m a -parseOrFailBSB = parseOrFail -{-# INLINE parseOrFailBSB #-} - --- | Parse from a 'SBS.ShortByteString' or fail using 'MonadFail' --- --- @since 1.3.0.0 -parseOrFailSBS :: (MonadFail m, Parse a) => SBS.ShortByteString -> m a -parseOrFailSBS = parseOrFail -{-# INLINE parseOrFailSBS #-} - ------------------------------------------------------------------------------- --- $ParseUnsafe --- --- The 'parseUnsafe' function raises an exception on error instead of using an --- 'Either' type. It should only be used when an error is not possible. The --- rest of the functions are equivalent to 'parseUnsafe', but they specify the --- type being parsed from. Use them to avoid having to write type annotations --- in cases where the type is ambiguous. - --- | Unsafely parse --- --- @since 0.1.0.0 -parseUnsafe :: (HasCallStack, Parse a, Textual t) => t -> a -parseUnsafe = either (error . ("parseUnsafe: " ++)) id . parse -{-# INLINE parseUnsafe #-} - --- | Unsafely parse from a 'String' --- --- @since 0.1.0.0 -parseUnsafeS :: (HasCallStack, Parse a) => String -> a -parseUnsafeS = parseUnsafe -{-# INLINE parseUnsafeS #-} - --- | Unsafely parse from strict 'T.Text' --- --- @since 0.1.0.0 -parseUnsafeT :: (HasCallStack, Parse a) => T.Text -> a -parseUnsafeT = parseUnsafe -{-# INLINE parseUnsafeT #-} - --- | Unsafely parse from lazy 'TL.Text' --- --- @since 0.1.0.0 -parseUnsafeTL :: (HasCallStack, Parse a) => TL.Text -> a -parseUnsafeTL = parseUnsafe -{-# INLINE parseUnsafeTL #-} - --- | Unsafely parse from a @Text@ 'TLB.Builder' --- --- @since 1.1.0.0 -parseUnsafeTLB :: (HasCallStack, Parse a) => TLB.Builder -> a -parseUnsafeTLB = parseUnsafe -{-# INLINE parseUnsafeTLB #-} - --- | Unsafely parse from a 'ST.ShortText' --- --- @since 1.4.0.0 -parseUnsafeST :: (HasCallStack, Parse a) => ST.ShortText -> a -parseUnsafeST = parseUnsafe -{-# INLINE parseUnsafeST #-} - --- | Unsafely parse from a strict 'BS.ByteString' --- --- @since 0.1.0.0 -parseUnsafeBS :: (HasCallStack, Parse a) => BS.ByteString -> a -parseUnsafeBS = parseUnsafe -{-# INLINE parseUnsafeBS #-} - --- | Unsafely parse from a lazy 'BSL.ByteString' --- --- @since 0.1.0.0 -parseUnsafeBSL :: (HasCallStack, Parse a) => BSL.ByteString -> a -parseUnsafeBSL = parseUnsafe -{-# INLINE parseUnsafeBSL #-} - --- | Unsafely parse from a @ByteString@ 'BSB.Builder' --- --- @since 1.1.0.0 -parseUnsafeBSB :: (HasCallStack, Parse a) => BSB.Builder -> a -parseUnsafeBSB = parseUnsafe -{-# INLINE parseUnsafeBSB #-} - --- | Unsafely parse from a 'SBS.ShortByteString' --- --- @since 1.1.0.0 -parseUnsafeSBS :: (HasCallStack, Parse a) => SBS.ShortByteString -> a -parseUnsafeSBS = parseUnsafe -{-# INLINE parseUnsafeSBS #-} - ------------------------------------------------------------------------------- --- $ParseWithASingleErrorMessage --- --- The 'withError' function takes an error message and a 'Maybe' value. It --- returns a 'Parse' result: the error when the 'Maybe' value is 'Nothing', or --- the value inside the 'Just'. This provides a convenient way to return the --- same error message for any parse error. The rest of the functions are --- equivalent to 'withError', but they specify the type of the error message. --- Use them to avoid having to write type annotations in cases where the type --- is ambiguous. - --- | Create a 'Parse' result from a 'Textual' error message and a 'Maybe' --- value --- --- @since 1.2.0.0 -withError - :: (Textual e', Textual e) - => e' - -> Maybe a - -> Either e a -withError err = maybe (Left $ convert err) Right -{-# INLINE withError #-} - --- | Create a 'Parse' result from a 'String' error message and a 'Maybe' value --- --- @since 1.2.0.0 -withErrorS - :: Textual e - => String - -> Maybe a - -> Either e a -withErrorS = withError -{-# INLINE withErrorS #-} - --- | Create a 'Parse' result from a 'T.Text' error message and a 'Maybe' value --- --- @since 1.2.0.0 -withErrorT - :: Textual e - => T.Text - -> Maybe a - -> Either e a -withErrorT = withError -{-# INLINE withErrorT #-} - --- | Create a 'Parse' result from a 'TL.Text' error message and a 'Maybe' --- value --- --- @since 1.2.0.0 -withErrorTL - :: Textual e - => TL.Text - -> Maybe a - -> Either e a -withErrorTL = withError -{-# INLINE withErrorTL #-} - --- | Create a 'Parse' result from a 'TLB.Builder' error message and a 'Maybe' --- value --- --- @since 1.2.0.0 -withErrorTLB - :: Textual e - => TLB.Builder - -> Maybe a - -> Either e a -withErrorTLB = withError -{-# INLINE withErrorTLB #-} - --- | Create a 'Parse' result from a 'ST.ShortText' error message and a 'Maybe' --- value --- --- @since 1.4.0.0 -withErrorST - :: Textual e - => ST.ShortText - -> Maybe a - -> Either e a -withErrorST = withError -{-# INLINE withErrorST #-} - --- | Create a 'Parse' result from a 'BS.ByteString' error message and a --- 'Maybe' value --- --- @since 1.2.0.0 -withErrorBS - :: Textual e - => BS.ByteString - -> Maybe a - -> Either e a -withErrorBS = withError -{-# INLINE withErrorBS #-} - --- | Create a 'Parse' result from a 'BSL.ByteString' error message and a --- 'Maybe' value --- --- @since 1.2.0.0 -withErrorBSL - :: Textual e - => BSL.ByteString - -> Maybe a - -> Either e a -withErrorBSL = withError -{-# INLINE withErrorBSL #-} - --- | Create a 'Parse' result from a 'BSB.Builder' error message and a --- 'Maybe' value --- --- @since 1.2.0.0 -withErrorBSB - :: Textual e - => BSB.Builder - -> Maybe a - -> Either e a -withErrorBSB = withError -{-# INLINE withErrorBSB #-} - --- | Create a 'Parse' result from a 'SBS.ShortByteString' error message and a --- 'Maybe' value --- --- @since 1.2.0.0 -withErrorSBS - :: Textual e - => SBS.ShortByteString - -> Maybe a - -> Either e a -withErrorSBS = withError -{-# INLINE withErrorSBS #-} - ------------------------------------------------------------------------------- --- $ParseWithAnErrorPrefix --- --- The 'prefixError' function adds a common prefix to error messages of a --- 'Parse' result. The rest of the functions are equivalent to 'prefixError', --- but they specify the type of the error message. Use them to avoid having --- to write type annotations in cases where the type is ambiguous. - --- | Add a prefix to 'Textual' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixError - :: (Monoid e', Textual e', Textual e) - => e' - -> Either e' a - -> Either e a -prefixError prefix = either (Left . convert . mappend prefix) Right -{-# INLINE prefixError #-} - --- | Add a prefix to 'String' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorS - :: Textual e - => String - -> Either String a - -> Either e a -prefixErrorS = prefixError -{-# INLINE prefixErrorS #-} - --- | Add a prefix to 'T.Text' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorT - :: Textual e - => T.Text - -> Either T.Text a - -> Either e a -prefixErrorT = prefixError -{-# INLINE prefixErrorT #-} - --- | Add a prefix to 'TL.Text' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorTL - :: Textual e - => TL.Text - -> Either TL.Text a - -> Either e a -prefixErrorTL = prefixError -{-# INLINE prefixErrorTL #-} - --- | Add a prefix to 'TLB.Builder' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorTLB - :: Textual e - => TLB.Builder - -> Either TLB.Builder a - -> Either e a -prefixErrorTLB = prefixError -{-# INLINE prefixErrorTLB #-} - --- | Add a prefix to 'ST.ShortText' error messages of a 'Parse' result --- --- @since 1.4.0.0 -prefixErrorST - :: Textual e - => ST.ShortText - -> Either ST.ShortText a - -> Either e a -prefixErrorST = prefixError -{-# INLINE prefixErrorST #-} - --- | Add a prefix to 'BS.ByteString' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorBS - :: Textual e - => BS.ByteString - -> Either BS.ByteString a - -> Either e a -prefixErrorBS = prefixError -{-# INLINE prefixErrorBS #-} - --- | Add a prefix to 'BSL.ByteString' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorBSL - :: Textual e - => BSL.ByteString - -> Either BSL.ByteString a - -> Either e a -prefixErrorBSL = prefixError -{-# INLINE prefixErrorBSL #-} - --- | Add a prefix to 'BSB.Builder' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorBSB - :: Textual e - => BSB.Builder - -> Either BSB.Builder a - -> Either e a -prefixErrorBSB = prefixError -{-# INLINE prefixErrorBSB #-} - --- | Add a prefix to 'SBS.ShortByteString' error messages of a 'Parse' result --- --- @since 1.2.0.0 -prefixErrorSBS - :: Textual e - => SBS.ShortByteString - -> Either SBS.ShortByteString a - -> Either e a -prefixErrorSBS = prefixError -{-# INLINE prefixErrorSBS #-} - ------------------------------------------------------------------------------- --- $ParseEnums - --- | Parse a value in an enumeration --- --- This function is intended to be used with types that have few choices, as --- the implementation uses a linear algorithm. --- --- See the @enum@ example program in the @examples@ directory. --- --- @since 0.1.0.0 -parseEnum - :: (Bounded a, Enum a, Render a, Textual t) - => Bool -- ^ case-insensitive when 'True' - -> Bool -- ^ accept unique prefixes when 'True' - -> e -- ^ invalid input error - -> e -- ^ ambiguous input error - -> t -- ^ textual input to parse - -> Either e a -- ^ error or parsed value -parseEnum allowCI allowPrefix invalidError ambiguousError t = - let t' = norm $ toT t - in case [v | v <- [minBound ..], t' `match` norm (render v)] of - [v] -> Right v - [] -> Left invalidError - _vs -> Left ambiguousError - where - norm :: T.Text -> T.Text - norm = if allowCI then T.toLower else id - - match :: T.Text -> T.Text -> Bool - match = if allowPrefix then T.isPrefixOf else (==) - --- | Parse a value in an enumeration, with 'Textual' error messages --- --- The following English error messages are returned: --- --- * \"invalid {name}\" when there are no matches --- * \"ambiguous {name}\" when there is more than one match --- --- @since 0.4.0.0 -parseEnum' - :: (Bounded a, Enum a, Render a, Textual t, Textual e) - => String -- ^ name to include in error messages - -> Bool -- ^ case-insensitive when 'True' - -> Bool -- ^ accept unique prefixes when 'True' - -> t -- ^ textual input to parse - -> Either e a -- ^ error or parsed value -parseEnum' name allowCI allowPrefix = - parseEnum - allowCI allowPrefix - (fromS $ "invalid " ++ name) - (fromS $ "ambiguous " ++ name) -{-# INLINEABLE parseEnum' #-} - ------------------------------------------------------------------------------- --- $ReadInstanced - --- | Parse a value using the 'Read' instance --- --- @since 0.1.0.0 -parseWithRead - :: (Read a, Textual t) - => e -- ^ invalid input error - -> t -- ^ textual input to parse - -> Either e a -- ^ error or parsed value -parseWithRead invalidError = maybe (Left invalidError) Right . readMaybe . toS -{-# INLINEABLE parseWithRead #-} - --- | Parse a value using the 'Read' instance, with 'Textual' error messages --- --- The following English error message is returned: --- --- * \"invalid {name}\" when the parse fails --- --- @since 0.3.0.0 -parseWithRead' - :: (Read a, Textual t, Textual e) - => String -- ^ name to include in error messages - -> t -- ^ textual input to parse - -> Either e a -- ^ error or parsed value -parseWithRead' name = parseWithRead (fromS $ "invalid " ++ name) -{-# INLINEABLE parseWithRead' #-} - --- | Parse a value to a 'Maybe' type using the 'Read' instance --- --- @since 0.3.0.0 -maybeParseWithRead - :: (Read a, Textual t) - => t -- ^ textual input to parse - -> Maybe a -- ^ parsed value or 'Nothing' if invalid -maybeParseWithRead = readMaybe . toS - --- | Implement 'ReadS' using 'parseEnum' --- --- This implementation expects all of the input to be consumed. --- --- @since 0.1.0.0 -readsEnum - :: (Bounded a, Enum a, Render a) - => Bool -- ^ case-insensitive when 'True' - -> Bool -- ^ accept unique prefixes when 'True' - -> ReadS a -readsEnum allowCI allowPrefix s = - case parseEnum allowCI allowPrefix () () s of - Right v -> [(v, "")] - Left{} -> [] -{-# INLINEABLE readsEnum #-} - --- | Implement 'ReadS' using a 'Parse' instance --- --- This implementation expects all of the input to be consumed. --- --- @since 0.3.0.0 -readsWithParse - :: Parse a - => ReadS a -readsWithParse s = case parseMaybe s of - Just v -> [(v, "")] - Nothing -> [] -{-# INLINEABLE readsWithParse #-} - ------------------------------------------------------------------------------- --- $ParseValid --- --- The follow functions provide a number of ways to use a 'Parse' instance to --- validate constants at compile-time. --- --- If you can use Template Haskell typed expressions in your project, use --- 'valid', 'mkValid', or 'validOf'. Use 'valid' to define constants for --- types that have a 'THS.Lift' instance. For types that do not have a --- 'THS.Lift' instance, use 'mkValid' to define a validation function for that --- type using a 'Proxy', or use 'validOf' to pass the 'Proxy' when defining --- constants. --- --- Typed expressions were not supported in @haskell-src-exts <1.22.0@, which --- causes problems with old versions of @hlint@. If the issue affects you, --- you may use 'mkUntypedValid', 'mkUntypedValidQQ', or 'untypedValidOf' --- instead of the above functions. Use 'mkUntypedValid' to define a --- validation function for a type using a 'Proxy', or use 'untypedValidOf' to --- pass the 'Proxy' when defining constants. Alternatively, use --- 'mkUntypedValidQQ' to define a validation quasi-quoter. --- --- For more details, see the following article: --- - --- | Validate a constant at compile-time using a 'Parse' instance --- --- This function parses the 'String' at compile-time and fails compilation on --- error. When valid, the result is compiled in, so the result type must have --- a 'THS.Lift' instance. When this is inconvenient, use one of the --- alternative functions in this library. --- --- This function uses a Template Haskell typed expression. Typed expressions --- were not supported in @haskell-src-exts <1.22.0@, which causes problems --- with old versions of @hlint@. If the issue affects you, use --- @hlint -i "Parse error"@ to ignore parse errors or use one of the --- alternative functions in this library. --- --- Note that the typed Template Haskell API changed in GHC 9. The type --- displayed in this documentation is determined by the version of GHC used to --- build the documentation. --- --- The type of this function in GHC 9 or later is as follows: --- --- @ --- valid --- :: (MonadFail m, THS.Quote m, Parse a, THS.Lift a) --- => String --- -> THS.Code m a --- @ --- --- The type of this function in previous versions of GHC is as follows: --- --- @ --- valid --- :: (Parse a, THS.Lift a) --- => String --- -> TH.Q (TH.TExp a) --- @ --- --- This function is used the same way in all GHC versions. See the @valid@, --- @invalid@, and @lift@ example programs in the @examples@ directory. The --- following is example usage from the @valid@ example: --- --- @ --- sample :: Username --- sample = $$(TTC.valid "tcard") --- @ --- --- @since 0.1.0.0 -#if __GLASGOW_HASKELL__ >= 900 -valid - :: (MonadFail m, THS.Quote m, Parse a, THS.Lift a) - => String - -> THS.Code m a -valid s = case parse s of - Right x -> [|| x ||] - Left err -> THS.Code . fail $ "Invalid constant: " ++ err -#else -valid - :: (Parse a, THS.Lift a) - => String - -> TH.Q (TH.TExp a) -valid s = case parse s of - Right x -> [|| x ||] - Left err -> fail $ "Invalid constant: " ++ err -#endif - --- | This instance enables use of 'valid' without having to type @valid@. The --- [OverloadedStrings](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_strings.html) --- extension must be enabled in the module where this functionality is used. --- Note that this reduces the number of characters in the code, but it can --- also make the code more difficult to understand by somebody who is not --- already familiar with it. Typing @valid@ gives people a way to investigate --- and understand what is going on. --- --- Note that the typed Template Haskell API changed in GHC 9. The type --- displayed in this documentation is determined by the version of GHC used to --- build the documentation. --- --- The type of this instance in GHC 9 or later is as follows: --- --- @ --- (MonadFail m, THS.Quote m, Parse a, THS.Lift a) => IsString (THS.Code m a) --- @ --- --- The type of this instance in previous versions of GHC is as follows: --- --- @ --- (Parse a, THS.Lift a) => IsString (TH.Q (TH.TExp a)) --- @ --- --- This functionality can be used as follows in all supported versions of GHC. --- The following is example usage from the @valid@ example: --- --- @ --- sample2 :: Username --- sample2 = $$("alice") --- @ --- --- The parenthesis are not required from GHC 9. The following is example --- usage from the @valid@ example: --- --- @ --- sample2 :: Username --- sample2 = $$"alice" --- @ --- --- @since 1.3.0.0 -#if __GLASGOW_HASKELL__ >= 900 -instance (MonadFail m, THS.Quote m, Parse a, THS.Lift a) - => IsString (THS.Code m a) where - fromString = valid -#else -instance (Parse a, THS.Lift a) => IsString (TH.Q (TH.TExp a)) where - fromString = valid -#endif - --- | Validate a constant at compile-time using a 'Parse' instance --- --- This function requires a 'Proxy' of the result type. Use 'mkValid' to --- avoid having to pass a 'Proxy' during constant definition. --- --- This function parses the 'String' at compile-time and fails compilation on --- error. When valid, the 'String' is compiled in, to be parsed again at --- run-time. Since the result is not compiled in, no 'THS.Lift' instance is --- required. --- --- This function uses a Template Haskell typed expression. Typed expressions --- were not supported in @haskell-src-exts <1.22.0@, which causes problems --- with old versions of @hlint@. If the issue affects you, use --- @hlint -i "Parse error"@ to ignore parse errors or use 'untypedValidOf' --- instead. --- --- Note that the typed Template Haskell API changed in GHC 9. The type --- displayed in this documentation is determined by the version of GHC used to --- build the documentation. --- --- The type of this function in GHC 9 or later is as follows: --- --- @ --- validOf --- :: (MonadFail m, THS.Quote m, Parse a) --- => Proxy a --- -> String --- -> THS.Code m a --- @ --- --- The type of this function in previous versions of GHC is as follows: --- --- @ --- validOf --- :: Parse a --- => Proxy a --- -> String --- -> TH.Q (TH.TExp a) --- @ --- --- This function is used the same way in all GHC versions. See the @validof@ --- example program in the @examples@ directory. The following is example --- usage from the @validof@ example: --- --- @ --- sample :: Username --- sample = $$(TTC.validOf (Proxy :: Proxy Username) "tcard") --- @ --- --- @since 0.1.0.0 -#if __GLASGOW_HASKELL__ >= 900 -validOf - :: (MonadFail m, THS.Quote m, Parse a) - => Proxy a - -> String - -> THS.Code m a -validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of - Right{} -> [|| parseUnsafeS s ||] - Left err -> THS.Code . fail $ "Invalid constant: " ++ err -#else -validOf - :: Parse a - => Proxy a - -> String - -> TH.Q (TH.TExp a) -validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of - Right{} -> [|| parseUnsafeS s ||] - Left err -> fail $ "Invalid constant: " ++ err -#endif - --- | Make a @valid@ function using 'validOf' for the given type --- --- Create a @valid@ function for a type in order to avoid having to write a --- 'Proxy' when defining constants. --- --- This function uses a Template Haskell typed expression. Typed expressions --- were not supported in @haskell-src-exts <1.22.0@, which causes problems --- with old versions of @hlint@. If the issue affects you, use --- @hlint -i "Parse error"@ to ignore parse errors or use 'mkUntypedValid' --- instead. --- --- Note that the typed Template Haskell API changed in GHC 9. The type --- displayed in this documentation is determined by the version of GHC used to --- build the documentation. --- --- The type of the created @valid@ function in GHC 9 or later is as follows: --- --- @ --- \$funName --- :: forall m. (MonadFail m, THS.Quote m) --- => String --- -> THS.Code m $resultType --- @ --- --- The type of the created @valid@ function in previous versions of GHC is as --- follows: --- --- @ --- \$funName --- :: String --- -> TH.Q (TH.TExp $resultType) --- @ --- --- This function is used the same way in all GHC versions. See the @mkvalid@ --- example program in the @examples@ directory. The following is example --- usage from the @mkvalid@ example: --- --- @ --- \$(TTC.mkValid "valid" ''Username) --- @ --- --- The created @valid@ function can then be used as follows: --- --- @ --- sample :: Username --- sample = $$(Username.valid "tcard") --- @ --- --- @since 0.1.0.0 -mkValid - :: String - -> TH.Name - -> TH.DecsQ -mkValid funName typeName = do - let funName' = TH.mkName funName - resultType = pure $ TH.ConT typeName -#if __GLASGOW_HASKELL__ >= 900 - funType <- - [t| - forall m . (MonadFail m, THS.Quote m) => - String -> THS.Code m $resultType - |] -#else - funType <- [t| String -> TH.Q (TH.TExp $resultType) |] -#endif - body <- [| validOf (Proxy :: Proxy $resultType) |] - return - [ TH.SigD funName' funType - , TH.FunD funName' [TH.Clause [] (TH.NormalB body) []] - ] - --- | Validate a constant at compile-time using a 'Parse' instance --- --- This function requires a 'Proxy' of the result type. Use 'mkUntypedValid' --- to avoid having to pass a 'Proxy' during constant definition. --- --- This function parses the 'String' at compile-time and fails compilation on --- error. When valid, the 'String' is compiled in, to be parsed again at --- run-time. Since the result is not compiled in, no 'THS.Lift' instance is --- required. --- --- See the @uvalidof@ example program in the @examples@ directory. The --- following is example usage from the @uvalidof@ example: --- --- @ --- sample :: Username --- sample = $(TTC.untypedValidOf (Proxy :: Proxy Username) "tcard") --- @ --- --- @since 0.2.0.0 -untypedValidOf - :: Parse a - => Proxy a - -> String - -> TH.ExpQ -untypedValidOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of - Right{} -> [| parseUnsafeS s |] - Left err -> fail $ "Invalid constant: " ++ err - --- | Make a @valid@ function using 'untypedValidOf' for the given type --- --- Create a @valid@ function for a type in order to avoid having to write a --- 'Proxy' when defining constants. --- --- See the @mkuvalid@ example program in the @examples@ directory. The --- following is example usage from the @mkuvalid@ example: --- --- @ --- \$(TTC.mkUntypedValid "valid" ''Username) --- @ --- --- The created @valid@ function can then be used as follows: --- --- @ --- sample :: Username --- sample = $(Username.valid "tcard") --- @ --- --- @since 0.2.0.0 -mkUntypedValid - :: String - -> TH.Name - -> TH.DecsQ -mkUntypedValid funName typeName = do - let funName' = TH.mkName funName - resultType = pure $ TH.ConT typeName - funType <- [t| String -> TH.ExpQ |] - body <- [| untypedValidOf (Proxy :: Proxy $resultType) |] - return - [ TH.SigD funName' funType - , TH.FunD funName' [TH.Clause [] (TH.NormalB body) []] - ] - --- | Make a @valid@ quasi-quoter using 'untypedValidOf' for the given type --- --- See the @uvalidqq@ example program in the @examples@ directory. The --- following is example usage from the @uvalidqq@ example: --- --- @ --- \$(TTC.mkUntypedValidQQ "valid" ''Username) --- @ --- --- The created @valid@ function can then be used as follows: --- --- @ --- sample :: Username --- sample = [Username.valid|tcard|] --- @ --- --- @since 0.2.0.0 -mkUntypedValidQQ - :: String - -> TH.Name - -> TH.DecsQ -mkUntypedValidQQ funName typeName = do - let funName' = TH.mkName funName - resultType = pure $ TH.ConT typeName - expE <- [| untypedValidOf (Proxy :: Proxy $resultType) |] - expP <- [| error "pattern not supported" |] - expT <- [| error "type not supported" |] - expD <- [| error "declaration not supported" |] - let body = TH.NormalB $ TH.RecConE 'Q.QuasiQuoter - [ ('Q.quoteExp, expE) - , ('Q.quotePat, expP) - , ('Q.quoteType, expT) - , ('Q.quoteDec, expD) - ] - return - [ TH.SigD funName' $ TH.ConT ''Q.QuasiQuoter - , TH.FunD funName' [TH.Clause [] body []] - ] +-- Description : Textual Type Classes +-- Copyright : Copyright (c) 2019-2025 Travis Cardwell +-- License : MIT +-- +-- TTC, an initialism of /Textual Type Classes/, is a library that provides +-- type classes for conversion between data types and textual data types +-- (strings). +-- +-- The 'Render' type class renders a data type as a textual data type, similar +-- to 'Show'. Use 'Render' in your business logic, and only use 'Show' for +-- debugging, as use of 'Show' instances in business logic is a common source +-- of bugs. +-- +-- The 'Parse' type class parses a data type from a textual data type, similar +-- to 'Read'. Unlike 'Read', 'Parse' allows you to specify meaningful error +-- messages. +-- +-- 'Render' and 'Parse' work with multiple textual data types. They are not +-- limited to 'String' (like 'Show' and 'Read'), and implementations can use +-- the textual data type that is most appropriate for each data type. +-- +-- Conversion between textual data types is managed by the 'Textual' type +-- class. This library provides instances to support the following textual +-- data types: +-- +-- * 'String' (@S@) +-- * Strict 'T.Text' (@T@) +-- * Lazy 'TL.Text' (@TL@) +-- * @Text@ 'TLB.Builder' (@TLB@) +-- * 'ST.ShortText' (@ST@) +-- * Strict 'BS.ByteString' (@BS@) +-- * Lazy 'BSL.ByteString' (@BSL@) +-- * @ByteString@ 'BSB.Builder' (@BSB@) +-- * 'SBS.ShortByteString' (@SBS@) +-- +-- This library is meant to be imported qualified, as follows: +-- +-- @ +-- import qualified Data.TTC as TTC +-- @ +-- +-- Note that this library has a similar API to the +-- [ETTC](https://github.com/ExtremaIS/ttc-haskell/tree/main/ettc) library, +-- which uses a @Utf8Convertible@ type class instead of 'Textual'. The TTC +-- API types are simpler, but it is not possible to add support for additional +-- textual data types without changing the library itself. The ETTC API types +-- are more complex, leading to longer compilation times, but one can add +-- support for additional textual data types by defining new @Utf8Convertible@ +-- instances. Both libraries are maintained, allowing you to use the one that +-- best matches the needs of your project. +------------------------------------------------------------------------------ + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.TTC + ( -- * Textual + Textual + , convert + -- ** \"To\" Conversions + -- $TextualTo + , toS + , toT + , toTL + , toTLB + , toST + , toBS + , toBSL + , toBSB + , toSBS + -- ** \"From\" Conversions + -- $TextualFrom + , fromS + , fromT + , fromTL + , fromTLB + , fromST + , fromBS + , fromBSL + , fromBSB + , fromSBS + -- ** \"As\" Conversions + -- $TextualAs + , asS + , asT + , asTL + , asTLB + , asST + , asBS + , asBSL + , asBSB + , asSBS + -- * Render + , Render(..) + , RenderDefault(..) + -- ** Render Utility Functions + -- $RenderUtilityFunctions + , renderWithShow + -- ** Rendering Specific Types + -- $RenderSpecific + , renderS + , renderT + , renderTL + , renderTLB + , renderST + , renderBS + , renderBSL + , renderBSB + , renderSBS + -- * Parse + , Parse(..) + , ParseDefault(..) + -- ** Parse Utility Functions + -- $ParseUtilityFunctions + -- *** Parse With A Single Error Message + -- $ParseWithASingleErrorMessage + , withError + , withErrorS + , withErrorT + , withErrorTL + , withErrorTLB + , withErrorST + , withErrorBS + , withErrorBSL + , withErrorBSB + , withErrorSBS + -- *** Parse With An Error Prefix + -- $ParseWithAnErrorPrefix + , prefixError + , prefixErrorS + , prefixErrorT + , prefixErrorTL + , prefixErrorTLB + , prefixErrorST + , prefixErrorBS + , prefixErrorBSL + , prefixErrorBSB + , prefixErrorSBS + -- *** 'Read' Parsing + , parseWithRead + , parseWithRead' + , maybeParseWithRead + -- *** 'Enum' Parsing + , parseEnum + , parseEnum' + -- ** Parsing From Specific Types + -- $ParseSpecific + , parseS + , parseT + , parseTL + , parseTLB + , parseST + , parseBS + , parseBSL + , parseBSB + , parseSBS + -- ** 'Maybe' Parsing + -- $ParseMaybe + , parseMaybe + , parseMaybeS + , parseMaybeT + , parseMaybeTL + , parseMaybeTLB + , parseMaybeST + , parseMaybeBS + , parseMaybeBSL + , parseMaybeBSB + , parseMaybeSBS + -- ** 'MonadFail' Parsing + -- $ParseOrFail + , parseOrFail + , parseOrFailS + , parseOrFailT + , parseOrFailTL + , parseOrFailTLB + , parseOrFailST + , parseOrFailBS + , parseOrFailBSL + , parseOrFailBSB + , parseOrFailSBS + -- ** Unsafe Parsing + -- $ParseUnsafe + , parseUnsafe + , parseUnsafeS + , parseUnsafeT + , parseUnsafeTL + , parseUnsafeTLB + , parseUnsafeST + , parseUnsafeBS + , parseUnsafeBSL + , parseUnsafeBSB + , parseUnsafeSBS + -- ** 'ReadS' Instances + , readsWithParse + , readsEnum + -- * Template Haskell + -- ** Constant Validation + -- $ConstantValidation + , valid + , validOf + , mkValid + , untypedValidOf + , mkUntypedValid + , mkUntypedValidQQ + -- * Default Instances + -- $DefaultInstances + , defaultRenderInstance + , defaultRenderInstances + , defaultParseInstance + , defaultParseInstances + , defaultRenderAndParseInstance + , defaultRenderAndParseInstances + ) where + +-- https://hackage.haskell.org/package/base +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +import Data.String (IsString(fromString)) +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Stack (HasCallStack) +import Text.Read (readMaybe) + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS + +-- https://hackage.haskell.org/package/template-haskell +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as Q +import qualified Language.Haskell.TH.Syntax as THS + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Encoding.Error as TEE +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Lazy.Encoding as TLE + +-- https://hackage.haskell.org/package/text-short +import qualified Data.Text.Short as ST + +------------------------------------------------------------------------------ +-- $Textual + +-- | Convert from one textual data type to another +-- +-- The following textual data types are supported: +-- +-- * 'String' (@S@) +-- * Strict 'T.Text' (@T@) +-- * Lazy 'TL.Text' (@TL@) +-- * @Text@ 'TLB.Builder' (@TLB@) +-- * 'ST.ShortText' (@ST@) +-- * Strict 'BS.ByteString' (@BS@) +-- * Lazy 'BSL.ByteString' (@BSL@) +-- * @ByteString@ 'BSB.Builder' (@BSB@) +-- * 'SBS.ShortByteString' (@SBS@) +-- +-- Note that support for additional textual data types cannot be implemented +-- by writing instances. Adding support for additional textual data types +-- requires changing the class definition itself. If you need support for +-- additional textual data types, consider using the +-- [ETTC](https://github.com/ExtremaIS/ttc-haskell/tree/main/ettc) library +-- instead. +-- +-- Encoded values are assumed to be valid UTF-8 encoded text. Conversions +-- must be pure, and any invalid bytes must be replaced with the Unicode +-- replacement character @U+FFFD@. In cases where different behavior is +-- required, process encoded values separately. +-- +-- For more details, see the following article: +-- +-- +-- @since 0.1.0.0 +class Textual t where + -- | Convert from a textual data type to a 'String' + -- + -- @since 0.1.0.0 + toS :: t -> String + + -- | Convert from a textual data type to strict 'T.Text' + -- + -- @since 0.1.0.0 + toT :: t -> T.Text + + -- | Convert from a textual data type to lazy 'TL.Text' + -- + -- @since 0.1.0.0 + toTL :: t -> TL.Text + + -- | Convert from a textual data type to a @Text@ 'TLB.Builder' + -- + -- @since 1.1.0.0 + toTLB :: t -> TLB.Builder + + -- | Convert from a textual data type to 'ST.ShortText' + -- + -- @since 1.4.0.0 + toST :: t -> ST.ShortText + + -- | Convert from a textual data type to a strict 'BS.ByteString' + -- + -- @since 0.1.0.0 + toBS :: t -> BS.ByteString + + -- | Convert from a textual data type to a lazy 'BS.ByteString' + -- + -- @since 0.1.0.0 + toBSL :: t -> BSL.ByteString + + -- | Convert from a textual data type to a @ByteString@ 'BSB.Builder' + -- + -- @since 1.1.0.0 + toBSB :: t -> BSB.Builder + + -- | Convert from a textual data type to a 'SBS.ShortByteString' + -- + -- @since 1.1.0.0 + toSBS :: t -> SBS.ShortByteString + + -- | Convert from one textual data type to another + -- + -- @since 0.1.0.0 + convert' :: Textual t' => t' -> t + +instance Textual String where + toS = id + toT = T.pack + toTL = TL.pack + toTLB = TLB.fromString + toST = ST.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 toST #-} + {-# 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 + toST = ST.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 toST #-} + {-# 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 + toST = ST.fromText . TL.toStrict + 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 toST #-} + {-# 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 + toST = ST.fromText . TL.toStrict . TLB.toLazyText + 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 toST #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} + {-# INLINE convert' #-} + +instance Textual ST.ShortText where + toS = ST.toString + toT = ST.toText + toTL = TL.fromStrict . ST.toText + toTLB = TLB.fromText . ST.toText + toST = id + toBS = ST.toByteString + toBSL = BSL.fromStrict . ST.toByteString + toBSB = BSB.byteString . ST.toByteString + toSBS = ST.toShortByteString + convert' = toST + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toTLB #-} + {-# INLINE toST #-} + {-# 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 + toST = ST.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 toST #-} + {-# 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 + toST = ST.fromText . TL.toStrict . 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 toST #-} + {-# 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 + toST + = ST.fromText + . TL.toStrict + . 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 toST #-} + {-# 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 + toST = ST.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 toST #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE toBSB #-} + {-# INLINE toSBS #-} + {-# INLINE convert' #-} + +------------------------------------------------------------------------------ + +-- | Convert from one textual data type to another +-- +-- The order of the type arguments was changed in version 1.5.0.0. +-- +-- @since 0.1.0.0 +convert :: forall t t'. (Textual t, Textual t') => t -> t' +convert = convert' +{-# INLINE convert #-} + +------------------------------------------------------------------------------ +-- $TextualTo +-- +-- These functions are equivalent to 'convert', but they specify the type +-- being converted to. Use them to avoid having to write type annotations in +-- cases where the type is ambiguous. Using these functions may make code +-- easier to understand even in cases where the types are not ambiguous. + +-- $TextualFrom +-- +-- These functions are equivalent to 'convert', but they specify the type +-- being converted from. Use them to avoid having to write type annotations +-- in cases where the type is ambiguous. Using these functions may make code +-- easier to understand even in cases where the types are not ambiguous. + +-- | Convert from a 'String' to a textual data type +-- +-- @since 0.1.0.0 +fromS :: Textual t => String -> t +fromS = convert' +{-# INLINE fromS #-} + +-- | Convert from strict 'T.Text' to a textual data type +-- +-- @since 0.1.0.0 +fromT :: Textual t => T.Text -> t +fromT = convert' +{-# INLINE fromT #-} + +-- | Convert from lazy 'TL.Text' to a textual data type +-- +-- @since 0.1.0.0 +fromTL :: Textual t => TL.Text -> t +fromTL = convert' +{-# INLINE fromTL #-} + +-- | Convert from a @Text@ 'TLB.Builder' to a textual data type +-- +-- @since 1.1.0.0 +fromTLB :: Textual t => TLB.Builder -> t +fromTLB = convert' +{-# INLINE fromTLB #-} + +-- | Convert from a 'ST.ShortText' to a textual data type +-- +-- @since 1.4.0.0 +fromST :: Textual t => ST.ShortText -> t +fromST = convert' +{-# INLINE fromST #-} + +-- | Convert from a strict 'BS.ByteString' to a textual data type +-- +-- @since 0.1.0.0 +fromBS :: Textual t => BS.ByteString -> t +fromBS = convert' +{-# INLINE fromBS #-} + +-- | Convert from a lazy 'BSL.ByteString' to a textual data type +-- +-- @since 0.1.0.0 +fromBSL :: Textual t => BSL.ByteString -> t +fromBSL = convert' +{-# INLINE fromBSL #-} + +-- | Convert from a @ByteString@ 'TLB.Builder' to a textual data type +-- +-- @since 1.1.0.0 +fromBSB :: Textual t => BSB.Builder -> t +fromBSB = convert' +{-# INLINE fromBSB #-} + +-- | Convert from a 'SBS.ShortByteString' to a textual data type +-- +-- @since 1.1.0.0 +fromSBS :: Textual t => SBS.ShortByteString -> t +fromSBS = convert' +{-# INLINE fromSBS #-} + +------------------------------------------------------------------------------ +-- $TextualAs +-- +-- These functions are used to convert a textual data type argument to a +-- specific type. Use them to reduce boilerplate in small function +-- definitions. + +-- | Convert a textual data type argument to a 'String' +-- +-- @since 0.1.0.0 +asS :: forall t a. Textual t => (String -> a) -> t -> a +asS f = f . convert' +{-# INLINE asS #-} + +-- | Convert a textual data type argument to strict 'T.Text' +-- +-- @since 0.1.0.0 +asT :: forall t a. Textual t => (T.Text -> a) -> t -> a +asT f = f . convert' +{-# INLINE asT #-} + +-- | Convert a textual data type argument to lazy 'TL.Text' +-- +-- @since 0.1.0.0 +asTL :: forall t a. Textual t => (TL.Text -> a) -> t -> a +asTL f = f . convert' +{-# INLINE asTL #-} + +-- | Convert a textual data type argument to a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +asTLB :: forall t a. Textual t => (TLB.Builder -> a) -> t -> a +asTLB f = f . convert' +{-# INLINE asTLB #-} + +-- | Convert a textual data type argument to a 'ST.ShortText' +-- +-- @since 1.4.0.0 +asST :: forall t a. Textual t => (ST.ShortText -> a) -> t -> a +asST f = f . convert' +{-# INLINE asST #-} + +-- | Convert a textual data type argument to a strict 'BS.ByteString' +-- +-- @since 0.1.0.0 +asBS :: forall t a. Textual t => (BS.ByteString -> a) -> t -> a +asBS f = f . convert' +{-# INLINE asBS #-} + +-- | Convert a textual data type argument to a lazy 'BSL.ByteString' +-- +-- @since 0.1.0.0 +asBSL :: forall t a. Textual t => (BSL.ByteString -> a) -> t -> a +asBSL f = f . convert' +{-# INLINE asBSL #-} + +-- | Convert a textual data type argument to a @ByteString@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +asBSB :: forall t a. Textual t => (BSB.Builder -> a ) -> t -> a +asBSB f = f . convert' +{-# INLINE asBSB #-} + +-- | Convert a textual data type argument to a 'SBS.ShortByteString' +-- +-- @since 1.1.0.0 +asSBS :: forall t a. Textual t => (SBS.ShortByteString -> a) -> t -> a +asSBS f = f . convert' +{-# INLINE asSBS #-} + +------------------------------------------------------------------------------ +-- $Render + +-- | Render a data type as a textual data type +-- +-- Use 'Render' in your business logic, and only use 'Show' for debugging, as +-- use of 'Show' instances in business logic is a common source of bugs. +-- +-- When defining an instance, render to the textual data type that is most +-- natural for the data type, and then use 'convert' to handle the conversion +-- to any textual data type. This is particularly wrappers around a textual +-- data type. Example: +-- +-- @ +-- newtype Username = Username { usernameText :: Text } +-- +-- instance TTC.Render Username where +-- render = TTC.convert . usernameText +-- @ +-- +-- To use @render@ in a context where the types are ambiguous, use the +-- [@TypeApplications@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html) +-- GHC extension to specify one or both types. Example: +-- +-- @ +-- -- Render to Text +-- render @_ @Text foo +-- @ +-- +-- Alternatively, use one of the functions that render to a specific textual +-- data type (such as 'renderS'). Using these functions may make code easier +-- to understand even in cases where the types are not ambiguous. +-- +-- See the @uname@ and @prompt@ example programs in the @ttc-examples@ +-- directory of the source repository. +-- +-- For more details, see the following article: +-- +-- +-- 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. Use @newtype@ wrappers instead. +-- +-- 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 defined for the 'RenderDefault' type class, however, +-- and the Template Haskell functions documented below can be used to load +-- these definitions with minimal boilerplate. +-- +-- @since 0.1.0.0 +class Render a where + -- | Render a data type as a textual data type + -- + -- @since 0.1.0.0 + render :: Textual t => a -> t + + default render :: (RenderDefault a, Textual t) => a -> t + render = renderDefault + +------------------------------------------------------------------------------ + +-- | Default 'Render' instances for some common types +-- +-- * The 'Bool' instance renders using the 'Show' instance. This instance was +-- added in version 1.5.0.0. +-- * The 'Char' instance renders a single-character string. +-- * Numeric type instances all render using the 'Show' instance. +-- * Textual data type instances all convert to the target textual data type. +-- +-- @since 1.1.0.0 +class RenderDefault a where + -- | Render a data type as a textual data type + -- + -- @since 1.1.0.0 + renderDefault :: Textual t => a -> t + +instance RenderDefault Bool where + renderDefault = renderWithShow + +instance RenderDefault Char where + renderDefault c = fromS [c] + +instance RenderDefault Double where + renderDefault = renderWithShow + +instance RenderDefault Float where + renderDefault = renderWithShow + +instance RenderDefault Integer 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 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 T.Text where + renderDefault = fromT + +instance RenderDefault TL.Text where + renderDefault = fromTL + +instance RenderDefault TLB.Builder where + renderDefault = fromTLB + +instance RenderDefault ST.ShortText where + renderDefault = fromST + +instance RenderDefault BS.ByteString where + renderDefault = fromBS + +instance RenderDefault BSL.ByteString where + renderDefault = fromBSL + +instance RenderDefault BSB.Builder where + renderDefault = fromBSB + +instance RenderDefault SBS.ShortByteString where + renderDefault = fromSBS + +------------------------------------------------------------------------------ +-- $RenderUtilityFunctions +-- +-- These functions are used to implement 'Render' instances. + +-- | Render a value to a textual data type using a 'Show' instance +-- +-- To use this function in a context where the types are ambiguous, use the +-- [@TypeApplications@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html) +-- GHC extension to specify one or both types. Example: +-- +-- @ +-- -- Render to Text +-- renderWithShow @Text foo +-- @ +-- +-- See the @enum@ example program in the @ttc-examples@ directory of the +-- source repository. +-- +-- @since 0.1.0.0 +renderWithShow :: forall t a. (Show a, Textual t) => a -> t +renderWithShow = convert' . show +{-# INLINE renderWithShow #-} + +------------------------------------------------------------------------------ +-- $RenderSpecific +-- +-- These functions are equivalent to 'render', but they specify the textual +-- data type being rendered to. Use them to avoid having to write type +-- annotations in cases where the type is ambiguous. Using these functions +-- may make code easier to understand even in cases where the types are not +-- ambiguous. + +-- | Render to a 'String' +-- +-- @since 0.1.0.0 +renderS :: Render a => a -> String +renderS = render +{-# INLINE renderS #-} + +-- | Render to strict 'T.Text' +-- +-- @since 0.1.0.0 +renderT :: Render a => a -> T.Text +renderT = render +{-# INLINE renderT #-} + +-- | Render to lazy 'TL.Text' +-- +-- @since 0.1.0.0 +renderTL :: Render a => a -> TL.Text +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 'ST.ShortText' +-- +-- @since 1.4.0.0 +renderST :: Render a => a -> ST.ShortText +renderST = render +{-# INLINE renderST #-} + +-- | Render to a strict 'BS.ByteString' +-- +-- @since 0.1.0.0 +renderBS :: Render a => a -> BS.ByteString +renderBS = render +{-# INLINE renderBS #-} + +-- | Render to a lazy 'BSL.ByteString' +-- +-- @since 0.1.0.0 +renderBSL :: Render a => a -> BSL.ByteString +renderBSL = render +{-# INLINE renderBSL #-} + +-- | Render to a @ByteString@ 'BSB.Builder' +-- +-- @since 0.4.0.0 +renderBSB :: Render a => a -> BSB.Builder +renderBSB = render +{-# INLINE renderBSB #-} + +-- | Render to a 'SBS.ShortByteString' +-- +-- @since 0.4.0.0 +renderSBS :: Render a => a -> SBS.ShortByteString +renderSBS = render +{-# INLINE renderSBS #-} + +------------------------------------------------------------------------------ +-- $Parse + +-- | Parse a data type from a textual data type +-- +-- Unlike 'Read', 'Parse' allows you to specify meaningful error messages. +-- +-- When defining an instance, first convert the textual data type to the +-- textual data type that is most natural for the data type. The @as@ +-- functions (such as 'asS') provide a convenient way to do this. Note that +-- error is also a textual data type. The 'withError' and 'prefixError' +-- functions can be used to reduce boilerplate. Example: +-- +-- @ +-- newtype Username = Username { usernameText :: Text } +-- +-- instance TTC.Parse Username where +-- parse = TTC.asT $ \t -> TTC.prefixErrorS "invalid username: " $ do +-- unless (T.all isAsciiLower t) $ Left "not only lowercase ASCII letters" +-- let len = T.length t +-- when (len < 3) $ Left "fewer than 3 characters" +-- when (len > 12) $ Left "more than 12 characters" +-- pure $ Username t +-- @ +-- +-- To use @parse@ in a context where the types are ambiguous, use the +-- [@TypeApplications@](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/type_applications.html) +-- GHC extension to specify one or more types. Example: +-- +-- @ +-- -- Parse from Text +-- parse @_ @Text foo +-- +-- -- Parse using String errors +-- parse @_ @_ @String foo +-- +-- -- Parse from Text using String errors +-- parse @_ @Text @String foo +-- @ +-- +-- Alternatively, use one of the functions that parse from a specific textual +-- data type (such as 'renderS'). Using these functions may make code easier +-- to understand even in cases where the types are not ambiguous. +-- +-- See the @uname@ and @prompt@ example programs in the @ttc-examples@ +-- directory of the source repository. +-- +-- For more details, see the following article: +-- +-- +-- 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. Use @newtype@ wrappers instead. +-- +-- 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 defined for the 'ParseDefault' type class, however, +-- and the Template Haskell functions documented below can be used to load +-- these definitions with minimal boilerplate. +-- +-- @since 0.3.0.0 +class Parse a where + -- | Parse a data type from a textual data type + -- + -- @since 0.3.0.0 + 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. +-- +-- @since 0.3.0.0 +parse' :: forall t a. (Parse a, Textual t) => t -> Either String a +parse' = parse +{-# INLINE parse' #-} + +------------------------------------------------------------------------------ + +-- | The 'ParseDefault' type class provides some default 'Parse' instances. +-- +-- * The 'Bool' instance parses using the 'Read' instance. This instance was +-- added in version 1.5.0.0. +-- * The 'Char' instance parses single-character strings. +-- * Numeric type instances all parse using the 'Read' instance. +-- * Textual data type instances all convert from the source textual data +-- type. +-- +-- @since 1.1.0.0 +class ParseDefault a where + -- | Parse a data type from a textual data type + -- + -- @since 1.1.0.0 + parseDefault :: (Textual t, Textual e) => t -> Either e a + +instance ParseDefault Bool where + parseDefault = parseWithRead' "Bool" + +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 Integer where + parseDefault = parseWithRead' "Integer" + +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 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 T.Text where + parseDefault = Right . toT + +instance ParseDefault TL.Text where + parseDefault = Right . toTL + +instance ParseDefault TLB.Builder where + parseDefault = Right . toTLB + +instance ParseDefault ST.ShortText where + parseDefault = Right . toST + +instance ParseDefault BS.ByteString where + parseDefault = Right . toBS + +instance ParseDefault BSL.ByteString where + parseDefault = Right . toBSL + +instance ParseDefault BSB.Builder where + parseDefault = Right . toBSB + +instance ParseDefault SBS.ShortByteString where + parseDefault = Right . toSBS + +------------------------------------------------------------------------------ +-- $ParseUtilityFunctions +-- +-- These functions are used to implement 'Parse' instances. + +------------------------------------------------------------------------------ +-- $ParseWithASingleErrorMessage +-- +-- The 'withError' function takes an error message and a 'Maybe' value. It +-- returns a 'Parse' result: the error when the 'Maybe' value is 'Nothing', or +-- the value inside the 'Just'. This provides a convenient way to return the +-- same error message for any parse error. The rest of the functions are +-- equivalent to 'withError', but they specify the type of the error message. +-- Use them to avoid having to write type annotations in cases where the type +-- is ambiguous. + +-- | Create a 'Parse' result from a 'Textual' error message and a 'Maybe' +-- value +-- +-- @since 1.2.0.0 +withError + :: forall e' e a. (Textual e', Textual e) + => e' + -> Maybe a + -> Either e a +withError err = maybe (Left $ convert' err) Right +{-# INLINE withError #-} + +-- | Create a 'Parse' result from a 'String' error message and a 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorS + :: forall e a. Textual e + => String + -> Maybe a + -> Either e a +withErrorS = withError +{-# INLINE withErrorS #-} + +-- | Create a 'Parse' result from a 'T.Text' error message and a 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorT + :: forall e a. Textual e + => T.Text + -> Maybe a + -> Either e a +withErrorT = withError +{-# INLINE withErrorT #-} + +-- | Create a 'Parse' result from a 'TL.Text' error message and a 'Maybe' +-- value +-- +-- @since 1.2.0.0 +withErrorTL + :: forall e a. Textual e + => TL.Text + -> Maybe a + -> Either e a +withErrorTL = withError +{-# INLINE withErrorTL #-} + +-- | Create a 'Parse' result from a 'TLB.Builder' error message and a 'Maybe' +-- value +-- +-- @since 1.2.0.0 +withErrorTLB + :: forall e a. Textual e + => TLB.Builder + -> Maybe a + -> Either e a +withErrorTLB = withError +{-# INLINE withErrorTLB #-} + +-- | Create a 'Parse' result from a 'ST.ShortText' error message and a 'Maybe' +-- value +-- +-- @since 1.4.0.0 +withErrorST + :: forall e a. Textual e + => ST.ShortText + -> Maybe a + -> Either e a +withErrorST = withError +{-# INLINE withErrorST #-} + +-- | Create a 'Parse' result from a 'BS.ByteString' error message and a +-- 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorBS + :: forall e a. Textual e + => BS.ByteString + -> Maybe a + -> Either e a +withErrorBS = withError +{-# INLINE withErrorBS #-} + +-- | Create a 'Parse' result from a 'BSL.ByteString' error message and a +-- 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorBSL + :: forall e a. Textual e + => BSL.ByteString + -> Maybe a + -> Either e a +withErrorBSL = withError +{-# INLINE withErrorBSL #-} + +-- | Create a 'Parse' result from a 'BSB.Builder' error message and a +-- 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorBSB + :: forall e a. Textual e + => BSB.Builder + -> Maybe a + -> Either e a +withErrorBSB = withError +{-# INLINE withErrorBSB #-} + +-- | Create a 'Parse' result from a 'SBS.ShortByteString' error message and a +-- 'Maybe' value +-- +-- @since 1.2.0.0 +withErrorSBS + :: forall e a. Textual e + => SBS.ShortByteString + -> Maybe a + -> Either e a +withErrorSBS = withError +{-# INLINE withErrorSBS #-} + +------------------------------------------------------------------------------ +-- $ParseWithAnErrorPrefix +-- +-- The 'prefixError' function adds a common prefix to error messages of a +-- 'Parse' result. The rest of the functions are equivalent to 'prefixError', +-- but they specify the type of the error message. Use them to avoid having +-- to write type annotations in cases where the type is ambiguous. + +-- | Add a prefix to 'Textual' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixError + :: forall e' e a. (Monoid e', Textual e', Textual e) + => e' + -> Either e' a + -> Either e a +prefixError prefix = either (Left . convert' . mappend prefix) Right +{-# INLINE prefixError #-} + +-- | Add a prefix to 'String' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorS + :: forall e a. Textual e + => String + -> Either String a + -> Either e a +prefixErrorS = prefixError +{-# INLINE prefixErrorS #-} + +-- | Add a prefix to 'T.Text' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorT + :: forall e a. Textual e + => T.Text + -> Either T.Text a + -> Either e a +prefixErrorT = prefixError +{-# INLINE prefixErrorT #-} + +-- | Add a prefix to 'TL.Text' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorTL + :: forall e a. Textual e + => TL.Text + -> Either TL.Text a + -> Either e a +prefixErrorTL = prefixError +{-# INLINE prefixErrorTL #-} + +-- | Add a prefix to 'TLB.Builder' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorTLB + :: forall e a. Textual e + => TLB.Builder + -> Either TLB.Builder a + -> Either e a +prefixErrorTLB = prefixError +{-# INLINE prefixErrorTLB #-} + +-- | Add a prefix to 'ST.ShortText' error messages of a 'Parse' result +-- +-- @since 1.4.0.0 +prefixErrorST + :: forall e a. Textual e + => ST.ShortText + -> Either ST.ShortText a + -> Either e a +prefixErrorST = prefixError +{-# INLINE prefixErrorST #-} + +-- | Add a prefix to 'BS.ByteString' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorBS + :: forall e a. Textual e + => BS.ByteString + -> Either BS.ByteString a + -> Either e a +prefixErrorBS = prefixError +{-# INLINE prefixErrorBS #-} + +-- | Add a prefix to 'BSL.ByteString' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorBSL + :: forall e a. Textual e + => BSL.ByteString + -> Either BSL.ByteString a + -> Either e a +prefixErrorBSL = prefixError +{-# INLINE prefixErrorBSL #-} + +-- | Add a prefix to 'BSB.Builder' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorBSB + :: forall e a. Textual e + => BSB.Builder + -> Either BSB.Builder a + -> Either e a +prefixErrorBSB = prefixError +{-# INLINE prefixErrorBSB #-} + +-- | Add a prefix to 'SBS.ShortByteString' error messages of a 'Parse' result +-- +-- @since 1.2.0.0 +prefixErrorSBS + :: forall e a. Textual e + => SBS.ShortByteString + -> Either SBS.ShortByteString a + -> Either e a +prefixErrorSBS = prefixError +{-# INLINE prefixErrorSBS #-} + +------------------------------------------------------------------------------ +-- $ReadParsing + +-- | Parse a value using a 'Read' instance +-- +-- @since 0.1.0.0 +parseWithRead + :: forall t e a. (Read a, Textual t) + => e -- ^ invalid input error + -> t -- ^ textual input to parse + -> Either e a -- ^ error or parsed value +parseWithRead invalidError = maybe (Left invalidError) Right . readMaybe . toS +{-# INLINEABLE parseWithRead #-} + +-- | Parse a value using a 'Read' instance with default error messages +-- +-- The following English error message is returned: +-- +-- * \"invalid {name}\" when the parse fails +-- +-- @since 0.3.0.0 +parseWithRead' + :: forall t e a. (Read a, Textual t, Textual e) + => String -- ^ name to include in error messages + -> t -- ^ textual input to parse + -> Either e a -- ^ error or parsed value +parseWithRead' name = parseWithRead (fromS $ "invalid " ++ name) +{-# INLINEABLE parseWithRead' #-} + +-- | Parse a value to a 'Maybe' result using a 'Read' instance +-- +-- @since 0.3.0.0 +maybeParseWithRead + :: forall t a. (Read a, Textual t) + => t -- ^ textual input to parse + -> Maybe a -- ^ parsed value or 'Nothing' if invalid +maybeParseWithRead = readMaybe . toS + +------------------------------------------------------------------------------ +-- $EnumParsing + +-- | Parse a value in an enumeration +-- +-- The 'Render' instance determines the textual values to parse from. +-- +-- This function is intended to be used with types that have few choices, as +-- the implementation uses a linear algorithm. +-- +-- See the @enum@ example program in the @ttc-examples@ directory of the +-- source repository. +-- +-- @since 0.1.0.0 +parseEnum + :: forall t e a. (Bounded a, Enum a, Render a, Textual t) + => Bool -- ^ case-insensitive when 'True' + -> Bool -- ^ accept unique prefixes when 'True' + -> e -- ^ invalid input error + -> e -- ^ ambiguous input error + -> t -- ^ textual input to parse + -> Either e a -- ^ error or parsed value +parseEnum allowCI allowPrefix invalidError ambiguousError t = + let t' = norm $ toT t + in case [v | v <- [minBound ..], t' `match` norm (render v)] of + [v] -> Right v + [] -> Left invalidError + _vs -> Left ambiguousError + where + norm :: T.Text -> T.Text + norm = if allowCI then T.toLower else id + + match :: T.Text -> T.Text -> Bool + match = if allowPrefix then T.isPrefixOf else (==) + +-- | Parse a value in an enumeration using default error messages +-- +-- The 'Render' instance determines the textual values to parse from. +-- +-- The following English error messages are returned: +-- +-- * \"invalid {name}\" when there are no matches +-- * \"ambiguous {name}\" when there is more than one match +-- +-- This function is intended to be used with types that have few choices, as +-- the implementation uses a linear algorithm. +-- +-- @since 0.4.0.0 +parseEnum' + :: forall t e a. (Bounded a, Enum a, Render a, Textual t, Textual e) + => String -- ^ name to include in error messages + -> Bool -- ^ case-insensitive when 'True' + -> Bool -- ^ accept unique prefixes when 'True' + -> t -- ^ textual input to parse + -> Either e a -- ^ error or parsed value +parseEnum' name allowCI allowPrefix = + parseEnum + allowCI allowPrefix + (fromS $ "invalid " ++ name) + (fromS $ "ambiguous " ++ name) +{-# INLINEABLE parseEnum' #-} + +------------------------------------------------------------------------------ +-- $ParseSpecific +-- +-- These functions are equivalent to 'parse', but they specify the textual +-- data type being parsed from. Use them to avoid having to write type +-- annotations in cases where the type is ambiguous. Using these functions +-- may make code easier to understand even in cases where the types are not +-- ambiguous. + +-- | Parse from a 'String' +-- +-- @since 0.3.0.0 +parseS :: forall e a. (Parse a, Textual e) => String -> Either e a +parseS = parse +{-# INLINE parseS #-} + +-- | Parse from strict 'T.Text' +-- +-- @since 0.3.0.0 +parseT :: forall e a. (Parse a, Textual e) => T.Text -> Either e a +parseT = parse +{-# INLINE parseT #-} + +-- | Parse from lazy 'TL.Text' +-- +-- @since 0.3.0.0 +parseTL :: forall e a. (Parse a, Textual e) => TL.Text -> Either e a +parseTL = parse +{-# INLINE parseTL #-} + +-- | Parse from a @Text@ 'TLB.Builder' +-- +-- @since 1.1.0.0 +parseTLB :: forall e a. (Parse a, Textual e) => TLB.Builder -> Either e a +parseTLB = parse +{-# INLINE parseTLB #-} + +-- | Parse from a 'ST.ShortText' +-- +-- @since 1.4.0.0 +parseST :: forall e a. (Parse a, Textual e) => ST.ShortText -> Either e a +parseST = parse +{-# INLINE parseST #-} + +-- | Parse from a strict 'BS.ByteString' +-- +-- @since 0.3.0.0 +parseBS :: forall e a. (Parse a, Textual e) => BS.ByteString -> Either e a +parseBS = parse +{-# INLINE parseBS #-} + +-- | Parse from a lazy 'BSL.ByteString' +-- +-- @since 0.3.0.0 +parseBSL :: forall e a. (Parse a, Textual e) => BSL.ByteString -> Either e a +parseBSL = parse +{-# INLINE parseBSL #-} + +-- | Parse from a @ByteString@ 'BSB.Builder' +-- +-- @since 1.1.0.0 +parseBSB :: forall e a. (Parse a, Textual e) => BSB.Builder -> Either e a +parseBSB = parse +{-# INLINE parseBSB #-} + +-- | Parse from a 'SBS.ShortByteString' +-- +-- @since 1.1.0.0 +parseSBS + :: forall e a. (Parse a, Textual e) + => SBS.ShortByteString + -> Either e a +parseSBS = parse +{-# INLINE parseSBS #-} + +------------------------------------------------------------------------------ +-- $ParseMaybe +-- +-- The 'parseMaybe' function parses to a 'Maybe' result instead of an 'Either' +-- result. +-- +-- The rest of the functions are equivalent to 'parseMaybe', but they specify +-- the type being parsed from. Use them to avoid having to write type +-- annotations in cases where the type is ambiguous. Using these functions +-- may make code easier to understand even in cases where the types are not +-- ambiguous. + +-- | Parse to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybe :: forall t a. (Parse a, Textual t) => t -> Maybe a +parseMaybe = either (const Nothing) Just . parse' +{-# INLINE parseMaybe #-} + +-- | Parse from a 'String' to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybeS :: Parse a => String -> Maybe a +parseMaybeS = parseMaybe +{-# INLINE parseMaybeS #-} + +-- | Parse from strict 'T.Text' to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybeT :: Parse a => T.Text -> Maybe a +parseMaybeT = parseMaybe +{-# INLINE parseMaybeT #-} + +-- | Parse from lazy 'TL.Text' to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybeTL :: Parse a => TL.Text -> Maybe a +parseMaybeTL = parseMaybe +{-# INLINE parseMaybeTL #-} + +-- | Parse from a @Text@ 'TLB.Builder' to a 'Maybe' result +-- +-- @since 1.1.0.0 +parseMaybeTLB :: Parse a => TLB.Builder -> Maybe a +parseMaybeTLB = parseMaybe +{-# INLINE parseMaybeTLB #-} + +-- | Parse from a 'ST.ShortText' to a 'Maybe' result +-- +-- @since 1.4.0.0 +parseMaybeST :: Parse a => ST.ShortText -> Maybe a +parseMaybeST = parseMaybe +{-# INLINE parseMaybeST #-} + +-- | Parse from a strict 'BS.ByteString' to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybeBS :: Parse a => BS.ByteString -> Maybe a +parseMaybeBS = parseMaybe +{-# INLINE parseMaybeBS #-} + +-- | Parse from a lazy 'BSL.ByteString' to a 'Maybe' result +-- +-- @since 0.3.0.0 +parseMaybeBSL :: Parse a => BSL.ByteString -> Maybe a +parseMaybeBSL = parseMaybe +{-# INLINE parseMaybeBSL #-} + +-- | Parse from a @ByteString@ 'BSB.Builder' to a 'Maybe' result +-- +-- @since 1.1.0.0 +parseMaybeBSB :: Parse a => BSB.Builder -> Maybe a +parseMaybeBSB = parseMaybe +{-# INLINE parseMaybeBSB #-} + +-- | Parse from a 'SBS.ShortByteString' to a 'Maybe' result +-- +-- @since 1.1.0.0 +parseMaybeSBS :: Parse a => SBS.ShortByteString -> Maybe a +parseMaybeSBS = parseMaybe +{-# INLINE parseMaybeSBS #-} + +------------------------------------------------------------------------------ +-- $ParseOrFail +-- +-- The 'parseOrFail' function fails using 'MonadFail' on error instead of +-- using an 'Either' result. +-- +-- The rest of the functions are equivalent to 'parseOrFail', but they specify +-- the type being parsed from. Use them to avoid having to write type +-- annotations in cases where the type is ambiguous. Using these functions +-- may make code easier to understand even in cases where the types are not +-- ambiguous. + +-- | Parse or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFail :: forall t a m. (MonadFail m, Parse a, Textual t) => t -> m a +parseOrFail = either fail pure . parse +{-# INLINE parseOrFail #-} + +-- | Parse from a 'String' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailS :: forall a m. (MonadFail m, Parse a) => String -> m a +parseOrFailS = parseOrFail +{-# INLINE parseOrFailS #-} + +-- | Parse from strict 'T.Text' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailT :: forall a m. (MonadFail m, Parse a) => T.Text -> m a +parseOrFailT = parseOrFail +{-# INLINE parseOrFailT #-} + +-- | Parse from lazy 'TL.Text' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailTL :: forall a m. (MonadFail m, Parse a) => TL.Text -> m a +parseOrFailTL = parseOrFail +{-# INLINE parseOrFailTL #-} + +-- | Parse from a @Text@ 'TLB.Builder' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailTLB :: forall a m. (MonadFail m, Parse a) => TLB.Builder -> m a +parseOrFailTLB = parseOrFail +{-# INLINE parseOrFailTLB #-} + +-- | Parse from a 'ST.ShortText' or fail using 'MonadFail' +-- +-- @since 1.4.0.0 +parseOrFailST :: forall a m. (MonadFail m, Parse a) => ST.ShortText -> m a +parseOrFailST = parseOrFail +{-# INLINE parseOrFailST #-} + +-- | Parse from a strict 'BS.ByteString' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailBS :: forall a m. (MonadFail m, Parse a) => BS.ByteString -> m a +parseOrFailBS = parseOrFail +{-# INLINE parseOrFailBS #-} + +-- | Parse from a lazy 'BSL.ByteString' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailBSL :: forall a m. (MonadFail m, Parse a) => BSL.ByteString -> m a +parseOrFailBSL = parseOrFail +{-# INLINE parseOrFailBSL #-} + +-- | Parse from a @ByteString@ 'BSB.Builder' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailBSB :: forall a m. (MonadFail m, Parse a) => BSB.Builder -> m a +parseOrFailBSB = parseOrFail +{-# INLINE parseOrFailBSB #-} + +-- | Parse from a 'SBS.ShortByteString' or fail using 'MonadFail' +-- +-- @since 1.3.0.0 +parseOrFailSBS + :: forall a m. (MonadFail m, Parse a) + => SBS.ShortByteString + -> m a +parseOrFailSBS = parseOrFail +{-# INLINE parseOrFailSBS #-} + +------------------------------------------------------------------------------ +-- $ParseUnsafe +-- +-- The 'parseUnsafe' function raises an exception on error instead of using an +-- 'Either' result. It should only be used when an error is not possible. +-- +-- The rest of the functions are equivalent to 'parseUnsafe', but they specify +-- the type being parsed from. Use them to avoid having to write type +-- annotations in cases where the type is ambiguous. Using these functions +-- may make code easier to understand even in cases where the types are not +-- ambiguous. + +-- | Parse or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafe :: forall t a. (HasCallStack, Parse a, Textual t) => t -> a +parseUnsafe = either (error . ("parseUnsafe: " ++)) id . parse +{-# INLINE parseUnsafe #-} + +-- | Parse from a 'String' or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafeS :: (HasCallStack, Parse a) => String -> a +parseUnsafeS = parseUnsafe +{-# INLINE parseUnsafeS #-} + +-- | Parse from strict 'T.Text' or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafeT :: (HasCallStack, Parse a) => T.Text -> a +parseUnsafeT = parseUnsafe +{-# INLINE parseUnsafeT #-} + +-- | Parse from lazy 'TL.Text' or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafeTL :: (HasCallStack, Parse a) => TL.Text -> a +parseUnsafeTL = parseUnsafe +{-# INLINE parseUnsafeTL #-} + +-- | Parse from a @Text@ 'TLB.Builder' or raise an exception +-- +-- @since 1.1.0.0 +parseUnsafeTLB :: (HasCallStack, Parse a) => TLB.Builder -> a +parseUnsafeTLB = parseUnsafe +{-# INLINE parseUnsafeTLB #-} + +-- | Parse from a 'ST.ShortText' or raise an exception +-- +-- @since 1.4.0.0 +parseUnsafeST :: (HasCallStack, Parse a) => ST.ShortText -> a +parseUnsafeST = parseUnsafe +{-# INLINE parseUnsafeST #-} + +-- | Parse from a strict 'BS.ByteString' or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafeBS :: (HasCallStack, Parse a) => BS.ByteString -> a +parseUnsafeBS = parseUnsafe +{-# INLINE parseUnsafeBS #-} + +-- | Parse from a lazy 'BSL.ByteString' or raise an exception +-- +-- @since 0.1.0.0 +parseUnsafeBSL :: (HasCallStack, Parse a) => BSL.ByteString -> a +parseUnsafeBSL = parseUnsafe +{-# INLINE parseUnsafeBSL #-} + +-- | Parse from a @ByteString@ 'BSB.Builder' or raise an exception +-- +-- @since 1.1.0.0 +parseUnsafeBSB :: (HasCallStack, Parse a) => BSB.Builder -> a +parseUnsafeBSB = parseUnsafe +{-# INLINE parseUnsafeBSB #-} + +-- | Parse from a 'SBS.ShortByteString' or raise an exception +-- +-- @since 1.1.0.0 +parseUnsafeSBS :: (HasCallStack, Parse a) => SBS.ShortByteString -> a +parseUnsafeSBS = parseUnsafe +{-# INLINE parseUnsafeSBS #-} + +------------------------------------------------------------------------------ +-- $ReadSInstances + +-- | Implement 'ReadS' using a 'Parse' instance +-- +-- This implementation expects all of the input to be consumed. +-- +-- @since 0.3.0.0 +readsWithParse + :: Parse a + => ReadS a +readsWithParse s = case parseMaybe s of + Just v -> [(v, "")] + Nothing -> [] +{-# INLINEABLE readsWithParse #-} + +-- | Implement 'ReadS' using 'parseEnum' +-- +-- This implementation expects all of the input to be consumed. +-- +-- @since 0.1.0.0 +readsEnum + :: (Bounded a, Enum a, Render a) + => Bool -- ^ case-insensitive when 'True' + -> Bool -- ^ accept unique prefixes when 'True' + -> ReadS a +readsEnum allowCI allowPrefix s = + case parseEnum allowCI allowPrefix () () s of + Right v -> [(v, "")] + Left{} -> [] +{-# INLINEABLE readsEnum #-} + +------------------------------------------------------------------------------ +-- $ConstantValidation +-- +-- The follow functions provide a number of ways to use a 'Parse' instance to +-- validate constants at compile-time. +-- +-- If you can use Template Haskell typed expressions in your project, use +-- 'valid', 'mkValid', or 'validOf'. Use 'valid' to define constants for +-- types that have a 'THS.Lift' instance. For types that do not have a +-- 'THS.Lift' instance, use 'mkValid' to define a validation function for that +-- type using a 'Proxy', or use 'validOf' to pass the 'Proxy' when defining +-- constants. +-- +-- Typed expressions were not supported in @haskell-src-exts <1.22.0@, which +-- causes problems with old versions of @hlint@. If the issue affects you, +-- you may use 'mkUntypedValid', 'mkUntypedValidQQ', or 'untypedValidOf' +-- instead of the above functions. Use 'mkUntypedValid' to define a +-- validation function for a type using a 'Proxy', or use 'untypedValidOf' to +-- pass the 'Proxy' when defining constants. Alternatively, use +-- 'mkUntypedValidQQ' to define a validation quasi-quoter. +-- +-- For more details, see the following article: +-- + +-- | Validate a constant at compile-time using a 'Parse' instance +-- +-- This function parses the 'String' at compile-time and fails compilation on +-- error. When valid, the result is compiled in, so the result type must have +-- a 'THS.Lift' instance. When this is inconvenient, use one of the +-- alternative functions in this library. +-- +-- This function uses a Template Haskell typed expression. Typed expressions +-- were not supported in @haskell-src-exts <1.22.0@, which causes problems +-- with old versions of @hlint@. If the issue affects you, use +-- @hlint -i "Parse error"@ to ignore parse errors or use one of the +-- alternative functions in this library. +-- +-- Note that the typed Template Haskell API changed in GHC 9. The type +-- displayed in this documentation is determined by the version of GHC used to +-- build the documentation. +-- +-- The type of this function in GHC 9 or later is as follows: +-- +-- @ +-- valid +-- :: (MonadFail m, THS.Quote m, Parse a, THS.Lift a) +-- => String +-- -> THS.Code m a +-- @ +-- +-- The type of this function in previous versions of GHC is as follows: +-- +-- @ +-- valid +-- :: (Parse a, THS.Lift a) +-- => String +-- -> TH.Q (TH.TExp a) +-- @ +-- +-- This function is used the same way in all GHC versions. See the @valid@ +-- and @invalid@ example programs in the @ttc-examples@ directory of the +-- source repository. The following is example usage from the @valid@ +-- example: +-- +-- @ +-- sample :: Username +-- sample = $$(TTC.valid "tcard") +-- @ +-- +-- @since 0.1.0.0 +#if __GLASGOW_HASKELL__ >= 900 +valid + :: (MonadFail m, THS.Quote m, Parse a, THS.Lift a) + => String + -> THS.Code m a +valid s = case parse s of + Right x -> [|| x ||] + Left err -> THS.Code . fail $ "Invalid constant: " ++ err +#else +valid + :: (Parse a, THS.Lift a) + => String + -> TH.Q (TH.TExp a) +valid s = case parse s of + Right x -> [|| x ||] + Left err -> fail $ "Invalid constant: " ++ err +#endif + +-- | This instance enables use of 'valid' without having to type @valid@. The +-- [OverloadedStrings](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/overloaded_strings.html) +-- extension must be enabled in the module where this functionality is used. +-- Note that this reduces the number of characters in the code, but it can +-- also make the code more difficult to understand by somebody who is not +-- already familiar with it. Typing @valid@ gives people a way to investigate +-- and understand what is going on. +-- +-- Note that the typed Template Haskell API changed in GHC 9. The type +-- displayed in this documentation is determined by the version of GHC used to +-- build the documentation. +-- +-- The type of this instance in GHC 9 or later is as follows: +-- +-- @ +-- (MonadFail m, THS.Quote m, Parse a, THS.Lift a) => IsString (THS.Code m a) +-- @ +-- +-- The type of this instance in previous versions of GHC is as follows: +-- +-- @ +-- (Parse a, THS.Lift a) => IsString (TH.Q (TH.TExp a)) +-- @ +-- +-- This functionality can be used as follows in all supported versions of GHC. +-- The following is example usage from the @valid@ example: +-- +-- @ +-- sample2 :: Username +-- sample2 = $$("alice") +-- @ +-- +-- The parenthesis are not required from GHC 9. The following is example +-- usage from the @valid@ example: +-- +-- @ +-- sample2 :: Username +-- sample2 = $$"alice" +-- @ +-- +-- @since 1.3.0.0 +#if __GLASGOW_HASKELL__ >= 900 +instance (MonadFail m, THS.Quote m, Parse a, THS.Lift a) + => IsString (THS.Code m a) where + fromString = valid +#else +instance (Parse a, THS.Lift a) => IsString (TH.Q (TH.TExp a)) where + fromString = valid +#endif + +-- | Validate a constant at compile-time using a 'Parse' instance +-- +-- This function requires a 'Proxy' of the result type. Use 'mkValid' to +-- avoid having to pass a 'Proxy' during constant definition. +-- +-- This function parses the 'String' at compile-time and fails compilation on +-- error. When valid, the 'String' is compiled in, to be parsed again at +-- run-time. Since the result is not compiled in, no 'THS.Lift' instance is +-- required. +-- +-- This function uses a Template Haskell typed expression. Typed expressions +-- were not supported in @haskell-src-exts <1.22.0@, which causes problems +-- with old versions of @hlint@. If the issue affects you, use +-- @hlint -i "Parse error"@ to ignore parse errors or use 'untypedValidOf' +-- instead. +-- +-- Note that the typed Template Haskell API changed in GHC 9. The type +-- displayed in this documentation is determined by the version of GHC used to +-- build the documentation. +-- +-- The type of this function in GHC 9 or later is as follows: +-- +-- @ +-- validOf +-- :: (MonadFail m, THS.Quote m, Parse a) +-- => Proxy a +-- -> String +-- -> THS.Code m a +-- @ +-- +-- The type of this function in previous versions of GHC is as follows: +-- +-- @ +-- validOf +-- :: Parse a +-- => Proxy a +-- -> String +-- -> TH.Q (TH.TExp a) +-- @ +-- +-- This function is used the same way in all GHC versions. See the @validof@ +-- example program in the @ttc-examples@ directory of the source repository. +-- The following is example usage from the @validof@ example: +-- +-- @ +-- sample :: Username +-- sample = $$(TTC.validOf (Proxy :: Proxy Username) "tcard") +-- @ +-- +-- @since 0.1.0.0 +#if __GLASGOW_HASKELL__ >= 900 +validOf + :: (MonadFail m, THS.Quote m, Parse a) + => Proxy a + -> String + -> THS.Code m a +validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of + Right{} -> [|| parseUnsafeS s ||] + Left err -> THS.Code . fail $ "Invalid constant: " ++ err +#else +validOf + :: Parse a + => Proxy a + -> String + -> TH.Q (TH.TExp a) +validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of + Right{} -> [|| parseUnsafeS s ||] + Left err -> fail $ "Invalid constant: " ++ err +#endif + +-- | Make a @valid@ function using 'validOf' for the given type +-- +-- Create a @valid@ function for a type in order to avoid having to write a +-- 'Proxy' when defining constants. +-- +-- This function uses a Template Haskell typed expression. Typed expressions +-- were not supported in @haskell-src-exts <1.22.0@, which causes problems +-- with old versions of @hlint@. If the issue affects you, use +-- @hlint -i "Parse error"@ to ignore parse errors or use 'mkUntypedValid' +-- instead. +-- +-- Note that the typed Template Haskell API changed in GHC 9. The type +-- displayed in this documentation is determined by the version of GHC used to +-- build the documentation. +-- +-- The type of the created @valid@ function in GHC 9 or later is as follows: +-- +-- @ +-- \$funName +-- :: forall m. (MonadFail m, THS.Quote m) +-- => String +-- -> THS.Code m $resultType +-- @ +-- +-- The type of the created @valid@ function in previous versions of GHC is as +-- follows: +-- +-- @ +-- \$funName +-- :: String +-- -> TH.Q (TH.TExp $resultType) +-- @ +-- +-- This function is used the same way in all GHC versions. See the @mkvalid@ +-- example program in the @ttc-examples@ directory of the source repository. +-- The following is example usage from the @mkvalid@ example: +-- +-- @ +-- \$(TTC.mkValid "valid" ''Username) +-- @ +-- +-- The created @valid@ function can then be used as follows: +-- +-- @ +-- sample :: Username +-- sample = $$(Username.valid "tcard") +-- @ +-- +-- @since 0.1.0.0 +mkValid + :: String + -> TH.Name + -> TH.DecsQ +mkValid funName typeName = do + let funName' = TH.mkName funName + resultType = pure $ TH.ConT typeName +#if __GLASGOW_HASKELL__ >= 900 + funType <- + [t| + forall m . (MonadFail m, THS.Quote m) => + String -> THS.Code m $resultType + |] +#else + funType <- [t| String -> TH.Q (TH.TExp $resultType) |] +#endif + body <- [| validOf (Proxy :: Proxy $resultType) |] + return + [ TH.SigD funName' funType + , TH.FunD funName' [TH.Clause [] (TH.NormalB body) []] + ] + +-- | Validate a constant at compile-time using a 'Parse' instance +-- +-- This function requires a 'Proxy' of the result type. Use 'mkUntypedValid' +-- to avoid having to pass a 'Proxy' during constant definition. +-- +-- This function parses the 'String' at compile-time and fails compilation on +-- error. When valid, the 'String' is compiled in, to be parsed again at +-- run-time. Since the result is not compiled in, no 'THS.Lift' instance is +-- required. +-- +-- See the @uvalidof@ example program in the @ttc-examples@ directory of the +-- source repository. The following is example usage from the @uvalidof@ +-- example: +-- +-- @ +-- sample :: Username +-- sample = $(TTC.untypedValidOf (Proxy :: Proxy Username) "tcard") +-- @ +-- +-- @since 0.2.0.0 +untypedValidOf + :: Parse a + => Proxy a + -> String + -> TH.ExpQ +untypedValidOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of + Right{} -> [| parseUnsafeS s |] + Left err -> fail $ "Invalid constant: " ++ err + +-- | Make a @valid@ function using 'untypedValidOf' for the given type +-- +-- Create a @valid@ function for a type in order to avoid having to write a +-- 'Proxy' when defining constants. +-- +-- See the @mkuvalid@ example program in the @ttc-examples@ directory of the +-- source repository. The following is example usage from the @mkuvalid@ +-- example: +-- +-- @ +-- \$(TTC.mkUntypedValid "valid" ''Username) +-- @ +-- +-- The created @valid@ function can then be used as follows: +-- +-- @ +-- sample :: Username +-- sample = $(Username.valid "tcard") +-- @ +-- +-- @since 0.2.0.0 +mkUntypedValid + :: String + -> TH.Name + -> TH.DecsQ +mkUntypedValid funName typeName = do + let funName' = TH.mkName funName + resultType = pure $ TH.ConT typeName + funType <- [t| String -> TH.ExpQ |] + body <- [| untypedValidOf (Proxy :: Proxy $resultType) |] + return + [ TH.SigD funName' funType + , TH.FunD funName' [TH.Clause [] (TH.NormalB body) []] + ] + +-- | Make a @valid@ quasi-quoter using 'untypedValidOf' for the given type +-- +-- See the @mkuvalidqq@ example program in the @ttc-examples@ directory of the +-- source repository. The following is example usage from the @mkuvalidqq@ +-- example: +-- +-- @ +-- \$(TTC.mkUntypedValidQQ "valid" ''Username) +-- @ +-- +-- The created @valid@ function can then be used as follows: +-- +-- @ +-- sample :: Username +-- sample = [Username.valid|tcard|] +-- @ +-- +-- @since 0.2.0.0 +mkUntypedValidQQ + :: String + -> TH.Name + -> TH.DecsQ +mkUntypedValidQQ funName typeName = do + let funName' = TH.mkName funName + resultType = pure $ TH.ConT typeName + expE <- [| untypedValidOf (Proxy :: Proxy $resultType) |] + expP <- [| error "pattern not supported" |] + expT <- [| error "type not supported" |] + expD <- [| error "declaration not supported" |] + let body = TH.NormalB $ TH.RecConE 'Q.QuasiQuoter + [ ('Q.quoteExp, expE) + , ('Q.quotePat, expP) + , ('Q.quoteType, expT) + , ('Q.quoteDec, expD) + ] + return + [ TH.SigD funName' $ TH.ConT ''Q.QuasiQuoter + , TH.FunD funName' [TH.Clause [] body []] + ] + +------------------------------------------------------------------------------ +-- $DefaultInstances +-- +-- These Template Haskell functions provide an easy way to load default +-- 'Render' and 'Parse' instances for common types. See the documentation for +-- 'Render' and 'Parse' for details about default instances. Remember that +-- loading such default instances should be avoided in libraries. + +-- | Load the default 'Render' instance for a type +-- +-- Example: +-- +-- @ +-- TTC.defaultRenderInstance ''Int +-- @ +-- +-- @since 1.5.0.0 +defaultRenderInstance :: TH.Name -> TH.DecsQ +defaultRenderInstance typeName = + let a = pure $ TH.ConT typeName + in [d| instance Render $a |] + +-- | Load the default 'Render' instances for any number of types +-- +-- Example: +-- +-- @ +-- TTC.defaultRenderInstances [''Int, ''Int8, ''Int16, ''Int32, ''Int64] +-- @ +-- +-- @since 1.5.0.0 +defaultRenderInstances :: [TH.Name] -> TH.DecsQ +defaultRenderInstances = fmap concat . mapM defaultRenderInstance + +-- | Load the default 'Parse' instance for a type +-- +-- Example: +-- +-- @ +-- TTC.defaultParseInstance ''Int +-- @ +-- +-- @since 1.5.0.0 +defaultParseInstance :: TH.Name -> TH.DecsQ +defaultParseInstance typeName = + let a = pure $ TH.ConT typeName + in [d| instance Parse $a |] + +-- | Load the default 'Parse' instances for any number of types +-- +-- Example: +-- +-- @ +-- TTC.defaultParseInstances [''Int, ''Int8, ''Int16, ''Int32, ''Int64] +-- @ +-- +-- @since 1.5.0.0 +defaultParseInstances :: [TH.Name] -> TH.DecsQ +defaultParseInstances = fmap concat . mapM defaultParseInstance + +-- | Load the default 'Render' and 'Parse' instance for a type +-- +-- Example: +-- +-- @ +-- TTC.defaultRenderAndParseInstance ''Int +-- @ +-- +-- @since 1.5.0.0 +defaultRenderAndParseInstance :: TH.Name -> TH.DecsQ +defaultRenderAndParseInstance typeName = do + -- NOTE This function is implemented this way for compatibility with old + -- versions of GHC/base. + renderDecs <- defaultRenderInstance typeName + parseDecs <- defaultParseInstance typeName + pure $ renderDecs ++ parseDecs + +-- | Load the default 'Render' and 'Parse' instances for any number of types +-- +-- Example: +-- +-- @ +-- TTC.defaultRenderAndParseInstances +-- [''Int, ''Int8, ''Int16, ''Int32, ''Int64] +-- @ +-- +-- @since 1.5.0.0 +defaultRenderAndParseInstances :: [TH.Name] -> TH.DecsQ +defaultRenderAndParseInstances = + fmap concat . mapM defaultRenderAndParseInstance diff --git a/src/Data/TTC/Wrapper.hs b/src/Data/TTC/Wrapper.hs new file mode 100644 --- /dev/null +++ b/src/Data/TTC/Wrapper.hs @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Data.TTC.Wrapper +-- Description : TTC wrapper types +-- Copyright : Copyright (c) 2019-2025 Travis Cardwell +-- License : MIT +-- +-- This module defines a @newtype@ wrapper for each 'TTC.Textual' data type. +-- Each wrapper has a 'TTC.Render' instance that converts the wrapped type and +-- a 'TTC.Parse' instance that wraps the argument (never failing). Data types +-- that are coercible to a 'TTC.Textual' data type can use these wrappers to +-- derive instances using @DerivingVia@. +-- +-- See the @wrapper@ example program in the @ttc-examples@ directory of the +-- source repository. +------------------------------------------------------------------------------ + +module Data.TTC.Wrapper + ( -- * Wrapper Types + WrapperS(..) + , WrapperT(..) + , WrapperTL(..) + , WrapperTLB(..) + , WrapperST(..) + , WrapperBS(..) + , WrapperBSL(..) + , WrapperBSB(..) + , WrapperSBS(..) + ) where + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +-- https://hackage.haskell.org/package/text-short +import qualified Data.Text.Short as ST + +-- (ttc) +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ + +-- | 'String' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperS = WrapperS { unWrapperS :: String } + +instance TTC.Parse WrapperS where + parse = TTC.asS $ pure . WrapperS + +instance TTC.Render WrapperS where + render = TTC.fromS . unWrapperS + +------------------------------------------------------------------------------ + +-- | Strict 'T.Text' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperT = WrapperT { unWrapperT :: T.Text } + +instance TTC.Parse WrapperT where + parse = TTC.asT $ pure . WrapperT + +instance TTC.Render WrapperT where + render = TTC.fromT . unWrapperT + +------------------------------------------------------------------------------ + +-- | Lazy 'TL.Text' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperTL = WrapperTL { unWrapperTL :: TL.Text } + +instance TTC.Parse WrapperTL where + parse = TTC.asTL $ pure . WrapperTL + +instance TTC.Render WrapperTL where + render = TTC.fromTL . unWrapperTL + +------------------------------------------------------------------------------ + +-- | Text 'TLB.Builder' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperTLB = WrapperTLB { unWrapperTLB :: TLB.Builder } + +instance TTC.Parse WrapperTLB where + parse = TTC.asTLB $ pure . WrapperTLB + +instance TTC.Render WrapperTLB where + render = TTC.fromTLB . unWrapperTLB + +------------------------------------------------------------------------------ + +-- | 'ST.ShortText' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperST = WrapperST { unWrapperST :: ST.ShortText } + +instance TTC.Parse WrapperST where + parse = TTC.asST $ pure . WrapperST + +instance TTC.Render WrapperST where + render = TTC.fromST . unWrapperST + +------------------------------------------------------------------------------ + +-- | Strict 'BS.ByteString' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperBS = WrapperBS { unWrapperBS :: BS.ByteString } + +instance TTC.Parse WrapperBS where + parse = TTC.asBS $ pure . WrapperBS + +instance TTC.Render WrapperBS where + render = TTC.fromBS . unWrapperBS + +------------------------------------------------------------------------------ + +-- | Lazy 'BSL.ByteString' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperBSL = WrapperBSL { unWrapperBSL :: BSL.ByteString } + +instance TTC.Parse WrapperBSL where + parse = TTC.asBSL $ pure . WrapperBSL + +instance TTC.Render WrapperBSL where + render = TTC.fromBSL . unWrapperBSL + +------------------------------------------------------------------------------ + +-- | ByteString 'BSB.Builder' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperBSB = WrapperBSB { unWrapperBSB :: BSB.Builder } + +instance TTC.Parse WrapperBSB where + parse = TTC.asBSB $ pure . WrapperBSB + +instance TTC.Render WrapperBSB where + render = TTC.fromBSB . unWrapperBSB + +------------------------------------------------------------------------------ + +-- | 'SBS.ShortByteString' wrapper type +-- +-- @since 1.5.0.0 +newtype WrapperSBS = WrapperSBS { unWrapperSBS :: SBS.ShortByteString } + +instance TTC.Parse WrapperSBS where + parse = TTC.asSBS $ pure . WrapperSBS + +instance TTC.Render WrapperSBS where + render = TTC.fromSBS . unWrapperSBS 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,1461 +1,994 @@ {-# LANGUAGE CPP #-} {-# 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 -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Short as SBS - --- https://hackage.haskell.org/package/tasty -import Test.Tasty (TestTree, testGroup) - --- https://hackage.haskell.org/package/tasty-hunit -import Test.Tasty.HUnit ((@=?), Assertion, assertFailure, testCase) - --- https://hackage.haskell.org/package/text -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB - --- https://hackage.haskell.org/package/text-short -import qualified Data.Text.Short as ST - --- (ttc) -import qualified Data.TTC as TTC - --- (ttc:test) -import qualified TestString -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 - -#if !MIN_VERSION_bytestring(0,11,1) -instance Show BSB.Builder where - show = show . BSB.toLazyByteString -#endif - ------------------------------------------------------------------------------- --- $HelperFunctions - -assertRaises - :: (HasCallStack, Exception e, Show a) - => Proxy e - -> a - -> Assertion -assertRaises proxy x = - handle - (const (return ()) . (`asProxyTypeOf` proxy)) - (assertFailure . ("expected exception; got: " ++) . show =<< evaluate x) - ------------------------------------------------------------------------------- --- $TestData - -xS :: String -xS = "test テスト" - -xT :: T.Text -xT = "test テスト" - -xTL :: TL.Text -xTL = "test テスト" - -xTLB :: TLB.Builder -xTLB = "test テスト" - -xST :: ST.ShortText -xST = "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" - -xBSB :: BSB.Builder -xBSB = "test テスト" - -xSBS :: SBS.ShortByteString -xSBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" - -xiS :: String -xiS = "test \xfffd" - -xiT :: T.Text -xiT = "test \xfffd" - -xiTL :: TL.Text -xiTL = "test \xfffd" - -xiTLB :: TLB.Builder -xiTLB = "test \xfffd" - -xiST :: ST.ShortText -xiST = "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 - -instance Show PosInt where - show (PosInt i) = "(PosInt " ++ show i ++ ")" - -instance TTC.Parse PosInt where - parse = TTC.asS $ \ s -> case readMaybe s of - Just i - | i >= 0 -> Right $ PosInt i - | otherwise -> Left $ TTC.fromS "not positive" - Nothing -> Left $ TTC.fromS "not an integer" - -instance TTC.Render PosInt where - render (PosInt i) = TTC.convert $ show i - -answer :: PosInt -answer = PosInt 42 - -answerS :: String -answerS = "42" - -answerT :: T.Text -answerT = "42" - -answerTL :: TL.Text -answerTL = "42" - -answerTLB :: TLB.Builder -answerTLB = "42" - -answerST :: ST.ShortText -answerST = "42" - -answerBS :: BS.ByteString -answerBS = "42" - -answerBSL :: BSL.ByteString -answerBSL = "42" - -answerBSB :: BSB.Builder -answerBSB = "42" - -answerSBS :: SBS.ShortByteString -answerSBS = "42" - -answerZ :: Int -answerZ = 42 - -data IntError = IntInvalid - deriving (Eq, Show) - ------------------------------------------------------------------------------- - -data Color - = Red - | Green - | Blue - | White - | Black - deriving (Bounded, Enum, Eq, Show) - -instance Read Color where - readsPrec _ = TTC.readsEnum True True - -instance TTC.Render Color where - render Red = TTC.fromT "red" - render Green = TTC.fromT "green" - render Blue = TTC.fromT "blue" - render White = TTC.fromT "white" - render Black = TTC.fromT "black" - -data ColorError - = ColorInvalid - | ColorAmbiguous - deriving (Eq, Show) - -redS :: String -redS = "red" - -redT :: T.Text -redT = "red" - -redTL :: TL.Text -redTL = "red" - -redTLB :: TLB.Builder -redTLB = "red" - -redST :: ST.ShortText -redST = "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) - -instance TTC.Parse PartialParser where - parse = TTC.asS $ \s -> do - when (null s) $ Left (TTC.fromT undefined) - pure $ PartialParser s - ------------------------------------------------------------------------------- --- $Textual - -testToS :: TestTree -testToS = testGroup "toS" - [ 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 "ST" $ xS @=? TTC.toS xST - , 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 -testToT = testGroup "toT" - [ 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 "ST" $ xT @=? TTC.toT xST - , 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 -testToTL = testGroup "toTL" - [ 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 "ST" $ xTL @=? TTC.toTL xST - , 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 "ST" $ xTLB @=? TTC.toTLB xST - , 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 - ] - -testToST :: TestTree -testToST = testGroup "toST" - [ testCase "S" $ xST @=? TTC.toST xS - , testCase "T" $ xST @=? TTC.toST xT - , testCase "TL" $ xST @=? TTC.toST xTL - , testCase "TLB" $ xST @=? TTC.toST xTLB - , testCase "ST" $ xST @=? TTC.toST xST - , testCase "BS" $ xST @=? TTC.toST xBS - , testCase "BS/invalid" $ xiST @=? TTC.toST xiBS - , testCase "BSL" $ xST @=? TTC.toST xBSL - , testCase "BSL/invalid" $ xiST @=? TTC.toST xiBSL - , testCase "BSB" $ xST @=? TTC.toST xBSB - , testCase "BSB/invalid" $ xiST @=? TTC.toST xiBSB - , testCase "SBS" $ xST @=? TTC.toST xSBS - , testCase "SBS/invalid" $ xiST @=? TTC.toST 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 "ST" $ xBS @=? TTC.toBS xST - , 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 -testToBSL = testGroup "toBSL" - [ 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 "ST" $ xBSL @=? TTC.toBSL xST - , 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 "ST" $ xBSB @=? TTC.toBSB xST - , 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 "ST" $ xSBS @=? TTC.toSBS xST - , 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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->ST" $ xST @=? 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 -testFromS = testGroup "fromS" - [ 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 "ST" $ xST @=? 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 -testFromT = testGroup "fromT" - [ 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 "ST" $ xST @=? 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 -testFromTL = testGroup "fromTL" - [ 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 "ST" $ xST @=? 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 "ST" $ xST @=? 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 "ST" $ xST @=? 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 -testFromBSL = testGroup "fromBSL" - [ 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 "ST" $ xST @=? 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 "ST" $ xST @=? 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 "ST" $ xST @=? 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 "ST" $ xS @=? TTC.asS id xST - , 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 -testAsT = testGroup "asT" - [ 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 "ST" $ xT @=? TTC.asT id xST - , 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 -testAsTL = testGroup "asTL" - [ 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 "ST" $ xTL @=? TTC.asTL id xST - , 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 "ST" $ xTLB @=? TTC.asTLB id xST - , 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 "ST" $ xBS @=? TTC.asBS id xST - , 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 -testAsBSL = testGroup "asBSL" - [ 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 "ST" $ xBSL @=? TTC.asBSL id xST - , 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 - ] - -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 "ST" $ xBSB @=? TTC.asBSB id xST - , 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 - ] - -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 "ST" $ xSBS @=? TTC.asSBS id xST - , 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 - -testRender :: TestTree -testRender = testGroup "render" - [ 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 "ST" $ answerST @=? 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 - -testRenderT :: TestTree -testRenderT = testCase "renderT" $ answerT @=? TTC.renderT answer - -testRenderTL :: TestTree -testRenderTL = testCase "renderTL" $ answerTL @=? TTC.renderTL answer - -testRenderTLB :: TestTree -testRenderTLB = testCase "renderTLB" $ answerTLB @=? TTC.renderTLB answer - -testRenderST :: TestTree -testRenderST = testCase "renderST" $ answerST @=? TTC.renderST answer - -testRenderBS :: TestTree -testRenderBS = testCase "renderBS" $ answerBS @=? TTC.renderBS answer - -testRenderBSL :: TestTree -testRenderBSL = testCase "renderBSL" $ answerBSL @=? TTC.renderBSL answer - -testRenderBSB :: TestTree -testRenderBSB = testCase "renderBSB" $ - answerBSL @=? BSB.toLazyByteString (TTC.renderBSB answer) - -testRenderSBS :: TestTree -testRenderSBS = testCase "renderSBS" $ answerSBS @=? TTC.renderSBS answer - -testRenderWithShow :: TestTree -testRenderWithShow = testGroup "renderWithShow" - [ 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 "ST" $ answerST @=? 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 - ] - ------------------------------------------------------------------------------- --- $Parse - -testParse :: TestTree -testParse = testGroup "parse" - [ 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 "ST" $ Just answer @=? TTC.parseMaybe answerST - , 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 = - let parseS = TTC.parseS :: String -> Either String PosInt - in testCase "parseS" $ Right answer @=? parseS answerS - -testParseT :: TestTree -testParseT = - let parseT = TTC.parseT :: T.Text -> Either String PosInt - in testCase "parseT" $ Right answer @=? parseT answerT - -testParseTL :: TestTree -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 - -testParseST :: TestTree -testParseST = - let parseST = TTC.parseST :: ST.ShortText -> Either String PosInt - in testCase "parseST" $ Right answer @=? parseST answerST - -testParseBS :: TestTree -testParseBS = - let parseBS = TTC.parseBS :: BS.ByteString -> Either String PosInt - in testCase "parseBS" $ Right answer @=? parseBS answerBS - -testParseBSL :: TestTree -testParseBSL = - 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 "ST" $ Just answer @=? TTC.parseMaybe answerST - , 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) - , testCase "negative" $ - Nothing @=? (TTC.parseMaybe ('-' : answerS) :: Maybe PosInt) - , testCase "invalid" $ - Nothing @=? (TTC.parseMaybe ('a' : answerS) :: Maybe PosInt) - ] - -testParseMaybeS :: TestTree -testParseMaybeS = testCase "parseMaybeS" $ - Just answer @=? TTC.parseMaybeS answerS - -testParseMaybeT :: TestTree -testParseMaybeT = testCase "parseMaybeT" $ - Just answer @=? TTC.parseMaybeT answerT - -testParseMaybeTL :: TestTree -testParseMaybeTL = testCase "parseMaybeTL" $ - Just answer @=? TTC.parseMaybeTL answerTL - -testParseMaybeTLB :: TestTree -testParseMaybeTLB = testCase "parseMaybeTLB" $ - Just answer @=? TTC.parseMaybeTLB answerTLB - -testParseMaybeST :: TestTree -testParseMaybeST = testCase "parseMaybeST" $ - Just answer @=? TTC.parseMaybeST answerST - -testParseMaybeBS :: TestTree -testParseMaybeBS = testCase "parseMaybeBS" $ - Just answer @=? TTC.parseMaybeBS answerBS - -testParseMaybeBSL :: TestTree -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 - -testParseOrFail :: TestTree -testParseOrFail = testGroup "parseOrFail" - [ testCase "S" $ Just answer @=? TTC.parseOrFail answerS - , testCase "T" $ Just answer @=? TTC.parseOrFail answerT - , testCase "TL" $ Just answer @=? TTC.parseOrFail answerTL - , testCase "TLB" $ Just answer @=? TTC.parseOrFail answerTLB - , testCase "ST" $ Just answer @=? TTC.parseOrFail answerST - , testCase "BS" $ Just answer @=? TTC.parseOrFail answerBS - , testCase "BSL" $ Just answer @=? TTC.parseOrFail answerBSL - , testCase "BSB" $ Just answer @=? TTC.parseOrFail answerBSB - , testCase "SBS" $ Just answer @=? TTC.parseOrFail answerSBS - -- successful 'parseOrFail' does not have any error type conversion: - , testCase "noerror" $ - Just (PartialParser "test") @=? TTC.parseOrFail ("test" :: String) - , testCase "negative" $ - Nothing @=? (TTC.parseOrFail ('-' : answerS) :: Maybe PosInt) - , testCase "invalid" $ - Nothing @=? (TTC.parseOrFail ('a' : answerS) :: Maybe PosInt) - ] - -testParseOrFailS :: TestTree -testParseOrFailS = testCase "parseOrFailS" $ - Just answer @=? TTC.parseOrFailS answerS - -testParseOrFailT :: TestTree -testParseOrFailT = testCase "parseOrFailT" $ - Just answer @=? TTC.parseOrFailT answerT - -testParseOrFailTL :: TestTree -testParseOrFailTL = testCase "parseOrFailTL" $ - Just answer @=? TTC.parseOrFailTL answerTL - -testParseOrFailTLB :: TestTree -testParseOrFailTLB = testCase "parseOrFailTLB" $ - Just answer @=? TTC.parseOrFailTLB answerTLB - -testParseOrFailST :: TestTree -testParseOrFailST = testCase "parseOrFailST" $ - Just answer @=? TTC.parseOrFailST answerST - -testParseOrFailBS :: TestTree -testParseOrFailBS = testCase "parseOrFailBS" $ - Just answer @=? TTC.parseOrFailBS answerBS - -testParseOrFailBSL :: TestTree -testParseOrFailBSL = testCase "parseOrFailBSL" $ - Just answer @=? TTC.parseOrFailBSL answerBSL - -testParseOrFailBSB :: TestTree -testParseOrFailBSB = testCase "parseOrFailBSB" $ - Just answer @=? TTC.parseOrFailBSB answerBSB - -testParseOrFailSBS :: TestTree -testParseOrFailSBS = testCase "parseOrFailSBS" $ - Just answer @=? TTC.parseOrFailSBS 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 "ST" $ answer @=? TTC.parseUnsafe answerST - , 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) - (TTC.parseUnsafe ('a' : answerS) :: PosInt) - ] - -testParseUnsafeS :: TestTree -testParseUnsafeS = testCase "parseUnsafeS" $ - answer @=? TTC.parseUnsafeS answerS - -testParseUnsafeT :: TestTree -testParseUnsafeT = testCase "parseUnsafeT" $ - answer @=? TTC.parseUnsafeT answerT - -testParseUnsafeTL :: TestTree -testParseUnsafeTL = testCase "parseUnsafeTL" $ - answer @=? TTC.parseUnsafeTL answerTL - -testParseUnsafeTLB :: TestTree -testParseUnsafeTLB = testCase "parseUnsafeTLB" $ - answer @=? TTC.parseUnsafeTLB answerTLB - -testParseUnsafeST :: TestTree -testParseUnsafeST = testCase "parseUnsafeST" $ - answer @=? TTC.parseUnsafeST answerST - -testParseUnsafeBS :: TestTree -testParseUnsafeBS = testCase "parseUnsafeBS" $ - answer @=? TTC.parseUnsafeBS answerBS - -testParseUnsafeBSL :: TestTree -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 - -testWithError :: TestTree -testWithError = testGroup "withError" - [ testCase "OK" $ Right answer @=? - (TTC.withError undefString (Just answer) :: Either T.Text PosInt) - , testCase "S" $ Left "err" @=? - (TTC.withErrorS "err" Nothing :: Either T.Text PosInt) - , testCase "T" $ Left "err" @=? - (TTC.withErrorT "err" Nothing :: Either String PosInt) - , testCase "TL" $ Left "err" @=? - (TTC.withErrorTL "err" Nothing :: Either String PosInt) - , testCase "TLB" $ Left "err" @=? - (TTC.withErrorTLB "err" Nothing :: Either String PosInt) - , testCase "ST" $ Left "err" @=? - (TTC.withErrorST "err" Nothing :: Either String PosInt) - , testCase "BS" $ Left "err" @=? - (TTC.withErrorBS "err" Nothing :: Either String PosInt) - , testCase "BSL" $ Left "err" @=? - (TTC.withErrorBSL "err" Nothing :: Either String PosInt) - , testCase "BSB" $ Left "err" @=? - (TTC.withErrorBSB "err" Nothing :: Either String PosInt) - , testCase "SBS" $ Left "err" @=? - (TTC.withErrorSBS "err" Nothing :: Either String PosInt) - ] - where - undefString :: String - undefString = undefined - -testPrefixError :: TestTree -testPrefixError = testGroup "prefixError" - [ testCase "OK" $ Right answer @=? - (TTC.prefixError undefString (Right answer) :: Either String PosInt) - , testCase "S" $ Left err @=? - (TTC.prefixErrorS "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "T" $ Left err @=? - (TTC.prefixErrorT "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "TL" $ Left err @=? - (TTC.prefixErrorTL "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "TLB" $ Left err @=? - (TTC.prefixErrorTLB "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "ST" $ Left err @=? - (TTC.prefixErrorTLB "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "BS" $ Left err @=? - (TTC.prefixErrorTL "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "BSL" $ Left err @=? - (TTC.prefixErrorTL "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "BSB" $ Left err @=? - (TTC.prefixErrorTL "error: " (Left "uh-oh") :: Either String PosInt) - , testCase "SBS" $ Left err @=? - (TTC.prefixErrorTL "error: " (Left "uh-oh") :: Either String PosInt) - ] - where - undefString, err :: String - undefString = undefined - err = "error: uh-oh" - -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 "ST" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerST - , 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 @=? parseWithRead' answerS - , testCase "T" $ Right answerZ @=? parseWithRead' answerT - , testCase "TL" $ Right answerZ @=? parseWithRead' answerTL - , testCase "TLB" $ Right answerZ @=? parseWithRead' answerTLB - , testCase "ST" $ Right answerZ @=? parseWithRead' answerST - , 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 "ST" $ Just answerZ @=? TTC.maybeParseWithRead answerST - , 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) - ] - -testParseEnum :: TestTree -testParseEnum = testGroup "parseEnum" - [ 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 "ST" $ Right Red @=? parse False False redST - , 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) - , testCase "prefix" $ Right Red @=? parse False True ("r" :: String) - , testCase "ambiguous" $ Left ColorAmbiguous @=? - parse False True ("bl" :: String) - ] - where - parse :: TTC.Textual t => Bool -> Bool -> t -> Either ColorError Color - parse allowCI allowPrefix = - TTC.parseEnum allowCI allowPrefix ColorInvalid ColorAmbiguous - -testParseEnum' :: TestTree -testParseEnum' = testGroup "parseEnum'" - [ 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 "ST" $ Right Red @=? parse False False redST - , 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) - , testCase "prefix" $ Right Red @=? parse False True ("r" :: String) - , testCase "ambiguous" $ Left "ambiguous Color" @=? - parse False True ("bl" :: String) - ] - where - parse :: TTC.Textual t => Bool -> Bool -> t -> Either String Color - parse = TTC.parseEnum' "Color" - -testReadsWithParse :: TestTree -testReadsWithParse = testGroup "readsWithParse" - [ testCase "valid" $ [(answer, "")] @=? TTC.readsWithParse answerS - , testCase "invalid" $ [] @=? (TTC.readsWithParse :: ReadS PosInt) "-42" - ] - -testReadsEnum :: TestTree -testReadsEnum = testGroup "readsEnum" - [ testCase "valid" $ Just Red @=? readMaybe "R" - , testCase "invalid" $ Nothing @=? (readMaybe "bl" :: Maybe Color) - ] - ------------------------------------------------------------------------------- --- $Valid - -testValid :: TestTree -testValid = testCase "valid" $ TestString "test" @=? validConst - where - validConst :: TestString - validConst = $$(TTC.valid "test") - -testValidIsString :: TestTree -testValidIsString = - testCase "validIsString" $ TestString "test" @=? validConst - where - validConst :: TestString - validConst = $$("test") - -testValidOf :: TestTree -testValidOf = testCase "validOf" $ - TestString "test" @=? $$(TTC.validOf (Proxy :: Proxy TestString) "test") - -testMkValid :: TestTree -testMkValid = testCase "mkValid" $ - TestString "test" @=? $$(TestString.valid "test") - -testUntypedValidOf :: TestTree -testUntypedValidOf = testCase "untypedValidOf" $ - TestString "test" @=? - $(TTC.untypedValidOf (Proxy :: Proxy TestString) "test") - -testMkUntypedValid :: TestTree -testMkUntypedValid = testCase "mkUntypedValid" $ - TestString "test" @=? $(TestString.untypedValid "test") - -testMkUntypedValidQQ :: TestTree -testMkUntypedValidQQ = testCase "mkUntypedValidQQ" $ - TestString "test" @=? [TestString.untypedValidQQ|test|] - ------------------------------------------------------------------------------- - -tests :: TestTree -tests = testGroup "Data.TTC" - [ testGroup "Textual" - [ testToS - , testToT - , testToTL - , testToTLB - , testToST - , testToBS - , testToBSL - , testToBSB - , testToSBS - , testConvert - , testFromS - , testFromT - , testFromTL - , testFromTLB - , testFromBS - , testFromBSL - , testFromBSB - , testFromSBS - , testAsS - , testAsT - , testAsTL - , testAsTLB - , testAsBS - , testAsBSL - , testAsBSB - , testAsSBS - ] - , testGroup "Render" - [ testRender - , testRenderDefault - , testRenderS - , testRenderT - , testRenderTL - , testRenderTLB - , testRenderST - , testRenderBS - , testRenderBSL - , testRenderBSB - , testRenderSBS - , testRenderWithShow - ] - , testGroup "Parse" - [ testParse - , testParseDefault - , testParseS - , testParseT - , testParseTL - , testParseTLB - , testParseST - , testParseBS - , testParseBSL - , testParseBSB - , testParseSBS - , testParseMaybe - , testParseMaybeS - , testParseMaybeT - , testParseMaybeTL - , testParseMaybeTLB - , testParseMaybeST - , testParseMaybeBS - , testParseMaybeBSL - , testParseMaybeBSB - , testParseMaybeSBS - , testParseOrFail - , testParseOrFailS - , testParseOrFailT - , testParseOrFailTL - , testParseOrFailTLB - , testParseOrFailST - , testParseOrFailBS - , testParseOrFailBSL - , testParseOrFailBSB - , testParseOrFailSBS - , testParseUnsafe - , testParseUnsafeS - , testParseUnsafeT - , testParseUnsafeTL - , testParseUnsafeTLB - , testParseUnsafeST - , testParseUnsafeBS - , testParseUnsafeBSL - , testParseUnsafeBSB - , testParseUnsafeSBS - , testWithError - , testPrefixError - , testParseWithRead - , testParseWithRead' - , testMaybeParseWithRead - , testParseEnum - , testParseEnum' +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +{-# 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 Data.Int (Int8, Int16, Int32, Int64) +import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +import Data.String (IsString) +import Data.Word (Word8, Word16, Word32, Word64) +import GHC.Stack (HasCallStack) +import Text.Read (readMaybe) + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (TestName, TestTree, testGroup) + +-- https://hackage.haskell.org/package/tasty-hunit +import Test.Tasty.HUnit ((@=?), Assertion, assertFailure, testCase) + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB + +-- https://hackage.haskell.org/package/text-short +import qualified Data.Text.Short as ST + +-- (ttc) +import qualified Data.TTC as TTC + +-- (ttc:test) +import qualified TestTypes.Ex as Ex +import TestTypes.Ex (Ex(Ex)) + +------------------------------------------------------------------------------ +-- $Instances + +TTC.defaultRenderAndParseInstances + [ ''Bool, ''Char, ''Double, ''Float, ''Integer + , ''Int, ''Int8, ''Int16, ''Int32, ''Int64 + , ''Word, ''Word8, ''Word16, ''Word32, ''Word64 + , ''String + , ''T.Text, ''TL.Text, ''TLB.Builder, ''ST.ShortText + , ''BS.ByteString, ''BSL.ByteString, ''BSB.Builder, ''SBS.ShortByteString + ] + +------------------------------------------------------------------------------ + +instance Eq BSB.Builder where + x == y = BSB.toLazyByteString x == BSB.toLazyByteString y + +#if !MIN_VERSION_bytestring(0,11,1) +instance Show BSB.Builder where + show = show . BSB.toLazyByteString +#endif + +------------------------------------------------------------------------------ +-- $HelperFunctions + +assertRaises + :: (HasCallStack, Exception e, Show a) + => Proxy e + -> a + -> Assertion +assertRaises proxy x = + handle + (const (return ()) . (`asProxyTypeOf` proxy)) + (assertFailure . ("expected exception; got: " ++) . show =<< evaluate x) + +------------------------------------------------------------------------------ +-- $TestData + +xS :: String +xS = "test テスト" + +xT :: T.Text +xT = "test テスト" + +xTL :: TL.Text +xTL = "test テスト" + +xTLB :: TLB.Builder +xTLB = "test テスト" + +xST :: ST.ShortText +xST = "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" + +xBSB :: BSB.Builder +xBSB = "test テスト" + +xSBS :: SBS.ShortByteString +xSBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" + +-- U+FFFD is the Unicode replacement character +xiS :: String +xiS = "test \xfffd" + +xiT :: T.Text +xiT = T.pack xiS + +xiTL :: TL.Text +xiTL = TL.pack xiS + +xiTLB :: TLB.Builder +xiTLB = TLB.fromString xiS + +xiST :: ST.ShortText +xiST = ST.pack xiS + +-- Lone continuation byte is invalid +xiBS :: BS.ByteString +xiBS = "test \xe3" + +xiBSL :: BSL.ByteString +xiBSL = BSL.fromStrict xiBS + +xiBSB :: BSB.Builder +xiBSB = BSB.byteString xiBS + +xiSBS :: SBS.ShortByteString +xiSBS = SBS.toShort xiBS + +------------------------------------------------------------------------------ + +newtype PosInt = PosInt Int + deriving (Eq, Show) + +instance TTC.Parse PosInt where + parse = TTC.asS $ \ s -> case readMaybe s of + Just i + | i >= 0 -> Right $ PosInt i + | otherwise -> Left $ TTC.fromS "not positive" + Nothing -> Left $ TTC.fromS "not an integer" + +instance TTC.Render PosInt where + render (PosInt i) = TTC.convert $ show i + +answer :: PosInt +answer = PosInt 42 + +answerS :: String +answerS = "42" + +answerT :: T.Text +answerT = "42" + +answerTL :: TL.Text +answerTL = "42" + +answerTLB :: TLB.Builder +answerTLB = "42" + +answerST :: ST.ShortText +answerST = "42" + +answerBS :: BS.ByteString +answerBS = "42" + +answerBSL :: BSL.ByteString +answerBSL = "42" + +answerBSB :: BSB.Builder +answerBSB = "42" + +answerSBS :: SBS.ShortByteString +answerSBS = "42" + +answerZ :: Int +answerZ = 42 + +data IntError = IntInvalid + deriving (Eq, Show) + +------------------------------------------------------------------------------ + +data Color + = Red + | Green + | Blue + | White + | Black + deriving (Bounded, Enum, Eq, Show) + +instance Read Color where + readsPrec _ = TTC.readsEnum True True + +instance TTC.Render Color where + render = TTC.fromT . \case + Red -> "red" + Green -> "green" + Blue -> "blue" + White -> "white" + Black -> "black" + +data ColorError + = ColorInvalid + | ColorAmbiguous + deriving (Eq, Show) + +redS :: String +redS = "red" + +redT :: T.Text +redT = "red" + +redTL :: TL.Text +redTL = "red" + +redTLB :: TLB.Builder +redTLB = "red" + +redST :: ST.ShortText +redST = "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) + +instance TTC.Parse PartialParser where + parse = TTC.asS $ \case + "" -> Left $ TTC.fromT undefined + s -> Right $ PartialParser s + +------------------------------------------------------------------------------ +-- $Textual + +testConvert :: TestTree +testConvert = testGroup "convert" $ + [ testCase "@@" $ + "test テスト" @=? TTC.convert @String @String "test テスト" + , testCase "@_" $ xT @=? TTC.convert @String "test テスト" + , testCase "_@" $ "test テスト" @=? TTC.convert @_ @TL.Text xT + ] + ++ mkTests "S" xS + ++ mkTests "T" xT + ++ mkTests "TL" xTL + ++ mkTests "TLB" xTLB + ++ mkTests "ST" xST + ++ mkTests "BS" xBS + ++ mkTests "BSL" xBSL + ++ mkTests "BSB" xBSB + ++ mkTests "SBS" xSBS + where + mkTests :: TTC.Textual a => String -> a -> [TestTree] + mkTests s x = + [ testCase (s ++ "->S") $ xS @=? TTC.convert x + , testCase (s ++ "->T") $ xT @=? TTC.convert x + , testCase (s ++ "->TL") $ xTL @=? TTC.convert x + , testCase (s ++ "->TLB") $ xTLB @=? TTC.convert x + , testCase (s ++ "->ST") $ xST @=? TTC.convert x + , testCase (s ++ "->BS") $ xBS @=? TTC.convert x + , testCase (s ++ "->BSL") $ xBSL @=? TTC.convert x + , testCase (s ++ "->BSB") $ xBSB @=? TTC.convert x + , testCase (s ++ "->SBS") $ xSBS @=? TTC.convert x + ] + +------------------------------------------------------------------------------ + +testToX :: TestTree +testToX = testGroup "to*" + [ mkTests "toS" TTC.toS xS xiS + , mkTests "toT" TTC.toT xT xiT + , mkTests "toTL" TTC.toTL xTL xiTL + , mkTests "toTLB" TTC.toTLB xTLB xiTLB + , mkTests "toST" TTC.toST xST xiST + , mkTests "toBS" TTC.toBS xBS xiBS + , mkTests "toBSL" TTC.toBSL xBSL xiBSL + , mkTests "toBSB" TTC.toBSB xBSB xiBSB + , mkTests "toSBS" TTC.toSBS xSBS xiSBS + ] + where + mkTests + :: (Eq a, Show a) + => TestName + -> (forall t. TTC.Textual t => t -> a) + -> a + -> a + -> TestTree + mkTests testName f x xi = testGroup testName + [ testCase "@" $ x @=? f @T.Text "test テスト" + , testCase "S" $ x @=? f xS + , testCase "T" $ x @=? f xT + , testCase "TL" $ x @=? f xTL + , testCase "TLB" $ x @=? f xTLB + , testCase "ST" $ x @=? f xST + , testCase "BS" $ x @=? f xBS + , testCase "BSL" $ x @=? f xBSL + , testCase "BSB" $ x @=? f xBSB + , testCase "SBS" $ x @=? f xSBS + , testCase "BS/invalid" $ xi @=? f xiBS + , testCase "BSL/invalid" $ xi @=? f xiBSL + , testCase "BSB/invalid" $ xi @=? f xiBSB + , testCase "SBS/invalid" $ xi @=? f xiSBS + ] + +------------------------------------------------------------------------------ + +testFromX :: TestTree +testFromX = testGroup "from*" + [ mkTests "fromS" TTC.fromS xS Nothing + , mkTests "fromT" TTC.fromT xT Nothing + , mkTests "fromTL" TTC.fromTL xTL Nothing + , mkTests "fromTLB" TTC.fromTLB xTLB Nothing + , mkTests "fromST" TTC.fromST xST Nothing + , mkTests "fromBS" TTC.fromBS xBS (Just xiBS) + , mkTests "fromBSL" TTC.fromBSL xBSL (Just xiBSL) + , mkTests "fromBSB" TTC.fromBSB xBSB (Just xiBSB) + , mkTests "fromSBS" TTC.fromSBS xSBS (Just xiSBS) + ] + where + mkTests + :: (Eq a, Show a) + => TestName + -> (forall t. TTC.Textual t => a -> t) + -> a + -> Maybe a + -> TestTree + mkTests testName f x mXi = testGroup testName $ + [ testCase "@" $ "test テスト" @=? f @String x + , testCase "S" $ xS @=? f x + , testCase "T" $ xT @=? f x + , testCase "TL" $ xTL @=? f x + , testCase "TLB" $ xTLB @=? f x + , testCase "ST" $ xST @=? f x + , testCase "BS" $ xBS @=? f x + , testCase "BSL" $ xBSL @=? f x + , testCase "BSB" $ xBSB @=? f x + , testCase "SBS" $ xSBS @=? f x + ] ++ + case mXi of + Nothing -> [] + Just xi -> + [ testCase "S/Invalid" $ xiS @=? f xi + , testCase "T/Invalid" $ xiT @=? f xi + , testCase "TL/Invalid" $ xiTL @=? f xi + , testCase "TLB/Invalid" $ xiTLB @=? f xi + , testCase "ST/Invalid" $ xiST @=? f xi + , testCase "BS/Invalid" $ xiBS @=? f xi + , testCase "BSL/Invalid" $ xiBSL @=? f xi + , testCase "BSB/Invalid" $ xiBSB @=? f xi + , testCase "SBS/Invalid" $ xiSBS @=? f xi + ] + +------------------------------------------------------------------------------ + +testAsX :: TestTree +testAsX = testGroup "as*" + [ mkTests "asS" TTC.asS xS xiS + , mkTests "asT" TTC.asT xT xiT + , mkTests "asTL" TTC.asTL xTL xiTL + , mkTests "asTLB" TTC.asTLB xTLB xiTLB + , mkTests "asST" TTC.asST xST xiST + , mkTests "asBS" TTC.asBS xBS xiBS + , mkTests "asBSL" TTC.asBSL xBSL xiBSL + , mkTests "asBSB" TTC.asBSB xBSB xiBSB + , mkTests "asSBS" TTC.asSBS xSBS xiSBS + ] + where + mkTests + :: (Eq a, Show a) + => TestName + -> (forall t. TTC.Textual t => (a -> a) -> t -> a) + -> a + -> a + -> TestTree + mkTests testName f x xi = testGroup testName + [ testCase "@" $ x @=? f @T.Text id "test テスト" + , testCase "S" $ x @=? f id xS + , testCase "T" $ x @=? f id xT + , testCase "TL" $ x @=? f id xTL + , testCase "TLB" $ x @=? f id xTLB + , testCase "ST" $ x @=? f id xST + , testCase "BS" $ x @=? f id xBS + , testCase "BSL" $ x @=? f id xBSL + , testCase "BSB" $ x @=? f id xBSB + , testCase "SBS" $ x @=? f id xSBS + , testCase "BS/invalid" $ xi @=? f id xiBS + , testCase "BSL/invalid" $ xi @=? f id xiBSL + , testCase "BSB/invalid" $ xi @=? f id xiBSB + , testCase "SBS/invalid" $ xi @=? f id xiSBS + ] + +------------------------------------------------------------------------------ +-- $Render + +testRender :: TestTree +testRender = testGroup "render" + [ testCase "_@" $ "42" @=? TTC.render @_ @String answer + , 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 "ST" $ answerST @=? 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 "Bool" $ "True" @=? TTC.renderS True + , testCase "Char" $ "*" @=? TTC.renderS '*' + , mkTestShow @Double "Double" 3.14159 + , mkTestShow @Float "Float" 3.14159 + , mkTestShow @Integer "Integer" 42 + , mkTestShow @Int "Int" 42 + , mkTestShow @Int8 "Int8" 42 + , mkTestShow @Int16 "Int16" 42 + , mkTestShow @Int32 "Int32" 42 + , mkTestShow @Int64 "Int64" 42 + , mkTestShow @Word "Word" 42 + , mkTestShow @Word8 "Word8" 42 + , mkTestShow @Word16 "Word16" 42 + , mkTestShow @Word32 "Word32" 42 + , mkTestShow @Word64 "Word64" 42 + , testCase "String" $ xS @=? TTC.renderS xS + , testCase "T.Text" $ xS @=? TTC.renderS xT + , testCase "TL.Text" $ xS @=? TTC.renderS xTL + , testCase "TLB.Builder" $ xS @=? TTC.renderS xTLB + , testCase "ST.ShortText" $ xS @=? TTC.renderS xST + , testCase "BS.ByteString" $ xS @=? TTC.renderS xBS + , testCase "BSL.ByteString" $ xS @=? TTC.renderS xBSL + , testCase "BSB.Builder" $ xS @=? TTC.renderS xBSB + , testCase "SBS.ShortByteString" $ xS @=? TTC.renderS xSBS + ] + where + mkTestShow :: (Show a, TTC.Render a) => TestName -> a -> TestTree + mkTestShow testName x = testCase testName $ show x @=? TTC.renderS x + +------------------------------------------------------------------------------ + +testRenderWithShow :: TestTree +testRenderWithShow = testGroup "renderWithShow" + [ testCase "@" $ "42" @=? TTC.renderWithShow @String answerZ + , 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 "ST" $ answerST @=? 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 + ] + +------------------------------------------------------------------------------ + +testRenderX :: TestTree +testRenderX = testGroup "render*" + [ testCase "renderS" $ answerS @=? TTC.renderS answer + , testCase "renderT" $ answerT @=? TTC.renderT answer + , testCase "renderTL" $ answerTL @=? TTC.renderTL answer + , testCase "renderTLB" $ answerTLB @=? TTC.renderTLB answer + , testCase "renderST" $ answerST @=? TTC.renderST answer + , testCase "renderBS" $ answerBS @=? TTC.renderBS answer + , testCase "renderBSL" $ answerBSL @=? TTC.renderBSL answer + , testCase "renderBSB" $ answerBSB @=? TTC.renderBSB answer + , testCase "renderSBS" $ answerSBS @=? TTC.renderSBS answer + ] + +------------------------------------------------------------------------------ +-- $Parse + +testParse :: TestTree +testParse = testGroup "parse" + [ testCase "_@@" $ Right answer @=? TTC.parse @_ @String @String "42" + , testCase "S" $ Right answer @=? parse answerS + , testCase "T" $ Right answer @=? parse answerT + , testCase "TL" $ Right answer @=? parse answerTL + , testCase "TLB" $ Right answer @=? parse answerTLB + , testCase "ST" $ Right answer @=? parse answerST + , testCase "BS" $ Right answer @=? parse answerBS + , testCase "BSL" $ Right answer @=? parse answerBSL + , testCase "BSB" $ Right answer @=? parse answerBSB + , testCase "SBS" $ Right answer @=? parse answerSBS + , testCase "negative" $ Left "not positive" @=? parse @String "-42" + , testCase "invalid" $ Left "not an integer" @=? parse @String "4a2" + ] + where + parse :: TTC.Textual t => t -> Either String PosInt + parse = TTC.parse + +------------------------------------------------------------------------------ + +testParseDefault :: TestTree +testParseDefault = testGroup "ParseDefault" + [ testGroup "Bool" + [ testCase "True" $ Right True @=? parse "True" + , testCase "False" $ Right False @=? parse "False" + , testCase "invalid" $ Left "invalid Bool" @=? parse @Bool "false" + ] + , testGroup "Char" + [ testCase "valid" $ Right '*' @=? parse "*" + , testCase "empty" $ Left "invalid Char" @=? parse @Char "" + , testCase "multiple" $ Left "invalid Char" @=? parse @Char "**" + ] + , mkTestsShow @Double "Double" 3.14159 + , mkTestsShow @Float "Float" 3.14159 + , mkTestsShow @Integer "Integer" 42 + , mkTestsShow @Int "Int" 42 + , mkTestsShow @Int8 "Int8" 42 + , mkTestsShow @Int16 "Int16" 42 + , mkTestsShow @Int32 "Int32" 42 + , mkTestsShow @Int64 "Int64" 42 + , mkTestsShow @Word "Word" 42 + , mkTestsShow @Word8 "Word8" 42 + , mkTestsShow @Word16 "Word16" 42 + , mkTestsShow @Word32 "Word32" 42 + , mkTestsShow @Word64 "Word64" 42 + , mkTestsTextual @String "String" xS + , mkTestsTextual @T.Text "T.Text" xT + , mkTestsTextual @TL.Text "TL.Text" xTL + , mkTestsTextual @TLB.Builder "TLB.Builder" xTLB + , mkTestsTextual @ST.ShortText "ST.ShortText" xST + , mkTestsTextual @BS.ByteString "BS.ByteString" xBS + , mkTestsTextual @BSL.ByteString "BSL.ByteString" xBSL + , mkTestsTextual @BSB.Builder "BSB.Builder" xBSB + , mkTestsTextual @SBS.ShortByteString "SBS.ShortByteString" xSBS + ] + where + mkTestsShow + :: forall a. (Eq a, Show a, TTC.Parse a) + => TestName + -> a + -> TestTree + mkTestsShow testName x = testGroup testName + [ testCase "valid" $ Right x @=? parse (show x) + , testCase "invalid" $ + Left ("invalid " ++ testName) @=? parse @a "invalid" + ] + + mkTestsTextual + :: forall a. (Eq a, IsString a, Show a, TTC.Parse a) + => TestName + -> a + -> TestTree + mkTestsTextual testName x = testGroup testName + [ testCase "empty" $ Right "" @=? parse @a "" + , testCase "nonempty" $ Right x @=? parse xS + ] + + parse :: TTC.Parse a => String -> Either String a + parse = TTC.parse + +------------------------------------------------------------------------------ + +testWithError :: TestTree +testWithError = testGroup "withError" + [ testCase "valid" $ + Right answer @=? TTC.withError @String @String undefined (Just answer) + , testCase "invalid" $ + Left "err" @=? TTC.withError @String @String @PosInt "err" Nothing + ] + +testWithErrorX :: TestTree +testWithErrorX = testGroup "withError*" + [ mkTests "withErrorS" TTC.withErrorS + , mkTests "withErrorT" TTC.withErrorT + , mkTests "withErrorTL" TTC.withErrorTL + , mkTests "withErrorTLB" TTC.withErrorTLB + , mkTests "withErrorST" TTC.withErrorST + , mkTests "withErrorBS" TTC.withErrorBS + , mkTests "withErrorBSL" TTC.withErrorBSL + , mkTests "withErrorBSB" TTC.withErrorBSB + , mkTests "withErrorSBS" TTC.withErrorSBS + ] + where + mkTests + :: IsString e' + => TestName + -> (e' -> Maybe PosInt -> Either String PosInt) + -> TestTree + mkTests testName f = testGroup testName + [ testCase "valid" $ Right answer @=? f undefined (Just answer) + , testCase "invalid" $ Left "err" @=? f "err" Nothing + ] + +------------------------------------------------------------------------------ + +testPrefixError :: TestTree +testPrefixError = testGroup "prefixError" + [ testCase "valid" $ + Right answer + @=? TTC.prefixError @String @String "oops: " (Right answer) + , testCase "invalid" $ + Left "oops: err" + @=? TTC.prefixError @String @String @PosInt "oops: " (Left "err") + ] + +testPrefixErrorX :: TestTree +testPrefixErrorX = testGroup "prefixError*" + [ mkTests "prefixErrorS" TTC.prefixErrorS + , mkTests "prefixErrorT" TTC.prefixErrorT + , mkTests "prefixErrorTL" TTC.prefixErrorTL + , mkTests "prefixErrorTLB" TTC.prefixErrorTLB + , mkTests "prefixErrorST" TTC.prefixErrorST + , mkTests "prefixErrorBS" TTC.prefixErrorBS + , mkTests "prefixErrorBSL" TTC.prefixErrorBSL + , mkTests "prefixErrorBSB" TTC.prefixErrorBSB + , mkTests "prefixErrorSBS" TTC.prefixErrorSBS + ] + where + mkTests + :: IsString e' + => TestName + -> (e' -> Either e' PosInt -> Either String PosInt) + -> TestTree + mkTests testName f = testGroup testName + [ testCase "valid" $ Right answer @=? f "oops: " (Right answer) + , testCase "invalid" $ Left "oops: err" @=? f "oops: " (Left "err") + ] + +------------------------------------------------------------------------------ + +testParseWithRead :: TestTree +testParseWithRead = testGroup "parseWithRead" + [ testCase "@" $ + Right answerZ @=? TTC.parseWithRead @String IntInvalid "42" + , 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 "ST" $ Right answerZ @=? parseWithRead answerST + , 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 IntInvalid @=? parseWithRead @String "4a2" + ] + where + parseWithRead :: TTC.Textual t => t -> Either IntError Int + parseWithRead = TTC.parseWithRead IntInvalid + +testParseWithRead' :: TestTree +testParseWithRead' = testGroup "parseWithRead'" + [ testCase "@" $ + Right answerZ @=? TTC.parseWithRead' @String @String "Int" "42" + , 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 "ST" $ Right answerZ @=? parseWithRead' answerST + , 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' @String "4a2" + ] + where + parseWithRead' :: TTC.Textual t => t -> Either String Int + parseWithRead' = TTC.parseWithRead' "Int" + +testMaybeParseWithRead :: TestTree +testMaybeParseWithRead = testGroup "maybeParseWithRead" + [ testCase "@" $ Just answerZ @=? TTC.maybeParseWithRead @String "42" + , 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 "ST" $ Just answerZ @=? TTC.maybeParseWithRead answerST + , 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 @String @Int "4a2" + ] + +------------------------------------------------------------------------------ + +testParseEnum :: TestTree +testParseEnum = testGroup "parseEnum" + [ testCase "@" $ + Right Red + @=? TTC.parseEnum @String + False False ColorInvalid ColorAmbiguous "red" + , testCase "S" $ Right Red @=? parseEnum False False redS + , testCase "T" $ Right Red @=? parseEnum False False redT + , testCase "TL" $ Right Red @=? parseEnum False False redTL + , testCase "TLB" $ Right Red @=? parseEnum False False redTLB + , testCase "ST" $ Right Red @=? parseEnum False False redST + , testCase "BS" $ Right Red @=? parseEnum False False redBS + , testCase "BSL" $ Right Red @=? parseEnum False False redBSL + , testCase "BSB" $ Right Red @=? parseEnum False False redBSB + , testCase "SBS" $ Right Red @=? parseEnum False False redSBS + , testCase "CI" $ Right Red @=? parseEnum @String True False "Red" + , testCase "!CI" $ + Left ColorInvalid @=? parseEnum @String False False "Red" + , testCase "prefix" $ Right Red @=? parseEnum @String False True "r" + , testCase "ambiguous" $ + Left ColorAmbiguous @=? parseEnum @String False True "bl" + ] + where + parseEnum :: TTC.Textual t => Bool -> Bool -> t -> Either ColorError Color + parseEnum allowCI allowPrefix = + TTC.parseEnum allowCI allowPrefix ColorInvalid ColorAmbiguous + +testParseEnum' :: TestTree +testParseEnum' = testGroup "parseEnum'" + [ testCase "@" $ + Right Red + @=? TTC.parseEnum' @String @String "Color" False False "red" + , testCase "S" $ Right Red @=? parseEnum' False False redS + , testCase "T" $ Right Red @=? parseEnum' False False redT + , testCase "TL" $ Right Red @=? parseEnum' False False redTL + , testCase "TLB" $ Right Red @=? parseEnum' False False redTLB + , testCase "ST" $ Right Red @=? parseEnum' False False redST + , testCase "BS" $ Right Red @=? parseEnum' False False redBS + , testCase "BSL" $ Right Red @=? parseEnum' False False redBSL + , testCase "BSB" $ Right Red @=? parseEnum' False False redBSB + , testCase "SBS" $ Right Red @=? parseEnum' False False redSBS + , testCase "CI" $ Right Red @=? parseEnum' @String True False "Red" + , testCase "!CI" $ + Left "invalid Color" @=? parseEnum' @String False False "Red" + , testCase "prefix" $ Right Red @=? parseEnum' @String False True "r" + , testCase "ambiguous" $ + Left "ambiguous Color" @=? parseEnum' @String False True "bl" + ] + where + parseEnum' :: TTC.Textual t => Bool -> Bool -> t -> Either String Color + parseEnum' = TTC.parseEnum' "Color" + +------------------------------------------------------------------------------ + +testParseX :: TestTree +testParseX = testGroup "parse*" + [ mkTests "parseS" TTC.parseS answerS + , mkTests "parseT" TTC.parseT answerT + , mkTests "parseTL" TTC.parseTL answerTL + , mkTests "parseTLB" TTC.parseTLB answerTLB + , mkTests "parseST" TTC.parseST answerST + , mkTests "parseBS" TTC.parseBS answerBS + , mkTests "parseBSL" TTC.parseBSL answerBSL + , mkTests "parseBSB" TTC.parseBSB answerBSB + , mkTests "parseSBS" TTC.parseSBS answerSBS + ] + where + mkTests + :: IsString a + => TestName + -> (a -> Either String PosInt) + -> a + -> TestTree + mkTests testName f x = testGroup testName + [ testCase "valid" $ Right answer @=? f x + , testCase "invalid" $ Left "not an integer" @=? f "4a2" + ] + +------------------------------------------------------------------------------ + +testParseMaybe :: TestTree +testParseMaybe = testGroup "parseMaybe" + [ testCase "@" $ Just answer @=? TTC.parseMaybe @String "42" + , 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 "ST" $ Just answer @=? TTC.parseMaybe answerST + , 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 "noerror" $ + Just (PartialParser "test") @=? TTC.parseMaybe @String "test" + , testCase "negative" $ Nothing @=? TTC.parseMaybe @String @PosInt "-42" + , testCase "invalid" $ Nothing @=? TTC.parseMaybe @String @PosInt "4a2" + ] + +testParseMaybeX :: TestTree +testParseMaybeX = testGroup "parseMaybe*" + [ mkTestsParseMaybe "parseMaybeS" TTC.parseMaybeS answerS + , mkTestsParseMaybe "parseMaybeT" TTC.parseMaybeT answerT + , mkTestsParseMaybe "parseMaybeTL" TTC.parseMaybeTL answerTL + , mkTestsParseMaybe "parseMaybeTLB" TTC.parseMaybeTLB answerTLB + , mkTestsParseMaybe "parseMaybeST" TTC.parseMaybeST answerST + , mkTestsParseMaybe "parseMaybeBS" TTC.parseMaybeBS answerBS + , mkTestsParseMaybe "parseMaybeBSL" TTC.parseMaybeBSL answerBSL + , mkTestsParseMaybe "parseMaybeBSB" TTC.parseMaybeBSB answerBSB + , mkTestsParseMaybe "parseMaybeSBS" TTC.parseMaybeSBS answerSBS + ] + +mkTestsParseMaybe + :: IsString a + => TestName + -> (a -> Maybe PosInt) + -> a + -> TestTree +mkTestsParseMaybe testName f x = testGroup testName + [ testCase "valid" $ Just answer @=? f x + , testCase "invalid" $ Nothing @=? f "4a2" + ] + +------------------------------------------------------------------------------ + +testParseOrFail :: TestTree +testParseOrFail = testGroup "parseOrFail" + [ testCase "@" $ Just answer @=? TTC.parseOrFail @String "42" + , testCase "S" $ Just answer @=? TTC.parseOrFail answerS + , testCase "T" $ Just answer @=? TTC.parseOrFail answerT + , testCase "TL" $ Just answer @=? TTC.parseOrFail answerTL + , testCase "TLB" $ Just answer @=? TTC.parseOrFail answerTLB + , testCase "ST" $ Just answer @=? TTC.parseOrFail answerST + , testCase "BS" $ Just answer @=? TTC.parseOrFail answerBS + , testCase "BSL" $ Just answer @=? TTC.parseOrFail answerBSL + , testCase "BSB" $ Just answer @=? TTC.parseOrFail answerBSB + , testCase "SBS" $ Just answer @=? TTC.parseOrFail answerSBS + , testCase "noerror" $ + Just (PartialParser "test") @=? TTC.parseOrFail @String "test" + , testCase "negative" $ Nothing @=? TTC.parseOrFail @String @PosInt "-42" + , testCase "invalid" $ Nothing @=? TTC.parseOrFail @String @PosInt "4a2" + ] + +testParseOrFailX :: TestTree +testParseOrFailX = testGroup "parseOrFail*" + [ mkTestsParseMaybe "parseOrFailS" TTC.parseOrFailS answerS + , mkTestsParseMaybe "parseOrFailT" TTC.parseOrFailT answerT + , mkTestsParseMaybe "parseOrFailTL" TTC.parseOrFailTL answerTL + , mkTestsParseMaybe "parseOrFailTLB" TTC.parseOrFailTLB answerTLB + , mkTestsParseMaybe "parseOrFailST" TTC.parseOrFailST answerST + , mkTestsParseMaybe "parseOrFailBS" TTC.parseOrFailBS answerBS + , mkTestsParseMaybe "parseOrFailBSL" TTC.parseOrFailBSL answerBSL + , mkTestsParseMaybe "parseOrFailBSB" TTC.parseOrFailBSB answerBSB + , mkTestsParseMaybe "parseOrFailSBS" TTC.parseOrFailSBS answerSBS + ] + +------------------------------------------------------------------------------ + +testParseUnsafe :: TestTree +testParseUnsafe = testGroup "parseUnsafe" + [ testCase "@" $ answer @=? TTC.parseUnsafe @String "42" + , 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 "ST" $ answer @=? TTC.parseUnsafe answerST + , 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 @String @PosInt "-42" + , testCase "invalid" . assertRaises (Proxy :: Proxy ErrorCall) $ + TTC.parseUnsafe @String @PosInt "4a2" + ] + +testParseUnsafeX :: TestTree +testParseUnsafeX = testGroup "parseUnsafe*" + [ mkTests "parseUnsafeS" TTC.parseUnsafeS answerS + , mkTests "parseUnsafeT" TTC.parseUnsafeT answerT + , mkTests "parseUnsafeTL" TTC.parseUnsafeTL answerTL + , mkTests "parseUnsafeTLB" TTC.parseUnsafeTLB answerTLB + , mkTests "parseUnsafeST" TTC.parseUnsafeST answerST + , mkTests "parseUnsafeBS" TTC.parseUnsafeBS answerBS + , mkTests "parseUnsafeBSL" TTC.parseUnsafeBSL answerBSL + , mkTests "parseUnsafeBSB" TTC.parseUnsafeBSB answerBSB + , mkTests "parseUnsafeSBS" TTC.parseUnsafeSBS answerSBS + ] + where + mkTests + :: IsString a + => TestName + -> (a -> PosInt) + -> a + -> TestTree + mkTests testName f x = testGroup testName + [ testCase "valid" $ answer @=? f x + , testCase "invalid" . assertRaises (Proxy :: Proxy ErrorCall) $ f "4a2" + ] + +------------------------------------------------------------------------------ + +testReadsWithParse :: TestTree +testReadsWithParse = testGroup "readsWithParse" + [ testCase "valid" $ [(answer, "")] @=? TTC.readsWithParse answerS + , testCase "invalid" $ [] @=? (TTC.readsWithParse :: ReadS PosInt) "-42" + ] + +testReadsEnum :: TestTree +testReadsEnum = testGroup "readsEnum" + [ testCase "valid" $ Just Red @=? readMaybe "R" + , testCase "invalid" $ Nothing @=? readMaybe @Color "bl" + ] + +------------------------------------------------------------------------------ +-- $Valid + +testValid :: TestTree +testValid = testCase "valid" $ Ex "test" @=? validConst + where + validConst :: Ex + validConst = $$(TTC.valid "test") + +testValidIsString :: TestTree +testValidIsString = + testCase "validIsString" $ Ex "test" @=? validConst + where + validConst :: Ex + validConst = $$("test") + +testValidOf :: TestTree +testValidOf = testCase "validOf" $ + Ex "test" @=? $$(TTC.validOf (Proxy :: Proxy Ex) "test") + +testMkValid :: TestTree +testMkValid = testCase "mkValid" $ Ex "test" @=? $$(Ex.valid "test") + +testUntypedValidOf :: TestTree +testUntypedValidOf = testCase "untypedValidOf" $ + Ex "test" @=? $(TTC.untypedValidOf (Proxy :: Proxy Ex) "test") + +testMkUntypedValid :: TestTree +testMkUntypedValid = testCase "mkUntypedValid" $ + Ex "test" @=? $(Ex.untypedValid "test") + +testMkUntypedValidQQ :: TestTree +testMkUntypedValidQQ = testCase "mkUntypedValidQQ" $ + Ex "test" @=? [Ex.untypedValidQQ|test|] + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "Data.TTC" + [ testGroup "Textual" + [ testConvert + , testToX + , testFromX + , testAsX + ] + , testGroup "Render" + [ testRender + , testRenderDefault + , testRenderWithShow + , testRenderX + ] + , testGroup "Parse" + [ testParse + , testParseDefault + , testWithError + , testWithErrorX + , testPrefixError + , testPrefixErrorX + , testParseWithRead + , testParseWithRead' + , testMaybeParseWithRead + , testParseEnum + , testParseEnum' + , testParseX + , testParseMaybe + , testParseMaybeX + , testParseOrFail + , testParseOrFailX + , testParseUnsafe + , testParseUnsafeX , testReadsWithParse , testReadsEnum ] diff --git a/test/Data/TTC/Wrapper/Test.hs b/test/Data/TTC/Wrapper/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/TTC/Wrapper/Test.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.TTC.Wrapper.Test (tests) where + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Short as SBS + +-- 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 +import qualified Data.Text.Lazy.Builder as TLB + +-- https://hackage.haskell.org/package/text-short +import qualified Data.Text.Short as ST + +-- (ttc) +import qualified Data.TTC as TTC +import qualified Data.TTC.Wrapper as TTCW + +------------------------------------------------------------------------------ + +instance Eq BSB.Builder where + x == y = BSB.toLazyByteString x == BSB.toLazyByteString y + +#if !MIN_VERSION_bytestring(0,11,1) +instance Show BSB.Builder where + show = show . BSB.toLazyByteString +#endif + +------------------------------------------------------------------------------ +-- $TestData + +xS :: String +xS = "test テスト" + +xT :: T.Text +xT = "test テスト" + +------------------------------------------------------------------------------ +-- $WrapperS + +newtype ExS = ExS String + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperS + deriving TTC.Render via TTCW.WrapperS + +testWrapperS :: TestTree +testWrapperS = testCase "WrapperS" $ + Right xT @=? (TTC.render <$> TTC.parse @ExS @_ @String xT) + +------------------------------------------------------------------------------ +-- $WrapperT + +newtype ExT = ExT T.Text + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperT + deriving TTC.Render via TTCW.WrapperT + +testWrapperT :: TestTree +testWrapperT = testCase "WrapperT" $ + Right xS @=? (TTC.render <$> TTC.parse @ExT @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperTL + +newtype ExTL = ExTL TL.Text + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperTL + deriving TTC.Render via TTCW.WrapperTL + +testWrapperTL :: TestTree +testWrapperTL = testCase "WrapperTL" $ + Right xS @=? (TTC.render <$> TTC.parse @ExTL @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperTLB + +newtype ExTLB = ExTLB TLB.Builder + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperTLB + deriving TTC.Render via TTCW.WrapperTLB + +testWrapperTLB :: TestTree +testWrapperTLB = testCase "WrapperTLB" $ + Right xS @=? (TTC.render <$> TTC.parse @ExTLB @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperST + +newtype ExST = ExST ST.ShortText + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperST + deriving TTC.Render via TTCW.WrapperST + +testWrapperST :: TestTree +testWrapperST = testCase "WrapperST" $ + Right xS @=? (TTC.render <$> TTC.parse @ExST @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperBS + +newtype ExBS = ExBS BS.ByteString + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperBS + deriving TTC.Render via TTCW.WrapperBS + +testWrapperBS :: TestTree +testWrapperBS = testCase "WrapperBS" $ + Right xS @=? (TTC.render <$> TTC.parse @ExBS @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperBSL + +newtype ExBSL = ExBSL BSL.ByteString + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperBSL + deriving TTC.Render via TTCW.WrapperBSL + +testWrapperBSL :: TestTree +testWrapperBSL = testCase "WrapperBSL" $ + Right xS @=? (TTC.render <$> TTC.parse @ExBSL @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperBSB + +newtype ExBSB = ExBSB BSB.Builder + deriving (Eq, Show) + deriving TTC.Parse via TTCW.WrapperBSB + deriving TTC.Render via TTCW.WrapperBSB + +testWrapperBSB :: TestTree +testWrapperBSB = testCase "WrapperBSB" $ + Right xS @=? (TTC.render <$> TTC.parse @ExBSB @_ @String xS) + +------------------------------------------------------------------------------ +-- $WrapperSBS + +newtype ExSBS = ExSBS SBS.ShortByteString + deriving (Eq, Ord, Show) + deriving TTC.Parse via TTCW.WrapperSBS + deriving TTC.Render via TTCW.WrapperSBS + +testWrapperSBS :: TestTree +testWrapperSBS = testCase "WrapperSBS" $ + Right xS @=? (TTC.render <$> TTC.parse @ExSBS @_ @String xS) + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "Data.TTC.Wrapper" + [ testWrapperS + , testWrapperT + , testWrapperTL + , testWrapperTLB + , testWrapperST + , testWrapperBS + , testWrapperBSL + , testWrapperBSB + , testWrapperSBS + ] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,10 +5,12 @@ -- (ttc:test) import qualified Data.TTC.Test +import qualified Data.TTC.Wrapper.Test ------------------------------------------------------------------------------ main :: IO () main = defaultMain $ testGroup "test" [ Data.TTC.Test.tests + , Data.TTC.Wrapper.Test.tests ] diff --git a/test/TestString.hs b/test/TestString.hs deleted file mode 100644 --- a/test/TestString.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE TemplateHaskell #-} - -module TestString where - --- https://hackage.haskell.org/package/template-haskell -import qualified Language.Haskell.TH.Syntax as THS - --- (ttc) -import qualified Data.TTC as TTC - ------------------------------------------------------------------------------- --- $Type - -newtype TestString = TestString String - deriving (Eq, Ord, Show, THS.Lift) - -instance TTC.Render TestString where - render (TestString s) = TTC.convert s - -instance TTC.Parse TestString where - parse = TTC.asS $ Right . TestString - ------------------------------------------------------------------------------- --- $API - -$(TTC.mkValid "valid" ''TestString) - -$(TTC.mkUntypedValid "untypedValid" ''TestString) - -$(TTC.mkUntypedValidQQ "untypedValidQQ" ''TestString) diff --git a/test/TestTypes/Ex.hs b/test/TestTypes/Ex.hs new file mode 100644 --- /dev/null +++ b/test/TestTypes/Ex.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE TemplateHaskell #-} + +module TestTypes.Ex where + +-- https://hackage.haskell.org/package/template-haskell +import qualified Language.Haskell.TH.Syntax as THS + +-- (ttc) +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ +-- $Type + +newtype Ex = Ex { exString :: String } + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse Ex where + parse = TTC.asS $ pure . Ex + +instance TTC.Render Ex where + render = TTC.convert . exString + +------------------------------------------------------------------------------ +-- $API + +$(TTC.mkValid "valid" ''Ex) + +$(TTC.mkUntypedValid "untypedValid" ''Ex) + +$(TTC.mkUntypedValidQQ "untypedValidQQ" ''Ex) diff --git a/ttc.cabal b/ttc.cabal --- a/ttc.cabal +++ b/ttc.cabal @@ -1,37 +1,35 @@ -name: ttc -version: 1.4.0.0 -category: Data, Text -synopsis: Textual Type Classes +cabal-version: 3.0 +name: ttc +version: 1.5.0.0 +synopsis: Textual Type Classes description: This library provides type classes for conversion between data types and textual data types (strings). Please see the README on GitHub at - . + . +homepage: https://github.com/ExtremaIS/ttc-haskell/tree/main/ttc#readme +bug-reports: https://github.com/ExtremaIS/ttc-haskell/issues +license: MIT +license-file: LICENSE +author: Travis Cardwell +maintainer: Travis Cardwell +copyright: Copyright (c) 2019-2025 Travis Cardwell +category: Data, Text +build-type: Simple -homepage: https://github.com/ExtremaIS/ttc-haskell#readme -bug-reports: https://github.com/ExtremaIS/ttc-haskell/issues -author: Travis Cardwell -maintainer: Travis Cardwell -copyright: Copyright (c) 2019-2023 Travis Cardwell -license: MIT -license-file: LICENSE +extra-doc-files: + CHANGELOG.md + README.md -cabal-version: 1.24 -build-type: Simple tested-with: - GHC ==8.2.2 - || ==8.4.4 - || ==8.6.5 - || ==8.8.4 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 - || ==9.6.3 - || ==9.8.1 - -extra-source-files: - CHANGELOG.md - README.md + || ==9.6.6 + || ==9.8.4 + || ==9.10.1 + || ==9.12.1 source-repository head type: git @@ -41,12 +39,13 @@ hs-source-dirs: src exposed-modules: Data.TTC + , Data.TTC.Wrapper build-depends: - base >=4.10.1 && <4.20 - , bytestring >=0.10.8 && <0.13 - , template-haskell >=2.12 && <2.22 - , text >=1.2.2 && <2.2 - , text-short >=0.1 && <0.2 + base >=4.13.0.0 && <4.22 + , bytestring >=0.10.10.1 && <0.13 + , template-haskell >=2.15.0.0 && <2.24 + , text >=1.2.4.0 && <2.2 + , text-short >=0.1.3 && <0.2 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -58,12 +57,13 @@ main-is: Spec.hs other-modules: Data.TTC.Test - , TestString + , Data.TTC.Wrapper.Test + , TestTypes.Ex build-depends: base , bytestring - , tasty >=0.11 && <1.6 - , tasty-hunit >=0.8 && <0.11 + , tasty >=1.2.3 && <1.6 + , tasty-hunit >=0.10.0.3 && <0.11 , template-haskell , text , text-short