ttc-1.5.0.0: test/Data/TTC/Test.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.TTC.Test (tests) where
-- https://hackage.haskell.org/package/base
import Control.Exception (ErrorCall, Exception, evaluate, handle)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Proxy (Proxy(Proxy), asProxyTypeOf)
import Data.String (IsString)
import Data.Word (Word8, Word16, Word32, Word64)
import GHC.Stack (HasCallStack)
import Text.Read (readMaybe)
-- https://hackage.haskell.org/package/bytestring
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Short as SBS
-- https://hackage.haskell.org/package/tasty
import Test.Tasty (TestName, TestTree, testGroup)
-- https://hackage.haskell.org/package/tasty-hunit
import Test.Tasty.HUnit ((@=?), Assertion, assertFailure, testCase)
-- https://hackage.haskell.org/package/text
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
-- https://hackage.haskell.org/package/text-short
import qualified Data.Text.Short as ST
-- (ttc)
import qualified Data.TTC as TTC
-- (ttc:test)
import qualified TestTypes.Ex as Ex
import TestTypes.Ex (Ex(Ex))
------------------------------------------------------------------------------
-- $Instances
TTC.defaultRenderAndParseInstances
[ ''Bool, ''Char, ''Double, ''Float, ''Integer
, ''Int, ''Int8, ''Int16, ''Int32, ''Int64
, ''Word, ''Word8, ''Word16, ''Word32, ''Word64
, ''String
, ''T.Text, ''TL.Text, ''TLB.Builder, ''ST.ShortText
, ''BS.ByteString, ''BSL.ByteString, ''BSB.Builder, ''SBS.ShortByteString
]
------------------------------------------------------------------------------
instance Eq BSB.Builder where
x == y = BSB.toLazyByteString x == BSB.toLazyByteString y
#if !MIN_VERSION_bytestring(0,11,1)
instance Show BSB.Builder where
show = show . BSB.toLazyByteString
#endif
------------------------------------------------------------------------------
-- $HelperFunctions
assertRaises
:: (HasCallStack, Exception e, Show a)
=> Proxy e
-> a
-> Assertion
assertRaises proxy x =
handle
(const (return ()) . (`asProxyTypeOf` proxy))
(assertFailure . ("expected exception; got: " ++) . show =<< evaluate x)
------------------------------------------------------------------------------
-- $TestData
xS :: String
xS = "test テスト"
xT :: T.Text
xT = "test テスト"
xTL :: TL.Text
xTL = "test テスト"
xTLB :: TLB.Builder
xTLB = "test テスト"
xST :: ST.ShortText
xST = "test テスト"
xBS :: BS.ByteString
xBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88"
xBSL :: BSL.ByteString
xBSL = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88"
xBSB :: BSB.Builder
xBSB = "test テスト"
xSBS :: SBS.ShortByteString
xSBS = "test \xe3\x83\x86\xe3\x82\xb9\xe3\x83\x88"
-- U+FFFD is the Unicode replacement character
xiS :: String
xiS = "test \xfffd"
xiT :: T.Text
xiT = T.pack xiS
xiTL :: TL.Text
xiTL = TL.pack xiS
xiTLB :: TLB.Builder
xiTLB = TLB.fromString xiS
xiST :: ST.ShortText
xiST = ST.pack xiS
-- Lone continuation byte is invalid
xiBS :: BS.ByteString
xiBS = "test \xe3"
xiBSL :: BSL.ByteString
xiBSL = BSL.fromStrict xiBS
xiBSB :: BSB.Builder
xiBSB = BSB.byteString xiBS
xiSBS :: SBS.ShortByteString
xiSBS = SBS.toShort xiBS
------------------------------------------------------------------------------
newtype PosInt = PosInt Int
deriving (Eq, Show)
instance TTC.Parse PosInt where
parse = TTC.asS $ \ s -> case readMaybe s of
Just i
| i >= 0 -> Right $ PosInt i
| otherwise -> Left $ TTC.fromS "not positive"
Nothing -> Left $ TTC.fromS "not an integer"
instance TTC.Render PosInt where
render (PosInt i) = TTC.convert $ show i
answer :: PosInt
answer = PosInt 42
answerS :: String
answerS = "42"
answerT :: T.Text
answerT = "42"
answerTL :: TL.Text
answerTL = "42"
answerTLB :: TLB.Builder
answerTLB = "42"
answerST :: ST.ShortText
answerST = "42"
answerBS :: BS.ByteString
answerBS = "42"
answerBSL :: BSL.ByteString
answerBSL = "42"
answerBSB :: BSB.Builder
answerBSB = "42"
answerSBS :: SBS.ShortByteString
answerSBS = "42"
answerZ :: Int
answerZ = 42
data IntError = IntInvalid
deriving (Eq, Show)
------------------------------------------------------------------------------
data Color
= Red
| Green
| Blue
| White
| Black
deriving (Bounded, Enum, Eq, Show)
instance Read Color where
readsPrec _ = TTC.readsEnum True True
instance TTC.Render Color where
render = TTC.fromT . \case
Red -> "red"
Green -> "green"
Blue -> "blue"
White -> "white"
Black -> "black"
data ColorError
= ColorInvalid
| ColorAmbiguous
deriving (Eq, Show)
redS :: String
redS = "red"
redT :: T.Text
redT = "red"
redTL :: TL.Text
redTL = "red"
redTLB :: TLB.Builder
redTLB = "red"
redST :: ST.ShortText
redST = "red"
redBS :: BS.ByteString
redBS = "red"
redBSL :: BSL.ByteString
redBSL = "red"
redBSB :: BSB.Builder
redBSB = "red"
redSBS :: SBS.ShortByteString
redSBS = "red"
------------------------------------------------------------------------------
newtype PartialParser = PartialParser String
deriving (Eq, Show)
instance TTC.Parse PartialParser where
parse = TTC.asS $ \case
"" -> Left $ TTC.fromT undefined
s -> Right $ PartialParser s
------------------------------------------------------------------------------
-- $Textual
testConvert :: TestTree
testConvert = testGroup "convert" $
[ testCase "@@" $
"test テスト" @=? TTC.convert @String @String "test テスト"
, testCase "@_" $ xT @=? TTC.convert @String "test テスト"
, testCase "_@" $ "test テスト" @=? TTC.convert @_ @TL.Text xT
]
++ mkTests "S" xS
++ mkTests "T" xT
++ mkTests "TL" xTL
++ mkTests "TLB" xTLB
++ mkTests "ST" xST
++ mkTests "BS" xBS
++ mkTests "BSL" xBSL
++ mkTests "BSB" xBSB
++ mkTests "SBS" xSBS
where
mkTests :: TTC.Textual a => String -> a -> [TestTree]
mkTests s x =
[ testCase (s ++ "->S") $ xS @=? TTC.convert x
, testCase (s ++ "->T") $ xT @=? TTC.convert x
, testCase (s ++ "->TL") $ xTL @=? TTC.convert x
, testCase (s ++ "->TLB") $ xTLB @=? TTC.convert x
, testCase (s ++ "->ST") $ xST @=? TTC.convert x
, testCase (s ++ "->BS") $ xBS @=? TTC.convert x
, testCase (s ++ "->BSL") $ xBSL @=? TTC.convert x
, testCase (s ++ "->BSB") $ xBSB @=? TTC.convert x
, testCase (s ++ "->SBS") $ xSBS @=? TTC.convert x
]
------------------------------------------------------------------------------
testToX :: TestTree
testToX = testGroup "to*"
[ mkTests "toS" TTC.toS xS xiS
, mkTests "toT" TTC.toT xT xiT
, mkTests "toTL" TTC.toTL xTL xiTL
, mkTests "toTLB" TTC.toTLB xTLB xiTLB
, mkTests "toST" TTC.toST xST xiST
, mkTests "toBS" TTC.toBS xBS xiBS
, mkTests "toBSL" TTC.toBSL xBSL xiBSL
, mkTests "toBSB" TTC.toBSB xBSB xiBSB
, mkTests "toSBS" TTC.toSBS xSBS xiSBS
]
where
mkTests
:: (Eq a, Show a)
=> TestName
-> (forall t. TTC.Textual t => t -> a)
-> a
-> a
-> TestTree
mkTests testName f x xi = testGroup testName
[ testCase "@" $ x @=? f @T.Text "test テスト"
, testCase "S" $ x @=? f xS
, testCase "T" $ x @=? f xT
, testCase "TL" $ x @=? f xTL
, testCase "TLB" $ x @=? f xTLB
, testCase "ST" $ x @=? f xST
, testCase "BS" $ x @=? f xBS
, testCase "BSL" $ x @=? f xBSL
, testCase "BSB" $ x @=? f xBSB
, testCase "SBS" $ x @=? f xSBS
, testCase "BS/invalid" $ xi @=? f xiBS
, testCase "BSL/invalid" $ xi @=? f xiBSL
, testCase "BSB/invalid" $ xi @=? f xiBSB
, testCase "SBS/invalid" $ xi @=? f xiSBS
]
------------------------------------------------------------------------------
testFromX :: TestTree
testFromX = testGroup "from*"
[ mkTests "fromS" TTC.fromS xS Nothing
, mkTests "fromT" TTC.fromT xT Nothing
, mkTests "fromTL" TTC.fromTL xTL Nothing
, mkTests "fromTLB" TTC.fromTLB xTLB Nothing
, mkTests "fromST" TTC.fromST xST Nothing
, mkTests "fromBS" TTC.fromBS xBS (Just xiBS)
, mkTests "fromBSL" TTC.fromBSL xBSL (Just xiBSL)
, mkTests "fromBSB" TTC.fromBSB xBSB (Just xiBSB)
, mkTests "fromSBS" TTC.fromSBS xSBS (Just xiSBS)
]
where
mkTests
:: (Eq a, Show a)
=> TestName
-> (forall t. TTC.Textual t => a -> t)
-> a
-> Maybe a
-> TestTree
mkTests testName f x mXi = testGroup testName $
[ testCase "@" $ "test テスト" @=? f @String x
, testCase "S" $ xS @=? f x
, testCase "T" $ xT @=? f x
, testCase "TL" $ xTL @=? f x
, testCase "TLB" $ xTLB @=? f x
, testCase "ST" $ xST @=? f x
, testCase "BS" $ xBS @=? f x
, testCase "BSL" $ xBSL @=? f x
, testCase "BSB" $ xBSB @=? f x
, testCase "SBS" $ xSBS @=? f x
] ++
case mXi of
Nothing -> []
Just xi ->
[ testCase "S/Invalid" $ xiS @=? f xi
, testCase "T/Invalid" $ xiT @=? f xi
, testCase "TL/Invalid" $ xiTL @=? f xi
, testCase "TLB/Invalid" $ xiTLB @=? f xi
, testCase "ST/Invalid" $ xiST @=? f xi
, testCase "BS/Invalid" $ xiBS @=? f xi
, testCase "BSL/Invalid" $ xiBSL @=? f xi
, testCase "BSB/Invalid" $ xiBSB @=? f xi
, testCase "SBS/Invalid" $ xiSBS @=? f xi
]
------------------------------------------------------------------------------
testAsX :: TestTree
testAsX = testGroup "as*"
[ mkTests "asS" TTC.asS xS xiS
, mkTests "asT" TTC.asT xT xiT
, mkTests "asTL" TTC.asTL xTL xiTL
, mkTests "asTLB" TTC.asTLB xTLB xiTLB
, mkTests "asST" TTC.asST xST xiST
, mkTests "asBS" TTC.asBS xBS xiBS
, mkTests "asBSL" TTC.asBSL xBSL xiBSL
, mkTests "asBSB" TTC.asBSB xBSB xiBSB
, mkTests "asSBS" TTC.asSBS xSBS xiSBS
]
where
mkTests
:: (Eq a, Show a)
=> TestName
-> (forall t. TTC.Textual t => (a -> a) -> t -> a)
-> a
-> a
-> TestTree
mkTests testName f x xi = testGroup testName
[ testCase "@" $ x @=? f @T.Text id "test テスト"
, testCase "S" $ x @=? f id xS
, testCase "T" $ x @=? f id xT
, testCase "TL" $ x @=? f id xTL
, testCase "TLB" $ x @=? f id xTLB
, testCase "ST" $ x @=? f id xST
, testCase "BS" $ x @=? f id xBS
, testCase "BSL" $ x @=? f id xBSL
, testCase "BSB" $ x @=? f id xBSB
, testCase "SBS" $ x @=? f id xSBS
, testCase "BS/invalid" $ xi @=? f id xiBS
, testCase "BSL/invalid" $ xi @=? f id xiBSL
, testCase "BSB/invalid" $ xi @=? f id xiBSB
, testCase "SBS/invalid" $ xi @=? f id xiSBS
]
------------------------------------------------------------------------------
-- $Render
testRender :: TestTree
testRender = testGroup "render"
[ testCase "_@" $ "42" @=? TTC.render @_ @String answer
, testCase "S" $ answerS @=? TTC.render answer
, testCase "T" $ answerT @=? TTC.render answer
, testCase "TL" $ answerTL @=? TTC.render answer
, testCase "TLB" $ answerTLB @=? TTC.render answer
, testCase "ST" $ answerST @=? TTC.render answer
, testCase "BS" $ answerBS @=? TTC.render answer
, testCase "BSL" $ answerBSL @=? TTC.render answer
, testCase "BSB" $ answerBSB @=? TTC.render answer
, testCase "SBS" $ answerSBS @=? TTC.render answer
]
------------------------------------------------------------------------------
testRenderDefault :: TestTree
testRenderDefault = testGroup "RenderDefault"
[ testCase "Bool" $ "True" @=? TTC.renderS True
, testCase "Char" $ "*" @=? TTC.renderS '*'
, mkTestShow @Double "Double" 3.14159
, mkTestShow @Float "Float" 3.14159
, mkTestShow @Integer "Integer" 42
, mkTestShow @Int "Int" 42
, mkTestShow @Int8 "Int8" 42
, mkTestShow @Int16 "Int16" 42
, mkTestShow @Int32 "Int32" 42
, mkTestShow @Int64 "Int64" 42
, mkTestShow @Word "Word" 42
, mkTestShow @Word8 "Word8" 42
, mkTestShow @Word16 "Word16" 42
, mkTestShow @Word32 "Word32" 42
, mkTestShow @Word64 "Word64" 42
, testCase "String" $ xS @=? TTC.renderS xS
, testCase "T.Text" $ xS @=? TTC.renderS xT
, testCase "TL.Text" $ xS @=? TTC.renderS xTL
, testCase "TLB.Builder" $ xS @=? TTC.renderS xTLB
, testCase "ST.ShortText" $ xS @=? TTC.renderS xST
, testCase "BS.ByteString" $ xS @=? TTC.renderS xBS
, testCase "BSL.ByteString" $ xS @=? TTC.renderS xBSL
, testCase "BSB.Builder" $ xS @=? TTC.renderS xBSB
, testCase "SBS.ShortByteString" $ xS @=? TTC.renderS xSBS
]
where
mkTestShow :: (Show a, TTC.Render a) => TestName -> a -> TestTree
mkTestShow testName x = testCase testName $ show x @=? TTC.renderS x
------------------------------------------------------------------------------
testRenderWithShow :: TestTree
testRenderWithShow = testGroup "renderWithShow"
[ testCase "@" $ "42" @=? TTC.renderWithShow @String answerZ
, testCase "S" $ answerS @=? TTC.renderWithShow answerZ
, testCase "T" $ answerT @=? TTC.renderWithShow answerZ
, testCase "TL" $ answerTL @=? TTC.renderWithShow answerZ
, testCase "TLB" $ answerTLB @=? TTC.renderWithShow answerZ
, testCase "ST" $ answerST @=? TTC.renderWithShow answerZ
, testCase "BS" $ answerBS @=? TTC.renderWithShow answerZ
, testCase "BSL" $ answerBSL @=? TTC.renderWithShow answerZ
, testCase "BSB" $ answerBSB @=? TTC.renderWithShow answerZ
, testCase "SBS" $ answerSBS @=? TTC.renderWithShow answerZ
]
------------------------------------------------------------------------------
testRenderX :: TestTree
testRenderX = testGroup "render*"
[ testCase "renderS" $ answerS @=? TTC.renderS answer
, testCase "renderT" $ answerT @=? TTC.renderT answer
, testCase "renderTL" $ answerTL @=? TTC.renderTL answer
, testCase "renderTLB" $ answerTLB @=? TTC.renderTLB answer
, testCase "renderST" $ answerST @=? TTC.renderST answer
, testCase "renderBS" $ answerBS @=? TTC.renderBS answer
, testCase "renderBSL" $ answerBSL @=? TTC.renderBSL answer
, testCase "renderBSB" $ answerBSB @=? TTC.renderBSB answer
, testCase "renderSBS" $ answerSBS @=? TTC.renderSBS answer
]
------------------------------------------------------------------------------
-- $Parse
testParse :: TestTree
testParse = testGroup "parse"
[ testCase "_@@" $ Right answer @=? TTC.parse @_ @String @String "42"
, testCase "S" $ Right answer @=? parse answerS
, testCase "T" $ Right answer @=? parse answerT
, testCase "TL" $ Right answer @=? parse answerTL
, testCase "TLB" $ Right answer @=? parse answerTLB
, testCase "ST" $ Right answer @=? parse answerST
, testCase "BS" $ Right answer @=? parse answerBS
, testCase "BSL" $ Right answer @=? parse answerBSL
, testCase "BSB" $ Right answer @=? parse answerBSB
, testCase "SBS" $ Right answer @=? parse answerSBS
, testCase "negative" $ Left "not positive" @=? parse @String "-42"
, testCase "invalid" $ Left "not an integer" @=? parse @String "4a2"
]
where
parse :: TTC.Textual t => t -> Either String PosInt
parse = TTC.parse
------------------------------------------------------------------------------
testParseDefault :: TestTree
testParseDefault = testGroup "ParseDefault"
[ testGroup "Bool"
[ testCase "True" $ Right True @=? parse "True"
, testCase "False" $ Right False @=? parse "False"
, testCase "invalid" $ Left "invalid Bool" @=? parse @Bool "false"
]
, testGroup "Char"
[ testCase "valid" $ Right '*' @=? parse "*"
, testCase "empty" $ Left "invalid Char" @=? parse @Char ""
, testCase "multiple" $ Left "invalid Char" @=? parse @Char "**"
]
, mkTestsShow @Double "Double" 3.14159
, mkTestsShow @Float "Float" 3.14159
, mkTestsShow @Integer "Integer" 42
, mkTestsShow @Int "Int" 42
, mkTestsShow @Int8 "Int8" 42
, mkTestsShow @Int16 "Int16" 42
, mkTestsShow @Int32 "Int32" 42
, mkTestsShow @Int64 "Int64" 42
, mkTestsShow @Word "Word" 42
, mkTestsShow @Word8 "Word8" 42
, mkTestsShow @Word16 "Word16" 42
, mkTestsShow @Word32 "Word32" 42
, mkTestsShow @Word64 "Word64" 42
, mkTestsTextual @String "String" xS
, mkTestsTextual @T.Text "T.Text" xT
, mkTestsTextual @TL.Text "TL.Text" xTL
, mkTestsTextual @TLB.Builder "TLB.Builder" xTLB
, mkTestsTextual @ST.ShortText "ST.ShortText" xST
, mkTestsTextual @BS.ByteString "BS.ByteString" xBS
, mkTestsTextual @BSL.ByteString "BSL.ByteString" xBSL
, mkTestsTextual @BSB.Builder "BSB.Builder" xBSB
, mkTestsTextual @SBS.ShortByteString "SBS.ShortByteString" xSBS
]
where
mkTestsShow
:: forall a. (Eq a, Show a, TTC.Parse a)
=> TestName
-> a
-> TestTree
mkTestsShow testName x = testGroup testName
[ testCase "valid" $ Right x @=? parse (show x)
, testCase "invalid" $
Left ("invalid " ++ testName) @=? parse @a "invalid"
]
mkTestsTextual
:: forall a. (Eq a, IsString a, Show a, TTC.Parse a)
=> TestName
-> a
-> TestTree
mkTestsTextual testName x = testGroup testName
[ testCase "empty" $ Right "" @=? parse @a ""
, testCase "nonempty" $ Right x @=? parse xS
]
parse :: TTC.Parse a => String -> Either String a
parse = TTC.parse
------------------------------------------------------------------------------
testWithError :: TestTree
testWithError = testGroup "withError"
[ testCase "valid" $
Right answer @=? TTC.withError @String @String undefined (Just answer)
, testCase "invalid" $
Left "err" @=? TTC.withError @String @String @PosInt "err" Nothing
]
testWithErrorX :: TestTree
testWithErrorX = testGroup "withError*"
[ mkTests "withErrorS" TTC.withErrorS
, mkTests "withErrorT" TTC.withErrorT
, mkTests "withErrorTL" TTC.withErrorTL
, mkTests "withErrorTLB" TTC.withErrorTLB
, mkTests "withErrorST" TTC.withErrorST
, mkTests "withErrorBS" TTC.withErrorBS
, mkTests "withErrorBSL" TTC.withErrorBSL
, mkTests "withErrorBSB" TTC.withErrorBSB
, mkTests "withErrorSBS" TTC.withErrorSBS
]
where
mkTests
:: IsString e'
=> TestName
-> (e' -> Maybe PosInt -> Either String PosInt)
-> TestTree
mkTests testName f = testGroup testName
[ testCase "valid" $ Right answer @=? f undefined (Just answer)
, testCase "invalid" $ Left "err" @=? f "err" Nothing
]
------------------------------------------------------------------------------
testPrefixError :: TestTree
testPrefixError = testGroup "prefixError"
[ testCase "valid" $
Right answer
@=? TTC.prefixError @String @String "oops: " (Right answer)
, testCase "invalid" $
Left "oops: err"
@=? TTC.prefixError @String @String @PosInt "oops: " (Left "err")
]
testPrefixErrorX :: TestTree
testPrefixErrorX = testGroup "prefixError*"
[ mkTests "prefixErrorS" TTC.prefixErrorS
, mkTests "prefixErrorT" TTC.prefixErrorT
, mkTests "prefixErrorTL" TTC.prefixErrorTL
, mkTests "prefixErrorTLB" TTC.prefixErrorTLB
, mkTests "prefixErrorST" TTC.prefixErrorST
, mkTests "prefixErrorBS" TTC.prefixErrorBS
, mkTests "prefixErrorBSL" TTC.prefixErrorBSL
, mkTests "prefixErrorBSB" TTC.prefixErrorBSB
, mkTests "prefixErrorSBS" TTC.prefixErrorSBS
]
where
mkTests
:: IsString e'
=> TestName
-> (e' -> Either e' PosInt -> Either String PosInt)
-> TestTree
mkTests testName f = testGroup testName
[ testCase "valid" $ Right answer @=? f "oops: " (Right answer)
, testCase "invalid" $ Left "oops: err" @=? f "oops: " (Left "err")
]
------------------------------------------------------------------------------
testParseWithRead :: TestTree
testParseWithRead = testGroup "parseWithRead"
[ testCase "@" $
Right answerZ @=? TTC.parseWithRead @String IntInvalid "42"
, testCase "S" $ Right answerZ @=? parseWithRead answerS
, testCase "T" $ Right answerZ @=? parseWithRead answerT
, testCase "TL" $ Right answerZ @=? parseWithRead answerTL
, testCase "TLB" $ Right answerZ @=? parseWithRead answerTLB
, testCase "ST" $ Right answerZ @=? parseWithRead answerST
, testCase "BS" $ Right answerZ @=? parseWithRead answerBS
, testCase "BSL" $ Right answerZ @=? parseWithRead answerBSL
, testCase "BSB" $ Right answerZ @=? parseWithRead answerBSB
, testCase "SBS" $ Right answerZ @=? parseWithRead answerSBS
, testCase "invalid" $ Left IntInvalid @=? parseWithRead @String "4a2"
]
where
parseWithRead :: TTC.Textual t => t -> Either IntError Int
parseWithRead = TTC.parseWithRead IntInvalid
testParseWithRead' :: TestTree
testParseWithRead' = testGroup "parseWithRead'"
[ testCase "@" $
Right answerZ @=? TTC.parseWithRead' @String @String "Int" "42"
, testCase "S" $ Right answerZ @=? parseWithRead' answerS
, testCase "T" $ Right answerZ @=? parseWithRead' answerT
, testCase "TL" $ Right answerZ @=? parseWithRead' answerTL
, testCase "TLB" $ Right answerZ @=? parseWithRead' answerTLB
, testCase "ST" $ Right answerZ @=? parseWithRead' answerST
, testCase "BS" $ Right answerZ @=? parseWithRead' answerBS
, testCase "BSL" $ Right answerZ @=? parseWithRead' answerBSL
, testCase "BSB" $ Right answerZ @=? parseWithRead' answerBSB
, testCase "SBS" $ Right answerZ @=? parseWithRead' answerSBS
, testCase "invalid" $ Left "invalid Int" @=? parseWithRead' @String "4a2"
]
where
parseWithRead' :: TTC.Textual t => t -> Either String Int
parseWithRead' = TTC.parseWithRead' "Int"
testMaybeParseWithRead :: TestTree
testMaybeParseWithRead = testGroup "maybeParseWithRead"
[ testCase "@" $ Just answerZ @=? TTC.maybeParseWithRead @String "42"
, testCase "S" $ Just answerZ @=? TTC.maybeParseWithRead answerS
, testCase "T" $ Just answerZ @=? TTC.maybeParseWithRead answerT
, testCase "TL" $ Just answerZ @=? TTC.maybeParseWithRead answerTL
, testCase "TLB" $ Just answerZ @=? TTC.maybeParseWithRead answerTLB
, testCase "ST" $ Just answerZ @=? TTC.maybeParseWithRead answerST
, testCase "BS" $ Just answerZ @=? TTC.maybeParseWithRead answerBS
, testCase "BSL" $ Just answerZ @=? TTC.maybeParseWithRead answerBSL
, testCase "BSB" $ Just answerZ @=? TTC.maybeParseWithRead answerBSB
, testCase "SBS" $ Just answerZ @=? TTC.maybeParseWithRead answerSBS
, testCase "invalid" $
Nothing @=? TTC.maybeParseWithRead @String @Int "4a2"
]
------------------------------------------------------------------------------
testParseEnum :: TestTree
testParseEnum = testGroup "parseEnum"
[ testCase "@" $
Right Red
@=? TTC.parseEnum @String
False False ColorInvalid ColorAmbiguous "red"
, testCase "S" $ Right Red @=? parseEnum False False redS
, testCase "T" $ Right Red @=? parseEnum False False redT
, testCase "TL" $ Right Red @=? parseEnum False False redTL
, testCase "TLB" $ Right Red @=? parseEnum False False redTLB
, testCase "ST" $ Right Red @=? parseEnum False False redST
, testCase "BS" $ Right Red @=? parseEnum False False redBS
, testCase "BSL" $ Right Red @=? parseEnum False False redBSL
, testCase "BSB" $ Right Red @=? parseEnum False False redBSB
, testCase "SBS" $ Right Red @=? parseEnum False False redSBS
, testCase "CI" $ Right Red @=? parseEnum @String True False "Red"
, testCase "!CI" $
Left ColorInvalid @=? parseEnum @String False False "Red"
, testCase "prefix" $ Right Red @=? parseEnum @String False True "r"
, testCase "ambiguous" $
Left ColorAmbiguous @=? parseEnum @String False True "bl"
]
where
parseEnum :: TTC.Textual t => Bool -> Bool -> t -> Either ColorError Color
parseEnum allowCI allowPrefix =
TTC.parseEnum allowCI allowPrefix ColorInvalid ColorAmbiguous
testParseEnum' :: TestTree
testParseEnum' = testGroup "parseEnum'"
[ testCase "@" $
Right Red
@=? TTC.parseEnum' @String @String "Color" False False "red"
, testCase "S" $ Right Red @=? parseEnum' False False redS
, testCase "T" $ Right Red @=? parseEnum' False False redT
, testCase "TL" $ Right Red @=? parseEnum' False False redTL
, testCase "TLB" $ Right Red @=? parseEnum' False False redTLB
, testCase "ST" $ Right Red @=? parseEnum' False False redST
, testCase "BS" $ Right Red @=? parseEnum' False False redBS
, testCase "BSL" $ Right Red @=? parseEnum' False False redBSL
, testCase "BSB" $ Right Red @=? parseEnum' False False redBSB
, testCase "SBS" $ Right Red @=? parseEnum' False False redSBS
, testCase "CI" $ Right Red @=? parseEnum' @String True False "Red"
, testCase "!CI" $
Left "invalid Color" @=? parseEnum' @String False False "Red"
, testCase "prefix" $ Right Red @=? parseEnum' @String False True "r"
, testCase "ambiguous" $
Left "ambiguous Color" @=? parseEnum' @String False True "bl"
]
where
parseEnum' :: TTC.Textual t => Bool -> Bool -> t -> Either String Color
parseEnum' = TTC.parseEnum' "Color"
------------------------------------------------------------------------------
testParseX :: TestTree
testParseX = testGroup "parse*"
[ mkTests "parseS" TTC.parseS answerS
, mkTests "parseT" TTC.parseT answerT
, mkTests "parseTL" TTC.parseTL answerTL
, mkTests "parseTLB" TTC.parseTLB answerTLB
, mkTests "parseST" TTC.parseST answerST
, mkTests "parseBS" TTC.parseBS answerBS
, mkTests "parseBSL" TTC.parseBSL answerBSL
, mkTests "parseBSB" TTC.parseBSB answerBSB
, mkTests "parseSBS" TTC.parseSBS answerSBS
]
where
mkTests
:: IsString a
=> TestName
-> (a -> Either String PosInt)
-> a
-> TestTree
mkTests testName f x = testGroup testName
[ testCase "valid" $ Right answer @=? f x
, testCase "invalid" $ Left "not an integer" @=? f "4a2"
]
------------------------------------------------------------------------------
testParseMaybe :: TestTree
testParseMaybe = testGroup "parseMaybe"
[ testCase "@" $ Just answer @=? TTC.parseMaybe @String "42"
, testCase "S" $ Just answer @=? TTC.parseMaybe answerS
, testCase "T" $ Just answer @=? TTC.parseMaybe answerT
, testCase "TL" $ Just answer @=? TTC.parseMaybe answerTL
, testCase "TLB" $ Just answer @=? TTC.parseMaybe answerTLB
, testCase "ST" $ Just answer @=? TTC.parseMaybe answerST
, testCase "BS" $ Just answer @=? TTC.parseMaybe answerBS
, testCase "BSL" $ Just answer @=? TTC.parseMaybe answerBSL
, testCase "BSB" $ Just answer @=? TTC.parseMaybe answerBSB
, testCase "SBS" $ Just answer @=? TTC.parseMaybe answerSBS
, testCase "noerror" $
Just (PartialParser "test") @=? TTC.parseMaybe @String "test"
, testCase "negative" $ Nothing @=? TTC.parseMaybe @String @PosInt "-42"
, testCase "invalid" $ Nothing @=? TTC.parseMaybe @String @PosInt "4a2"
]
testParseMaybeX :: TestTree
testParseMaybeX = testGroup "parseMaybe*"
[ mkTestsParseMaybe "parseMaybeS" TTC.parseMaybeS answerS
, mkTestsParseMaybe "parseMaybeT" TTC.parseMaybeT answerT
, mkTestsParseMaybe "parseMaybeTL" TTC.parseMaybeTL answerTL
, mkTestsParseMaybe "parseMaybeTLB" TTC.parseMaybeTLB answerTLB
, mkTestsParseMaybe "parseMaybeST" TTC.parseMaybeST answerST
, mkTestsParseMaybe "parseMaybeBS" TTC.parseMaybeBS answerBS
, mkTestsParseMaybe "parseMaybeBSL" TTC.parseMaybeBSL answerBSL
, mkTestsParseMaybe "parseMaybeBSB" TTC.parseMaybeBSB answerBSB
, mkTestsParseMaybe "parseMaybeSBS" TTC.parseMaybeSBS answerSBS
]
mkTestsParseMaybe
:: IsString a
=> TestName
-> (a -> Maybe PosInt)
-> a
-> TestTree
mkTestsParseMaybe testName f x = testGroup testName
[ testCase "valid" $ Just answer @=? f x
, testCase "invalid" $ Nothing @=? f "4a2"
]
------------------------------------------------------------------------------
testParseOrFail :: TestTree
testParseOrFail = testGroup "parseOrFail"
[ testCase "@" $ Just answer @=? TTC.parseOrFail @String "42"
, testCase "S" $ Just answer @=? TTC.parseOrFail answerS
, testCase "T" $ Just answer @=? TTC.parseOrFail answerT
, testCase "TL" $ Just answer @=? TTC.parseOrFail answerTL
, testCase "TLB" $ Just answer @=? TTC.parseOrFail answerTLB
, testCase "ST" $ Just answer @=? TTC.parseOrFail answerST
, testCase "BS" $ Just answer @=? TTC.parseOrFail answerBS
, testCase "BSL" $ Just answer @=? TTC.parseOrFail answerBSL
, testCase "BSB" $ Just answer @=? TTC.parseOrFail answerBSB
, testCase "SBS" $ Just answer @=? TTC.parseOrFail answerSBS
, testCase "noerror" $
Just (PartialParser "test") @=? TTC.parseOrFail @String "test"
, testCase "negative" $ Nothing @=? TTC.parseOrFail @String @PosInt "-42"
, testCase "invalid" $ Nothing @=? TTC.parseOrFail @String @PosInt "4a2"
]
testParseOrFailX :: TestTree
testParseOrFailX = testGroup "parseOrFail*"
[ mkTestsParseMaybe "parseOrFailS" TTC.parseOrFailS answerS
, mkTestsParseMaybe "parseOrFailT" TTC.parseOrFailT answerT
, mkTestsParseMaybe "parseOrFailTL" TTC.parseOrFailTL answerTL
, mkTestsParseMaybe "parseOrFailTLB" TTC.parseOrFailTLB answerTLB
, mkTestsParseMaybe "parseOrFailST" TTC.parseOrFailST answerST
, mkTestsParseMaybe "parseOrFailBS" TTC.parseOrFailBS answerBS
, mkTestsParseMaybe "parseOrFailBSL" TTC.parseOrFailBSL answerBSL
, mkTestsParseMaybe "parseOrFailBSB" TTC.parseOrFailBSB answerBSB
, mkTestsParseMaybe "parseOrFailSBS" TTC.parseOrFailSBS answerSBS
]
------------------------------------------------------------------------------
testParseUnsafe :: TestTree
testParseUnsafe = testGroup "parseUnsafe"
[ testCase "@" $ answer @=? TTC.parseUnsafe @String "42"
, testCase "S" $ answer @=? TTC.parseUnsafe answerS
, testCase "T" $ answer @=? TTC.parseUnsafe answerT
, testCase "TL" $ answer @=? TTC.parseUnsafe answerTL
, testCase "TLB" $ answer @=? TTC.parseUnsafe answerTLB
, testCase "ST" $ answer @=? TTC.parseUnsafe answerST
, testCase "BS" $ answer @=? TTC.parseUnsafe answerBS
, testCase "BSL" $ answer @=? TTC.parseUnsafe answerBSL
, testCase "BSB" $ answer @=? TTC.parseUnsafe answerBSB
, testCase "SBS" $ answer @=? TTC.parseUnsafe answerSBS
, testCase "negative" . assertRaises (Proxy :: Proxy ErrorCall) $
TTC.parseUnsafe @String @PosInt "-42"
, testCase "invalid" . assertRaises (Proxy :: Proxy ErrorCall) $
TTC.parseUnsafe @String @PosInt "4a2"
]
testParseUnsafeX :: TestTree
testParseUnsafeX = testGroup "parseUnsafe*"
[ mkTests "parseUnsafeS" TTC.parseUnsafeS answerS
, mkTests "parseUnsafeT" TTC.parseUnsafeT answerT
, mkTests "parseUnsafeTL" TTC.parseUnsafeTL answerTL
, mkTests "parseUnsafeTLB" TTC.parseUnsafeTLB answerTLB
, mkTests "parseUnsafeST" TTC.parseUnsafeST answerST
, mkTests "parseUnsafeBS" TTC.parseUnsafeBS answerBS
, mkTests "parseUnsafeBSL" TTC.parseUnsafeBSL answerBSL
, mkTests "parseUnsafeBSB" TTC.parseUnsafeBSB answerBSB
, mkTests "parseUnsafeSBS" TTC.parseUnsafeSBS answerSBS
]
where
mkTests
:: IsString a
=> TestName
-> (a -> PosInt)
-> a
-> TestTree
mkTests testName f x = testGroup testName
[ testCase "valid" $ answer @=? f x
, testCase "invalid" . assertRaises (Proxy :: Proxy ErrorCall) $ f "4a2"
]
------------------------------------------------------------------------------
testReadsWithParse :: TestTree
testReadsWithParse = testGroup "readsWithParse"
[ testCase "valid" $ [(answer, "")] @=? TTC.readsWithParse answerS
, testCase "invalid" $ [] @=? (TTC.readsWithParse :: ReadS PosInt) "-42"
]
testReadsEnum :: TestTree
testReadsEnum = testGroup "readsEnum"
[ testCase "valid" $ Just Red @=? readMaybe "R"
, testCase "invalid" $ Nothing @=? readMaybe @Color "bl"
]
------------------------------------------------------------------------------
-- $Valid
testValid :: TestTree
testValid = testCase "valid" $ Ex "test" @=? validConst
where
validConst :: Ex
validConst = $$(TTC.valid "test")
testValidIsString :: TestTree
testValidIsString =
testCase "validIsString" $ Ex "test" @=? validConst
where
validConst :: Ex
validConst = $$("test")
testValidOf :: TestTree
testValidOf = testCase "validOf" $
Ex "test" @=? $$(TTC.validOf (Proxy :: Proxy Ex) "test")
testMkValid :: TestTree
testMkValid = testCase "mkValid" $ Ex "test" @=? $$(Ex.valid "test")
testUntypedValidOf :: TestTree
testUntypedValidOf = testCase "untypedValidOf" $
Ex "test" @=? $(TTC.untypedValidOf (Proxy :: Proxy Ex) "test")
testMkUntypedValid :: TestTree
testMkUntypedValid = testCase "mkUntypedValid" $
Ex "test" @=? $(Ex.untypedValid "test")
testMkUntypedValidQQ :: TestTree
testMkUntypedValidQQ = testCase "mkUntypedValidQQ" $
Ex "test" @=? [Ex.untypedValidQQ|test|]
------------------------------------------------------------------------------
tests :: TestTree
tests = testGroup "Data.TTC"
[ testGroup "Textual"
[ testConvert
, testToX
, testFromX
, testAsX
]
, testGroup "Render"
[ testRender
, testRenderDefault
, testRenderWithShow
, testRenderX
]
, testGroup "Parse"
[ testParse
, testParseDefault
, testWithError
, testWithErrorX
, testPrefixError
, testPrefixErrorX
, testParseWithRead
, testParseWithRead'
, testMaybeParseWithRead
, testParseEnum
, testParseEnum'
, testParseX
, testParseMaybe
, testParseMaybeX
, testParseOrFail
, testParseOrFailX
, testParseUnsafe
, testParseUnsafeX
, testReadsWithParse
, testReadsEnum
]
, testGroup "Valid"
[ testValid
, testValidIsString
, testValidOf
, testMkValid
, testUntypedValidOf
, testMkUntypedValid
, testMkUntypedValidQQ
]
]