ttc 0.2.3.0 → 0.3.0.0
raw patch · 7 files changed
+116/−72 lines, 7 filesdep ~tasty
Dependency ranges changed: tasty
Files
- CHANGELOG.md +7/−0
- README.md +2/−2
- src/Data/TTC.hs +33/−23
- src/Data/TTC/Instances.hs +1/−1
- test/Data/TTC/Instances/Test.hs +24/−24
- test/Data/TTC/Test.hs +47/−20
- ttc.cabal +2/−2
CHANGELOG.md view
@@ -24,6 +24,13 @@ [KaC]: <https://keepachangelog.com/en/1.0.0/> +## 0.3.0.0 (2020-11-03)++### Breaking++* Use `Textual` error messages+* Add `maybeParseWithRead` function+ ## 0.2.3.0 (2020-09-25) ### Non-Breaking
README.md view
@@ -84,7 +84,7 @@ ```haskell class Parse a where- parse :: Textual t => t -> Either String a+ parse :: (Textual t, Textual e) => t -> Either e a ``` It is analogous to the `Read` type class, which can be reserved for@@ -100,7 +100,7 @@ ```haskell instance TTC.Parse Username where- parse = TTC.asT $ \t-> do+ parse = TTC.asT $ \t-> first TTC.fromS $ do 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"
src/Data/TTC.hs view
@@ -93,6 +93,7 @@ , parseEnum' , parseWithRead , parseWithRead'+ , maybeParseWithRead , readsEnum , readsWithParse -- ** Constant Validation@@ -127,13 +128,6 @@ 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 @@ -411,8 +405,14 @@ -- -- See the @uname@ and @prompt@ example programs in the @examples@ directory. class Parse a where- parse :: Textual t => t -> Either String a+ parse :: (Textual t, Textual e) => t -> Either e a +-- This function is equivalent to 'parse' with the error type fixed to+-- 'String', used internally when the error is ignored.+parse' :: (Parse a, Textual t) => t -> Either String a+parse' = parse+{-# INLINE parse' #-}+ -- $ParseSpecific -- -- These functions are equivalent to 'parse', but they specify the type being@@ -420,27 +420,27 @@ -- where the type is ambiguous. -- | Parse from a 'String'-parseS :: Parse a => String -> Either String a+parseS :: (Parse a, Textual e) => String -> Either e a parseS = parse {-# INLINE parseS #-} -- | Parse from strict 'T.Text'-parseT :: Parse a => T.Text -> Either String a+parseT :: (Parse a, Textual e) => T.Text -> Either e a parseT = parse {-# INLINE parseT #-} -- | Parse from lazy 'TL.Text'-parseTL :: Parse a => TL.Text -> Either String a+parseTL :: (Parse a, Textual e) => TL.Text -> Either e a parseTL = parse {-# INLINE parseTL #-} -- | Parse from a strict 'BS.ByteString'-parseBS :: Parse a => BS.ByteString -> Either String a+parseBS :: (Parse a, Textual e) => BS.ByteString -> Either e a parseBS = parse {-# INLINE parseBS #-} -- | Parse from a lazy 'BSL.ByteString'-parseBSL :: Parse a => BSL.ByteString -> Either String a+parseBSL :: (Parse a, Textual e) => BSL.ByteString -> Either e a parseBSL = parse {-# INLINE parseBSL #-} @@ -452,8 +452,8 @@ -- 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+parseMaybe :: (Parse a, Textual t) => t -> Maybe a+parseMaybe = either (const Nothing) Just . parse' {-# INLINE parseMaybe #-} -- | Parse from a 'String' to a 'Maybe' type@@ -523,6 +523,9 @@ -- | Parse a value in an enumeration --+-- This function is intended to be used with types that have few choices, as+-- the implementation uses a linear algorithm.+-- -- See the @enum@ example program in the @examples@ directory. parseEnum :: (Bounded a, Enum a, Render a, Textual t)@@ -577,13 +580,20 @@ -- -- * \"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)+ :: (Read a, Textual t, Textual e)+ => String -- ^ name to include in error messages+ -> t -- ^ textual input to parse+ -> Either e a -- ^ error or parsed value+parseWithRead' name = parseWithRead (fromS $ "invalid " ++ name) {-# INLINEABLE parseWithRead' #-} +-- | Parse a value to a 'Maybe' type using the 'Read' instance+maybeParseWithRead+ :: (Read a, Textual t)+ => t -- ^ textual input to parse+ -> Maybe a -- ^ error or parsed value+maybeParseWithRead = readMaybe . toS+ -- | Implement 'ReadS' using 'parseEnum' -- -- This implementation expects all of the input to be consumed.@@ -604,9 +614,9 @@ readsWithParse :: Parse a => ReadS a-readsWithParse s = case parse s of- Right v -> [(v, "")]- Left{} -> []+readsWithParse s = case parseMaybe s of+ Just v -> [(v, "")]+ Nothing -> [] {-# INLINEABLE readsWithParse #-} -- $ParseValid
src/Data/TTC/Instances.hs view
@@ -44,7 +44,7 @@ instance TTC.Parse Char where parse = TTC.asS $ \case [c] -> Right c- _ -> Left "invalid Char"+ _ -> Left $ TTC.fromS "invalid Char" instance TTC.Render Char where render c = TTC.fromS [c]
test/Data/TTC/Instances/Test.hs view
@@ -47,7 +47,7 @@ testChar :: TestTree testChar = testGroup "Char" [ testCase "Render" $ "*" @=? TTC.render '*'- , testCase "Parse.OK" $ Right '*' @=? TTC.parse "*"+ , testCase "Parse.OK" $ Just '*' @=? TTC.parseMaybe "*" , testCase "Parse.empty" $ Left "invalid Char" @=? (TTC.parse "" :: Either String Char) , testCase "Parse.multiple" $ Left "invalid Char" @=?@@ -57,7 +57,7 @@ testDouble :: TestTree testDouble = testGroup "Double" [ testCase "Render" $ s @=? TTC.render x- , testCase "Parse.OK" $ Right x' @=? TTC.parse s+ , testCase "Parse.OK" $ Just x' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Double" @=? (TTC.parse "invalid" :: Either String Double) ]@@ -74,7 +74,7 @@ testFloat :: TestTree testFloat = testGroup "Float" [ testCase "Render" $ s @=? TTC.render x- , testCase "Parse.OK" $ Right x' @=? TTC.parse s+ , testCase "Parse.OK" $ Just x' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Float" @=? (TTC.parse "invalid" :: Either String Float) ]@@ -91,7 +91,7 @@ testInt :: TestTree testInt = testGroup "Int" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Int" @=? (TTC.parse "invalid" :: Either String Int) ]@@ -108,7 +108,7 @@ testInt8 :: TestTree testInt8 = testGroup "Int8" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Int8" @=? (TTC.parse "invalid" :: Either String Int8) ]@@ -125,7 +125,7 @@ testInt16 :: TestTree testInt16 = testGroup "Int16" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Int16" @=? (TTC.parse "invalid" :: Either String Int16) ]@@ -142,7 +142,7 @@ testInt32 :: TestTree testInt32 = testGroup "Int32" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Int32" @=? (TTC.parse "invalid" :: Either String Int32) ]@@ -159,7 +159,7 @@ testInt64 :: TestTree testInt64 = testGroup "Int64" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Int64" @=? (TTC.parse "invalid" :: Either String Int64) ]@@ -176,7 +176,7 @@ testInteger :: TestTree testInteger = testGroup "Integer" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Integer" @=? (TTC.parse "invalid" :: Either String Integer) ]@@ -193,7 +193,7 @@ testWord :: TestTree testWord = testGroup "Word" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Word" @=? (TTC.parse "invalid" :: Either String Word) ]@@ -210,7 +210,7 @@ testWord8 :: TestTree testWord8 = testGroup "Word8" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Word8" @=? (TTC.parse "invalid" :: Either String Word8) ]@@ -227,7 +227,7 @@ testWord16 :: TestTree testWord16 = testGroup "Word16" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Word16" @=? (TTC.parse "invalid" :: Either String Word16) ]@@ -244,7 +244,7 @@ testWord32 :: TestTree testWord32 = testGroup "Word32" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Word32" @=? (TTC.parse "invalid" :: Either String Word32) ]@@ -261,7 +261,7 @@ testWord64 :: TestTree testWord64 = testGroup "Word64" [ testCase "Render" $ s @=? TTC.render n- , testCase "Parse.OK" $ Right n' @=? TTC.parse s+ , testCase "Parse.OK" $ Just n' @=? TTC.parseMaybe s , testCase "Parse.invalid" $ Left "invalid Word64" @=? (TTC.parse "invalid" :: Either String Word64) ]@@ -278,36 +278,36 @@ 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+ , testCase "Parse.empty" $ Just "" @=? TTC.parseMaybe ""+ , testCase "Parse.nonempty" $ Just xS @=? TTC.parseMaybe xS ] testBSL :: TestTree testBSL = testGroup "BSL.ByteString" [ testCase "Render" $ xS @=? TTC.render xBSL- , testCase "Parse.empty" $ Right BSL.empty @=? TTC.parse ""- , testCase "Parse.nonempty" $ Right xBSL @=? TTC.parse xS+ , testCase "Parse.empty" $ Just BSL.empty @=? TTC.parseMaybe ""+ , testCase "Parse.nonempty" $ Just xBSL @=? TTC.parseMaybe xS ] testBS :: TestTree testBS = testGroup "BS.ByteString" [ testCase "Render" $ xS @=? TTC.render xBS- , testCase "Parse.empty" $ Right BS.empty @=? TTC.parse ""- , testCase "Parse.nonempty" $ Right xBS @=? TTC.parse xS+ , testCase "Parse.empty" $ Just BS.empty @=? TTC.parseMaybe ""+ , testCase "Parse.nonempty" $ Just xBS @=? TTC.parseMaybe xS ] testTL :: TestTree testTL = testGroup "TL.Text" [ testCase "Render" $ xS @=? TTC.render xTL- , testCase "Parse.empty" $ Right TL.empty @=? TTC.parse ""- , testCase "Parse.nonempty" $ Right xTL @=? TTC.parse xS+ , testCase "Parse.empty" $ Just TL.empty @=? TTC.parseMaybe ""+ , testCase "Parse.nonempty" $ Just xTL @=? TTC.parseMaybe xS ] testT :: TestTree testT = testGroup "T.Text" [ testCase "Render" $ xS @=? TTC.render xT- , testCase "Parse.empty" $ Right T.empty @=? TTC.parse ""- , testCase "Parse.nonempty" $ Right xT @=? TTC.parse xS+ , testCase "Parse.empty" $ Just T.empty @=? TTC.parseMaybe ""+ , testCase "Parse.nonempty" $ Just xT @=? TTC.parseMaybe xS ] ------------------------------------------------------------------------------
test/Data/TTC/Test.hs view
@@ -6,6 +6,7 @@ -- https://hackage.haskell.org/package/base import Control.Exception (ErrorCall, Exception, evaluate, handle)+import Control.Monad (when) import Data.Proxy (Proxy(Proxy), asProxyTypeOf) import Text.Read (readMaybe) @@ -33,9 +34,6 @@ import qualified TestString import TestString (TestString(TestString)) --- HLint does not support typed expression splices-{-# ANN module ("HLint: ignore" :: String) #-}- ------------------------------------------------------------------------------ -- $HelperFunctions @@ -101,8 +99,8 @@ parse = TTC.asS $ \ s -> case readMaybe s of Just i | i >= 0 -> Right $ PosInt i- | otherwise -> Left "not positive"- Nothing -> Left "not an integer"+ | otherwise -> Left $ TTC.fromS "not positive"+ Nothing -> Left $ TTC.fromS "not an integer" instance TTC.Render PosInt where render (PosInt i) = TTC.convert $ show i@@ -169,6 +167,14 @@ redBSL :: BSL.ByteString redBSL = "red" +newtype PartialParser = PartialParser String+ deriving (Eq, Show)++instance TTC.Parse PartialParser where+ parse = TTC.asS $ \s -> do+ when (null s) $ Left (TTC.fromT undefined)+ pure $ PartialParser s+ ------------------------------------------------------------------------------ -- $Textual @@ -402,11 +408,11 @@ 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 "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" $ Left "not positive" @=? (TTC.parse ('-' : answerS) :: Either String PosInt) , testCase "invalid" $ Left "not an integer" @=?@@ -414,19 +420,20 @@ ] testParseS :: TestTree-testParseS = testCase "parseS" $ Right answer @=? TTC.parseS answerS+testParseS = testCase "parseS" $ Just answer @=? TTC.parseMaybeS answerS testParseT :: TestTree-testParseT = testCase "parseT" $ Right answer @=? TTC.parseT answerT+testParseT = testCase "parseT" $ Just answer @=? TTC.parseMaybeT answerT testParseTL :: TestTree-testParseTL = testCase "parseTL" $ Right answer @=? TTC.parseTL answerTL+testParseTL = testCase "parseTL" $ Just answer @=? TTC.parseMaybeTL answerTL testParseBS :: TestTree-testParseBS = testCase "parseBS" $ Right answer @=? TTC.parseBS answerBS+testParseBS = testCase "parseBS" $ Just answer @=? TTC.parseMaybeBS answerBS testParseBSL :: TestTree-testParseBSL = testCase "parseBSL" $ Right answer @=? TTC.parseBSL answerBSL+testParseBSL =+ testCase "parseBSL" $ Just answer @=? TTC.parseMaybeBSL answerBSL testParseMaybe :: TestTree testParseMaybe = testGroup "parseMaybe"@@ -435,6 +442,9 @@ , testCase "TL" $ Just answer @=? TTC.parseMaybe answerTL , testCase "BS" $ Just answer @=? TTC.parseMaybe answerBS , testCase "BSL" $ Just answer @=? TTC.parseMaybe answerBSL+ -- successful 'parseMaybe' does not have any error type conversion:+ , testCase "noerror" $+ Just (PartialParser "test") @=? TTC.parseMaybe ("test" :: String) , testCase "negative" $ Nothing @=? (TTC.parseMaybe ('-' : answerS) :: Maybe PosInt) , testCase "invalid" $@@ -508,15 +518,31 @@ 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 "S" $ Right answerZ @=?+ (TTC.parseWithRead' "Int" answerS :: Either String Int)+ , testCase "T" $ Right answerZ @=?+ (TTC.parseWithRead' "Int" answerT :: Either String Int)+ , testCase "TL" $ Right answerZ @=?+ (TTC.parseWithRead' "Int" answerTL :: Either String Int)+ , testCase "BS" $ Right answerZ @=?+ (TTC.parseWithRead' "Int" answerBS :: Either String Int)+ , testCase "BSL" $ Right answerZ @=?+ (TTC.parseWithRead' "Int" answerBSL :: Either String Int) , testCase "invalid" $ Left "invalid Int" @=? (TTC.parseWithRead' "Int" ('a' : answerS) :: Either String Int) ] +testMaybeParseWithRead :: TestTree+testMaybeParseWithRead = testGroup "maybeParseWithRead"+ [ testCase "S" $ Just answerZ @=? TTC.maybeParseWithRead answerS+ , testCase "T" $ Just answerZ @=? TTC.maybeParseWithRead answerT+ , testCase "TL" $ Just answerZ @=? TTC.maybeParseWithRead answerTL+ , testCase "BS" $ Just answerZ @=? TTC.maybeParseWithRead answerBS+ , testCase "BSL" $ Just answerZ @=? TTC.maybeParseWithRead answerBSL+ , testCase "invalid" $ Nothing @=?+ (TTC.maybeParseWithRead ('a' : answerS) :: Maybe Int)+ ]+ testParseEnum :: TestTree testParseEnum = testGroup "parseEnum" [ testCase "S" $ Right Red @=? parse False False redS@@ -654,6 +680,7 @@ , testParseUnsafeBSL , testParseWithRead , testParseWithRead'+ , testMaybeParseWithRead , testParseEnum , testParseEnum' , testReadsWithParse
ttc.cabal view
@@ -1,5 +1,5 @@ name: ttc-version: 0.2.3.0+version: 0.3.0.0 category: Data, Text synopsis: Textual Type Classes description:@@ -56,7 +56,7 @@ build-depends: base , bytestring- , tasty >=1.0 && <1.4+ , tasty >=1.0 && <1.5 , tasty-hunit >=0.10 && <0.11 , template-haskell , text