diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -24,6 +24,14 @@ [KaC]: +## 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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" diff --git a/examples/CreditCard.hs b/examples/CreditCard.hs deleted file mode 100644 --- a/examples/CreditCard.hs +++ /dev/null @@ -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 diff --git a/examples/Duration.hs b/examples/Duration.hs deleted file mode 100644 --- a/examples/Duration.hs +++ /dev/null @@ -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) diff --git a/examples/Username.hs b/examples/Username.hs deleted file mode 100644 --- a/examples/Username.hs +++ /dev/null @@ -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 diff --git a/examples/invalid.hs b/examples/invalid.hs deleted file mode 100644 --- a/examples/invalid.hs +++ /dev/null @@ -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 diff --git a/examples/mkvalid.hs b/examples/mkvalid.hs deleted file mode 100644 --- a/examples/mkvalid.hs +++ /dev/null @@ -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 diff --git a/examples/prompt.hs b/examples/prompt.hs deleted file mode 100644 --- a/examples/prompt.hs +++ /dev/null @@ -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" diff --git a/examples/uname.hs b/examples/uname.hs deleted file mode 100644 --- a/examples/uname.hs +++ /dev/null @@ -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 diff --git a/examples/valid.hs b/examples/valid.hs deleted file mode 100644 --- a/examples/valid.hs +++ /dev/null @@ -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 diff --git a/src/Data/TTC.hs b/src/Data/TTC.hs --- a/src/Data/TTC.hs +++ b/src/Data/TTC.hs @@ -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 []] ] diff --git a/test/Data/TTC/Test.hs b/test/Data/TTC/Test.hs --- a/test/Data/TTC/Test.hs +++ b/test/Data/TTC/Test.hs @@ -1,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 ] ] diff --git a/test/TestString.hs b/test/TestString.hs new file mode 100644 --- /dev/null +++ b/test/TestString.hs @@ -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) diff --git a/ttc.cabal b/ttc.cabal --- a/ttc.cabal +++ b/ttc.cabal @@ -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