hydra-0.15.0: src/main/haskell/Hydra/Sources/Test/Json/Parser.hs
module Hydra.Sources.Test.Json.Parser where
-- Standard imports for shallow DSL tests
import Hydra.Kernel
import Hydra.Dsl.Meta.Testing as Testing
import Hydra.Dsl.Meta.Terms as Terms
import Hydra.Sources.Kernel.Types.All
import qualified Hydra.Dsl.Meta.Core as Core
import qualified Hydra.Dsl.Meta.Phantoms as Phantoms
import qualified Hydra.Dsl.Meta.Types as T
import qualified Hydra.Sources.Test.TestGraph as TestGraph
import qualified Hydra.Sources.Test.TestTerms as TestTerms
import qualified Hydra.Sources.Test.TestTypes as TestTypes
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Scientific as Sci
-- Additional imports specific to this module
import Hydra.Json.Model (Value)
import Hydra.Parsing (ParseResult)
import Hydra.Testing
import Hydra.Sources.Libraries
import qualified Hydra.Dsl.Json.Model as Json
import qualified Hydra.Dsl.Parsing as Parsing
import qualified Hydra.Sources.Kernel.Terms.Parsers as Parsers
import qualified Hydra.Sources.Json.Parser as JsonParser
import qualified Hydra.Sources.Json.Writer as JsonWriter
import qualified Hydra.Dsl.Meta.Lib.Strings as Strings
ns :: Namespace
ns = Namespace "hydra.test.json.parser"
module_ :: Module
module_ = Module {
moduleNamespace = ns,
moduleDefinitions = definitions,
moduleTermDependencies = [Namespace "hydra.parsers", Namespace "hydra.json.parser", Namespace "hydra.json.writer",
Namespace "hydra.lib.strings", Namespace "hydra.parsing"],
moduleTypeDependencies = kernelTypesNamespaces,
moduleDescription = (Just "Test cases for JSON parsing")}
where
definitions = [
Phantoms.toDefinition allTests]
define :: String -> TTerm a -> TTermDefinition a
define = definitionInModule module_
allTests :: TTermDefinition TestGroup
allTests = define "allTests" $
Phantoms.doc "Test cases for JSON parsing" $
supergroup "JSON parsing" [
primitivesGroup,
decimalPrecisionGroup,
stringsGroup,
arraysGroup,
objectsGroup,
nestedGroup,
whitespaceGroup]
-- Show a ParseResult Value as a string for universal test comparison.
-- Uses Phantoms.cases to pattern-match the ParseResult union.
showParseResult :: TTerm (ParseResult Value) -> TTerm String
showParseResult pr = Phantoms.cases _ParseResult pr Nothing [
_ParseResult_success Phantoms.>>: Phantoms.lambda "ps" (Strings.cat2
(Phantoms.string "success(")
(Strings.cat2
(JsonWriter.printJson Phantoms.@@ Parsing.parseSuccessValue (Phantoms.var "ps"))
(Strings.cat2 (Phantoms.string ", ")
(Strings.cat2 (Parsing.parseSuccessRemainder (Phantoms.var "ps")) (Phantoms.string ")"))))),
_ParseResult_failure Phantoms.>>: Phantoms.lambda "pe" (Strings.cat2
(Phantoms.string "failure(")
(Strings.cat2 (Phantoms.string "parse error") (Phantoms.string ")")))]
-- Helper for creating successful JSON parser test cases as UniversalTestCase
parserCase :: String -> String -> TTerm Value -> TTerm TestCaseWithMetadata
parserCase name input expectedValue = universalCase name
(showParseResult (Parsers.runParser Phantoms.@@ JsonParser.jsonValue Phantoms.@@ Phantoms.string input))
(showParseResult (Parsing.parseResultSuccess $ Parsing.parseSuccess expectedValue (Phantoms.string "")))
primitivesGroup :: TTerm TestGroup
primitivesGroup = subgroup "primitives" [
-- Null
parserCase "null" "null" Json.valueNull,
-- Booleans
parserCase "true" "true" (Json.valueBoolean $ Phantoms.boolean True),
parserCase "false" "false" (Json.valueBoolean $ Phantoms.boolean False),
-- Numbers - integers
parserCase "zero" "0" (Json.valueNumber $ Phantoms.decimal 0.0),
parserCase "positive integer" "42" (Json.valueNumber $ Phantoms.decimal 42.0),
parserCase "negative integer" "-17" (Json.valueNumber $ Phantoms.decimal (-17.0)),
parserCase "large integer" "1000000" (Json.valueNumber $ Phantoms.decimal 1000000.0),
-- Numbers - decimals
parserCase "decimal" "3.14" (Json.valueNumber $ Phantoms.decimal 3.14),
parserCase "negative decimal" "-2.5" (Json.valueNumber $ Phantoms.decimal (-2.5)),
-- Numbers - scientific notation
parserCase "scientific notation" "1e3" (Json.valueNumber $ Phantoms.decimal 1000.0),
parserCase "scientific with decimal" "1.5e2" (Json.valueNumber $ Phantoms.decimal 150.0),
parserCase "negative exponent" "1e-2" (Json.valueNumber $ Phantoms.decimal 0.01)]
-- | Parser precision tests: inputs that exercise the writer's lexical output choices.
-- We do not test "more digits than Double" cases here because several Hydra hosts emit
-- decimal literals as host-native Double, losing precision before the test can exercise
-- the parser. The decimal type coder (separate test) preserves full precision end-to-end.
decimalPrecisionGroup :: TTerm TestGroup
decimalPrecisionGroup = subgroup "decimal precision" [
parserCase "tiny exponent"
"1e-20"
(Json.valueNumber $ Phantoms.decimal (Sci.scientific 1 (-20))),
parserCase "huge exponent"
"1e20"
(Json.valueNumber $ Phantoms.decimal (Sci.scientific 1 20))]
stringsGroup :: TTerm TestGroup
stringsGroup = subgroup "strings" [
-- Basic strings
parserCase "empty string" "\"\"" (Json.valueString $ Phantoms.string ""),
parserCase "simple string" "\"hello\"" (Json.valueString $ Phantoms.string "hello"),
parserCase "string with spaces" "\"hello world\"" (Json.valueString $ Phantoms.string "hello world"),
-- Escape sequences
parserCase "escaped double quote" "\"say \\\"hi\\\"\"" (Json.valueString $ Phantoms.string "say \"hi\""),
parserCase "escaped backslash" "\"path\\\\to\\\\file\"" (Json.valueString $ Phantoms.string "path\\to\\file"),
parserCase "escaped newline" "\"line1\\nline2\"" (Json.valueString $ Phantoms.string "line1\nline2"),
parserCase "escaped carriage return" "\"line1\\rline2\"" (Json.valueString $ Phantoms.string "line1\rline2"),
parserCase "escaped tab" "\"col1\\tcol2\"" (Json.valueString $ Phantoms.string "col1\tcol2"),
parserCase "escaped forward slash" "\"a\\/b\"" (Json.valueString $ Phantoms.string "a/b")]
arraysGroup :: TTerm TestGroup
arraysGroup = subgroup "arrays" [
-- Empty and single element
parserCase "empty array" "[]" (Json.valueArray $ Phantoms.list ([] :: [TTerm Value])),
parserCase "single element" "[1]" (Json.valueArray $ Phantoms.list [Json.valueNumber $ Phantoms.decimal 1.0]),
-- Multiple elements
parserCase "multiple numbers" "[1, 2, 3]" (Json.valueArray $ Phantoms.list [
Json.valueNumber $ Phantoms.decimal 1.0,
Json.valueNumber $ Phantoms.decimal 2.0,
Json.valueNumber $ Phantoms.decimal 3.0]),
parserCase "multiple strings" "[\"a\", \"b\"]" (Json.valueArray $ Phantoms.list [
Json.valueString $ Phantoms.string "a",
Json.valueString $ Phantoms.string "b"]),
-- Mixed types
parserCase "mixed types" "[1, \"two\", true, null]" (Json.valueArray $ Phantoms.list [
Json.valueNumber $ Phantoms.decimal 1.0,
Json.valueString $ Phantoms.string "two",
Json.valueBoolean $ Phantoms.boolean True,
Json.valueNull])]
objectsGroup :: TTerm TestGroup
objectsGroup = subgroup "objects" [
-- Empty and single key
parserCase "empty object" "{}" (Json.valueObject $ Phantoms.map M.empty),
parserCase "single key-value" "{\"name\": \"Alice\"}" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "name", Json.valueString $ Phantoms.string "Alice")]),
-- Multiple keys
parserCase "multiple keys" "{\"a\": 1, \"b\": 2}" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "a", Json.valueNumber $ Phantoms.decimal 1.0),
(Phantoms.string "b", Json.valueNumber $ Phantoms.decimal 2.0)]),
-- Mixed value types
parserCase "mixed value types" "{\"active\": true, \"count\": 42, \"name\": \"test\"}" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "count", Json.valueNumber $ Phantoms.decimal 42.0),
(Phantoms.string "name", Json.valueString $ Phantoms.string "test"),
(Phantoms.string "active", Json.valueBoolean $ Phantoms.boolean True)])]
nestedGroup :: TTerm TestGroup
nestedGroup = subgroup "nested structures" [
-- Array of arrays
parserCase "nested arrays" "[[1, 2], [3, 4]]" (Json.valueArray $ Phantoms.list [
Json.valueArray $ Phantoms.list [Json.valueNumber $ Phantoms.decimal 1.0, Json.valueNumber $ Phantoms.decimal 2.0],
Json.valueArray $ Phantoms.list [Json.valueNumber $ Phantoms.decimal 3.0, Json.valueNumber $ Phantoms.decimal 4.0]]),
-- Object with array
parserCase "object with array" "{\"items\": [1, 2]}" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "items", Json.valueArray $ Phantoms.list [
Json.valueNumber $ Phantoms.decimal 1.0,
Json.valueNumber $ Phantoms.decimal 2.0])]),
-- Array of objects
parserCase "array of objects" "[{\"id\": 1}, {\"id\": 2}]" (Json.valueArray $ Phantoms.list [
Json.valueObject $ Phantoms.map $ M.singleton (Phantoms.string "id") (Json.valueNumber $ Phantoms.decimal 1.0),
Json.valueObject $ Phantoms.map $ M.singleton (Phantoms.string "id") (Json.valueNumber $ Phantoms.decimal 2.0)]),
-- Nested object
parserCase "nested object" "{\"user\": {\"name\": \"Bob\"}}" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "user", Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "name", Json.valueString $ Phantoms.string "Bob")])])]
whitespaceGroup :: TTerm TestGroup
whitespaceGroup = subgroup "whitespace handling" [
-- Trailing whitespace (leading whitespace is not stripped by the parser)
parserCase "trailing whitespace" "null " Json.valueNull,
-- Whitespace in arrays
parserCase "array with whitespace" "[ 1 , 2 , 3 ]" (Json.valueArray $ Phantoms.list [
Json.valueNumber $ Phantoms.decimal 1.0,
Json.valueNumber $ Phantoms.decimal 2.0,
Json.valueNumber $ Phantoms.decimal 3.0]),
-- Whitespace in objects
parserCase "object with whitespace" "{ \"a\" : 1 }" (Json.valueObject $ Phantoms.map $ M.fromList [
(Phantoms.string "a", Json.valueNumber $ Phantoms.decimal 1.0)]),
-- Newlines
parserCase "multiline array" "[\n 1,\n 2\n]" (Json.valueArray $ Phantoms.list [
Json.valueNumber $ Phantoms.decimal 1.0,
Json.valueNumber $ Phantoms.decimal 2.0])]