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.19 +version: 0.2021.10.24 build-type: Simple category: JSON @@ -23,13 +23,13 @@ common library build-depends: - , array >= 0.5.4 && < 0.6 , base >= 4.14.0 && < 4.16 , bytestring >= 0.10.12 && < 0.11 , containers >= 0.6.4 && < 0.7 , deepseq >= 1.4.4 && < 1.5 , template-haskell >= 2.16.0 && < 2.18 , text >= 1.2.4 && < 1.3 + , transformers >= 0.5.6 && < 0.6 default-language: Haskell2010 ghc-options: -Weverything @@ -58,6 +58,7 @@ library import: library + autogen-modules: Paths_argo exposed-modules: Argo Argo.Class.FromValue @@ -65,20 +66,30 @@ Argo.Decode Argo.Decoder Argo.Encode + Argo.Encoder + Argo.Json.Array + Argo.Json.Boolean + Argo.Json.Member + Argo.Json.Name + Argo.Json.Null + Argo.Json.Number + Argo.Json.Object + Argo.Json.String + Argo.Json.Value Argo.Literal + Argo.Main Argo.Pattern Argo.QuasiQuoter Argo.Result - Argo.Type - Argo.Type.Array - Argo.Type.Boolean - Argo.Type.Null - Argo.Type.Number - Argo.Type.Object - Argo.Type.Pair - Argo.Type.String - Argo.Type.Value hs-source-dirs: source/library + other-modules: + Argo.Vendor.ByteString + Argo.Vendor.Builder + Argo.Vendor.DeepSeq + Argo.Vendor.TemplateHaskell + Argo.Vendor.Text + Argo.Vendor.Transformers + Paths_argo executable argo import: executable @@ -90,6 +101,9 @@ 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/benchmark/Main.hs b/source/benchmark/Main.hs --- a/source/benchmark/Main.hs +++ b/source/benchmark/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} import qualified Argo -import qualified Data.Array import qualified Data.ByteString as ByteString import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LazyByteString @@ -29,20 +28,20 @@ , Tasty.bench "10000 characters" . Tasty.nf encode . Argo.String . Text.pack $ replicate 10000 'a' ] , Tasty.bgroup "Array" - [ Tasty.bench "empty" . Tasty.nf encode . Argo.Array $ array [] - , Tasty.bench "1 element" . Tasty.nf encode . Argo.Array . array $ replicate 1 Argo.Null - , Tasty.bench "10 elements" . Tasty.nf encode . Argo.Array . array $ replicate 10 Argo.Null - , Tasty.bench "100 elements" . Tasty.nf encode . Argo.Array . array $ replicate 100 Argo.Null - , Tasty.bench "1000 elements" . Tasty.nf encode . Argo.Array . array $ replicate 1000 Argo.Null - , Tasty.bench "10000 elements" . Tasty.nf encode . Argo.Array . array $ replicate 10000 Argo.Null + [ Tasty.bench "empty" . Tasty.nf encode $ Argo.Array [] + , Tasty.bench "1 element" . Tasty.nf encode . Argo.Array $ replicate 1 Argo.Null + , Tasty.bench "10 elements" . Tasty.nf encode . Argo.Array $ replicate 10 Argo.Null + , Tasty.bench "100 elements" . Tasty.nf encode . Argo.Array $ replicate 100 Argo.Null + , Tasty.bench "1000 elements" . Tasty.nf encode . Argo.Array $ replicate 1000 Argo.Null + , Tasty.bench "10000 elements" . Tasty.nf encode . Argo.Array $ replicate 10000 Argo.Null ] , Tasty.bgroup "Object" - [ Tasty.bench "empty" . Tasty.nf encode . Argo.Object $ array [] - , Tasty.bench "1 element" . Tasty.nf encode . Argo.Object . array . replicate 1 $ Argo.Pair "" Argo.Null - , Tasty.bench "10 elements" . Tasty.nf encode . Argo.Object . array . replicate 10 $ Argo.Pair "" Argo.Null - , Tasty.bench "100 elements" . Tasty.nf encode . Argo.Object . array . replicate 100 $ Argo.Pair "" Argo.Null - , Tasty.bench "1000 elements" . Tasty.nf encode . Argo.Object . array . replicate 1000 $ Argo.Pair "" Argo.Null - , Tasty.bench "10000 elements" . Tasty.nf encode . Argo.Object . array . replicate 10000 $ Argo.Pair "" Argo.Null + [ Tasty.bench "empty" . Tasty.nf encode $ Argo.Object [] + , Tasty.bench "1 element" . Tasty.nf encode . Argo.Object . replicate 1 $ Argo.Member (Argo.Name "") Argo.Null + , Tasty.bench "10 elements" . Tasty.nf encode . Argo.Object . replicate 10 $ Argo.Member (Argo.Name "") Argo.Null + , Tasty.bench "100 elements" . Tasty.nf encode . Argo.Object . replicate 100 $ Argo.Member (Argo.Name "") Argo.Null + , Tasty.bench "1000 elements" . Tasty.nf encode . Argo.Object . replicate 1000 $ Argo.Member (Argo.Name "") Argo.Null + , Tasty.bench "10000 elements" . Tasty.nf encode . Argo.Object . replicate 10000 $ Argo.Member (Argo.Name "") Argo.Null ] ] , Tasty.bgroup "decode" $ let decode = resultToMaybe . Argo.decode :: ByteString.ByteString -> Maybe Argo.Value in @@ -64,18 +63,30 @@ , Tasty.bench "short escape" $ Tasty.nf decode "\"\\n\"" , Tasty.bench "long escape" $ Tasty.nf decode "\"\\u001f\"" , Tasty.bench "surrogate pair" $ Tasty.nf decode "\"\\ud834\\udd1e\"" + , Tasty.bench "1 character" . Tasty.nf decode $ "\"" <> ByteString.replicate 1 0x61 <> "\"" + , Tasty.bench "10 characters" . Tasty.nf decode $ "\"" <> ByteString.replicate 10 0x61 <> "\"" + , Tasty.bench "100 characters" . Tasty.nf decode $ "\"" <> ByteString.replicate 100 0x61 <> "\"" + , Tasty.bench "1000 characters" . Tasty.nf decode $ "\"" <> ByteString.replicate 1000 0x61 <> "\"" + , Tasty.bench "10000 characters" . Tasty.nf decode $ "\"" <> ByteString.replicate 10000 0x61 <> "\"" ] , Tasty.bgroup "Array" [ Tasty.bench "empty" $ Tasty.nf decode "[]" + , Tasty.bench "1 element" $ Tasty.nf decode "[null]" + , Tasty.bench "10 elements" . Tasty.nf decode $ "[null" <> ByteString.pack (take (5 * 9) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) <> "]" + , Tasty.bench "100 elements" . Tasty.nf decode $ "[null" <> ByteString.pack (take (5 * 99) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) <> "]" + , Tasty.bench "1000 elements" . Tasty.nf decode $ "[null" <> ByteString.pack (take (5 * 999) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) <> "]" + , Tasty.bench "10000 elements" . Tasty.nf decode $ "[null" <> ByteString.pack (take (5 * 9999) $ cycle [0x2c, 0x6e, 0x75, 0x6c, 0x6c]) <> "]" ] , Tasty.bgroup "Object" [ Tasty.bench "empty" $ Tasty.nf decode "{}" + , Tasty.bench "1 element" $ Tasty.nf decode "{\"\":null}" + , Tasty.bench "10 elements" . Tasty.nf decode $ "{\"\":null" <> ByteString.pack (take (5 * 9) $ cycle [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c]) <> "}" + , Tasty.bench "100 elements" . Tasty.nf decode $ "{\"\":null" <> ByteString.pack (take (5 * 99) $ cycle [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c]) <> "}" + , Tasty.bench "1000 elements" . Tasty.nf decode $ "{\"\":null" <> ByteString.pack (take (5 * 999) $ cycle [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c]) <> "}" + , Tasty.bench "10000 elements" . Tasty.nf decode $ "{\"\":null" <> ByteString.pack (take (5 * 9999) $ cycle [0x2c, 0x22, 0x22, 0x3a, 0x6e, 0x75, 0x6c, 0x6c]) <> "}" ] ] ] - -array :: [a] -> Data.Array.Array Int a -array xs = Data.Array.listArray (0, length xs - 1) xs resultToMaybe :: Argo.Result a -> Maybe a resultToMaybe r = case r of diff --git a/source/executable/Main.hs b/source/executable/Main.hs --- a/source/executable/Main.hs +++ b/source/executable/Main.hs @@ -1,11 +1,4 @@ -import qualified Argo -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as Builder -import qualified System.IO as IO +import qualified Argo.Main as Argo main :: IO () -main = do - contents <- ByteString.getContents - case Argo.decode contents of - Argo.Failure e -> fail e - Argo.Success value -> Builder.hPutBuilder IO.stdout $ Argo.encode (value :: Argo.Value) +main = Argo.main diff --git a/source/library/Argo.hs b/source/library/Argo.hs --- a/source/library/Argo.hs +++ b/source/library/Argo.hs @@ -9,10 +9,15 @@ , Pattern.Array , Pattern.Object ) - , Type.Array - , Pair.Pair(Pattern.Pair) - , Type.Object + , Pattern.Array + , Name.Name + , pattern Pattern.Name + , Pattern.Member + , pattern Pattern.Member + , Pattern.Object , Encode.encode + , Encode.encodeWith + , Encoder.Indent(Spaces, Tab) , Decode.decode , FromValue.FromValue(fromValue) , ToValue.ToValue(toValue) @@ -24,9 +29,9 @@ import qualified Argo.Class.ToValue as ToValue import qualified Argo.Decode as Decode import qualified Argo.Encode as Encode +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.Name as Name +import qualified Argo.Json.Value as Value import qualified Argo.Pattern as Pattern import qualified Argo.QuasiQuoter as QuasiQuoter import qualified Argo.Result as Result -import qualified Argo.Type as Type -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.Value as Value diff --git a/source/library/Argo/Class/FromValue.hs b/source/library/Argo/Class/FromValue.hs --- a/source/library/Argo/Class/FromValue.hs +++ b/source/library/Argo/Class/FromValue.hs @@ -2,21 +2,15 @@ module Argo.Class.FromValue where +import qualified Argo.Json.Number as Number +import qualified Argo.Json.Value as Value +import qualified Argo.Pattern as Pattern import qualified Argo.Result as Result -import qualified Argo.Type.Array as Array -import qualified Argo.Type.Boolean as Boolean -import qualified Argo.Type.Number as Number -import qualified Argo.Type.Object as Object -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.String as String -import qualified Argo.Type.Value as Value -import qualified Data.Array +import qualified Argo.Vendor.Text as Text import qualified Data.Bits as Bits import qualified Data.Int as Int import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText import qualified Data.Word as Word class FromValue a where @@ -66,7 +60,7 @@ instance FromValue Integer where fromValue = withNumber "Integer" $ \ x y -> if y < 0 - then fail $ "expected integer but got " <> show (Number.number x y) + then fail $ "expected integer but got " <> show (Pattern.Number x y) else pure $ x * 10 ^ y instance FromValue Float where @@ -83,70 +77,62 @@ instance FromValue Text.Text where fromValue = withString "Text" pure -instance FromValue LazyText.Text where - fromValue = fmap LazyText.fromStrict . fromValue +instance FromValue Text.LazyText where + fromValue = fmap Text.fromStrict . fromValue instance FromValue a => FromValue (Maybe a) where fromValue x = case x of - Value.Null _ -> pure Nothing + Pattern.Null -> pure Nothing _ -> Just <$> fromValue x instance FromValue () where - fromValue x = do - [] <- fromValue x :: Result.Result [Value.Value] - pure () + fromValue = withArray "()" $ \ xs -> case xs of + [] -> pure () + _ -> fail $ "expected empty list but got " <> show xs instance (FromValue a, FromValue b) => FromValue (a, b) where - fromValue x = do - [y, z] <- fromValue x - (,) <$> fromValue y <*> fromValue z - -instance FromValue a => FromValue (Data.Array.Array Int a) where - fromValue = withArray "Array" $ traverse fromValue + fromValue = withArray "(a, b)" $ \ xs -> case xs of + [x, y] -> (,) <$> fromValue x <*> fromValue y + _ -> fail $ "expected tuple but got " <> show xs instance FromValue a => FromValue [a] where - fromValue = - let - arrayToList :: Data.Array.Array Int b -> [b] - arrayToList = Data.Array.elems - in fmap arrayToList . fromValue + fromValue = withArray "[a]" $ traverse fromValue -instance (FromValue a, Show a) => FromValue (NonEmpty.NonEmpty a) where +instance FromValue a => FromValue (NonEmpty.NonEmpty a) where fromValue value = do list <- fromValue value case NonEmpty.nonEmpty list of - Nothing -> fail $ "expected non-empty list but got " <> show list + Nothing -> fail "unexpected empty list" Just nonEmpty -> pure nonEmpty instance FromValue a => FromValue (Map.Map Text.Text a) where fromValue = withObject "Map" $ fmap Map.fromList - . traverse (\ (Pair.Pair (String.String k, v)) -> (,) k <$> fromValue v) - . Data.Array.elems + . traverse (\ (Pattern.Member (Pattern.Name k) v) -> (,) k <$> fromValue v) withBoolean :: String -> (Bool -> Result.Result a) -> Value.Value -> Result.Result a withBoolean s f x = case x of - Value.Boolean (Boolean.Boolean y) -> f y + Pattern.Boolean y -> f y _ -> fail $ "expected " <> s <> " but got " <> show x withNumber :: String -> (Integer -> Integer -> Result.Result a) -> Value.Value -> Result.Result a withNumber s f x = case x of - Value.Number (Number.Number y z) -> f y z + Pattern.Number y z -> f y z _ -> fail $ "expected " <> s <> " but got " <> show x withString :: String -> (Text.Text -> Result.Result a) -> Value.Value -> Result.Result a withString s f x = case x of - Value.String (String.String y) -> f y + Pattern.String y -> f y _ -> fail $ "expected " <> s <> " but got " <> show x -withArray :: String -> (Data.Array.Array Int Value.Value -> Result.Result a) -> Value.Value -> Result.Result a +withArray :: String -> (Pattern.Array -> Result.Result a) -> Value.Value -> Result.Result a withArray s f x = case x of - Value.Array (Array.Array y) -> f y + Pattern.Array y -> f y _ -> fail $ "expected " <> s <> " but got " <> show x -withObject :: String -> (Data.Array.Array Int (Pair.Pair String.String Value.Value) -> Result.Result a) -> Value.Value -> Result.Result a +withObject :: String -> (Pattern.Object -> Result.Result a) -> Value.Value -> Result.Result a withObject s f x = case x of - Value.Object (Object.Object y) -> f y + Pattern.Object y -> f y _ -> fail $ "expected " <> s <> " but got " <> show x viaInteger :: (Integral a, Bits.Bits a) => Value.Value -> Result.Result a diff --git a/source/library/Argo/Class/ToValue.hs b/source/library/Argo/Class/ToValue.hs --- a/source/library/Argo/Class/ToValue.hs +++ b/source/library/Argo/Class/ToValue.hs @@ -2,21 +2,14 @@ module Argo.Class.ToValue where -import qualified Argo.Type.Array as Array -import qualified Argo.Type.Boolean as Boolean -import qualified Argo.Type.Null as Null -import qualified Argo.Type.Number as Number -import qualified Argo.Type.Object as Object -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.String as String -import qualified Argo.Type.Value as Value -import qualified Data.Array +import qualified Argo.Json.Number as Number +import qualified Argo.Json.Value as Value +import qualified Argo.Pattern as Pattern +import qualified Argo.Vendor.Text as Text import qualified Data.Int as Int import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map as Map -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText import qualified Data.Word as Word import qualified Numeric @@ -27,7 +20,7 @@ toValue = id instance ToValue Bool where - toValue = Value.Boolean . Boolean.Boolean + toValue = Pattern.Boolean instance ToValue Char where toValue = toValue . Text.singleton @@ -63,7 +56,7 @@ toValue = toValue . toInteger instance ToValue Integer where - toValue = Value.Number . flip Number.number 0 + toValue = flip Pattern.Number 0 instance ToValue Float where toValue = realFloatToValue @@ -75,13 +68,13 @@ toValue = toValue . Text.pack instance ToValue Text.Text where - toValue = Value.String . String.String + toValue = Pattern.String -instance ToValue LazyText.Text where - toValue = toValue . LazyText.toStrict +instance ToValue Text.LazyText where + toValue = toValue . Text.toStrict instance ToValue a => ToValue (Maybe a) where - toValue = maybe (Value.Null $ Null.Null ()) toValue + toValue = maybe Pattern.Null toValue instance ToValue () where toValue = const $ toValue ([] :: [Value.Value]) @@ -89,30 +82,21 @@ instance (ToValue a, ToValue b) => ToValue (a, b) where toValue (x, y) = toValue [toValue x, toValue y] -instance ToValue a => ToValue (Data.Array.Array Int a) where - toValue = Value.Array . Array.Array . fmap toValue - instance ToValue a => ToValue [a] where - toValue = - let - listToArray :: [b] -> Data.Array.Array Int b - listToArray xs = Data.Array.listArray (0, length xs - 1) xs - in toValue . listToArray + toValue = Pattern.Array . fmap toValue instance ToValue a => ToValue (NonEmpty.NonEmpty a) where toValue = toValue . NonEmpty.toList instance ToValue a => ToValue (Map.Map Text.Text a) where - toValue x = Value.Object - . Object.Object - . Data.Array.listArray (0, Map.size x - 1) - . fmap (\ (k, v) -> Pair.Pair (String.String k, toValue v)) + toValue x = Pattern.Object + . fmap (\ (k, v) -> Pattern.Member (Pattern.Name k) (toValue v)) $ Map.toAscList x realFloatToValue :: RealFloat a => a -> Value.Value realFloatToValue x - | isNaN x = Value.Null $ Null.Null () - | isInfinite x = Value.Null $ Null.Null () + | isNaN x = Pattern.Null + | isInfinite x = Pattern.Null | otherwise = let isNegative = x < 0 in Value.Number diff --git a/source/library/Argo/Decode.hs b/source/library/Argo/Decode.hs --- a/source/library/Argo/Decode.hs +++ b/source/library/Argo/Decode.hs @@ -2,15 +2,12 @@ import qualified Argo.Class.FromValue as FromValue import qualified Argo.Decoder as Decoder +import qualified Argo.Json.Value as Value import qualified Argo.Result as Result -import qualified Argo.Type.Value as Value -import qualified Data.ByteString as ByteString +import qualified Argo.Vendor.ByteString as ByteString decode :: FromValue.FromValue a => ByteString.ByteString -> Result.Result a -decode = decodeWith FromValue.fromValue - -decodeWith :: (Value.Value -> Result.Result a) -> ByteString.ByteString -> Result.Result a -decodeWith f x = +decode x = case Decoder.run (Decoder.spaces *> Value.decode <* Decoder.eof) x of Result.Failure e -> Result.Failure e - Result.Success (_, y) -> f y + Result.Success (_, y) -> FromValue.fromValue y diff --git a/source/library/Argo/Decoder.hs b/source/library/Argo/Decoder.hs --- a/source/library/Argo/Decoder.hs +++ b/source/library/Argo/Decoder.hs @@ -2,10 +2,9 @@ import qualified Argo.Literal as Literal import qualified Argo.Result as Result +import qualified Argo.Vendor.ByteString as ByteString import qualified Control.Applicative as Applicative import qualified Control.Monad as Monad -import qualified Data.Array as Array -import qualified Data.ByteString as ByteString import qualified Data.Word as Word newtype Decoder a = Decoder @@ -39,19 +38,19 @@ Result.Failure _ -> run dy b1 Result.Success (b2, x) -> Result.Success (b2, x) -array :: Decoder a -> Decoder (Array.Array Int a) -array f = arrayWith f 0 [] +list :: Decoder a -> Decoder [a] +list f = listWith f [] -arrayWith :: Decoder a -> Int -> [(Int, a)] -> Decoder (Array.Array Int a) -arrayWith f n xs = do +listWith :: Decoder a -> [a] -> Decoder [a] +listWith f xs = do m <- Applicative.optional $ do - Monad.when (n /= 0) $ do + Monad.unless (null xs) $ do word8 Literal.comma spaces f case m of - Nothing -> pure $ Array.array (0, n - 1) xs - Just x -> arrayWith f (n + 1) $ (n, x) : xs + Nothing -> pure $ reverse xs + Just x -> listWith f $ x : xs byteString :: ByteString.ByteString -> Decoder () byteString x = do 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 @@ -1,11 +1,26 @@ module Argo.Encode where import qualified Argo.Class.ToValue as ToValue -import qualified Argo.Type.Value as Value -import qualified Data.ByteString.Builder as Builder +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.Value as Value +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified Data.Functor.Identity as Identity encode :: ToValue.ToValue a => a -> Builder.Builder -encode = encodeWith ToValue.toValue +encode = encodeWith $ Encoder.Spaces 0 -encodeWith :: (a -> Value.Value) -> a -> Builder.Builder -encodeWith f = Value.encode . f +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 + . flip Trans.runReaderT c + $ do + Value.encode $ ToValue.toValue x + Monad.when (Encoder.hasIndent c) + . Trans.lift + . Trans.tell + $ Builder.word8 Literal.newLine diff --git a/source/library/Argo/Encoder.hs b/source/library/Argo/Encoder.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Encoder.hs @@ -0,0 +1,57 @@ +module Argo.Encoder where + +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified Data.Functor.Identity as Identity +import qualified Data.Semigroup as Semigroup + +type Encoder = Trans.ReaderT Config (Trans.WriterT Builder.Builder Identity.Identity) + +data Config = Config + { indent :: Indent + , level :: Int + } deriving (Eq, Show) + +data Indent + = Spaces Int + | Tab + deriving (Eq, Show) + +hasIndent :: Config -> Bool +hasIndent x = case indent x of + Spaces y -> y > 0 + Tab -> True + +increaseLevel :: Config -> Config +increaseLevel x = x { level = level x + 1 } + +list :: Encoder () -> Encoder () -> Encoder () -> (a -> Encoder ()) -> [a] -> Encoder () +list l r s f xs = case xs of + [] -> do + l + r + x : ys -> do + l + c <- Trans.ask + let newLine = if hasIndent c then Builder.word8 Literal.newLine else mempty + Trans.local increaseLevel $ do + i <- Trans.asks makeIndent + Trans.lift . Trans.tell $ newLine <> i + f x + Monad.forM_ ys $ \ y -> do + s + Trans.lift . Trans.tell $ newLine <> i + f y + Trans.lift . Trans.tell $ newLine <> makeIndent c + r + +makeIndent :: Config -> Builder.Builder +makeIndent x = case indent x of + Spaces y -> if y <= 0 then mempty else + Semigroup.stimesMonoid (level x) + . Semigroup.stimes y + $ Builder.word8 Literal.space + Tab -> Semigroup.stimesMonoid (level x) + $ Builder.word8 Literal.horizontalTabulation diff --git a/source/library/Argo/Json/Array.hs b/source/library/Argo/Json/Array.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Array.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Array where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified GHC.Generics as Generics + +newtype ArrayOf value + = Array [value] + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: (value -> Encoder.Encoder ()) -> ArrayOf value -> Encoder.Encoder () +encode f (Array xs) = 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 + +decode :: Decoder.Decoder value -> Decoder.Decoder (ArrayOf value) +decode f = do + Decoder.word8 Literal.leftSquareBracket + Decoder.spaces + xs <- Decoder.list f + Decoder.word8 Literal.rightSquareBracket + Decoder.spaces + pure $ Array xs diff --git a/source/library/Argo/Json/Boolean.hs b/source/library/Argo/Json/Boolean.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Boolean.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Boolean where + +import Control.Applicative ((<|>)) + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified GHC.Generics as Generics + +newtype Boolean + = Boolean Bool + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: Boolean -> Encoder.Encoder () +encode (Boolean x) = Trans.lift + . Trans.tell + . Builder.byteString + $ if 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 + +decodeTrue :: Decoder.Decoder Boolean +decodeTrue = Boolean True <$ Decoder.byteString Literal.true <* Decoder.spaces diff --git a/source/library/Argo/Json/Member.hs b/source/library/Argo/Json/Member.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Member.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Member where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.Name as Name +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified GHC.Generics as Generics + +data MemberOf value + = Member Name.Name value + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: (value -> Encoder.Encoder ()) -> MemberOf value -> Encoder.Encoder () +encode f (Member x y) = do + Name.encode x + Trans.lift . Trans.tell $ Builder.word8 Literal.colon + config <- Trans.ask + Monad.when (Encoder.hasIndent config) + . Trans.lift + . Trans.tell + $ Builder.word8 Literal.space + f y + +decode :: Decoder.Decoder value -> Decoder.Decoder (MemberOf value) +decode g = Member + <$> Name.decode <* Decoder.word8 Literal.colon <* Decoder.spaces + <*> g diff --git a/source/library/Argo/Json/Name.hs b/source/library/Argo/Json/Name.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Name.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Name where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.String as String +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified GHC.Generics as Generics + +newtype Name + = Name String.String + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: Name -> Encoder.Encoder () +encode (Name x) = String.encode x + +decode :: Decoder.Decoder Name +decode = Name <$> String.decode diff --git a/source/library/Argo/Json/Null.hs b/source/library/Argo/Json/Null.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Null.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Null where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified GHC.Generics as Generics + +newtype Null + = Null () + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +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 diff --git a/source/library/Argo/Json/Number.hs b/source/library/Argo/Json/Number.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Number.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Number where + +import Data.Ratio ((%)) + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.ByteString as ByteString +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Applicative as Applicative +import qualified Control.Monad as Monad +import qualified Data.Bool as Bool +import qualified Data.Maybe as Maybe +import qualified Data.Ratio as Ratio +import qualified Data.Word as Word +import qualified GHC.Generics as Generics + +data Number + = Number Integer Integer + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +number :: Integer -> Integer -> Number +number x = normalize . Number x + +normalize :: Number -> Number +normalize (Number x y) = + if x == 0 + then Number 0 0 + else let (q, r) = quotRem x 10 in if r == 0 + then normalize $ Number q (y + 1) + else Number x y + +encode :: Number -> Encoder.Encoder () +encode (Number x y) = do + Trans.lift . Trans.tell $ Builder.integerDec x + Monad.when (y /= 0) + . Trans.lift + . Trans.tell + $ Builder.word8 Literal.latinSmallLetterE + <> Builder.integerDec y + +decode :: Decoder.Decoder Number +decode = do + ni <- fmap Maybe.isJust . Applicative.optional $ Decoder.word8 Literal.hyphenMinus + i <- Decoder.takeWhile1 Decoder.isDigit + Monad.when (ByteString.length i > 1 && ByteString.elemIndex Literal.digitZero i == Just 0) + $ fail "leading zero" + f <- fmap (Maybe.fromMaybe ByteString.empty) . Applicative.optional $ do + Decoder.word8 Literal.fullStop + Decoder.takeWhile1 Decoder.isDigit + (ne, e) <- fmap (Maybe.fromMaybe (False, ByteString.empty)) . Applicative.optional $ do + Monad.void + . Decoder.satisfy + $ \ x -> x == Literal.latinSmallLetterE || x == Literal.latinCapitalLetterE + ne <- fmap (== Just Literal.hyphenMinus) + . Applicative.optional + . Decoder.satisfy + $ \ x -> x == Literal.hyphenMinus || x == Literal.plusSign + e <- Decoder.takeWhile1 Decoder.isDigit + pure (ne, e) + Decoder.spaces + pure $ number + (negateIf ni $ (fromDigits i * 10 ^ ByteString.length f) + fromDigits f) + (negateIf ne (fromDigits e) - intToInteger (ByteString.length f)) + +negateIf :: Bool -> Integer -> Integer +negateIf = Bool.bool id negate + +fromDigits :: ByteString.ByteString -> Integer +fromDigits = ByteString.foldl' (\ a e -> (a * 10) + word8ToInteger (e - 0x30)) 0 + +intToInteger :: Int -> Integer +intToInteger = fromIntegral + +word8ToInteger :: Word.Word8 -> Integer +word8ToInteger = fromIntegral + +toRational :: Number -> Rational +toRational (Number x y) = + if y < 0 + then x % (10 ^ (-y)) + else fromInteger $ x * 10 ^ y + +fromRational :: Rational -> Maybe Number +fromRational r = + let + n = Ratio.numerator r + d1 = Ratio.denominator r + (t, d2) = factor 2 (0 :: Integer) d1 + (f, d3) = factor 5 (0 :: Integer) d2 + p = max t f + in if d3 == 1 + then Just $ number (n * 2 ^ (p - t) * 5 ^ (p - f)) (-p) + else Nothing + +-- factor d 0 x = (p, y) <=> x = (d ^ p) * y +factor :: (Num a, Integral b) => b -> a -> b -> (a, b) +factor d n x = + let (q, r) = quotRem x d + in if x /= 0 && r == 0 + then factor d (n + 1) q + else (n, x) diff --git a/source/library/Argo/Json/Object.hs b/source/library/Argo/Json/Object.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Object.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Object where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.Member as Member +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified GHC.Generics as Generics + +newtype ObjectOf value + = Object [Member.MemberOf value] + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: (value -> Encoder.Encoder ()) -> ObjectOf value -> Encoder.Encoder () +encode f (Object xs) = 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 + +encodeElement :: (value -> Encoder.Encoder ()) -> Int -> Member.MemberOf value -> Encoder.Encoder () +encodeElement f i x = do + Monad.when (i > 0) . Trans.lift . Trans.tell $ Builder.word8 Literal.comma + Member.encode f x + +decode :: Decoder.Decoder value -> Decoder.Decoder (ObjectOf value) +decode f = do + Decoder.word8 Literal.leftCurlyBracket + Decoder.spaces + xs <- Decoder.list $ Member.decode f + Decoder.word8 Literal.rightCurlyBracket + Decoder.spaces + pure $ Object xs diff --git a/source/library/Argo/Json/String.hs b/source/library/Argo/Json/String.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/String.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.String where + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Literal as Literal +import qualified Argo.Vendor.Builder as Builder +import qualified Argo.Vendor.ByteString as ByteString +import qualified Argo.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Text as Text +import qualified Argo.Vendor.Transformers as Trans +import qualified Control.Monad as Monad +import qualified Data.Char as Char +import qualified Data.Word as Word +import qualified GHC.Generics as Generics + +newtype String + = String Text.Text + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: Argo.Json.String.String -> Encoder.Encoder () +encode (String x) = Trans.lift + . Trans.tell + $ Builder.word8 Literal.quotationMark + <> Text.encodeUtf8BuilderEscaped encodeChar x + <> Builder.word8 Literal.quotationMark + +encodeChar :: Builder.BoundedPrim Word.Word8 +encodeChar = + Builder.condB (== Literal.quotationMark) (encodeShortEscape Literal.quotationMark) + . Builder.condB (== Literal.reverseSolidus) (encodeShortEscape Literal.reverseSolidus) + . Builder.condB (== Literal.backspace) (encodeShortEscape Literal.latinSmallLetterB) + . Builder.condB (== Literal.formFeed) (encodeShortEscape Literal.latinSmallLetterF) + . Builder.condB (== Literal.newLine) (encodeShortEscape Literal.latinSmallLetterN) + . Builder.condB (== Literal.carriageReturn) (encodeShortEscape Literal.latinSmallLetterR) + . Builder.condB (== Literal.horizontalTabulation) (encodeShortEscape Literal.latinSmallLetterT) + . Builder.condB (< Literal.space) encodeLongEscape + $ Builder.liftFixedToBounded Builder.word8F + +encodeShortEscape :: Word.Word8 -> Builder.BoundedPrim a +encodeShortEscape x = Builder.liftFixedToBounded + $ const (Literal.reverseSolidus, x) + Builder.>$< Builder.word8F + Builder.>*< Builder.word8F + +encodeLongEscape :: Builder.BoundedPrim Word.Word8 +encodeLongEscape = Builder.liftFixedToBounded + $ (\ x -> (Literal.reverseSolidus, (Literal.latinSmallLetterU, word8ToWord16 x))) + Builder.>$< Builder.word8F + Builder.>*< Builder.word8F + Builder.>*< Builder.word16HexFixed + +word8ToWord16 :: Word.Word8 -> Word.Word16 +word8ToWord16 = fromIntegral + +decode :: Decoder.Decoder Argo.Json.String.String +decode = do + Decoder.word8 Literal.quotationMark + b1 <- Decoder.get + i <- case getClose b1 0 of + Nothing -> fail "unterminated string" + Just i -> pure i + let (xs, b2) = ByteString.splitAt i b1 + Monad.when (ByteString.any (< Literal.space) xs) $ fail "unescaped control character" + Decoder.put b2 + Decoder.word8 Literal.quotationMark + Decoder.spaces + case Text.decodeUtf8' xs of + Left e -> fail $ show e + Right x -> case unescapeText x of + Nothing -> fail "invalid escape" + Just y -> pure $ String y + +findAt :: Word.Word8 -> Int -> ByteString.ByteString -> Maybe Int +findAt x i = fmap (+ i) . ByteString.elemIndex x . ByteString.drop i + +countConsecutive :: Word.Word8 -> Int -> ByteString.ByteString -> Int +countConsecutive x i = ByteString.length . ByteString.takeWhileEnd (== x) . ByteString.take i + +getClose :: ByteString.ByteString -> Int -> Maybe Int +getClose b i = do + j <- findAt Literal.quotationMark i b + let n = countConsecutive Literal.reverseSolidus j b + if even n then Just j else getClose b $ j + 1 + +unescapeText :: Text.Text -> Maybe Text.Text +unescapeText = fmap (Text.pack . combineSurrogatePairs) . unescapeString . Text.unpack + +combineSurrogatePairs :: Prelude.String -> Prelude.String +combineSurrogatePairs xs = case xs of + "" -> xs + x : y : zs | isHighSurrogate x && isLowSurrogate y -> + combineSurrogatePair x y : combineSurrogatePairs zs + x : ys -> x : combineSurrogatePairs ys + +combineSurrogatePair :: Char -> Char -> Char +combineSurrogatePair hi lo = Char.chr + $ 0x10000 + + ((Char.ord hi - 0xd800) * 0x400) + + (Char.ord lo - 0xdc00) + +isHighSurrogate :: Char -> Bool +isHighSurrogate x = '\xd800' <= x && x <= '\xdbff' + +isLowSurrogate :: Char -> Bool +isLowSurrogate x = '\xdc00' <= x && x <= '\xdfff' + +unescapeString :: Prelude.String -> Maybe Prelude.String +unescapeString xs = case xs of + "" -> pure xs + '\\' : ys -> case ys of + "" -> fail "empty escape" + x : zs -> case x of + '"' -> ('"' :) <$> unescapeString zs + '\\' -> ('\\' :) <$> unescapeString zs + '/' -> ('/' :) <$> unescapeString zs + 'b' -> ('\b' :) <$> unescapeString zs + 'f' -> ('\f' :) <$> unescapeString zs + 'n' -> ('\n' :) <$> unescapeString zs + 'r' -> ('\r' :) <$> unescapeString zs + 't' -> ('\t' :) <$> unescapeString zs + 'u' -> case zs of + a : b : c : d : es | Just y <- fromLongEscape a b c d -> + (y :) <$> unescapeString es + _ -> fail "invalid long escape" + _ -> fail "invalid short escape" + x : ys -> (x :) <$> unescapeString ys + +fromLongEscape :: Char -> Char -> Char -> Char -> Maybe Char +fromLongEscape a b c d = do + w <- fromHexadecimalDigit a + x <- fromHexadecimalDigit b + y <- fromHexadecimalDigit c + z <- fromHexadecimalDigit d + pure . Char.chr $ (0x1000 * w) + (0x100 * x) + (0x10 * y) + z + +fromHexadecimalDigit :: Char -> Maybe Int +fromHexadecimalDigit x = + if Char.isHexDigit x then Just $ Char.digitToInt x else Nothing diff --git a/source/library/Argo/Json/Value.hs b/source/library/Argo/Json/Value.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Json/Value.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} + +module Argo.Json.Value where + +import Control.Applicative ((<|>)) + +import qualified Argo.Decoder as Decoder +import qualified Argo.Encoder as Encoder +import qualified Argo.Json.Array as Array +import qualified Argo.Json.Boolean as Boolean +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.Vendor.DeepSeq as DeepSeq +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified GHC.Generics as Generics + +data Value + = Null Null.Null + | Boolean Boolean.Boolean + | Number Number.Number + | String String.String + | Array (Array.ArrayOf Value) + | Object (Object.ObjectOf Value) + deriving (Eq, Generics.Generic, TH.Lift, DeepSeq.NFData, Show) + +encode :: Value -> Encoder.Encoder () +encode x = case x of + Null y -> Null.encode y + Boolean y -> Boolean.encode y + Number y -> Number.encode y + String y -> String.encode y + Array y -> Array.encode encode y + Object y -> Object.encode encode y + +decode :: Decoder.Decoder Value +decode = + Null <$> Null.decode + <|> Boolean <$> Boolean.decode + <|> Number <$> Number.decode + <|> String <$> String.decode + <|> Array <$> Array.decode decode + <|> Object <$> Object.decode decode 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 @@ -1,6 +1,6 @@ module Argo.Literal where -import qualified Data.ByteString as ByteString +import qualified Argo.Vendor.ByteString as ByteString import qualified Data.Word as Word backspace :: Word.Word8 diff --git a/source/library/Argo/Main.hs b/source/library/Argo/Main.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Main.hs @@ -0,0 +1,81 @@ +module Argo.Main where + +import qualified Argo +import qualified Argo.Encoder as Encoder +import qualified Control.Monad as Monad +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as Builder +import qualified Data.Version as Version +import qualified Paths_argo as This +import qualified System.Console.GetOpt as Console +import qualified System.Environment as Environment +import qualified System.Exit as Exit +import qualified System.IO as IO +import qualified Text.Read as Read + +main :: IO () +main = do + name <- Environment.getProgName + arguments <- Environment.getArgs + let (flags, as, os, es) = Console.getOpt' Console.Permute options arguments + mapM_ (IO.hPutStrLn IO.stderr . mappend "unknown argument " . quote) as + mapM_ (IO.hPutStrLn IO.stderr . mappend "unknown option " . quote) os + mapM_ (IO.hPutStr IO.stderr) es + Monad.unless (null es) Exit.exitFailure + + config <- either fail pure $ Monad.foldM applyFlag defaultConfig flags + Monad.when (configHelp config) $ do + putStr $ Console.usageInfo (name <> " version " <> version) options + Exit.exitSuccess + Monad.when (configVersion config) $ do + putStrLn version + Exit.exitSuccess + + contents <- ByteString.getContents + case Argo.decode contents of + Argo.Failure e -> fail e + Argo.Success value -> Builder.hPutBuilder IO.stdout + $ Argo.encodeWith (configIndent config) (value :: Argo.Value) + +quote :: String -> String +quote x = "`" <> x <> "'" + +version :: String +version = Version.showVersion This.version + +data Flag + = FlagHelp + | FlagSpaces String + | FlagTab + | FlagVersion + deriving (Eq, Show) + +options :: [Console.OptDescr Flag] +options = + [ Console.Option ['h', '?'] ["help"] (Console.NoArg FlagHelp) "shows this help message and exits" + , Console.Option ['v'] ["version"] (Console.NoArg FlagVersion) "shows the version number and exits" + , Console.Option ['s'] ["spaces"] (Console.ReqArg FlagSpaces "INT") "pretty-prints the output using INT sapces" + , Console.Option ['t'] ["tab"] (Console.NoArg FlagTab) "pretty-prints the output using tabs" + ] + +data Config = Config + { configHelp :: Bool + , configIndent :: Encoder.Indent + , configVersion :: Bool + } deriving (Eq, Show) + +defaultConfig :: Config +defaultConfig = Config + { configHelp = False + , configIndent = Encoder.Spaces 0 + , configVersion = False + } + +applyFlag :: Config -> Flag -> Either String Config +applyFlag config flag = case flag of + FlagHelp -> pure config { configHelp = True } + FlagSpaces string -> do + int <- Read.readEither string + pure config { configIndent = Encoder.Spaces int } + FlagTab -> pure config { configIndent = Encoder.Tab } + FlagVersion -> pure config { configVersion = True } diff --git a/source/library/Argo/Pattern.hs b/source/library/Argo/Pattern.hs --- a/source/library/Argo/Pattern.hs +++ b/source/library/Argo/Pattern.hs @@ -2,16 +2,16 @@ module Argo.Pattern where -import qualified Argo.Type as Type -import qualified Argo.Type.Array as Array -import qualified Argo.Type.Boolean as Boolean -import qualified Argo.Type.Null as Null -import qualified Argo.Type.Number as Number -import qualified Argo.Type.Object as Object -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.String as String -import qualified Argo.Type.Value as Value -import qualified Data.Text as Text +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.Vendor.Text as Text pattern Null :: Value.Value pattern Null = Value.Null (Null.Null ()) @@ -26,15 +26,26 @@ pattern String :: Text.Text -> Value.Value pattern String x = Value.String (String.String x) -pattern Array :: Type.Array -> Value.Value +type Array = [Value.Value] + +pattern Array :: Array -> Value.Value pattern Array x = Value.Array (Array.Array x) -pattern Object :: Type.Object -> Value.Value +type Object = [Member] + +pattern Object :: Object -> Value.Value pattern Object x = Value.Object (Object.Object x) {-# COMPLETE Null, Boolean, Number, String, Array, Object #-} -pattern Pair :: Text.Text -> Value.Value -> Pair.Pair String.String Value.Value -pattern Pair k v = Pair.Pair (String.String k, v) +type Member = Member.MemberOf Value.Value -{-# COMPLETE Pair #-} +pattern Member :: Name.Name -> Value.Value -> Member +pattern Member k v = Member.Member k v + +{-# COMPLETE Member #-} + +pattern Name :: Text.Text -> Name.Name +pattern Name x = Name.Name (String.String x) + +{-# COMPLETE Name #-} diff --git a/source/library/Argo/QuasiQuoter.hs b/source/library/Argo/QuasiQuoter.hs --- a/source/library/Argo/QuasiQuoter.hs +++ b/source/library/Argo/QuasiQuoter.hs @@ -1,21 +1,20 @@ module Argo.QuasiQuoter where import qualified Argo.Decode as Decode +import qualified Argo.Json.Value as Value import qualified Argo.Result as Result -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Language.Haskell.TH.Quote as QQ -import qualified Language.Haskell.TH.Syntax as TH +import qualified Argo.Vendor.TemplateHaskell as TH +import qualified Argo.Vendor.Text as Text -value :: QQ.QuasiQuoter -value = QQ.QuasiQuoter - { QQ.quoteDec = const $ fail "quoteDec" - , QQ.quoteExp = quoteExp - , QQ.quotePat = const $ fail "quotePat" - , QQ.quoteType = const $ fail "quoteType" +value :: TH.QuasiQuoter +value = TH.QuasiQuoter + { TH.quoteDec = const $ fail "cannot be used as a declaration" + , TH.quoteExp = quoteExp + , TH.quotePat = const $ fail "cannot be used as a pattern" + , TH.quoteType = const $ fail "cannot be used as a type" } quoteExp :: String -> TH.Q TH.Exp -quoteExp x = case Decode.decodeWith pure . Text.encodeUtf8 $ Text.pack x of +quoteExp x = case Decode.decode . Text.encodeUtf8 $ Text.pack x of Result.Failure e -> fail e - Result.Success y -> TH.lift y + Result.Success y -> TH.lift (y :: Value.Value) diff --git a/source/library/Argo/Type.hs b/source/library/Argo/Type.hs deleted file mode 100644 --- a/source/library/Argo/Type.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Argo.Type where - -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.String as String -import qualified Argo.Type.Value as Value -import qualified Data.Array - -type Array = Data.Array.Array Int Value.Value - -type Object = Data.Array.Array Int (Pair.Pair String.String Value.Value) diff --git a/source/library/Argo/Type/Array.hs b/source/library/Argo/Type/Array.hs deleted file mode 100644 --- a/source/library/Argo/Type/Array.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Array where - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Array as Array -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -newtype Array a - = Array (Array.Array Int a) - deriving (Eq, Show) - -instance TH.Lift a => TH.Lift (Array a) where - liftTyped (Array x) = - let - bounds = Array.bounds x - elems = Array.elems x - in [|| Array $ Array.listArray bounds elems ||] - -instance DeepSeq.NFData a => DeepSeq.NFData (Array a) where - rnf (Array x) = DeepSeq.rnf x - -encode :: (a -> Builder.Builder) -> Array a -> Builder.Builder -encode f (Array x) = - Builder.word8 Literal.leftSquareBracket - <> foldMap - (\ (i, e) -> (if i /= 0 then Builder.word8 Literal.comma else mempty) - <> f e) - (Array.assocs x) - <> Builder.word8 Literal.rightSquareBracket - -decode :: Decoder.Decoder a -> Decoder.Decoder (Array a) -decode f = do - Decoder.word8 Literal.leftSquareBracket - Decoder.spaces - xs <- Decoder.array f - Decoder.word8 Literal.rightSquareBracket - Decoder.spaces - pure $ Array xs diff --git a/source/library/Argo/Type/Boolean.hs b/source/library/Argo/Type/Boolean.hs deleted file mode 100644 --- a/source/library/Argo/Type/Boolean.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Boolean where - -import Control.Applicative ((<|>)) - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.DeepSeq as DeepSeq -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -newtype Boolean - = Boolean Bool - deriving (Eq, Show) - -instance TH.Lift Boolean where - liftTyped (Boolean x) = [|| Boolean x ||] - -instance DeepSeq.NFData Boolean where - rnf (Boolean x) = DeepSeq.rnf x - -encode :: Boolean -> Builder.Builder -encode (Boolean x) = - Builder.byteString $ if 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 - -decodeTrue :: Decoder.Decoder Boolean -decodeTrue = Boolean True <$ Decoder.byteString Literal.true <* Decoder.spaces diff --git a/source/library/Argo/Type/Null.hs b/source/library/Argo/Type/Null.hs deleted file mode 100644 --- a/source/library/Argo/Type/Null.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Null where - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.DeepSeq as DeepSeq -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -newtype Null - = Null () - deriving (Eq, Show) - -instance TH.Lift Null where - liftTyped (Null x) = [|| Null x ||] - -instance DeepSeq.NFData Null where - rnf (Null x) = DeepSeq.rnf x - -encode :: Null -> Builder.Builder -encode = const $ Builder.byteString Literal.null - -decode :: Decoder.Decoder Null -decode = Null () <$ Decoder.byteString Literal.null <* Decoder.spaces diff --git a/source/library/Argo/Type/Number.hs b/source/library/Argo/Type/Number.hs deleted file mode 100644 --- a/source/library/Argo/Type/Number.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Number where - -import Data.Ratio ((%)) - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.Applicative as Applicative -import qualified Control.DeepSeq as DeepSeq -import qualified Control.Monad as Monad -import qualified Data.Bool as Bool -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as Builder -import qualified Data.Maybe as Maybe -import qualified Data.Ratio as Ratio -import qualified Data.Word as Word -import qualified Language.Haskell.TH.Syntax as TH - -data Number - = Number Integer Integer - deriving (Eq, Show) - -instance TH.Lift Number where - liftTyped (Number x y) = [|| Number x y ||] - -instance DeepSeq.NFData Number where - rnf (Number x y) = DeepSeq.deepseq x $ DeepSeq.rnf y - -number :: Integer -> Integer -> Number -number x = normalize . Number x - -normalize :: Number -> Number -normalize (Number x y) = - if x == 0 - then Number 0 0 - else let (q, r) = quotRem x 10 in if r == 0 - then normalize $ Number q (y + 1) - else Number x y - -encode :: Number -> Builder.Builder -encode (Number x y) = - if y == 0 - then Builder.integerDec x - else Builder.integerDec x - <> Builder.word8 Literal.latinSmallLetterE - <> Builder.integerDec y - -decode :: Decoder.Decoder Number -decode = do - ni <- fmap Maybe.isJust . Applicative.optional $ Decoder.word8 Literal.hyphenMinus - i <- Decoder.takeWhile1 Decoder.isDigit - Monad.when (ByteString.length i > 1 && ByteString.elemIndex Literal.digitZero i == Just 0) - $ fail "leading zero" - f <- fmap (Maybe.fromMaybe ByteString.empty) . Applicative.optional $ do - Decoder.word8 Literal.fullStop - Decoder.takeWhile1 Decoder.isDigit - (ne, e) <- fmap (Maybe.fromMaybe (False, ByteString.empty)) . Applicative.optional $ do - Monad.void - . Decoder.satisfy - $ \ x -> x == Literal.latinSmallLetterE || x == Literal.latinCapitalLetterE - ne <- fmap (== Just Literal.hyphenMinus) - . Applicative.optional - . Decoder.satisfy - $ \ x -> x == Literal.hyphenMinus || x == Literal.plusSign - e <- Decoder.takeWhile1 Decoder.isDigit - pure (ne, e) - Decoder.spaces - pure $ number - (negateIf ni $ (fromDigits i * 10 ^ ByteString.length f) + fromDigits f) - (negateIf ne (fromDigits e) - intToInteger (ByteString.length f)) - -negateIf :: Bool -> Integer -> Integer -negateIf = Bool.bool id negate - -fromDigits :: ByteString.ByteString -> Integer -fromDigits = ByteString.foldl' (\ a e -> (a * 10) + word8ToInteger (e - 0x30)) 0 - -intToInteger :: Int -> Integer -intToInteger = fromIntegral - -word8ToInteger :: Word.Word8 -> Integer -word8ToInteger = fromIntegral - -toRational :: Number -> Rational -toRational (Number x y) = - if y < 0 - then x % (10 ^ (-y)) - else fromInteger $ x * 10 ^ y - -fromRational :: Rational -> Maybe Number -fromRational r = - let - n = Ratio.numerator r - d1 = Ratio.denominator r - (t, d2) = factor 2 (0 :: Integer) d1 - (f, d3) = factor 5 (0 :: Integer) d2 - p = max t f - in if d3 == 1 - then Just $ number (n * 2 ^ (p - t) * 5 ^ (p - f)) (-p) - else Nothing - --- factor d 0 x = (p, y) <=> x = (d ^ p) * y -factor :: (Num a, Integral b) => b -> a -> b -> (a, b) -factor d n x = - let (q, r) = quotRem x d - in if x /= 0 && r == 0 - then factor d (n + 1) q - else (n, x) diff --git a/source/library/Argo/Type/Object.hs b/source/library/Argo/Type/Object.hs deleted file mode 100644 --- a/source/library/Argo/Type/Object.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Object where - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Argo.Type.Pair as Pair -import qualified Argo.Type.String as String -import qualified Control.DeepSeq as DeepSeq -import qualified Data.Array as Array -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -newtype Object a - = Object (Array.Array Int (Pair.Pair String.String a)) - deriving (Eq, Show) - -instance TH.Lift a => TH.Lift (Object a) where - liftTyped (Object x) = - let - bounds = Array.bounds x - elems = Array.elems x - in [|| Object $ Array.listArray bounds elems ||] - -instance DeepSeq.NFData a => DeepSeq.NFData (Object a) where - rnf (Object x) = DeepSeq.rnf x - -encode :: (a -> Builder.Builder) -> Object a -> Builder.Builder -encode f (Object x) = - Builder.word8 Literal.leftCurlyBracket - <> foldMap - (\ (i, e) -> (if i /= 0 then Builder.word8 Literal.comma else mempty) - <> Pair.encode String.encode f e) - (Array.assocs x) - <> Builder.word8 Literal.rightCurlyBracket - -decode :: Decoder.Decoder a -> Decoder.Decoder (Object a) -decode f = do - Decoder.word8 Literal.leftCurlyBracket - Decoder.spaces - xs <- Decoder.array $ Pair.decode String.decode f - Decoder.word8 Literal.rightCurlyBracket - Decoder.spaces - pure $ Object xs diff --git a/source/library/Argo/Type/Pair.hs b/source/library/Argo/Type/Pair.hs deleted file mode 100644 --- a/source/library/Argo/Type/Pair.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Pair where - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.DeepSeq as DeepSeq -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -newtype Pair k v - = Pair (k, v) - deriving (Eq, Show) - -instance (TH.Lift k, TH.Lift v) => TH.Lift (Pair k v) where - liftTyped (Pair x) = [|| Pair x ||] - -instance (DeepSeq.NFData k, DeepSeq.NFData v) => DeepSeq.NFData (Pair k v) where - rnf (Pair x) = DeepSeq.rnf x - -encode :: (k -> Builder.Builder) -> (v -> Builder.Builder) -> Pair k v -> Builder.Builder -encode f g (Pair (x, y)) = - f x - <> Builder.word8 Literal.colon - <> g y - -decode :: Decoder.Decoder k -> Decoder.Decoder v -> Decoder.Decoder (Pair k v) -decode f g = do - k <- f - Decoder.word8 Literal.colon - Decoder.spaces - v <- g - pure $ Pair (k, v) diff --git a/source/library/Argo/Type/String.hs b/source/library/Argo/Type/String.hs deleted file mode 100644 --- a/source/library/Argo/Type/String.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.String where - -import qualified Argo.Decoder as Decoder -import qualified Argo.Literal as Literal -import qualified Control.DeepSeq as DeepSeq -import qualified Control.Monad as Monad -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Builder.Prim as P -import qualified Data.Char as Char -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified Data.Word as Word -import qualified Language.Haskell.TH.Syntax as TH - -newtype String - = String Text.Text - deriving (Eq, Show) - -instance TH.Lift Argo.Type.String.String where - liftTyped (String x) = [|| String x ||] - -instance DeepSeq.NFData Argo.Type.String.String where - rnf (String x) = DeepSeq.rnf x - -encode :: Argo.Type.String.String -> Builder.Builder -encode (String x) = - Builder.word8 Literal.quotationMark - <> Text.encodeUtf8BuilderEscaped encodeChar x - <> Builder.word8 Literal.quotationMark - -encodeChar :: P.BoundedPrim Word.Word8 -encodeChar = - P.condB (== Literal.quotationMark) (encodeShortEscape Literal.quotationMark) - . P.condB (== Literal.reverseSolidus) (encodeShortEscape Literal.reverseSolidus) - . P.condB (== Literal.backspace) (encodeShortEscape Literal.latinSmallLetterB) - . P.condB (== Literal.formFeed) (encodeShortEscape Literal.latinSmallLetterF) - . P.condB (== Literal.newLine) (encodeShortEscape Literal.latinSmallLetterN) - . P.condB (== Literal.carriageReturn) (encodeShortEscape Literal.latinSmallLetterR) - . P.condB (== Literal.horizontalTabulation) (encodeShortEscape Literal.latinSmallLetterT) - . P.condB (< Literal.space) encodeLongEscape - $ P.liftFixedToBounded P.word8 - -encodeShortEscape :: Word.Word8 -> P.BoundedPrim a -encodeShortEscape x = P.liftFixedToBounded - $ const (Literal.reverseSolidus, x) - P.>$< P.word8 - P.>*< P.word8 - -encodeLongEscape :: P.BoundedPrim Word.Word8 -encodeLongEscape = P.liftFixedToBounded - $ (\ x -> (Literal.reverseSolidus, (Literal.latinSmallLetterU, word8ToWord16 x))) - P.>$< P.word8 - P.>*< P.word8 - P.>*< P.word16HexFixed - -word8ToWord16 :: Word.Word8 -> Word.Word16 -word8ToWord16 = fromIntegral - -decode :: Decoder.Decoder Argo.Type.String.String -decode = do - Decoder.word8 Literal.quotationMark - b1 <- Decoder.get - i <- case getClose b1 0 of - Nothing -> fail "unterminated string" - Just i -> pure i - let (xs, b2) = ByteString.splitAt i b1 - Monad.when (ByteString.any (< Literal.space) xs) $ fail "unescaped control character" - Decoder.put b2 - Decoder.word8 Literal.quotationMark - Decoder.spaces - case Text.decodeUtf8' xs of - Left e -> fail $ show e - Right x -> case unescapeText x of - Nothing -> fail "invalid escape" - Just y -> pure $ String y - -findAt :: Word.Word8 -> Int -> ByteString.ByteString -> Maybe Int -findAt x i = fmap (+ i) . ByteString.elemIndex x . ByteString.drop i - -countConsecutive :: Word.Word8 -> Int -> ByteString.ByteString -> Int -countConsecutive x i = ByteString.length . ByteString.takeWhileEnd (== x) . ByteString.take i - -getClose :: ByteString.ByteString -> Int -> Maybe Int -getClose b i = do - j <- findAt Literal.quotationMark i b - let n = countConsecutive Literal.reverseSolidus j b - if even n then Just j else getClose b $ j + 1 - -unescapeText :: Text.Text -> Maybe Text.Text -unescapeText = fmap (Text.pack . combineSurrogatePairs) . unescapeString . Text.unpack - -combineSurrogatePairs :: Prelude.String -> Prelude.String -combineSurrogatePairs xs = case xs of - "" -> xs - x : y : zs | isHighSurrogate x && isLowSurrogate y -> - combineSurrogatePair x y : combineSurrogatePairs zs - x : ys -> x : combineSurrogatePairs ys - -combineSurrogatePair :: Char -> Char -> Char -combineSurrogatePair hi lo = Char.chr - $ 0x10000 - + ((Char.ord hi - 0xd800) * 0x400) - + (Char.ord lo - 0xdc00) - -isHighSurrogate :: Char -> Bool -isHighSurrogate x = '\xd800' <= x && x <= '\xdbff' - -isLowSurrogate :: Char -> Bool -isLowSurrogate x = '\xdc00' <= x && x <= '\xdfff' - -unescapeString :: Prelude.String -> Maybe Prelude.String -unescapeString xs = case xs of - "" -> pure xs - '\\' : ys -> case ys of - "" -> fail "empty escape" - x : zs -> case x of - '"' -> ('"' :) <$> unescapeString zs - '\\' -> ('\\' :) <$> unescapeString zs - '/' -> ('/' :) <$> unescapeString zs - 'b' -> ('\b' :) <$> unescapeString zs - 'f' -> ('\f' :) <$> unescapeString zs - 'n' -> ('\n' :) <$> unescapeString zs - 'r' -> ('\r' :) <$> unescapeString zs - 't' -> ('\t' :) <$> unescapeString zs - 'u' -> case zs of - a : b : c : d : es | Just y <- fromLongEscape a b c d -> - (y :) <$> unescapeString es - _ -> fail "invalid long escape" - _ -> fail "invalid short escape" - x : ys -> (x :) <$> unescapeString ys - -fromLongEscape :: Char -> Char -> Char -> Char -> Maybe Char -fromLongEscape a b c d = do - w <- fromHexadecimalDigit a - x <- fromHexadecimalDigit b - y <- fromHexadecimalDigit c - z <- fromHexadecimalDigit d - pure . Char.chr $ (0x1000 * w) + (0x100 * x) + (0x10 * y) + z - -fromHexadecimalDigit :: Char -> Maybe Int -fromHexadecimalDigit x = - if Char.isHexDigit x then Just $ Char.digitToInt x else Nothing diff --git a/source/library/Argo/Type/Value.hs b/source/library/Argo/Type/Value.hs deleted file mode 100644 --- a/source/library/Argo/Type/Value.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE TemplateHaskellQuotes #-} - -module Argo.Type.Value where - -import Control.Applicative ((<|>)) - -import qualified Argo.Decoder as Decoder -import qualified Argo.Type.Array as Array -import qualified Argo.Type.Boolean as Boolean -import qualified Argo.Type.Null as Null -import qualified Argo.Type.Number as Number -import qualified Argo.Type.Object as Object -import qualified Argo.Type.String as String -import qualified Control.DeepSeq as DeepSeq -import qualified Data.ByteString.Builder as Builder -import qualified Language.Haskell.TH.Syntax as TH - -data Value - = Null Null.Null - | Boolean Boolean.Boolean - | Number Number.Number - | String String.String - | Array (Array.Array Value) - | Object (Object.Object Value) - deriving (Eq, Show) - -instance TH.Lift Value where - liftTyped x = case x of - Null y -> [|| Null y ||] - Boolean y -> [|| Boolean y ||] - Number y -> [|| Number y ||] - String y -> [|| String y ||] - Array y -> [|| Array y ||] - Object y -> [|| Object y ||] - -instance DeepSeq.NFData Value where - rnf x = case x of - Null y -> DeepSeq.rnf y - Boolean y -> DeepSeq.rnf y - Number y -> DeepSeq.rnf y - String y -> DeepSeq.rnf y - Array y -> DeepSeq.rnf y - Object y -> DeepSeq.rnf y - -encode :: Value -> Builder.Builder -encode x = case x of - Null y -> Null.encode y - Boolean y -> Boolean.encode y - Number y -> Number.encode y - String y -> String.encode y - Array y -> Array.encode encode y - Object y -> Object.encode encode y - -decode :: Decoder.Decoder Value -decode = - Null <$> Null.decode - <|> Boolean <$> Boolean.decode - <|> Number <$> Number.decode - <|> String <$> String.decode - <|> Array <$> Array.decode decode - <|> Object <$> Object.decode decode diff --git a/source/library/Argo/Vendor/Builder.hs b/source/library/Argo/Vendor/Builder.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/Builder.hs @@ -0,0 +1,20 @@ +module Argo.Vendor.Builder + ( Prim.BoundedPrim + , Builder.Builder + , Builder.byteString + , Prim.condB + , Builder.integerDec + , Prim.liftFixedToBounded + , Builder.word8 + , word8F + , Prim.word16HexFixed + , (Prim.>$<) + , (Prim.>*<) + ) where + +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Prim as Prim +import qualified Data.Word as Word + +word8F :: Prim.FixedPrim Word.Word8 +word8F = Prim.word8 diff --git a/source/library/Argo/Vendor/ByteString.hs b/source/library/Argo/Vendor/ByteString.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/ByteString.hs @@ -0,0 +1,20 @@ +module Argo.Vendor.ByteString + ( ByteString.ByteString + , ByteString.any + , ByteString.drop + , ByteString.dropWhile + , ByteString.elemIndex + , ByteString.empty + , ByteString.foldl' + , ByteString.length + , ByteString.null + , ByteString.pack + , ByteString.span + , ByteString.splitAt + , ByteString.stripPrefix + , ByteString.take + , ByteString.takeWhileEnd + , ByteString.uncons + ) where + +import qualified Data.ByteString as ByteString diff --git a/source/library/Argo/Vendor/DeepSeq.hs b/source/library/Argo/Vendor/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/DeepSeq.hs @@ -0,0 +1,6 @@ +module Argo.Vendor.DeepSeq + ( DeepSeq.NFData(..) + , DeepSeq.deepseq + ) where + +import qualified Control.DeepSeq as DeepSeq diff --git a/source/library/Argo/Vendor/TemplateHaskell.hs b/source/library/Argo/Vendor/TemplateHaskell.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/TemplateHaskell.hs @@ -0,0 +1,9 @@ +module Argo.Vendor.TemplateHaskell + ( TH.Exp + , TH.Lift(..) + , TH.Q + , QQ.QuasiQuoter(..) + ) where + +import qualified Language.Haskell.TH.Quote as QQ +import qualified Language.Haskell.TH.Syntax as TH diff --git a/source/library/Argo/Vendor/Text.hs b/source/library/Argo/Vendor/Text.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/Text.hs @@ -0,0 +1,20 @@ +module Argo.Vendor.Text + ( LazyText + , Text.Text + , Encoding.decodeUtf8' + , Encoding.encodeUtf8 + , Encoding.encodeUtf8BuilderEscaped + , LazyText.fromStrict + , Text.null + , Text.pack + , Text.singleton + , LazyText.toStrict + , Text.uncons + , Text.unpack + ) where + +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Encoding +import qualified Data.Text.Lazy as LazyText + +type LazyText = LazyText.Text diff --git a/source/library/Argo/Vendor/Transformers.hs b/source/library/Argo/Vendor/Transformers.hs new file mode 100644 --- /dev/null +++ b/source/library/Argo/Vendor/Transformers.hs @@ -0,0 +1,15 @@ +module Argo.Vendor.Transformers + ( ReaderT.ReaderT + , WriterT.WriterT + , ReaderT.ask + , ReaderT.asks + , WriterT.execWriterT + , Trans.lift + , ReaderT.local + , ReaderT.runReaderT + , WriterT.tell + ) where + +import qualified Control.Monad.Trans.Class as Trans +import qualified Control.Monad.Trans.Reader as ReaderT +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,15 +4,17 @@ {-# 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 Data.Array as Array 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 @@ -87,19 +89,19 @@ ] , Tasty.testGroup "Array" [ Tasty.testCase "empty" $ do - encode (Argo.Array (array [])) @?= "[]" + encode (Argo.Array []) @?= "[]" , Tasty.testCase "one element" $ do - encode (Argo.Array (array [Argo.Number 1 0])) @?= "[1]" + encode (Argo.Array [Argo.Number 1 0]) @?= "[1]" , Tasty.testCase "two elements" $ do - encode (Argo.Array (array [Argo.Number 1 0, Argo.Number 2 0])) @?= "[1,2]" + encode (Argo.Array [Argo.Number 1 0, Argo.Number 2 0]) @?= "[1,2]" ] , Tasty.testGroup "Object" [ Tasty.testCase "empty" $ do - encode (Argo.Object (array [])) @?= "{}" + encode (Argo.Object []) @?= "{}" , Tasty.testCase "one element" $ do - encode (Argo.Object (array [Argo.Pair "a" $ Argo.Number 1 0])) @?= "{\"a\":1}" + encode (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Number 1 0]) @?= "{\"a\":1}" , Tasty.testCase "two elements" $ do - encode (Argo.Object (array [Argo.Pair "a" $ Argo.Number 1 0, Argo.Pair "b" $ Argo.Number 2 0])) @?= "{\"a\":1,\"b\":2}" + encode (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Number 1 0, Argo.Member (Argo.Name "b") $ Argo.Number 2 0]) @?= "{\"a\":1,\"b\":2}" ] ] , Tasty.testGroup "decode" $ let decode = resultToMaybe . Argo.decode :: ByteString.ByteString -> Maybe Argo.Value in @@ -239,13 +241,13 @@ ] , Tasty.testGroup "Array" [ Tasty.testCase "empty" $ do - decode "[]" @?= Just (Argo.Array $ array []) + decode "[]" @?= Just (Argo.Array []) , Tasty.testCase "one element" $ do - decode "[1]" @?= Just (Argo.Array $ array [Argo.Number 1 0]) + decode "[1]" @?= Just (Argo.Array [Argo.Number 1 0]) , Tasty.testCase "two elements" $ do - decode "[1,2]" @?= Just (Argo.Array $ array [Argo.Number 1 0, Argo.Number 2 0]) + decode "[1,2]" @?= Just (Argo.Array [Argo.Number 1 0, Argo.Number 2 0]) , Tasty.testCase "nested" $ do - decode "[1,[2]]" @?= Just (Argo.Array $ array [Argo.Number 1 0, Argo.Array $ array [Argo.Number 2 0]]) + decode "[1,[2]]" @?= Just (Argo.Array [Argo.Number 1 0, Argo.Array [Argo.Number 2 0]]) , Tasty.testCase "not closed" $ do decode "[" @?= Nothing , Tasty.testCase "not opened" $ do @@ -261,13 +263,13 @@ ] , Tasty.testGroup "Object" [ Tasty.testCase "empty" $ do - decode "{}" @?= Just (Argo.Object $ array []) + decode "{}" @?= Just (Argo.Object []) , Tasty.testCase "one element" $ do - decode "{\"a\":1}" @?= Just (Argo.Object $ array [Argo.Pair "a" $ Argo.Number 1 0]) + decode "{\"a\":1}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Number 1 0]) , Tasty.testCase "two elements" $ do - decode "{\"a\":1,\"b\":2}" @?= Just (Argo.Object $ array [Argo.Pair "a" $ Argo.Number 1 0, Argo.Pair "b" $ Argo.Number 2 0]) + decode "{\"a\":1,\"b\":2}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Number 1 0, Argo.Member (Argo.Name "b") $ Argo.Number 2 0]) , Tasty.testCase "nested" $ do - decode "{\"a\":{\"b\":2}}" @?= Just (Argo.Object $ array [Argo.Pair "a" . Argo.Object $ array [Argo.Pair "b" $ Argo.Number 2 0]]) + decode "{\"a\":{\"b\":2}}" @?= Just (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Object [Argo.Member (Argo.Name "b") $ Argo.Number 2 0]]) , Tasty.testCase "not closed" $ do decode "{" @?= Nothing , Tasty.testCase "not opened" $ do @@ -338,17 +340,15 @@ , Tasty.testCase "Maybe a" $ do fromValue (Argo.Boolean False) @?= Just (Just False) , Tasty.testCase "()" $ do - fromValue (Argo.Array $ array []) @?= Just () + fromValue (Argo.Array []) @?= Just () , Tasty.testCase "(a, b)" $ do - fromValue (Argo.Array $ array [Argo.Boolean False, Argo.String "a"]) @?= Just (False, 'a') - , Tasty.testCase "Array Int a" $ do - fromValue (Argo.Array $ array []) @?= Just (array [] :: Array.Array Int Bool) + fromValue (Argo.Array [Argo.Boolean False, Argo.String "a"]) @?= Just (False, 'a') , Tasty.testCase "[a]" $ do - fromValue (Argo.Array $ array []) @?= Just ([] :: [Bool]) + fromValue (Argo.Array []) @?= Just ([] :: [Bool]) , Tasty.testCase "NonEmpty a" $ do - fromValue (Argo.Array $ array [Argo.Boolean False]) @?= Just (False :| []) + fromValue (Argo.Array [Argo.Boolean False]) @?= Just (False :| []) , Tasty.testCase "Map Text a" $ do - fromValue (Argo.Object $ array [Argo.Pair "a" $ Argo.Boolean False]) @?= Just (Map.fromList [("a" :: Text.Text, False)]) + fromValue (Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Boolean False]) @?= Just (Map.fromList [("a" :: Text.Text, False)]) ] , Tasty.testGroup "toValue" [ Tasty.testCase "Value" $ do @@ -392,17 +392,15 @@ , Tasty.testCase "Maybe a" $ do Argo.toValue (Just False) @?= Argo.Boolean False , Tasty.testCase "()" $ do - Argo.toValue () @?= Argo.Array (array []) + Argo.toValue () @?= Argo.Array [] , Tasty.testCase "(a, b)" $ do - Argo.toValue (False, 'a') @?= Argo.Array (array [Argo.Boolean False, Argo.String "a"]) - , Tasty.testCase "Array Int a" $ do - Argo.toValue (array [] :: Array.Array Int Bool) @?= Argo.Array (array []) + Argo.toValue (False, 'a') @?= Argo.Array [Argo.Boolean False, Argo.String "a"] , Tasty.testCase "[a]" $ do - Argo.toValue ([] :: [Bool]) @?= Argo.Array (array []) + Argo.toValue ([] :: [Bool]) @?= Argo.Array [] , Tasty.testCase "NonEmpty a" $ do - Argo.toValue (False :| []) @?= Argo.Array (array [Argo.Boolean False]) + Argo.toValue (False :| []) @?= Argo.Array [Argo.Boolean False] , Tasty.testCase "Map Text a" $ do - Argo.toValue (Map.fromList [("a" :: Text.Text, False)]) @?= Argo.Object (array [Argo.Pair "a" $ Argo.Boolean False]) + Argo.toValue (Map.fromList [("a" :: Text.Text, False)]) @?= Argo.Object [Argo.Member (Argo.Name "a") $ Argo.Boolean False] ] , Tasty.testGroup "quasi quoter" [ Tasty.testCase "Null" $ do @@ -414,120 +412,138 @@ , Tasty.testCase "String" $ do [Argo.value| "" |] @?= Argo.String "" , Tasty.testCase "Array" $ do - [Argo.value| [] |] @?= Argo.Array (array []) + [Argo.value| [] |] @?= Argo.Array [] , Tasty.testCase "Object" $ do - [Argo.value| {} |] @?= Argo.Object (array []) + [Argo.value| {} |] @?= Argo.Object [] ] , Tasty.testGroup "property" - [ Tasty.testProperty "decode . encode" . Tasty.forAll genValue $ \ x -> Tasty.shrinking shrinkValue x $ \ y -> - (resultToMaybe . Argo.decode . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encode y) === Just y + [ property "decode . encode" $ \ x -> + (resultToMaybe . Argo.decode . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encode x) === Just (x :: Argo.Value) + , property "decode . encodeWith" $ \ x -> + (Argo.decode . LazyByteString.toStrict . Builder.toLazyByteString $ Argo.encodeWith Argo.Tab x) === Argo.Success (x :: Argo.Value) , Tasty.testGroup "fromValue . toValue" - [ Tasty.testProperty "Value" . Tasty.forAll genValue $ \ x -> Tasty.shrinking shrinkValue x $ \ y -> - (resultToMaybe . Argo.fromValue $ Argo.toValue y) === Just y - , Tasty.testProperty "Bool" $ \ x -> + [ property "Value" $ \ x -> + (resultToMaybe . Argo.fromValue $ Argo.toValue x) === Just (x :: Argo.Value) + , property "Bool" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Bool) - , Tasty.testProperty "Char" $ \ x -> - Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Char) - , Tasty.testProperty "Int" $ \ x -> + , property "Char" $ \ x -> + Argo.fromValue (Argo.toValue x) === if '\xd800' <= x && x <= '\xdfff' + then Argo.Success '\xfffd' + else Argo.Success x + , property "Int" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Int) - , Tasty.testProperty "Int8" $ \ x -> + , property "Int8" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Int.Int8) - , Tasty.testProperty "Int16" $ \ x -> + , property "Int16" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Int.Int16) - , Tasty.testProperty "Int32" $ \ x -> + , property "Int32" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Int.Int32) - , Tasty.testProperty "Int64" $ \ x -> + , property "Int64" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Int.Int64) - , Tasty.testProperty "Word" $ \ x -> + , property "Word" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Word) - , Tasty.testProperty "Word8" $ \ x -> + , property "Word8" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Word.Word8) - , Tasty.testProperty "Word16" $ \ x -> + , property "Word16" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Word.Word16) - , Tasty.testProperty "Word32" $ \ x -> + , property "Word32" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Word.Word32) - , Tasty.testProperty "Word64" $ \ x -> + , property "Word64" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Word.Word64) - , Tasty.testProperty "Integer" $ \ x -> + , property "Integer" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Integer) - , Tasty.testProperty "Float" $ \ x -> - Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Float) - , Tasty.testProperty "Double" $ \ x -> - Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Double) - , Tasty.testProperty "String" $ \ x -> - Argo.fromValue (Argo.toValue x) === Argo.Success (x :: String) - , Tasty.testProperty "Text" $ \ x -> + , property "Float" $ \ x -> + Argo.fromValue (Argo.toValue x) === if isNaN x || isInfinite x + then Argo.Failure "expected Float but got Null (Null ())" + else Argo.Success (x :: Float) + , property "Double" $ \ x -> + Argo.fromValue (Argo.toValue x) === if isNaN x || isInfinite x + then Argo.Failure "expected Double but got Null (Null ())" + else Argo.Success (x :: Double) + , property "String" $ \ x -> + Argo.fromValue (Argo.toValue x) === Argo.Success (Text.unpack $ Text.pack x) + , property "Text" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Text.Text) - , Tasty.testProperty "LazyText" $ \ x -> + , property "LazyText" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: LazyText.Text) - , Tasty.testProperty "Maybe a" $ \ x -> + , property "Maybe a" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Maybe Bool) - , Tasty.testProperty "()" $ \ x -> + , property "()" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: ()) - , Tasty.testProperty "(a, b)" $ \ x -> + , property "(a, b)" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: (Bool, Int.Int8)) - , Tasty.testProperty "Array Int a" $ \ x -> - Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Array.Array Int Bool) - , Tasty.testProperty "[a]" $ \ x -> + , property "[a]" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: [Bool]) - , Tasty.testProperty "NonEmpty a" $ \ x -> + , property "NonEmpty a" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: NonEmpty Bool) - , Tasty.testProperty "Map Text a" $ \ x -> + , property "Map Text a" $ \ x -> Argo.fromValue (Argo.toValue x) === Argo.Success (x :: Map.Map Text.Text Bool) ] ] ] -array :: [a] -> Array.Array Int a -array xs = Array.listArray (0, length xs - 1) xs +property + :: (Show t, Tasty.Testable prop, GenValidity.GenValid t) + => Tasty.TestName + -> (t -> prop) + -> Tasty.TestTree +property n = propertyWith n GenValidity.genValid GenValidity.shrinkValid -genValue :: Tasty.Gen Argo.Value -genValue = Tasty.sized genValueSized +propertyWith + :: (Show t, Tasty.Testable prop) + => Tasty.TestName + -> Tasty.Gen t + -> (t -> [t]) + -> (t -> prop) + -> Tasty.TestTree +propertyWith n g s f = Tasty.testProperty n + . Tasty.forAll g + $ \ x -> Tasty.shrinking s x f -genValueSized :: Int -> Tasty.Gen Argo.Value -genValueSized size = let newSize = div size 3 in Tasty.oneof - [ pure Argo.Null - , Argo.Boolean <$> Tasty.arbitrary - , Argo.Number <$> Tasty.arbitrary <*> Tasty.arbitrary - , Argo.String <$> Tasty.arbitrary - , Argo.Array <$> genArray size (genValueSized newSize) - , Argo.Object <$> genArray size (Argo.Pair <$> Tasty.arbitrary <*> genValueSized newSize) - ] +instance GenValidity.Validity Argo.Name where + validate (Argo.Name x) = GenValidity.validate x -genArray :: Int -> Tasty.Gen a -> Tasty.Gen (Array.Array Int a) -genArray n = fmap (Array.listArray (0, n - 1)) . Tasty.vectorOf n +instance GenValidity.GenValid Argo.Name where + genValid = Argo.Name <$> GenValidity.genValid + shrinkValid (Argo.Name x) = Argo.Name <$> GenValidity.shrinkValid x -type Shrink a = a -> [a] +instance GenValidity.Validity Argo.Member where + validate (Argo.Member k v) = GenValidity.validate (k, v) -shrinkValue :: Shrink Argo.Value -shrinkValue x = case x of - Argo.Null -> [] - 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 <$> shrinkArray shrinkValue y - Argo.Object y -> Argo.Object <$> shrinkArray (\ (Argo.Pair k v) -> Argo.Pair <$> Tasty.shrink k <*> shrinkValue v) y +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) -shrinkArray :: Shrink a -> Shrink (Array.Array Int a) -shrinkArray = Tasty.shrinkMapBy array Array.elems . Tasty.shrinkList +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 GenValidity.GenValid Argo.Value where + genValid = Tasty.sized genValueSized + shrinkValid 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 + +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.Array <$> Tasty.vectorOf size (genValueSized newSize) + , Argo.Object <$> Tasty.vectorOf size (Argo.Member <$> GenValidity.genValid <*> 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) - -instance Tasty.Arbitrary a => Tasty.Arbitrary (Array.Array Int a) where - arbitrary = array <$> Tasty.arbitrary - shrink = Tasty.shrinkMap array Array.elems