diff --git a/argo.cabal b/argo.cabal --- a/argo.cabal +++ b/argo.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: argo -version: 0.2021.10.24 +version: 0.2021.11.2 build-type: Simple category: JSON @@ -23,11 +23,11 @@ common library build-depends: - , base >= 4.14.0 && < 4.16 - , bytestring >= 0.10.12 && < 0.11 + , base >= 4.14.0 && < 4.17 + , bytestring >= 0.10.12 && < 0.12 , containers >= 0.6.4 && < 0.7 , deepseq >= 1.4.4 && < 1.5 - , template-haskell >= 2.16.0 && < 2.18 + , template-haskell >= 2.16.0 && < 2.19 , text >= 1.2.4 && < 1.3 , transformers >= 0.5.6 && < 0.6 default-language: Haskell2010 @@ -35,6 +35,7 @@ -Weverything -Wno-all-missed-specialisations -Wno-implicit-prelude + -Wno-missed-specialisations -Wno-missing-deriving-strategies -Wno-missing-export-lists -Wno-missing-exported-signatures @@ -46,6 +47,11 @@ if flag(pedantic) ghc-options: -Werror + if impl(ghc >= 9.2) + ghc-options: + -Wno-implicit-lift + -Wno-missing-kind-signatures + common executable import: library @@ -63,6 +69,7 @@ Argo Argo.Class.FromValue Argo.Class.ToValue + Argo.Codec Argo.Decode Argo.Decoder Argo.Encode @@ -101,9 +108,6 @@ import: executable build-depends: - , genvalidity >= 0.11.0 && < 0.12 - , genvalidity-containers >= 0.9.0 && < 0.10 - , genvalidity-text >= 0.7.0 && < 0.8 , tasty >= 1.4.2 && < 1.5 , tasty-hunit >= 0.10.0 && < 0.11 , tasty-quickcheck >= 0.10.1 && < 0.11 diff --git a/source/library/Argo/Codec.hs b/source/library/Argo/Codec.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Codec.hs @@ -0,0 +1,303 @@ +module Argo.Codec where + +import Control.Applicative ((<|>)) + +import qualified Argo.Json.Array as Array +import qualified Argo.Json.Boolean as Boolean +import qualified Argo.Json.Member as Member +import qualified Argo.Json.Name as Name +import qualified Argo.Json.Null as Null +import qualified Argo.Json.Number as Number +import qualified Argo.Json.Object as Object +import qualified Argo.Json.String as String +import qualified Argo.Json.Value as Value +import qualified Argo.Result as Result +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Applicative as Applicative +import qualified Control.Monad as Monad +import qualified Data.Functor.Identity as Identity +import qualified Data.Text as Text + +decodeWith :: ValueCodec a -> Value.Value -> Result.Result a +decodeWith c = either fail pure + . Identity.runIdentity + . Trans.runExceptT + . Trans.runReaderT (decode c) + +encodeWith :: ValueCodec a -> a -> Value.Value +encodeWith c x = snd + . Identity.runIdentity + . Trans.runStateT (Trans.runMaybeT $ encode c x) + . Value.Null + $ Null.fromUnit () + +project :: (i -> f) -> CodecOf r w f o -> CodecOf r w i o +project f c = c { encode = encode c . f } + +data CodecOf r w i o = Codec + { decode :: r o + , encode :: i -> w o + } + +instance (Functor r, Functor w) => Functor (CodecOf r w i) where + fmap f c = Codec + { decode = fmap f $ decode c + , encode = fmap f . encode c + } + +instance (Applicative r, Applicative w) => Applicative (CodecOf r w i) where + pure x = Codec + { decode = pure x + , encode = const $ pure x + } + cf <*> cx = Codec + { decode = decode cf <*> decode cx + , encode = \ i -> encode cf i <*> encode cx i + } + +instance (Applicative.Alternative r, Applicative.Alternative w) => Applicative.Alternative (CodecOf r w i) where + empty = Codec + { decode = Applicative.empty + , encode = const Applicative.empty + } + cx <|> cy = Codec + { decode = decode cx <|> decode cy + , encode = \ i -> encode cx i <|> encode cy i + } + +type Codec r w a = CodecOf r w a a + +dimap :: (Functor r, Functor w) => (a -> b) -> (b -> a) -> Codec r w a -> Codec r w b +dimap f g c = Codec + { decode = fmap f $ decode c + , encode = fmap f . encode c . g + } + +type ValueCodec a = Codec + (Trans.ReaderT Value.Value (Trans.ExceptT String Identity.Identity)) + (Trans.MaybeT (Trans.StateT Value.Value Identity.Identity)) + a + +valueCodec :: ValueCodec Value.Value +valueCodec = Codec + { decode = Trans.ask + , encode = \ x -> do + Trans.lift $ Trans.put x + pure x + } + +nullCodec :: ValueCodec Null.Null +nullCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.Null y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected Null but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.Null x + pure x + } + +booleanCodec :: ValueCodec Boolean.Boolean +booleanCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.Boolean y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected Boolean but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.Boolean x + pure x + } + +numberCodec :: ValueCodec Number.Number +numberCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.Number y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected Number but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.Number x + pure x + } + +stringCodec :: ValueCodec String.String +stringCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.String y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected String but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.String x + pure x + } + +arrayCodec :: ValueCodec (Array.ArrayOf Value.Value) +arrayCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.Array y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected Array but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.Array x + pure x + } + +objectCodec :: ValueCodec (Object.ObjectOf Value.Value) +objectCodec = Codec + { decode = do + x <- Trans.ask + case x of + Value.Object y -> pure y + _ -> Trans.lift . Trans.throwE $ "expected Object but got " <> show x + , encode = \ x -> do + Trans.lift . Trans.put $ Value.Object x + pure x + } + +boolCodec :: ValueCodec Bool +boolCodec = dimap Boolean.toBool Boolean.fromBool booleanCodec + +textCodec :: ValueCodec Text.Text +textCodec = dimap String.toText String.fromText stringCodec + +maybeCodec :: ValueCodec a -> ValueCodec (Maybe a) +maybeCodec c = + mapBoth Just id c + <|> dimap (const Nothing) (const $ Null.fromUnit ()) nullCodec + +eitherCodec :: ValueCodec a -> ValueCodec b -> ValueCodec (Either a b) +eitherCodec cx cy = + mapBoth Left (either Just (const Nothing)) (tagged "Left" cx) + <|> mapBoth Right (either (const Nothing) Just) (tagged "Right" cy) + +mapBoth + :: (Functor r, Applicative.Alternative w) + => (o2 -> o1) -> (i1 -> Maybe i2) -> CodecOf r w i2 o2 -> CodecOf r w i1 o1 +mapBoth f g c = Codec + { decode = fmap f $ decode c + , encode = \ x -> case g x of + Nothing -> Applicative.empty + Just y -> fmap f $ encode c y + } + +tagged :: String -> ValueCodec a -> ValueCodec a +tagged t c = dimap snd ((,) ()) . fromObjectCodec Allow $ (,) + <$> project fst (required (Name.fromString . String.fromText $ Text.pack "type") (literalCodec (Value.String . String.fromText $ Text.pack t))) + <*> project snd (required (Name.fromString . String.fromText $ Text.pack "value") c) + +literalCodec :: Value.Value -> ValueCodec () +literalCodec expected = Codec + { decode = do + actual <- Trans.ask + Monad.when (actual /= expected) + . Trans.lift + . Trans.throwE + $ "expected " <> show expected <> " but got " <> show actual + , encode = const . Trans.lift $ Trans.put expected + } + +data Permission + = Allow + | Forbid + deriving (Eq, Show) + +type ListCodec e a = Codec + (Trans.StateT [e] (Trans.ExceptT String Identity.Identity)) + (Trans.WriterT [e] Identity.Identity) + a + +fromListCodec :: ValueCodec [e] -> Permission -> ListCodec e a -> ValueCodec a +fromListCodec ce p ca = Codec + { decode = do + xs <- decode ce + case Identity.runIdentity . Trans.runExceptT $ Trans.runStateT (decode ca) xs of + Left x -> Trans.lift $ Trans.throwE x + Right (x, ys) -> do + case (p, ys) of + (Forbid, _ : _) -> Trans.lift $ Trans.throwE "leftover elements" + _ -> pure () + pure x + , encode = \ x -> do + Monad.void + . encode ce + . snd + . Identity.runIdentity + . Trans.runWriterT + $ encode ca x + pure x + } + +type ArrayCodec a = ListCodec Value.Value a + +fromArrayCodec :: Permission -> ArrayCodec a -> ValueCodec a +fromArrayCodec = fromListCodec $ dimap Array.toList Array.fromList arrayCodec + +element :: ValueCodec a -> ArrayCodec a +element c = Codec + { decode = do + l <- Trans.get + case l of + [] -> Trans.lift $ Trans.throwE "unexpected empty list" + h : t -> case decodeWith c h of + Result.Failure y -> Trans.lift $ Trans.throwE y + Result.Success y -> do + Trans.put t + pure y + , encode = \ x -> do + Trans.tell [encodeWith c x] + pure x + } + +tupleCodec :: ValueCodec a -> ValueCodec b -> ValueCodec (a, b) +tupleCodec cx cy = fromArrayCodec Forbid $ (,) + <$> project fst (element cx) + <*> project snd (element cy) + +type ObjectCodec a = ListCodec (Member.MemberOf Value.Value) a + +fromObjectCodec :: Permission -> ObjectCodec a -> ValueCodec a +fromObjectCodec = fromListCodec $ dimap Object.toList Object.fromList objectCodec + +required :: Name.Name -> ValueCodec a -> ObjectCodec a +required k c = Codec + { decode = do + m <- decode (optional k c) + case m of + Nothing -> Trans.lift . Trans.throwE $ "missing required member: " <> show k + Just x -> pure x + , encode = \ x -> do + Monad.void . encode (optional k c) $ Just x + pure x + } + +optional :: Name.Name -> ValueCodec a -> ObjectCodec (Maybe a) +optional k c = Codec + { decode = do + xs <- Trans.get + case detect (\ (Member.Member j _) -> j == k) xs of + Nothing -> pure Nothing + Just (Member.Member _ x, ys) -> case decodeWith c x of + Result.Failure y -> Trans.lift $ Trans.throwE y + Result.Success y -> do + Trans.put ys + pure $ Just y + , encode = \ x -> do + case x of + Nothing -> pure () + Just y -> Trans.tell [Member.Member k $ encodeWith c y] + pure x + } + +detect :: (a -> Bool) -> [a] -> Maybe (a, [a]) +detect = detectWith id + +detectWith :: ([a] -> [a]) -> (a -> Bool) -> [a] -> Maybe (a, [a]) +detectWith f p xs = case xs of + [] -> Nothing + x : ys -> if p x + then Just (x, f ys) + else detectWith (f . (x :)) p ys diff --git a/source/library/Argo/Encode.hs b/source/library/Argo/Encode.hs --- a/source/library/Argo/Encode.hs +++ b/source/library/Argo/Encode.hs @@ -15,8 +15,9 @@ encodeWith :: ToValue.ToValue a => Encoder.Indent -> a -> Builder.Builder encodeWith i x = let c = Encoder.Config { Encoder.indent = i, Encoder.level = 0 } - in Identity.runIdentity - . Trans.execWriterT + in snd + . Identity.runIdentity + . Trans.runWriterT . flip Trans.runReaderT c $ do Value.encode $ ToValue.toValue x diff --git a/source/library/Argo/Encoder.hs b/source/library/Argo/Encoder.hs --- a/source/library/Argo/Encoder.hs +++ b/source/library/Argo/Encoder.hs @@ -37,7 +37,7 @@ c <- Trans.ask let newLine = if hasIndent c then Builder.word8 Literal.newLine else mempty Trans.local increaseLevel $ do - i <- Trans.asks makeIndent + i <- makeIndent <$> Trans.ask Trans.lift . Trans.tell $ newLine <> i f x Monad.forM_ ys $ \ y -> do diff --git a/source/library/Argo/Json/Array.hs b/source/library/Argo/Json/Array.hs --- a/source/library/Argo/Json/Array.hs +++ b/source/library/Argo/Json/Array.hs @@ -17,13 +17,19 @@ = Array [value] deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromList :: [value] -> ArrayOf value +fromList = Array + +toList :: ArrayOf value -> [value] +toList (Array x) = x + encode :: (value -> Encoder.Encoder ()) -> ArrayOf value -> Encoder.Encoder () -encode f (Array xs) = Encoder.list +encode f = Encoder.list (Trans.lift . Trans.tell $ Builder.word8 Literal.leftSquareBracket) (Trans.lift . Trans.tell $ Builder.word8 Literal.rightSquareBracket) (Trans.lift . Trans.tell $ Builder.word8 Literal.comma) f - xs + . toList decode :: Decoder.Decoder value -> Decoder.Decoder (ArrayOf value) decode f = do @@ -32,4 +38,4 @@ xs <- Decoder.list f Decoder.word8 Literal.rightSquareBracket Decoder.spaces - pure $ Array xs + pure $ fromList xs diff --git a/source/library/Argo/Json/Boolean.hs b/source/library/Argo/Json/Boolean.hs --- a/source/library/Argo/Json/Boolean.hs +++ b/source/library/Argo/Json/Boolean.hs @@ -19,17 +19,23 @@ = Boolean Bool deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromBool :: Bool -> Boolean +fromBool = Boolean + +toBool :: Boolean -> Bool +toBool (Boolean x) = x + encode :: Boolean -> Encoder.Encoder () -encode (Boolean x) = Trans.lift +encode x = Trans.lift . Trans.tell . Builder.byteString - $ if x then Literal.true else Literal.false + $ if toBool x then Literal.true else Literal.false decode :: Decoder.Decoder Boolean decode = decodeFalse <|> decodeTrue decodeFalse :: Decoder.Decoder Boolean -decodeFalse = Boolean False <$ Decoder.byteString Literal.false <* Decoder.spaces +decodeFalse = fromBool False <$ Decoder.byteString Literal.false <* Decoder.spaces decodeTrue :: Decoder.Decoder Boolean -decodeTrue = Boolean True <$ Decoder.byteString Literal.true <* Decoder.spaces +decodeTrue = fromBool True <$ Decoder.byteString Literal.true <* Decoder.spaces diff --git a/source/library/Argo/Json/Name.hs b/source/library/Argo/Json/Name.hs --- a/source/library/Argo/Json/Name.hs +++ b/source/library/Argo/Json/Name.hs @@ -15,8 +15,14 @@ = Name String.String deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromString :: String.String -> Name +fromString = Name + +toString :: Name -> String.String +toString (Name x) = x + encode :: Name -> Encoder.Encoder () -encode (Name x) = String.encode x +encode = String.encode . toString decode :: Decoder.Decoder Name -decode = Name <$> String.decode +decode = fromString <$> String.decode diff --git a/source/library/Argo/Json/Null.hs b/source/library/Argo/Json/Null.hs --- a/source/library/Argo/Json/Null.hs +++ b/source/library/Argo/Json/Null.hs @@ -17,8 +17,14 @@ = Null () deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromUnit :: () -> Null +fromUnit = Null + +toUnit :: Null -> () +toUnit (Null x) = x + encode :: Null -> Encoder.Encoder () encode = const . Trans.lift . Trans.tell $ Builder.byteString Literal.null decode :: Decoder.Decoder Null -decode = Null () <$ Decoder.byteString Literal.null <* Decoder.spaces +decode = fromUnit () <$ Decoder.byteString Literal.null <* Decoder.spaces diff --git a/source/library/Argo/Json/Object.hs b/source/library/Argo/Json/Object.hs --- a/source/library/Argo/Json/Object.hs +++ b/source/library/Argo/Json/Object.hs @@ -19,13 +19,19 @@ = Object [Member.MemberOf value] deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromList :: [Member.MemberOf value] -> ObjectOf value +fromList = Object + +toList :: ObjectOf value -> [Member.MemberOf value] +toList (Object x) = x + encode :: (value -> Encoder.Encoder ()) -> ObjectOf value -> Encoder.Encoder () -encode f (Object xs) = Encoder.list +encode f = Encoder.list (Trans.lift . Trans.tell $ Builder.word8 Literal.leftCurlyBracket) (Trans.lift . Trans.tell $ Builder.word8 Literal.rightCurlyBracket) (Trans.lift . Trans.tell $ Builder.word8 Literal.comma) (Member.encode f) - xs + . toList encodeElement :: (value -> Encoder.Encoder ()) -> Int -> Member.MemberOf value -> Encoder.Encoder () encodeElement f i x = do @@ -39,4 +45,4 @@ xs <- Decoder.list $ Member.decode f Decoder.word8 Literal.rightCurlyBracket Decoder.spaces - pure $ Object xs + pure $ fromList xs diff --git a/source/library/Argo/Json/String.hs b/source/library/Argo/Json/String.hs --- a/source/library/Argo/Json/String.hs +++ b/source/library/Argo/Json/String.hs @@ -22,11 +22,17 @@ = String Text.Text deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) +fromText :: Text.Text -> Argo.Json.String.String +fromText = String + +toText :: Argo.Json.String.String -> Text.Text +toText (String x) = x + encode :: Argo.Json.String.String -> Encoder.Encoder () -encode (String x) = Trans.lift +encode x = Trans.lift . Trans.tell $ Builder.word8 Literal.quotationMark - <> Text.encodeUtf8BuilderEscaped encodeChar x + <> Text.encodeUtf8BuilderEscaped encodeChar (toText x) <> Builder.word8 Literal.quotationMark encodeChar :: Builder.BoundedPrim Word.Word8 @@ -73,7 +79,7 @@ Left e -> fail $ show e Right x -> case unescapeText x of Nothing -> fail "invalid escape" - Just y -> pure $ String y + Just y -> pure $ fromText y findAt :: Word.Word8 -> Int -> ByteString.ByteString -> Maybe Int findAt x i = fmap (+ i) . ByteString.elemIndex x . ByteString.drop i diff --git a/source/library/Argo/Literal.hs b/source/library/Argo/Literal.hs --- a/source/library/Argo/Literal.hs +++ b/source/library/Argo/Literal.hs @@ -18,9 +18,6 @@ digitNine :: Word.Word8 digitNine = 0x39 -digitOne :: Word.Word8 -digitOne = 0x31 - digitZero :: Word.Word8 digitZero = 0x30 diff --git a/source/library/Argo/Vendor/Transformers.hs b/source/library/Argo/Vendor/Transformers.hs --- a/source/library/Argo/Vendor/Transformers.hs +++ b/source/library/Argo/Vendor/Transformers.hs @@ -1,15 +1,26 @@ module Argo.Vendor.Transformers - ( ReaderT.ReaderT + ( ExceptT.ExceptT + , MaybeT.MaybeT + , ReaderT.ReaderT + , StateT.StateT , WriterT.WriterT , ReaderT.ask - , ReaderT.asks - , WriterT.execWriterT + , StateT.get , Trans.lift , ReaderT.local + , StateT.put + , ExceptT.runExceptT + , MaybeT.runMaybeT , ReaderT.runReaderT + , StateT.runStateT + , WriterT.runWriterT , WriterT.tell + , ExceptT.throwE ) where import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Except as ExceptT +import qualified Control.Monad.Trans.Maybe as MaybeT import qualified Control.Monad.Trans.Reader as ReaderT +import qualified Control.Monad.Trans.State as StateT import qualified Control.Monad.Trans.Writer as WriterT diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -4,17 +4,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -import Data.GenValidity.Map () -import Data.GenValidity.Text () import Data.List.NonEmpty (NonEmpty((:|))) import Test.Tasty.HUnit ((@?=)) import Test.Tasty.QuickCheck ((===)) import qualified Argo +import qualified Argo.Codec as Codec import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LazyByteString -import qualified Data.GenValidity as GenValidity import qualified Data.Int as Int import qualified Data.Map as Map import qualified Data.Text as Text @@ -480,14 +478,56 @@ Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Map.Map Text.Text Bool) ] ] + , Tasty.testGroup "Codec" + [ Tasty.testCase "encode text" $ do + Codec.encodeWith Codec.textCodec "" @?= Argo.String "" + , Tasty.testCase "decode text" $ do + Codec.decodeWith Codec.textCodec (Argo.String "") @?= Argo.Success "" + , Tasty.testCase "encode bool" $ do + Codec.encodeWith Codec.boolCodec False @?= Argo.Boolean False + , Tasty.testCase "decode bool" $ do + Codec.decodeWith Codec.boolCodec (Argo.Boolean False) @?= Argo.Success False + , Tasty.testCase "encode maybe text" $ do + Codec.encodeWith (Codec.maybeCodec Codec.textCodec) Nothing @?= Argo.Null + Codec.encodeWith (Codec.maybeCodec Codec.textCodec) (Just "") @?= Argo.String "" + , Tasty.testCase "decode maybe text" $ do + Codec.decodeWith (Codec.maybeCodec Codec.textCodec) Argo.Null @?= Argo.Success Nothing + Codec.decodeWith (Codec.maybeCodec Codec.textCodec) (Argo.String "") @?= Argo.Success (Just "") + , Tasty.testCase "encode either text bool" $ do + Codec.encodeWith (Codec.eitherCodec Codec.textCodec Codec.boolCodec) (Left "") @?= Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Left", Argo.Member (Argo.Name "value") $ Argo.String ""] + Codec.encodeWith (Codec.eitherCodec Codec.textCodec Codec.boolCodec) (Right False) @?= Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Right", Argo.Member (Argo.Name "value") $ Argo.Boolean False] + , Tasty.testCase "decode either text bool" $ do + Codec.decodeWith (Codec.eitherCodec Codec.textCodec Codec.boolCodec) (Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Left", Argo.Member (Argo.Name "value") $ Argo.String ""]) @?= Argo.Success (Left "") + Codec.decodeWith (Codec.eitherCodec Codec.textCodec Codec.boolCodec) (Argo.Object [Argo.Member (Argo.Name "type") $ Argo.String "Right", Argo.Member (Argo.Name "value") $ Argo.Boolean False]) @?= Argo.Success (Right False) + , Tasty.testCase "encode tuple text bool" $ do + Codec.encodeWith (Codec.tupleCodec Codec.textCodec Codec.boolCodec) ("", False) @?= Argo.Array [Argo.String "", Argo.Boolean False] + , Tasty.testCase "decode tuple text bool" $ do + Codec.decodeWith (Codec.tupleCodec Codec.textCodec Codec.boolCodec) (Argo.Array [Argo.String "", Argo.Boolean False]) @?= Argo.Success ("", False) + , Tasty.testCase "encode record" $ do + Codec.encodeWith recordCodec (Record False Nothing) @?= Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False] + Codec.encodeWith recordCodec (Record False $ Just "") @?= Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False, Argo.Member (Argo.Name "text") $ Argo.String ""] + , Tasty.testCase "decode record" $ do + Codec.decodeWith recordCodec (Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False]) @?= Argo.Success (Record False Nothing) + Codec.decodeWith recordCodec (Argo.Object [Argo.Member (Argo.Name "bool") $ Argo.Boolean False, Argo.Member (Argo.Name "text") $ Argo.String ""]) @?= Argo.Success (Record False $ Just "") + ] ] +data Record = Record + { recordBool :: Bool + , recordText :: Maybe Text.Text + } deriving (Eq, Show) + +recordCodec :: Codec.ValueCodec Record +recordCodec = Codec.fromObjectCodec Codec.Allow $ Record + <$> Codec.project recordBool (Codec.required (Argo.Name "bool") Codec.boolCodec) + <*> Codec.project recordText (Codec.optional (Argo.Name "text") Codec.textCodec) + property - :: (Show t, Tasty.Testable prop, GenValidity.GenValid t) + :: (Show t, Tasty.Testable prop, Tasty.Arbitrary t) => Tasty.TestName -> (t -> prop) -> Tasty.TestTree -property n = propertyWith n GenValidity.genValid GenValidity.shrinkValid +property n = propertyWith n Tasty.arbitrary Tasty.shrink propertyWith :: (Show t, Tasty.Testable prop) @@ -500,50 +540,47 @@ . Tasty.forAll g $ \ x -> Tasty.shrinking s x f -instance GenValidity.Validity Argo.Name where - validate (Argo.Name x) = GenValidity.validate x - -instance GenValidity.GenValid Argo.Name where - genValid = Argo.Name <$> GenValidity.genValid - shrinkValid (Argo.Name x) = Argo.Name <$> GenValidity.shrinkValid x - -instance GenValidity.Validity Argo.Member where - validate (Argo.Member k v) = GenValidity.validate (k, v) - -instance GenValidity.GenValid Argo.Member where - genValid = Argo.Member <$> GenValidity.genValid <*> GenValidity.genValid - shrinkValid (Argo.Member k v) = uncurry Argo.Member <$> GenValidity.shrinkValid (k, v) +instance Tasty.Arbitrary Argo.Name where + arbitrary = Argo.Name <$> Tasty.arbitrary + shrink (Argo.Name x) = Argo.Name <$> Tasty.shrink x -instance GenValidity.Validity Argo.Value where - validate x = case x of - Argo.Null -> GenValidity.valid - Argo.Boolean y -> GenValidity.annotate y "Boolean" - Argo.Number y z -> GenValidity.annotate (y, z) "Number" - Argo.String y -> GenValidity.annotate y "String" - Argo.Array y -> GenValidity.annotate y "Array" - Argo.Object y -> GenValidity.annotate y "Object" +instance Tasty.Arbitrary Argo.Member where + arbitrary = Argo.Member <$> Tasty.arbitrary <*> Tasty.arbitrary + shrink (Argo.Member k v) = uncurry Argo.Member <$> Tasty.shrink (k, v) -instance GenValidity.GenValid Argo.Value where - genValid = Tasty.sized genValueSized - shrinkValid x = case x of +instance Tasty.Arbitrary Argo.Value where + arbitrary = Tasty.sized genValueSized + shrink x = case x of Argo.Null -> [] - Argo.Boolean y -> Argo.Boolean <$> GenValidity.shrinkValid y - Argo.Number y z -> uncurry Argo.Number <$> GenValidity.shrinkValid (y, z) - Argo.String y -> Argo.String <$> GenValidity.shrinkValid y - Argo.Array y -> Argo.Array <$> GenValidity.shrinkValid y - Argo.Object y -> Argo.Object <$> GenValidity.shrinkValid y + Argo.Boolean y -> Argo.Boolean <$> Tasty.shrink y + Argo.Number y z -> uncurry Argo.Number <$> Tasty.shrink (y, z) + Argo.String y -> Argo.String <$> Tasty.shrink y + Argo.Array y -> Argo.Array <$> Tasty.shrink y + Argo.Object y -> Argo.Object <$> Tasty.shrink y genValueSized :: Int -> Tasty.Gen Argo.Value genValueSized size = let newSize = div size 3 in Tasty.oneof [ pure Argo.Null - , Argo.Boolean <$> GenValidity.genValid - , Argo.Number <$> GenValidity.genValid <*> GenValidity.genValid - , Argo.String <$> GenValidity.genValid + , Argo.Boolean <$> Tasty.arbitrary + , Argo.Number <$> Tasty.arbitrary <*> Tasty.arbitrary + , Argo.String <$> Tasty.arbitrary , Argo.Array <$> Tasty.vectorOf size (genValueSized newSize) - , Argo.Object <$> Tasty.vectorOf size (Argo.Member <$> GenValidity.genValid <*> genValueSized newSize) + , Argo.Object <$> Tasty.vectorOf size (Argo.Member <$> Tasty.arbitrary <*> genValueSized newSize) ] resultToMaybe :: Argo.Result a -> Maybe a resultToMaybe r = case r of Argo.Failure _ -> Nothing Argo.Success x -> Just x + +instance Tasty.Arbitrary Text.Text where + arbitrary = Text.pack <$> Tasty.arbitrary + shrink = Tasty.shrinkMap Text.pack Text.unpack + +instance Tasty.Arbitrary LazyText.Text where + arbitrary = LazyText.pack <$> Tasty.arbitrary + shrink = Tasty.shrinkMap LazyText.pack LazyText.unpack + +instance Tasty.Arbitrary a => Tasty.Arbitrary (NonEmpty a) where + arbitrary = (:|) <$> Tasty.arbitrary <*> Tasty.arbitrary + shrink (x :| xs) = uncurry (:|) <$> Tasty.shrink (x, xs)