diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,58 @@ +# `ttc-haskell` 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 +every version is considered breaking. + +[PVP]: +[SemVer]: + +The format of this changelog is based on [Keep a Changelog][KaC], with the +following conventions: + +* Level-two heading `Unreleased` is used to track changes that have not been + released. +* Other level-two headings specify the release in `A.B.C.D (YYYY-MM-DD)` + format, with newer versions above older versions. +* Level-three headings are used to categorize changes as follows: + 1. Breaking + 2. Non-Breaking +* Changes are listed in arbitrary order and present tense. + +[KaC]: + +## 0.1.0.0 (2019-12-01) + +### Non-Breaking + +* Update Cabal file in preparation for release to Hackage + +## 0.0.0.4 (2019-11-30) + +### Non-Breaking + +* Update Cabal file in preparation for release to Hackage +* Update documentation +* Add examples + +## 0.0.0.3 (2019-11-28) + +### Non-Breaking + +* Add continuous integration support + +## 0.0.0.2 (2019-11-28) + +### Non-Breaking + +* Update Cabal metadata +* Update README + +## 0.0.0.1 (2019-11-23) + +### Breaking + +* Initial public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License + +Copyright (c) 2019 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 +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,241 @@ +# TTC: Textual Type Classes + +[![Build Status](https://travis-ci.com/ExtremaIS/ttc-haskell.svg?branch=master)](https://travis-ci.com/ExtremaIS/ttc-haskell) +[![Hackage](https://img.shields.io/hackage/v/ttc.svg)](https://hackage.haskell.org/package/ttc) +[![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) + * [`Render`](#render) + * [`Parse`](#parse) + * [`Textual`](#textual) +* [Related Work](#related-work) + * [Rendering and Parsing](#rendering-and-parsing) + * [Constant Validation](#constant-validation) + * [String Type Conversion](#string-type-conversion) +* [Project](#project) + * [Links](#links) + * [Dependencies](#dependencies) + * [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 following is a brief overview of the type classes provided by this +library. See the +[API documentation on Hackage](https://hackage.haskell.org/package/ttc#modules) +for details and the [`examples` directory](examples) for usage examples. + +### `Render` + +The `Render` type class renders a data type as a [`Textual`](#textual) data +type: + +```haskell +class Render a where + render :: Textual t => a -> t +``` + +It is analogous to the `Show` type class, which can be reserved for +debugging/development. + +The `render` function returns any of the supported textual data types. Use +the textual data type that is most natural in the implementation of `render` +instances, and return values are converted to other textual data types when +necessary. The `Show` and `IsString` type classes are not used, so use of the +`String` type is not required. + +As a simple example, consider a `Username` type that is implemented as a +`newtype` over `Text`: + +```haskell +module Username (Username) where + +import Control.Monad (unless, when) +import Data.Char (isAsciiLower) +import qualified Data.Text as T +import Data.Text (Text) +import qualified Data.TTC as TTC + +newtype Username = Username Text + deriving (Eq, Ord, Show) + +instance TTC.Render Username where + render (Username t) = TTC.convert t +``` + +If a username needs to be included in a `String` error message, conversion is +automatic: + +```haskell +putStrLn $ "user not found: " ++ TTC.render uname +``` + +### `Parse` + +The `Parse` type class parses a data type from a [`Textual`](#textual) data +type: + +```haskell +class Parse a where + parse :: Textual t => t -> Either String a +``` + +It is analogous to the `Read` type class, which can be reserved for +debugging/development. + +The `parse` function takes any of the supported textual data types as an +argument. Use the textual data type that is most natural in the +implementation of `parse` instances, and arguments are converted from other +textual data types when necessary. The `IsString` type class is not used, so +use of the `String` type is not required. + +Here is an example instance for `Username`, implementing some restrictions: + +```haskell +instance TTC.Parse Username where + parse = TTC.asT $ \t-> do + unless (T.all isAsciiLower t) $ Left "username has invalid characters" + let len = T.length t + when (len < 3) $ Left "username has fewer than 3 characters" + when (len > 12) $ Left "username has more than 12 characters" + pure $ Username t +``` + +If a username needs to be parsed from a `String`, conversion is automatic: + +```haskell +case TTC.parse "tcard" :: Either String Username of + Right uname -> putStrLn $ "valid username: " ++ TTC.render uname + Left err -> putStrLn $ "invalid username: " ++ err +``` + +It is common to create data types that have "smart constructors" to ensure +that all constructed values are valid. If the `Username` constructor were +exported, it would be possible to create values with arbitrary `Text`, such +as `Username T.empty`, which is not a valid `Username`. Smart constructors +can be inconvenient when constructing constants, however, as neither runtime +error handling nor failure are desired. This library provides Template +Haskell functions that use `Parse` instances to validate such constants at +compile-time. + +### `Textual` + +The `Textual` type class is used to convert between the following textual data +types: + +* `String` +* Strict `Text` +* Lazy `Text` +* Strict `ByteString` +* Lazy `ByteString` + +Conversion between any of these types is direct; it is not done through a +fixed textual data type (such as `String` or `Text`). The key feature of this +type class is that it has a single type variable, making it easy to write +functions that accept arguments and/or returns values that may be any of the +supported textual data types. + +Functions are provided to convert to/from the following other textual data +types: + +* `Text` `Builder` +* `ByteString` `Builder` +* `ShortByteString` + +## Related Work + +### Rendering and Parsing + +The [relude](https://hackage.haskell.org/package/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](https://hackage.haskell.org/package/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`. + +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](https://harry.garrood.me/blog/down-with-show-part-1/) +* [Down with Show! Part 2: What's wrong with the Show type class](https://harry.garrood.me/blog/down-with-show-part-2/) +* [Down with Show! Part 3: A replacement for Show](https://harry.garrood.me/blog/down-with-show-part-3/) + +### Constant Validation + +The +[validated-literals](https://hackage.haskell.org/package/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](https://gist.github.com/chrisdone/809296b769ee36d352ae4f8dbe89a364) +about implementing statically checked overloaded strings. + +### String Type Conversion + +There are a number of libraries that simplify conversion between string types. + +The +[string-conversions](https://hackage.haskell.org/package/string-conversions) +and [string-conv](https://hackage.haskell.org/package/string-conv) libraries +have type classes with two type variables. The primary benefit of this +approach is that one can add support for any string type. + +The [text-conversions](https://hackage.haskell.org/package/text-conversions) +library converts between string types via the `Text` type, using `FromText` +and `ToText` type classes. This works well in most cases, but it not optimal +when converting between `ByteString` types. + +The [textual](https://hackage.haskell.org/package/textual) library +(deprecated) converts between string types via the `String` type, using a +`Textual` type class (which provides a `toString` function) as well as the +standard `IsString` type class (which provides the `fromString` function). + +## Project + +### Links + +* Hackage: +* Stackage: +* GitHub: +* Travis CI: + +### Dependencies + +Dependency version bounds are strictly specified according to what versions +have been tested. If upper bounds need to be bumped when a new package is +released or the package has been tested with earlier versions, feel free to +submit an issue. + +### Releases + +All releases are tagged in the `master` branch. Release tags are signed using +the +[`security@extrema.is` GPG key](http://keys.gnupg.net/pks/lookup?op=vindex&fingerprint=on&search=0x1D484E4B4705FADF). + +### 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](https://opensource.org/licenses/MIT) as specified in the +[`LICENSE`](LICENSE) file. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/CreditCard.hs b/examples/CreditCard.hs new file mode 100644 --- /dev/null +++ b/examples/CreditCard.hs @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- | +-- Module : CreditCard +-- Description : credit card data types +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- This module defines the data types for a credit card, with 'TTC.Render' and +-- 'TTC.Parse' instances, as an example of TTC usage. +-- +-- The data types in this module all have 'THS.Lift' instances, to demonstrate +-- how to use 'TTC.valid' in `examples/valid.hs`. All of the 'THS.Lift' +-- instances are derived, using the `DeriveLift` extension. +-- +-- The constructors and accessors of composite data types 'CreditCard' and +-- 'ExpirationDate' are exported, but the constructors for 'Name', 'Number', +-- 'Year', 'Month', and 'SecurityCode' are not. The 'TTC.Parse' instances +-- serve as "smart constructors," ensuring that all values are valid. +------------------------------------------------------------------------------ + +{-# LANGUAGE DeriveLift #-} + +module CreditCard + ( -- * CreditCard + CreditCard(..) + -- ** Name + , Name + -- ** Number + , Number + -- ** ExpirationDate + , ExpirationDate(..) + , toDay + , Year + , Month + -- ** SecurityCode + , SecurityCode + ) where + +-- http://hackage.haskell.org/package/base +import Control.Monad (unless, when) +import Data.Char (digitToInt, isDigit, isSpace, toUpper) +import Data.List (dropWhileEnd, intersperse) +import Text.Read (readMaybe) + +-- https://hackage.haskell.org/package/template-haskell +import qualified Language.Haskell.TH.Syntax as THS + +-- http://hackage.haskell.org/package/time +import qualified Data.Time.Calendar as Calendar + +-- (ttc) +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ + +-- | A credit card has a name, number, expiration date, and security code. +data CreditCard + = CreditCard + { name :: !Name + , number :: !Number + , expirationDate :: !ExpirationDate + , securityCode :: !SecurityCode + } + deriving Show + +------------------------------------------------------------------------------ + +-- | After any leading and trailing whitespace is stripped and all lowercase +-- characters are converted to uppercase, a name must meet the following +-- constraints: +-- +-- * Only characters between `0x20` (space) and `0x5F` (underscore) are +-- allowed. +-- * The name must be between 1 and 26 characters in length. +-- +-- Reference: +-- +-- * https://stackoverflow.com/questions/2004532 +newtype Name = Name String + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse Name where + parse = TTC.asS $ \s -> do + let name' = map toUpper $ strip s + invChars = filter ((||) <$> (< ' ') <*> (> '_')) name' + unless (null invChars) . Left $ + "name has invalid character(s): " <> intersperse ',' invChars + when (null name') $ Left "name is empty" + when (length name' > 26) $ Left "name has more than 26 characters" + pure $ Name name' + +instance TTC.Render Name where + render (Name name') = TTC.convert name' + +------------------------------------------------------------------------------ + +-- | After any space and dash characters are removed, a number must meet the +-- following constraints: +-- +-- * Only ASCII digits are allowed. +-- * The number must be between 8 and 19 characters in length. +-- * The number must have a valid checksum. +-- +-- Reference: +-- +-- * https://en.wikipedia.org/wiki/Payment_card_number +-- * https://en.wikipedia.org/wiki/Luhn_algorithm +-- * http://rosettacode.org/wiki/Luhn_test_of_credit_card_numbers#Haskell +newtype Number = Number String + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse Number where + parse = TTC.asS $ \s -> do + let number' = filter ((&&) <$> (/= ' ') <*> (/= '-')) s + invChars = filter (not . isDigit) number' + len = length number' + unless (null invChars) . Left $ + "number has invalid character(s): " <> intersperse ',' invChars + unless (len >= 8) $ Left "number has fewer than 8 characters" + unless (len <= 19) $ Left "number has more than 19 characters" + unless (luhn number') $ Left "number checksum is invalid" + pure $ Number number' + +instance TTC.Render Number where + render (Number number') = TTC.convert number' + +luhn :: String -> Bool +luhn + = (== 0) + . (`mod` 10) + . sum + . map (uncurry (+) . (`divMod` 10)) + . zipWith (*) (cycle [1, 2]) + . map digitToInt + . reverse + +------------------------------------------------------------------------------ + +-- | When parsed from a single string, an expiration date must be in `YYYY-MM` +-- format. +data ExpirationDate + = ExpirationDate + { year :: !Year + , month :: !Month + } + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse ExpirationDate where + parse = TTC.asS $ \s -> case break (== '-') (strip s) of + (year', '-':month') -> + ExpirationDate <$> TTC.parse year' <*> TTC.parse month' + _ -> Left "expiration date not in YYYY-MM format" + +instance TTC.Render ExpirationDate where + render (ExpirationDate year' month') = + TTC.fromS $ TTC.render year' <> "-" <> TTC.render month' + +toDay + :: ExpirationDate + -> Calendar.Day +toDay (ExpirationDate (Year year') (Month month')) = + let yearZ = fromIntegral year' + day = Calendar.gregorianMonthLength yearZ month' + in Calendar.fromGregorian yearZ month' day + +------------------------------------------------------------------------------ + +-- | A year must be in `YYYY` format, between 1900 and 9999. +newtype Year = Year Int + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse Year where + parse = TTC.asS $ \s -> do + year' <- maybe (Left "year is not in YYYY format") pure $ readMaybe s + unless (year' >= 1900) $ Left "year is before 1900" + unless (year' <= 9999) $ Left "year is after 9999" + pure $ Year year' + +instance TTC.Render Year where + render (Year year') = TTC.convert $ show year' + +------------------------------------------------------------------------------ + +-- | A month must be in `MM` format, between 1 (January) and 12 (December). +newtype Month = Month Int + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse Month where + parse = TTC.asS $ \s -> do + month' <- maybe (Left "month is not in MM format") pure $ readMaybe s + unless (month' >= 1 && month' <= 12) $ Left "month is not in 1-12 range" + pure $ Month month' + +instance TTC.Render Month where + render (Month month') + | month' < 10 = TTC.convert $ '0' : show month' + | otherwise = TTC.convert $ show month' + +------------------------------------------------------------------------------ + +-- | After any leading and trailing whitespace is stripped, a security code +-- must meet the following constraints: +-- +-- * Only ASCII digits are allowed. +-- * The number must be 3 or 4 characters in length. +-- +-- Reference: +-- +-- * https://en.wikipedia.org/wiki/Card_security_code +newtype SecurityCode = SecurityCode String + deriving (Eq, Ord, Show, THS.Lift) + +instance TTC.Parse SecurityCode where + parse = TTC.asS $ \s -> do + let securityCode' = strip s + invChars = filter (not . isDigit) securityCode' + len = length securityCode' + unless (null invChars) . Left $ + "security code has invalid character(s): " <> intersperse ',' invChars + unless (len >= 3) $ Left "security code has fewer than 3 characters" + unless (len <= 4) $ Left "security code has more than 4 characters" + pure $ SecurityCode securityCode' + +instance TTC.Render SecurityCode where + render (SecurityCode securityCode') = TTC.convert securityCode' + +------------------------------------------------------------------------------ + +strip :: String -> String +strip = dropWhile isSpace . dropWhileEnd isSpace diff --git a/examples/Duration.hs b/examples/Duration.hs new file mode 100644 --- /dev/null +++ b/examples/Duration.hs @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Duration +-- Description : duration data type +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- This module defines a duration data type, with 'TTC.Render' and 'TTC.Parse' +-- instances, as an example of TTC usage. +-- +-- The constructor for 'Duration' is not exported. The 'TTC.Parse' instance +-- serves as a "smart constructor," ensuring that all values are valid. +------------------------------------------------------------------------------ + +{-# LANGUAGE TemplateHaskell #-} + +module Duration + ( -- * Type + Duration + -- * API + , fromDouble + , fromFloat + , fromInt + , fromMicro + , fromNominalDiffTime + , fromReal + , toDouble + , toFloat + , toInt + , toIntegral + , toMicro + , toNominalDiffTime + , valid + ) where + +-- https://hackage.haskell.org/package/base +import Data.List (dropWhileEnd) +import Text.Read (readMaybe) + +-- https://hackage.haskell.org/package/time +import Data.Time.Clock (NominalDiffTime) + +-- ttc +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ +-- $Type + +-- | A 'Duration' is a measure of seconds. It is fractional and must be zero +-- or greater. +-- +-- The underlying type is 'NominalDiffTime', which may be negative. The +-- constructor is not exported, and all functions that create a value ensure +-- that the constraint holds. +newtype Duration = Duration NominalDiffTime + deriving Show + +instance TTC.Parse Duration where + parse = TTC.asS $ \s -> + maybe (Left $ "invalid Duration: " <> s) fromDouble $ readMaybe s + +instance TTC.Render Duration where + render (Duration t) = TTC.fromS . dropWhileEnd (== 's') $ show t + +------------------------------------------------------------------------------ +-- $API + +-- | Construct a 'Duration' from a 'Double' (seconds). +fromDouble :: Double -> Either String Duration +fromDouble = fromReal + +-- | Construct a 'Duration' from a 'Float' (seconds). +fromFloat :: Float -> Either String Duration +fromFloat = fromReal + +-- | Construct a 'Duration' from an 'Int' (seconds). +fromInt :: Int -> Either String Duration +fromInt = fromReal + +-- | Construct a 'Duration' from an 'Int' (microseconds). +fromMicro :: Int -> Either String Duration +fromMicro us = fromDouble $ fromIntegral us / 1000000.0 + +-- | Construct a 'Duration' from a 'NominalDiffTime'. +fromNominalDiffTime :: NominalDiffTime -> Either String Duration +fromNominalDiffTime t + | t >= 0.0 = Right $ Duration t + | otherwise = Left $ "Duration less than zero: " ++ show t + +-- | Construct a 'Duration' from a 'Real' (seconds). +fromReal :: (Real a, Show a) => a -> Either String Duration +fromReal x + | x >= 0 = Right . Duration $ realToFrac x + | otherwise = Left $ "Duration less than zero: " ++ show x + +-- | Convert a 'Duration' to a 'Double' (seconds). +toDouble :: Duration -> Double +toDouble = toFractional + +-- | Convert a 'Duration' to a 'Float' (seconds). +toFloat :: Duration -> Float +toFloat = toFractional + +-- | Convert a 'Duration' to a 'Fractional' (seconds). +toFractional :: Fractional a => Duration -> a +toFractional (Duration t) = realToFrac t + +-- | Convert a 'Duration' to an 'Int' (seconds). +toInt :: Duration -> Int +toInt = toIntegral + +-- | Convert a 'Duration' to an 'Integral' (seconds). +toIntegral :: Integral a => Duration -> a +toIntegral = round . toFloat + +-- | Convert a 'Duration' to an 'Int' (microseconds). +toMicro :: Duration -> Int +toMicro (Duration t) = round (realToFrac t * 1000000.0 :: Double) + +-- | Convert a 'Duration' to a 'NominalDiffTime'. +toNominalDiffTime :: Duration -> NominalDiffTime +toNominalDiffTime (Duration t) = t + +-- | The 'valid' function is created using 'TTC.mkValid' via Template Haskell. +-- Note that 'Duration' does not have a 'Language.Haskell.TH.Syntax.Lift' +-- instance. +$(TTC.mkValid "valid" ''Duration) diff --git a/examples/Username.hs b/examples/Username.hs new file mode 100644 --- /dev/null +++ b/examples/Username.hs @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Username +-- Description : username data type +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- This module defines a username data type, with 'TTC.Render' and 'TTC.Parse' +-- instances, as an example of TTC usage. +-- +-- The constructor for 'Username' is not exported. The 'TTC.Parse' instance +-- serves as a "smart constructor," ensuring that all values are valid. +------------------------------------------------------------------------------ + +module Username (Username) where + +-- https://hackage.haskell.org/package/base +import Control.Monad (unless, when) +import Data.Char (isAsciiLower) + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import Data.Text (Text) + +-- ttc +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ + +-- | A 'Username' must consist of 3 to 12 lowercase ASCII letters. +newtype Username = Username Text + deriving (Eq, Ord, Show) + +instance TTC.Render Username where + render (Username t) = TTC.convert t + +instance TTC.Parse Username where + parse = TTC.asT $ \t -> do + unless (T.all isAsciiLower t) $ Left "username has invalid characters" + let len = T.length t + when (len < 3) $ Left "username has fewer than 3 characters" + when (len > 12) $ Left "username has more than 12 characters" + pure $ Username t diff --git a/examples/invalid.hs b/examples/invalid.hs new file mode 100644 --- /dev/null +++ b/examples/invalid.hs @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : example of compile-time validation failure +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- 'TTC.valid' is used to create validated constants. The credit card number +-- has an invalid checksum, triggering a compile-time error. +------------------------------------------------------------------------------ + +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +-- (ttc) +import qualified Data.TTC as TTC + +-- (ttc:example-invalid) +import CreditCard (CreditCard(CreditCard)) + +-- HLint does not support typed expression splices +{-# ANN module "HLint: ignore" #-} + +------------------------------------------------------------------------------ + +sample :: CreditCard +sample = CreditCard + $$(TTC.valid "John Q Doe") + $$(TTC.valid "1234 5678 9012") + $$(TTC.valid "2020-06") + $$(TTC.valid "123") + +------------------------------------------------------------------------------ + +main :: IO () +main = print sample diff --git a/examples/mkvalid.hs b/examples/mkvalid.hs new file mode 100644 --- /dev/null +++ b/examples/mkvalid.hs @@ -0,0 +1,33 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : example of compile-time validation +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- 'Data.TTC.mkValid' is used to create the 'Duration.valid' function, without +-- the need for a 'Language.Haskell.TH.Syntax.Lift' instance. In this +-- example, the sample duration is validated at compile-time and parsed again +-- at run-time. +------------------------------------------------------------------------------ + +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +-- (ttc:example-mkvalid) +import qualified Duration as Duration +import Duration (Duration) + +-- HLint does not support typed expression splices +{-# ANN module "HLint: ignore" #-} + +------------------------------------------------------------------------------ + +sample :: Duration +sample = $$(Duration.valid "123") + +------------------------------------------------------------------------------ + +main :: IO () +main = print sample diff --git a/examples/prompt.hs b/examples/prompt.hs new file mode 100644 --- /dev/null +++ b/examples/prompt.hs @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : example CLI prompt using TTC +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- 'TTC.Parse' and 'TTC.Render' instances are used to create a CLI prompt, +-- demonstrating TTC usage. +------------------------------------------------------------------------------ + +module Main (main) where + +-- https://hackage.haskell.org/package/base +import qualified System.IO as IO + +-- https://hackage.haskell.org/package/time +import qualified Data.Time.Calendar as Calendar +import qualified Data.Time.Clock as Clock + +-- (ttc) +import qualified Data.TTC as TTC + +-- (ttc:example-prompt) +import qualified CreditCard as CC +import CreditCard (CreditCard(CreditCard), ExpirationDate(ExpirationDate)) + +------------------------------------------------------------------------------ + +-- | This function prompts for a value of the desired type. When input is +-- invalid, it displays the error and tries again. +prompt + :: TTC.Parse a + => String -- ^ prompt string + -> IO a +prompt promptString = loop + where + loop = do + putStr promptString + IO.hFlush IO.stdout + s <- getLine + case TTC.parse s of + Right x -> return x + Left err -> do + putStrLn $ " " <> err + loop + +------------------------------------------------------------------------------ + +-- | This function prompts for credit card details. +promptCC :: IO CreditCard +promptCC = CreditCard + <$> prompt "Enter the name: " + <*> prompt "Enter the number: " + <*> + ( ExpirationDate + <$> prompt "Enter the expiration year (YYYY): " + <*> prompt "Enter the expiration month (MM): " + ) + <*> prompt "Enter the security code: " + +------------------------------------------------------------------------------ + +-- | The program prompts for credit card details, prints out the normalized +-- values, and shows information about expiration. +main :: IO () +main = do + putStrLn "Please enter some fake credit card details." + cc <- promptCC + putStrLn $ replicate 78 '-' + putStrLn $ "Name: " <> TTC.render (CC.name cc) + putStrLn $ "Number: " <> TTC.render (CC.number cc) + putStrLn $ "Expiration date: " <> TTC.render (CC.expirationDate cc) + putStrLn $ "Security code: " <> TTC.render (CC.securityCode cc) + putStrLn $ replicate 78 '-' + today <- Clock.utctDay <$> Clock.getCurrentTime + putStrLn . ("This credit card " <>) . (<> "!") $ + case CC.toDay (CC.expirationDate cc) of + expiry + | expiry > today -> "expires in " <> diffDays expiry today + | expiry < today -> "expired " <> diffDays today expiry <> " ago" + | otherwise -> "expires today" + where + diffDays :: Calendar.Day -> Calendar.Day -> String + diffDays day1 day2 = case Calendar.diffDays day1 day2 of + 1 -> "1 day" + n -> show n <> " days" diff --git a/examples/uname.hs b/examples/uname.hs new file mode 100644 --- /dev/null +++ b/examples/uname.hs @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : minimal example of using Render and Parse instances +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +------------------------------------------------------------------------------ + +module Main (main) where + +-- (ttc) +import qualified Data.TTC as TTC + +-- (ttc:example-uname) +import Username (Username) + +------------------------------------------------------------------------------ + +main :: IO () +main = case TTC.parse "tcard" :: Either String Username of + Right uname -> putStrLn $ "valid username: " ++ TTC.render uname + Left err -> putStrLn $ "invalid username: " ++ err diff --git a/examples/valid.hs b/examples/valid.hs new file mode 100644 --- /dev/null +++ b/examples/valid.hs @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Main +-- Description : example of compile-time validation +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- 'TTC.valid' is used to create validated constants. The sample credit card +-- is validated at compile-time. +------------------------------------------------------------------------------ + +{-# LANGUAGE TemplateHaskell #-} + +module Main (main) where + +-- (ttc) +import qualified Data.TTC as TTC + +-- (ttc:example-valid) +import CreditCard (CreditCard(CreditCard)) + +-- HLint does not support typed expression splices +{-# ANN module "HLint: ignore" #-} + +------------------------------------------------------------------------------ + +sample :: CreditCard +sample = CreditCard + $$(TTC.valid "John Q Doe") + $$(TTC.valid "1234 5678 9015") + $$(TTC.valid "2020-06") + $$(TTC.valid "123") + +------------------------------------------------------------------------------ + +main :: IO () +main = print sample diff --git a/src/Data/TTC.hs b/src/Data/TTC.hs new file mode 100644 --- /dev/null +++ b/src/Data/TTC.hs @@ -0,0 +1,641 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Data.TTC +-- Description : textual type classes +-- Copyright : Copyright (c) 2019 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 FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.TTC + ( -- * Textual + Textual + , convert + -- ** \"To\" Conversions + -- $TextualTo + , toS + , toT + , toTL + , toBS + , toBSL + -- ** \"From\" Conversions + -- $TextualFrom + , fromS + , fromT + , fromTL + , fromBS + , fromBSL + -- ** \"As\" Conversions + -- $TextualAs + , asS + , asT + , asTL + , asBS + , asBSL + -- ** Other Conversions + -- $TextualOther + , toTLB + , fromTLB + , toBSB + , fromBSB + , toSBS + , fromSBS + -- * Render + , Render(..) + -- ** Rendering Specific Types + -- $RenderSpecific + , renderS + , renderT + , renderTL + , renderBS + , renderBSL + -- ** Render Utilities + , renderWithShow + -- * Parse + , Parse(..) + -- ** Parsing From Specific Types + -- $ParseSpecific + , parseS + , parseT + , parseTL + , parseBS + , parseBSL + -- ** 'Maybe' Parsing + -- $ParseMaybe + , parseMaybe + , parseMaybeS + , parseMaybeT + , parseMaybeTL + , parseMaybeBS + , parseMaybeBSL + -- ** Unsafe Parsing + -- $ParseUnsafe + , parseUnsafe + , parseUnsafeS + , parseUnsafeT + , parseUnsafeTL + , parseUnsafeBS + , parseUnsafeBSL + -- ** Parse Utilities + , parseEnum + , parseEnum' + , parseWithRead + , parseWithRead' + , readsEnum + , readsWithParse + , valid + , validOf + , mkValid + ) where + +-- https://hackage.haskell.org/package/base +import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +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.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 + +-- HLint does not support typed expression quotations: +-- https://github.com/ndmitchell/hlint/issues/332 +-- +-- The following ignore annotation is not working. It works via the CLI: +-- hlint -i "Parse error" +{-# ANN module "HLint: ignore Parse error" #-} + +------------------------------------------------------------------------------ +-- $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@) +-- * Strict 'BS.ByteString' (@BS@) +-- * Lazy 'BSL.ByteString' (@BSL@) +-- +-- @ByteString@ values are assumed to be UTF-8 encoded text. Invalid bytes +-- are replaced with the Unicode replacement character @U+FFFD@. In cases +-- where different behavior is required, process @ByteString@ values /before/ +-- using this class. +-- +-- The key feature of this type class is that it has a single type variable, +-- making it easy to write functions that accepts arguments and/or returns +-- values that may be any of the supported textual data types. +-- +-- Note that support for additional data types cannot be implemented by +-- writing instances. Adding support for additional data types would require +-- changing the class definition itself. This is the price paid for having +-- only one type variable instead of two. +class Textual t where + -- | Convert to a 'String' + toS :: t -> String + + -- | Convert to strict 'T.Text' + toT :: t -> T.Text + + -- | Convert to lazy 'TL.Text' + toTL :: t -> TL.Text + + -- | Convert to a strict 'BS.ByteString' + toBS :: t -> BS.ByteString + + -- | Convert to a lazy 'BS.ByteString' + toBSL :: t -> BSL.ByteString + + -- | Convert between any supported textual data types + convert :: Textual t' => t' -> t + +instance Textual String where + toS = id + toT = T.pack + toTL = TL.pack + toBS = TE.encodeUtf8 . T.pack + toBSL = TLE.encodeUtf8 . TL.pack + convert = toS + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE convert #-} + +instance Textual T.Text where + toS = T.unpack + toT = id + toTL = TL.fromStrict + toBS = TE.encodeUtf8 + toBSL = TLE.encodeUtf8 . TL.fromStrict + convert = toT + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# INLINE convert #-} + +instance Textual TL.Text where + toS = TL.unpack + toT = TL.toStrict + toTL = id + toBS = BSL.toStrict . TLE.encodeUtf8 + toBSL = TLE.encodeUtf8 + convert = toTL + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# 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 + toBS = id + toBSL = BSL.fromStrict + convert = toBS + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# 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 + toBS = BSL.toStrict + toBSL = id + convert = toBSL + {-# INLINE toS #-} + {-# INLINE toT #-} + {-# INLINE toTL #-} + {-# INLINE toBS #-} + {-# INLINE toBSL #-} + {-# 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' +fromS :: Textual t => String -> t +fromS = convert +{-# INLINE fromS #-} + +-- | Convert from strict 'T.Text' +fromT :: Textual t => T.Text -> t +fromT = convert +{-# INLINE fromT #-} + +-- | Convert from lazy 'TL.Text' +fromTL :: Textual t => TL.Text -> t +fromTL = convert +{-# INLINE fromTL #-} + +-- | Convert from a strict 'BS.ByteString' +fromBS :: Textual t => BS.ByteString -> t +fromBS = convert +{-# INLINE fromBS #-} + +-- | Convert from a lazy 'BSL.ByteString' +fromBSL :: Textual t => BSL.ByteString -> t +fromBSL = convert +{-# INLINE fromBSL #-} + +-- $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' +asS :: Textual t => (String -> a) -> t -> a +asS f = f . convert +{-# INLINE asS #-} + +-- | Convert an argument to strict 'T.Text' +asT :: Textual t => (T.Text -> a) -> t -> a +asT f = f . convert +{-# INLINE asT #-} + +-- | Convert an argument to lazy 'TL.Text' +asTL :: Textual t => (TL.Text -> a) -> t -> a +asTL f = f . convert +{-# INLINE asTL #-} + +-- | Convert an argument to a strict 'BS.ByteString' +asBS :: Textual t => (BS.ByteString -> a) -> t -> a +asBS f = f . convert +{-# INLINE asBS #-} + +-- | Convert an argument to a lazy 'BSL.ByteString' +asBSL :: Textual t => (BSL.ByteString -> a) -> t -> a +asBSL f = f . convert +{-# INLINE asBSL #-} + +-- $TextualOther +-- +-- These functions are used to convert to/from the following other textual +-- data types: +-- +-- * @Text@ 'TLB.Builder' (@TLB@) +-- * @ByteString@ 'BSB.Builder' (@BSB@) +-- * 'SBS.ShortByteString' (@SBS@) + +-- | Convert to a @Text@ 'TLB.Builder' +toTLB :: Textual t => t -> TLB.Builder +toTLB = TLB.fromLazyText . convert + +-- | Convert from a @Text@ 'TLB.Builder' +fromTLB :: Textual t => TLB.Builder -> t +fromTLB = convert . TLB.toLazyText + +-- | Convert to a @ByteString@ 'BSB.Builder' +toBSB :: Textual t => t -> BSB.Builder +toBSB = BSB.lazyByteString . convert + +-- | Convert from a @ByteString@ 'BSB.Builder' +fromBSB :: Textual t => BSB.Builder -> t +fromBSB = convert . BSB.toLazyByteString + +-- | Convert to a 'SBS.ShortByteString' +toSBS :: Textual t => t -> SBS.ShortByteString +toSBS = SBS.toShort . convert + +-- | Convert from a 'SBS.ShortByteString' +fromSBS :: Textual t => SBS.ShortByteString -> t +fromSBS = convert . SBS.fromShort + +------------------------------------------------------------------------------ +-- $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 available in "Data.TTC.Instances". +class Render a where + render :: Textual t => a -> t + +-- $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' +renderS :: Render a => a -> String +renderS = render +{-# INLINE renderS #-} + +-- | Render to strict 'T.Text' +renderT :: Render a => a -> T.Text +renderT = render +{-# INLINE renderT #-} + +-- | Render to lazy 'TL.Text' +renderTL :: Render a => a -> TL.Text +renderTL = render +{-# INLINE renderTL #-} + +-- | Render to a strict 'BS.ByteString' +renderBS :: Render a => a -> BS.ByteString +renderBS = render +{-# INLINE renderBS #-} + +-- | Render to a lazy 'BSL.ByteString' +renderBSL :: Render a => a -> BSL.ByteString +renderBSL = render +{-# INLINE renderBSL #-} + +-- $RenderUtils + +-- | Render a value to a textual data type using the 'Show' instance +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 available in "Data.TTC.Instances". +class Parse a where + parse :: Textual t => t -> Either String a + +-- $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' +parseS :: Parse a => String -> Either String a +parseS = parse +{-# INLINE parseS #-} + +-- | Parse from strict 'T.Text' +parseT :: Parse a => T.Text -> Either String a +parseT = parse +{-# INLINE parseT #-} + +-- | Parse from lazy 'TL.Text' +parseTL :: Parse a => TL.Text -> Either String a +parseTL = parse +{-# INLINE parseTL #-} + +-- | Parse from a strict 'BS.ByteString' +parseBS :: Parse a => BS.ByteString -> Either String a +parseBS = parse +{-# INLINE parseBS #-} + +-- | Parse from a lazy 'BSL.ByteString' +parseBSL :: Parse a => BSL.ByteString -> Either String a +parseBSL = parse +{-# INLINE parseBSL #-} + +-- $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 +parseMaybe :: Parse a => Textual t => t -> Maybe a +parseMaybe = either (const Nothing) Just . parse +{-# INLINE parseMaybe #-} + +-- | Parse from a 'String' to a 'Maybe' type +parseMaybeS :: Parse a => String -> Maybe a +parseMaybeS = parseMaybe +{-# INLINE parseMaybeS #-} + +-- | Parse from strict 'T.Text' to a 'Maybe' type +parseMaybeT :: Parse a => T.Text -> Maybe a +parseMaybeT = parseMaybe +{-# INLINE parseMaybeT #-} + +-- | Parse from lazy 'TL.Text' to a 'Maybe' type +parseMaybeTL :: Parse a => TL.Text -> Maybe a +parseMaybeTL = parseMaybe +{-# INLINE parseMaybeTL #-} + +-- | Parse from a strict 'BS.ByteString' to a 'Maybe' type +parseMaybeBS :: Parse a => BS.ByteString -> Maybe a +parseMaybeBS = parseMaybe +{-# INLINE parseMaybeBS #-} + +-- | Parse from a lazy 'BSL.ByteString' to a 'Maybe' type +parseMaybeBSL :: Parse a => BSL.ByteString -> Maybe a +parseMaybeBSL = parseMaybe +{-# INLINE parseMaybeBSL #-} + +-- $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 +parseUnsafe :: (Parse a, Textual t) => t -> a +parseUnsafe = either (error . ("parseUnsafe: " ++)) id . parse +{-# INLINE parseUnsafe #-} + +-- | Unsafely parse to a 'String' +parseUnsafeS :: Parse a => String -> a +parseUnsafeS = parseUnsafe +{-# INLINE parseUnsafeS #-} + +-- | Unsafely parse to strict 'T.Text' +parseUnsafeT :: Parse a => T.Text -> a +parseUnsafeT = parseUnsafe +{-# INLINE parseUnsafeT #-} + +-- | Unsafely parse to lazy 'TL.Text' +parseUnsafeTL :: Parse a => TL.Text -> a +parseUnsafeTL = parseUnsafe +{-# INLINE parseUnsafeTL #-} + +-- | Unsafely parse to a strict 'BS.ByteString' +parseUnsafeBS :: Parse a => BS.ByteString -> a +parseUnsafeBS = parseUnsafe +{-# INLINE parseUnsafeBS #-} + +-- | Unsafely parse to a lazy 'BSL.ByteString' +parseUnsafeBSL :: Parse a => BSL.ByteString -> a +parseUnsafeBSL = parseUnsafe +{-# INLINE parseUnsafeBSL #-} + +-- $ParseUtils + +-- | Parse a value in an enumeration +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 + _ -> 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 'String' 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 +parseEnum' + :: (Bounded a, Enum a, Render a, Textual t) + => String -- ^ name to include in error messages + -> Bool -- ^ case-insensitive when 'True' + -> Bool -- ^ accept unique prefixes when 'True' + -> t -- ^ textual input to parse + -> Either String a -- ^ error or parsed value +parseEnum' name allowCI allowPrefix = + parseEnum allowCI allowPrefix ("invalid " ++ name) ("ambiguous " ++ name) +{-# INLINEABLE parseEnum' #-} + +-- | Parse a value using the 'Read' instance +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 'String' error messages +-- +-- The following English error message is returned: +-- +-- * \"invalid {name}\" when the parse fails +parseWithRead' + :: (Read a, Textual t) + => String -- ^ name to include in error messages + -> t -- ^ textual input to parse + -> Either String a -- ^ error or parsed value +parseWithRead' name = parseWithRead ("invalid " ++ name) +{-# INLINEABLE parseWithRead' #-} + +-- | Implement 'ReadS' using 'parseEnum' +-- +-- This implementation expects all of the input to be consumed. +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. +readsWithParse + :: Parse a + => ReadS a +readsWithParse s = case parse s of + Right v -> [(v, "")] + Left{} -> [] +{-# INLINEABLE readsWithParse #-} + +-- | Validate a constant at compile-time using a 'Parse' instance +-- +-- This function parses the 'String' at compile-time in order to validate it. +-- When valid, the result is compiled in, so the result type must have a +-- 'THS.Lift' instance. Use 'validOf' when this is inconvenient. +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 + +-- | Validate a constant at compile-time using a 'Parse' instance +-- +-- This function parses the 'String' at compile-time in order to validate it. +-- 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. +validOf + :: Parse a + => Proxy a + -> String + -> TH.Q (TH.TExp a) +validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of + Right{} -> [|| parseUnsafe s ||] + Left err -> fail $ "Invalid constant: " ++ err + +-- | Make a @valid@ function using 'validOf' for the given type +mkValid + :: String + -> TH.Name + -> TH.DecsQ +mkValid funName typeName = do + let funName' = TH.mkName funName + resultType = pure $ TH.ConT typeName + funType <- [t| String -> TH.Q (TH.TExp $resultType) |] + body <- [| validOf (Proxy :: Proxy $resultType) |] + return + [ TH.SigD funName' funType + , TH.FunD funName' [TH.Clause [] (TH.NormalB body) []] + ] diff --git a/src/Data/TTC/Instances.hs b/src/Data/TTC/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/TTC/Instances.hs @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Data.TTC.Instances +-- Description : instances for basic data types +-- Copyright : Copyright (c) 2019 Travis Cardwell +-- License : MIT +-- +-- This module defines TTC 'TTC.Render' and 'TTC.Parse' instances for some +-- basic data types. The definitions for the numeric data types are +-- implemented using the 'Show' and 'Read' instances. The definitions for the +-- character and textual data types are implemented without quoting. +-- +-- To use these instances, explicitly import them as follows: +-- +-- @ +-- import Data.TTC.Instances () +-- @ +------------------------------------------------------------------------------ + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.TTC.Instances () where + +-- https://hackage.haskell.org/package/base +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- (ttc) +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ + +instance TTC.Parse Char where + parse = TTC.asS $ \case + [c] -> Right c + _ -> Left "invalid Char" + +instance TTC.Render Char where + render c = TTC.fromS [c] + +------------------------------------------------------------------------------ + +instance TTC.Parse Double where + parse = TTC.parseWithRead' "Double" + +instance TTC.Render Double where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Float where + parse = TTC.parseWithRead' "Float" + +instance TTC.Render Float where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Int where + parse = TTC.parseWithRead' "Int" + +instance TTC.Render Int where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Int8 where + parse = TTC.parseWithRead' "Int8" + +instance TTC.Render Int8 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Int16 where + parse = TTC.parseWithRead' "Int16" + +instance TTC.Render Int16 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Int32 where + parse = TTC.parseWithRead' "Int32" + +instance TTC.Render Int32 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Int64 where + parse = TTC.parseWithRead' "Int64" + +instance TTC.Render Int64 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Integer where + parse = TTC.parseWithRead' "Integer" + +instance TTC.Render Integer where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Word where + parse = TTC.parseWithRead' "Word" + +instance TTC.Render Word where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Word8 where + parse = TTC.parseWithRead' "Word8" + +instance TTC.Render Word8 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Word16 where + parse = TTC.parseWithRead' "Word16" + +instance TTC.Render Word16 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Word32 where + parse = TTC.parseWithRead' "Word32" + +instance TTC.Render Word32 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse Word64 where + parse = TTC.parseWithRead' "Word64" + +instance TTC.Render Word64 where + render = TTC.renderWithShow + +------------------------------------------------------------------------------ + +instance TTC.Parse String where + parse = Right . TTC.toS + +instance TTC.Render String where + render = TTC.fromS + +------------------------------------------------------------------------------ + +instance TTC.Parse BSL.ByteString where + parse = Right . TTC.toBSL + +instance TTC.Render BSL.ByteString where + render = TTC.fromBSL + +------------------------------------------------------------------------------ + +instance TTC.Parse BS.ByteString where + parse = Right . TTC.toBS + +instance TTC.Render BS.ByteString where + render = TTC.fromBS + +------------------------------------------------------------------------------ + +instance TTC.Parse TL.Text where + parse = Right . TTC.toTL + +instance TTC.Render TL.Text where + render = TTC.fromTL + +------------------------------------------------------------------------------ + +instance TTC.Parse T.Text where + parse = Right . TTC.toT + +instance TTC.Render T.Text where + render = TTC.fromT diff --git a/test/Data/TTC/Instances/Test.hs b/test/Data/TTC/Instances/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/TTC/Instances/Test.hs @@ -0,0 +1,336 @@ +module Data.TTC.Instances.Test (tests) where + +-- https://hackage.haskell.org/package/base +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) + +-- https://hackage.haskell.org/package/bytestring +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (TestTree, testGroup) + +-- https://hackage.haskell.org/package/tasty-hunit +import Test.Tasty.HUnit ((@=?), testCase) + +-- https://hackage.haskell.org/package/text +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- (ttc) +import qualified Data.TTC as TTC +import Data.TTC.Instances () + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +------------------------------------------------------------------------------ +-- $TestData + +xS :: String +xS = "test テスト" + +xT :: T.Text +xT = TTC.convert "test テスト" + +xTL :: TL.Text +xTL = TTC.convert "test テスト" + +xBS :: BS.ByteString +xBS = TTC.convert "test テスト" + +xBSL :: BSL.ByteString +xBSL = TTC.convert "test テスト" + +------------------------------------------------------------------------------ + +testChar :: TestTree +testChar = testGroup "Char" + [ testCase "Render" $ "*" @=? TTC.render '*' + , testCase "Parse.OK" $ Right '*' @=? TTC.parse "*" + , testCase "Parse.empty" $ Left "invalid Char" @=? + (TTC.parse "" :: Either String Char) + , testCase "Parse.multiple" $ Left "invalid Char" @=? + (TTC.parse "**" :: Either String Char) + ] + +testDouble :: TestTree +testDouble = testGroup "Double" + [ testCase "Render" $ s @=? TTC.render x + , testCase "Parse.OK" $ Right x' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Double" @=? + (TTC.parse "invalid" :: Either String Double) + ] + where + x :: Double + x = 3.14159 + + s :: String + s = show x + + x' :: Double + x' = read s + +testFloat :: TestTree +testFloat = testGroup "Float" + [ testCase "Render" $ s @=? TTC.render x + , testCase "Parse.OK" $ Right x' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Float" @=? + (TTC.parse "invalid" :: Either String Float) + ] + where + x :: Float + x = 3.14159 + + s :: String + s = show x + + x' :: Float + x' = read s + +testInt :: TestTree +testInt = testGroup "Int" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Int" @=? + (TTC.parse "invalid" :: Either String Int) + ] + where + n :: Int + n = 42 + + s :: String + s = show n + + n' :: Int + n' = read s + +testInt8 :: TestTree +testInt8 = testGroup "Int8" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Int8" @=? + (TTC.parse "invalid" :: Either String Int8) + ] + where + n :: Int8 + n = 42 + + s :: String + s = show n + + n' :: Int8 + n' = read s + +testInt16 :: TestTree +testInt16 = testGroup "Int16" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Int16" @=? + (TTC.parse "invalid" :: Either String Int16) + ] + where + n :: Int16 + n = 42 + + s :: String + s = show n + + n' :: Int16 + n' = read s + +testInt32 :: TestTree +testInt32 = testGroup "Int32" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Int32" @=? + (TTC.parse "invalid" :: Either String Int32) + ] + where + n :: Int32 + n = 42 + + s :: String + s = show n + + n' :: Int32 + n' = read s + +testInt64 :: TestTree +testInt64 = testGroup "Int64" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Int64" @=? + (TTC.parse "invalid" :: Either String Int64) + ] + where + n :: Int64 + n = 42 + + s :: String + s = show n + + n' :: Int64 + n' = read s + +testInteger :: TestTree +testInteger = testGroup "Integer" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Integer" @=? + (TTC.parse "invalid" :: Either String Integer) + ] + where + n :: Integer + n = 42 + + s :: String + s = show n + + n' :: Integer + n' = read s + +testWord :: TestTree +testWord = testGroup "Word" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Word" @=? + (TTC.parse "invalid" :: Either String Word) + ] + where + n :: Word + n = 42 + + s :: String + s = show n + + n' :: Word + n' = read s + +testWord8 :: TestTree +testWord8 = testGroup "Word8" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Word8" @=? + (TTC.parse "invalid" :: Either String Word8) + ] + where + n :: Word8 + n = 42 + + s :: String + s = show n + + n' :: Word8 + n' = read s + +testWord16 :: TestTree +testWord16 = testGroup "Word16" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Word16" @=? + (TTC.parse "invalid" :: Either String Word16) + ] + where + n :: Word16 + n = 42 + + s :: String + s = show n + + n' :: Word16 + n' = read s + +testWord32 :: TestTree +testWord32 = testGroup "Word32" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Word32" @=? + (TTC.parse "invalid" :: Either String Word32) + ] + where + n :: Word32 + n = 42 + + s :: String + s = show n + + n' :: Word32 + n' = read s + +testWord64 :: TestTree +testWord64 = testGroup "Word64" + [ testCase "Render" $ s @=? TTC.render n + , testCase "Parse.OK" $ Right n' @=? TTC.parse s + , testCase "Parse.invalid" $ Left "invalid Word64" @=? + (TTC.parse "invalid" :: Either String Word64) + ] + where + n :: Word64 + n = 42 + + s :: String + s = show n + + n' :: Word64 + n' = read s + +testString :: TestTree +testString = testGroup "String" + [ testCase "Render" $ xS @=? TTC.render xS + , testCase "Parse.empty" $ Right "" @=? TTC.parse "" + , testCase "Parse.nonempty" $ Right xS @=? TTC.parse xS + ] + +testBSL :: TestTree +testBSL = testGroup "BSL.ByteString" + [ testCase "Render" $ xS @=? TTC.render xBSL + , testCase "Parse.empty" $ Right BSL.empty @=? TTC.parse "" + , testCase "Parse.nonempty" $ Right xBSL @=? TTC.parse xS + ] + +testBS :: TestTree +testBS = testGroup "BS.ByteString" + [ testCase "Render" $ xS @=? TTC.render xBS + , testCase "Parse.empty" $ Right BS.empty @=? TTC.parse "" + , testCase "Parse.nonempty" $ Right xBS @=? TTC.parse xS + ] + +testTL :: TestTree +testTL = testGroup "TL.Text" + [ testCase "Render" $ xS @=? TTC.render xTL + , testCase "Parse.empty" $ Right TL.empty @=? TTC.parse "" + , testCase "Parse.nonempty" $ Right xTL @=? TTC.parse xS + ] + +testT :: TestTree +testT = testGroup "T.Text" + [ testCase "Render" $ xS @=? TTC.render xT + , testCase "Parse.empty" $ Right T.empty @=? TTC.parse "" + , testCase "Parse.nonempty" $ Right xT @=? TTC.parse xS + ] + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "Data.TTC.Instances" + [ testChar + , testDouble + , testFloat + , testInt + , testInt8 + , testInt16 + , testInt32 + , testInt64 + , testInteger + , testWord + , testWord8 + , testWord16 + , testWord32 + , testWord64 + , testString + , testBSL + , testBS + , testTL + , testT + ] diff --git a/test/Data/TTC/Test.hs b/test/Data/TTC/Test.hs new file mode 100644 --- /dev/null +++ b/test/Data/TTC/Test.hs @@ -0,0 +1,623 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.TTC.Test (tests) where + +-- https://hackage.haskell.org/package/base +import Control.Exception (ErrorCall, Exception, evaluate, handle) +import Data.Proxy (Proxy(Proxy), asProxyTypeOf) +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 + +-- (ttc) +import qualified Data.TTC as TTC + +------------------------------------------------------------------------------ +-- $HelperFunctions + +assertRaises + :: (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 テスト" + +xBS :: BS.ByteString +xBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" + +xBSL :: BSL.ByteString +xBSL = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88" + +xTLB :: TLB.Builder +xTLB = "test テスト" + +xBSB :: BSB.Builder +xBSB = "test テスト" + +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" + +xiBS :: BS.ByteString +xiBS = "test \xe3" + +xiBSL :: BSL.ByteString +xiBSL = "test \xe3" + +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 "not positive" + Nothing -> Left "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" + +answerBS :: BS.ByteString +answerBS = "42" + +answerBSL :: BSL.ByteString +answerBSL = "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" + +redBS :: BS.ByteString +redBS = "red" + +redBSL :: BSL.ByteString +redBSL = "red" + +------------------------------------------------------------------------------ +-- $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 "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 + ] + +testToT :: TestTree +testToT = testGroup "toT" + [ testCase "S" $ xT @=? TTC.toT xS + , testCase "T" $ xT @=? TTC.toT xT + , testCase "TL" $ xT @=? TTC.toT xTL + , 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 + ] + +testToTL :: TestTree +testToTL = testGroup "toTL" + [ testCase "S" $ xTL @=? TTC.toTL xS + , testCase "T" $ xTL @=? TTC.toTL xT + , testCase "TL" $ xTL @=? TTC.toTL xTL + , 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 + ] + +testToBS :: TestTree +testToBS = testGroup "toBS" + [ testCase "S" $ xBS @=? TTC.toBS xS + , testCase "T" $ xBS @=? TTC.toBS xT + , testCase "TL" $ xBS @=? TTC.toBS xTL + , testCase "BS" $ xBS @=? TTC.toBS xBS + , testCase "BSL" $ xBS @=? TTC.toBS xBSL + ] + +testToBSL :: TestTree +testToBSL = testGroup "toBSL" + [ testCase "S" $ xBSL @=? TTC.toBSL xS + , testCase "T" $ xBSL @=? TTC.toBSL xT + , testCase "TL" $ xBSL @=? TTC.toBSL xTL + , testCase "BS" $ xBSL @=? TTC.toBSL xBS + , testCase "BSL" $ xBSL @=? TTC.toBSL xBSL + ] + +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->BS" $ xBS @=? TTC.convert xS + , testCase "S->BSL" $ xBSL @=? 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->BS" $ xBS @=? TTC.convert xT + , testCase "T->BSL" $ xBSL @=? 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->BS" $ xBS @=? TTC.convert xTL + , testCase "TL->BSL" $ xBSL @=? TTC.convert xTL + , testCase "BS->S" $ xS @=? TTC.convert xBS + , testCase "BS->T" $ xT @=? TTC.convert xBS + , testCase "BS->TL" $ xTL @=? TTC.convert xBS + , testCase "BS->BS" $ xBS @=? TTC.convert xBS + , testCase "BS->BSL" $ xBSL @=? 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->BS" $ xBS @=? TTC.convert xBSL + , testCase "BSL->BSL" $ xBSL @=? TTC.convert xBSL + ] + +testFromS :: TestTree +testFromS = testGroup "fromS" + [ testCase "S" $ xS @=? TTC.fromS xS + , testCase "T" $ xT @=? TTC.fromS xS + , testCase "TL" $ xTL @=? TTC.fromS xS + , testCase "BS" $ xBS @=? TTC.fromS xS + , testCase "BSL" $ xBSL @=? 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 "BS" $ xBS @=? TTC.fromT xT + , testCase "BSL" $ xBSL @=? 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 "BS" $ xBS @=? TTC.fromTL xTL + , testCase "BSL" $ xBSL @=? TTC.fromTL xTL + ] + +testFromBS :: TestTree +testFromBS = testGroup "fromBS" + [ testCase "S" $ xS @=? TTC.fromBS xBS + , testCase "T" $ xT @=? TTC.fromBS xBS + , testCase "TL" $ xTL @=? TTC.fromBS xBS + , testCase "BS" $ xBS @=? TTC.fromBS xBS + , testCase "BSL" $ xBSL @=? 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 "BS" $ xBS @=? TTC.fromBSL xBSL + , testCase "BSL" $ xBSL @=? TTC.fromBSL xBSL + ] + +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 "BS" $ xS @=? TTC.asS id xBS + , testCase "BSL" $ xS @=? TTC.asS id xBSL + ] + +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 "BS" $ xT @=? TTC.asT id xBS + , testCase "BSL" $ xT @=? TTC.asT id xBSL + ] + +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 "BS" $ xTL @=? TTC.asTL id xBS + , testCase "BSL" $ xTL @=? TTC.asTL id xBSL + ] + +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 "BS" $ xBS @=? TTC.asBS id xBS + , testCase "BSL" $ xBS @=? TTC.asBS id xBSL + ] + +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 "BS" $ xBSL @=? TTC.asBSL id xBS + , testCase "BSL" $ xBSL @=? TTC.asBSL id xBSL + ] + +testToTLB :: TestTree +testToTLB = testCase "toTLB" $ xTLB @=? TTC.toTLB xS + +testFromTLB :: TestTree +testFromTLB = testCase "fromTLB" $ xS @=? TTC.fromTLB xTLB + +testToBSB :: TestTree +testToBSB = testCase "toBSB" $ + BSB.toLazyByteString xBSB @=? BSB.toLazyByteString (TTC.toBSB xS) + +testFromBSB :: TestTree +testFromBSB = testCase "fromBSB" $ xS @=? TTC.fromBSB xBSB + +testToSBS :: TestTree +testToSBS = testCase "toSBS" $ xSBS @=? TTC.toSBS xS + +testFromSBS :: TestTree +testFromSBS = testCase "fromSBS" $ xS @=? TTC.fromSBS 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 "BS" $ answerBS @=? TTC.render answer + , testCase "BSL" $ answerBSL @=? TTC.render answer + ] + +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 + +testRenderBS :: TestTree +testRenderBS = testCase "renderBS" $ answerBS @=? TTC.renderBS answer + +testRenderBSL :: TestTree +testRenderBSL = testCase "renderBSL" $ answerBSL @=? TTC.renderBSL 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 "BS" $ answerBS @=? TTC.renderWithShow answerZ + , testCase "BSL" $ answerBSL @=? TTC.renderWithShow answerZ + ] + +------------------------------------------------------------------------------ +-- $Parse + +testParse :: TestTree +testParse = testGroup "parse" + [ testCase "S" $ Right answer @=? TTC.parse answerS + , testCase "T" $ Right answer @=? TTC.parse answerT + , testCase "TL" $ Right answer @=? TTC.parse answerTL + , testCase "BS" $ Right answer @=? TTC.parse answerBS + , testCase "BSL" $ Right answer @=? TTC.parse answerBSL + , testCase "negative" $ Left "not positive" @=? + (TTC.parse ('-' : answerS) :: Either String PosInt) + , testCase "invalid" $ Left "not an integer" @=? + (TTC.parse ('a' : answerS) :: Either String PosInt) + ] + +testParseS :: TestTree +testParseS = testCase "parseS" $ Right answer @=? TTC.parseS answerS + +testParseT :: TestTree +testParseT = testCase "parseT" $ Right answer @=? TTC.parseT answerT + +testParseTL :: TestTree +testParseTL = testCase "parseTL" $ Right answer @=? TTC.parseTL answerTL + +testParseBS :: TestTree +testParseBS = testCase "parseBS" $ Right answer @=? TTC.parseBS answerBS + +testParseBSL :: TestTree +testParseBSL = testCase "parseBSL" $ Right answer @=? TTC.parseBSL answerBSL + +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 "BS" $ Just answer @=? TTC.parseMaybe answerBS + , testCase "BSL" $ Just answer @=? TTC.parseMaybe answerBSL + , 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 + +testParseMaybeBS :: TestTree +testParseMaybeBS = testCase "parseMaybeBS" $ + Just answer @=? TTC.parseMaybeBS answerBS + +testParseMaybeBSL :: TestTree +testParseMaybeBSL = testCase "parseMaybeBSL" $ + Just answer @=? TTC.parseMaybeBSL answerBSL + +testParseUnsafe :: TestTree +testParseUnsafe = testGroup "parseUnsafe" + [ testCase "S" $ answer @=? TTC.parseUnsafe answerS + , testCase "T" $ answer @=? TTC.parseUnsafe answerT + , testCase "TL" $ answer @=? TTC.parseUnsafe answerTL + , testCase "BS" $ answer @=? TTC.parseUnsafe answerBS + , testCase "BSL" $ answer @=? TTC.parseUnsafe answerBSL + , 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 + +testParseUnsafeBS :: TestTree +testParseUnsafeBS = testCase "parseUnsafeBS" $ + answer @=? TTC.parseUnsafeBS answerBS + +testParseUnsafeBSL :: TestTree +testParseUnsafeBSL = testCase "parseUnsafeBSL" $ + answer @=? TTC.parseUnsafeBSL answerBSL + +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 "BS" $ Right answerZ @=? TTC.parseWithRead IntInvalid answerBS + , testCase "BSL" $ + Right answerZ @=? TTC.parseWithRead IntInvalid answerBSL + , testCase "invalid" $ Left IntInvalid @=? + (TTC.parseWithRead IntInvalid ('a' : answerS) :: Either IntError Int) + ] + +testParseWithRead' :: TestTree +testParseWithRead' = testGroup "parseWithRead'" + [ testCase "S" $ Right answerZ @=? TTC.parseWithRead' "Int" answerS + , testCase "T" $ Right answerZ @=? TTC.parseWithRead' "Int" answerT + , testCase "TL" $ Right answerZ @=? TTC.parseWithRead' "Int" answerTL + , testCase "BS" $ Right answerZ @=? TTC.parseWithRead' "Int" answerBS + , testCase "BSL" $ Right answerZ @=? TTC.parseWithRead' "Int" answerBSL + , testCase "invalid" $ Left "invalid Int" @=? + (TTC.parseWithRead' "Int" ('a' : answerS) :: Either String 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 "BS" $ Right Red @=? parse False False redBS + , testCase "BSL" $ Right Red @=? parse False False redBSL + , 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 "BS" $ Right Red @=? parse False False redBS + , testCase "BSL" $ Right Red @=? parse False False redBSL + , 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) + ] + +------------------------------------------------------------------------------ + +tests :: TestTree +tests = testGroup "Data.TTC" + [ testGroup "Textual" + [ testToS + , testToT + , testToTL + , testToBS + , testToBSL + , testConvert + , testFromS + , testFromT + , testFromTL + , testFromBS + , testFromBSL + , testAsS + , testAsT + , testAsTL + , testAsBS + , testAsBSL + , testToTLB + , testFromTLB + , testToBSB + , testFromBSB + , testToSBS + , testFromSBS + ] + , testGroup "Render" + [ testRender + , testRenderS + , testRenderT + , testRenderTL + , testRenderBS + , testRenderBSL + , testRenderWithShow + ] + , testGroup "Parse" + [ testParse + , testParseS + , testParseT + , testParseTL + , testParseBS + , testParseBSL + , testParseMaybe + , testParseMaybeS + , testParseMaybeT + , testParseMaybeTL + , testParseMaybeBS + , testParseMaybeBSL + , testParseUnsafe + , testParseUnsafeS + , testParseUnsafeT + , testParseUnsafeTL + , testParseUnsafeBS + , testParseUnsafeBSL + , testParseWithRead + , testParseWithRead' + , testParseEnum + , testParseEnum' + , testReadsWithParse + , testReadsEnum + ] + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,16 @@ +module Main (main) where + +-- https://hackage.haskell.org/package/tasty +import Test.Tasty (defaultMain, testGroup) + +-- (ttc:test) +import qualified Data.TTC.Test +import qualified Data.TTC.Instances.Test + +------------------------------------------------------------------------------ + +main :: IO () +main = defaultMain $ testGroup "test" + [ Data.TTC.Test.tests + , Data.TTC.Instances.Test.tests + ] diff --git a/ttc.cabal b/ttc.cabal new file mode 100644 --- /dev/null +++ b/ttc.cabal @@ -0,0 +1,168 @@ +name: ttc +version: 0.1.0.0 +category: Data, Text +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#readme +bug-reports: https://github.com/ExtremaIS/ttc-haskell/issues +author: Travis Cardwell +maintainer: Travis Cardwell +copyright: Copyright (c) 2019 Travis Cardwell +license: MIT +license-file: LICENSE + +cabal-version: >=1.10 +build-type: Simple +tested-with: + GHC ==8.2.2 + || ==8.4.4 + || ==8.6.5 + +extra-source-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/ExtremaIS/ttc-haskell.git + +flag example-invalid + description: build example-invalid + default: False + +flag example-mkvalid + description: build example-mkvalid + default: False + +flag example-prompt + description: build example-prompt + default: False + +flag example-uname + description: build example-uname + default: False + +flag example-valid + description: build example-valid + default: False + +flag examples + description: build all buildable examples + default: False + +library + hs-source-dirs: src + exposed-modules: + Data.TTC + , Data.TTC.Instances + build-depends: + base >=4.7 && <5 + , bytestring >=0.10.8 && <0.11 + , template-haskell >=2.12 && <2.16 + , text >=1.2.3 && <1.3 + default-language: Haskell2010 + ghc-options: -Wall + +executable example-invalid + if flag(example-invalid) + buildable: True + else + buildable: False + hs-source-dirs: examples + main-is: invalid.hs + other-modules: + CreditCard + build-depends: + base + , template-haskell + , time >=1.8 && <1.9 + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +executable example-mkvalid + if flag(examples) || flag(example-mkvalid) + buildable: True + else + buildable: False + hs-source-dirs: examples + main-is: mkvalid.hs + other-modules: + Duration + build-depends: + base + , time >=1.8 && <1.9 + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +executable example-prompt + if flag(examples) || flag(example-prompt) + buildable: True + else + buildable: False + hs-source-dirs: examples + main-is: prompt.hs + other-modules: + CreditCard + build-depends: + base + , template-haskell + , time >=1.8 && <1.9 + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +executable example-uname + if flag(examples) || flag(example-uname) + buildable: True + else + buildable: False + hs-source-dirs: examples + main-is: uname.hs + other-modules: + Username + build-depends: + base + , text + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +executable example-valid + if flag(examples) || flag(example-valid) + buildable: True + else + buildable: False + hs-source-dirs: examples + main-is: valid.hs + other-modules: + CreditCard + build-depends: + base + , template-haskell + , time >=1.8 && <1.9 + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +test-suite ttc-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: + Data.TTC.Test + , Data.TTC.Instances.Test + build-depends: + base + , bytestring + , tasty >=1.0 && <1.3 + , tasty-hunit >=0.10 && <0.11 + , text + , ttc + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N