ttc 0.1.0.1 → 0.2.0.0

raw patch · 14 files changed

+205/−732 lines, 14 filesdep −timedep ~basedep ~tastydep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies removed: time

Dependency ranges changed: base, tasty, template-haskell, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +1/−1
• examples/CreditCard.hs +0/−230
• examples/Duration.hs +0/−127
• examples/Username.hs +0/−43
• examples/invalid.hs +0/−37
• examples/mkvalid.hs +0/−33
• examples/prompt.hs +0/−87
• examples/uname.hs +0/−22
• examples/valid.hs +0/−37
• src/Data/TTC.hs +115/−7
• test/Data/TTC/Test.hs +47/−0
• test/TestString.hs +31/−0
• ttc.cabal +3/−108

@@ -24,6 +24,14 @@  [KaC]: <https://keepachangelog.com/en/1.0.0/> +## 0.2.0.0 (2019-12-15)++### Non-Breaking++* Add untyped validation functions+* Move examples to a separate package+* Refactor examples and add more+ ## 0.1.0.1 (2019-12-02)  ### Non-Breaking

@@ -101,7 +101,7 @@ ```haskell instance TTC.Parse Username where   parse = TTC.asT $ \t-> do-    unless (T.all isAsciiLower t) $ Left "username has invalid characters"+    unless (T.all isAsciiLower t) $ Left "username has invalid character(s)"     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"

@@ -1,230 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -1,127 +0,0 @@---------------------------------------------------------------------------------- |--- 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)

@@ -1,43 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -1,37 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -1,33 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -1,87 +0,0 @@---------------------------------------------------------------------------------- |--- 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"

@@ -1,22 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -1,37 +0,0 @@---------------------------------------------------------------------------------- |--- 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

@@ -95,9 +95,13 @@   , parseWithRead'   , readsEnum   , readsWithParse+    -- ** Constant Validation   , valid   , validOf   , mkValid+  , untypedValidOf+  , mkUntypedValid+  , mkUntypedValidQQ   ) where  -- https://hackage.haskell.org/package/base@@ -112,6 +116,7 @@  -- 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@@ -352,6 +357,8 @@ -- 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".+--+-- See the @uname@ and @prompt@ example programs in the @examples@ directory. class Render a where   render :: Textual t => a -> t @@ -401,6 +408,8 @@ -- 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".+--+-- See the @uname@ and @prompt@ example programs in the @examples@ directory. class Parse a where   parse :: Textual t => t -> Either String a @@ -513,6 +522,8 @@ -- $ParseUtils  -- | Parse a value in an enumeration+--+-- See the @enum@ example program in the @examples@ directory. parseEnum   :: (Bounded a, Enum a, Render a, Textual t)   => Bool        -- ^ case-insensitive when 'True'@@ -598,11 +609,22 @@     Left{}  -> [] {-# INLINEABLE readsWithParse #-} +-- $ParseValid+ -- | 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.+-- 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 typed expression.  Typed expressions were not+-- supported in @haskell-src-exts <1.22.0@, which caused problems with+-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore+-- parse errors or use one of the alternative functions in this library.+--+-- See the @valid@, @invalid@, and @lift@ example programs in the @examples@+-- directory. valid   :: (Parse a, THS.Lift a)   => String@@ -613,19 +635,40 @@  -- | 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.+-- 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 typed expression.  Typed expressions were not+-- supported in @haskell-src-exts <1.22.0@, which caused problems with+-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore+-- parse errors or use 'untypedValidOf' instead.+--+-- See the @validof@ example program in the @examples@ directory. validOf   :: Parse a   => Proxy a   -> String   -> TH.Q (TH.TExp a) validOf proxy s = case (`asProxyTypeOf` proxy) <$> parse s of-    Right{} -> [|| parseUnsafe s ||]+    Right{} -> [|| parseUnsafeS s ||]     Left err -> fail $ "Invalid constant: " ++ err  -- | Make a @valid@ function using 'validOf' for the given type+--+-- Create a @valid@ function in the module for a type in order to avoid having+-- to write a 'Proxy' when defining constants.+--+-- This function uses a typed expression.  Typed expressions were not+-- supported in @haskell-src-exts <1.22.0@, which caused problems with+-- @hlint@.  If the issue effects you, use @hlint -i "Parse error"@ to ignore+-- parse errors or use 'mkUntypedValidOf' instead.+--+-- See the @mkvalid@ example program in the @examples@ directory. mkValid   :: String   -> TH.Name@@ -638,4 +681,69 @@     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.+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 in the module for a type in order to avoid having+-- to write a 'Proxy' when defining constants.+--+-- See the @mkuvalid@ example program in the @examples@ directory.+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.+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 []]       ]

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Data.TTC.Test (tests) where @@ -27,6 +29,13 @@ -- (ttc) import qualified Data.TTC as TTC +-- (ttc:test)+import qualified TestString+import TestString (TestString(TestString))++-- HLint does not support typed expression splices+{-# ANN module ("HLint: ignore" :: String) #-}+ ------------------------------------------------------------------------------ -- $HelperFunctions @@ -558,7 +567,37 @@     ]  ------------------------------------------------------------------------------+-- $Valid +testValid :: TestTree+testValid = testCase "valid" $ TestString "test" @=? validConst+  where+    validConst :: TestString+    validConst = $$(TTC.valid "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"@@ -619,5 +658,13 @@         , testParseEnum'         , testReadsWithParse         , testReadsEnum+        ]+    , testGroup "Valid"+        [ testValid+        , testValidOf+        , testMkValid+        , testUntypedValidOf+        , testMkUntypedValid+        , testMkUntypedValidQQ         ]     ]

@@ -0,0 +1,31 @@+{-# 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)

@@ -1,5 +1,5 @@ name:           ttc-version:        0.1.0.1+version:        0.2.0.0 category:       Data, Text synopsis:       Textual Type Classes description:@@ -31,30 +31,6 @@   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:@@ -68,89 +44,6 @@   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.10-    , 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.10-    , 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.10-    , 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.10-    , 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@@ -158,11 +51,13 @@   other-modules:       Data.TTC.Test     , Data.TTC.Instances.Test+    , TestString   build-depends:       base     , bytestring     , tasty >=1.0 && <1.3     , tasty-hunit >=0.10 && <0.11+    , template-haskell     , text     , ttc   default-language: Haskell2010