argo 0.2021.10.24 → 0.2021.11.2
raw patch · 13 files changed
+459/−70 lines, 13 filesdep −genvaliditydep −genvalidity-containersdep −genvalidity-textdep ~basedep ~bytestringdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: genvalidity, genvalidity-containers, genvalidity-text
Dependency ranges changed: base, bytestring, template-haskell
API changes (from Hackage documentation)
- Argo.Literal: digitOne :: Word8
+ Argo.Codec: Allow :: Permission
+ Argo.Codec: Codec :: r o -> (i -> w o) -> CodecOf r w i o
+ Argo.Codec: Forbid :: Permission
+ Argo.Codec: [decode] :: CodecOf r w i o -> r o
+ Argo.Codec: [encode] :: CodecOf r w i o -> i -> w o
+ Argo.Codec: arrayCodec :: ValueCodec (ArrayOf Value)
+ Argo.Codec: boolCodec :: ValueCodec Bool
+ Argo.Codec: booleanCodec :: ValueCodec Boolean
+ Argo.Codec: data CodecOf r w i o
+ Argo.Codec: data Permission
+ Argo.Codec: decodeWith :: ValueCodec a -> Value -> Result a
+ Argo.Codec: detect :: (a -> Bool) -> [a] -> Maybe (a, [a])
+ Argo.Codec: detectWith :: ([a] -> [a]) -> (a -> Bool) -> [a] -> Maybe (a, [a])
+ Argo.Codec: dimap :: (Functor r, Functor w) => (a -> b) -> (b -> a) -> Codec r w a -> Codec r w b
+ Argo.Codec: eitherCodec :: ValueCodec a -> ValueCodec b -> ValueCodec (Either a b)
+ Argo.Codec: element :: ValueCodec a -> ArrayCodec a
+ Argo.Codec: encodeWith :: ValueCodec a -> a -> Value
+ Argo.Codec: fromArrayCodec :: Permission -> ArrayCodec a -> ValueCodec a
+ Argo.Codec: fromListCodec :: ValueCodec [e] -> Permission -> ListCodec e a -> ValueCodec a
+ Argo.Codec: fromObjectCodec :: Permission -> ObjectCodec a -> ValueCodec a
+ Argo.Codec: instance (GHC.Base.Alternative r, GHC.Base.Alternative w) => GHC.Base.Alternative (Argo.Codec.CodecOf r w i)
+ Argo.Codec: instance (GHC.Base.Applicative r, GHC.Base.Applicative w) => GHC.Base.Applicative (Argo.Codec.CodecOf r w i)
+ Argo.Codec: instance (GHC.Base.Functor r, GHC.Base.Functor w) => GHC.Base.Functor (Argo.Codec.CodecOf r w i)
+ Argo.Codec: instance GHC.Classes.Eq Argo.Codec.Permission
+ Argo.Codec: instance GHC.Show.Show Argo.Codec.Permission
+ Argo.Codec: literalCodec :: Value -> ValueCodec ()
+ Argo.Codec: mapBoth :: (Functor r, Alternative w) => (o2 -> o1) -> (i1 -> Maybe i2) -> CodecOf r w i2 o2 -> CodecOf r w i1 o1
+ Argo.Codec: maybeCodec :: ValueCodec a -> ValueCodec (Maybe a)
+ Argo.Codec: nullCodec :: ValueCodec Null
+ Argo.Codec: numberCodec :: ValueCodec Number
+ Argo.Codec: objectCodec :: ValueCodec (ObjectOf Value)
+ Argo.Codec: optional :: Name -> ValueCodec a -> ObjectCodec (Maybe a)
+ Argo.Codec: project :: (i -> f) -> CodecOf r w f o -> CodecOf r w i o
+ Argo.Codec: required :: Name -> ValueCodec a -> ObjectCodec a
+ Argo.Codec: stringCodec :: ValueCodec String
+ Argo.Codec: tagged :: String -> ValueCodec a -> ValueCodec a
+ Argo.Codec: textCodec :: ValueCodec Text
+ Argo.Codec: tupleCodec :: ValueCodec a -> ValueCodec b -> ValueCodec (a, b)
+ Argo.Codec: type ArrayCodec a = ListCodec Value a
+ Argo.Codec: type Codec r w a = CodecOf r w a a
+ Argo.Codec: type ListCodec e a = Codec (StateT [e] (ExceptT String Identity)) (WriterT [e] Identity) a
+ Argo.Codec: type ObjectCodec a = ListCodec (MemberOf Value) a
+ Argo.Codec: type ValueCodec a = Codec (ReaderT Value (ExceptT String Identity)) (MaybeT (StateT Value Identity)) a
+ Argo.Codec: valueCodec :: ValueCodec Value
+ Argo.Json.Array: fromList :: [value] -> ArrayOf value
+ Argo.Json.Array: toList :: ArrayOf value -> [value]
+ Argo.Json.Boolean: fromBool :: Bool -> Boolean
+ Argo.Json.Boolean: toBool :: Boolean -> Bool
+ Argo.Json.Name: fromString :: String -> Name
+ Argo.Json.Name: toString :: Name -> String
+ Argo.Json.Null: fromUnit :: () -> Null
+ Argo.Json.Null: toUnit :: Null -> ()
+ Argo.Json.Object: fromList :: [MemberOf value] -> ObjectOf value
+ Argo.Json.Object: toList :: ObjectOf value -> [MemberOf value]
+ Argo.Json.String: fromText :: Text -> String
+ Argo.Json.String: toText :: String -> Text
Files
- argo.cabal +11/−7
- source/library/Argo/Codec.hs +303/−0
- source/library/Argo/Encode.hs +3/−2
- source/library/Argo/Encoder.hs +1/−1
- source/library/Argo/Json/Array.hs +9/−3
- source/library/Argo/Json/Boolean.hs +10/−4
- source/library/Argo/Json/Name.hs +8/−2
- source/library/Argo/Json/Null.hs +7/−1
- source/library/Argo/Json/Object.hs +9/−3
- source/library/Argo/Json/String.hs +9/−3
- source/library/Argo/Literal.hs +0/−3
- source/library/Argo/Vendor/Transformers.hs +14/−3
- source/test-suite/Main.hs +75/−38
argo.cabal view
@@ -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
+ source/library/Argo/Codec.hs view
@@ -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
source/library/Argo/Encode.hs view
@@ -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
source/library/Argo/Encoder.hs view
@@ -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
source/library/Argo/Json/Array.hs view
@@ -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
source/library/Argo/Json/Boolean.hs view
@@ -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
source/library/Argo/Json/Name.hs view
@@ -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
source/library/Argo/Json/Null.hs view
@@ -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
source/library/Argo/Json/Object.hs view
@@ -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
source/library/Argo/Json/String.hs view
@@ -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
source/library/Argo/Literal.hs view
@@ -18,9 +18,6 @@ digitNine :: Word.Word8 digitNine = 0x39 -digitOne :: Word.Word8-digitOne = 0x31- digitZero :: Word.Word8 digitZero = 0x30
source/library/Argo/Vendor/Transformers.hs view
@@ -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
source/test-suite/Main.hs view
@@ -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)