From 733a3b010133e834c1d39aa7a5856020c27a5070 Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 16 Mar 2026 09:50:43 +0100 Subject: [PATCH 1/2] Support empty record definitions in parser Allow RRFields production to match zero or more fields, enabling empty record definitions. Fixed applicativeE to wrap empty lists in return, enabling proper JSON parsing for empty record types. Added test cases for empty records, mixed empty and filled records. Fixes #83. --- src/Data/API/Parse.y | 2 +- src/Data/API/TH.hs | 4 ++-- tests/Data/API/Test/DSL.hs | 3 +++ tests/Data/API/Test/JSON.hs | 15 +++++++++++++++ 4 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y index 9f73a3d..b28b647 100644 --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -138,7 +138,7 @@ Union RRFields :: { [(FieldName, FieldType)] } RRFields : RRFields FieldName '::' FieldType { ($2,$4) : $1 } - | FieldName '::' FieldType { [($1,$3)] } + | { [] } FieldType :: { FieldType } FieldType diff --git a/src/Data/API/TH.hs b/src/Data/API/TH.hs index e8c0ee1..fb3eb2f 100644 --- a/src/Data/API/TH.hs +++ b/src/Data/API/TH.hs @@ -29,12 +29,12 @@ import Prelude -- | Construct an idiomatic expression (an expression in an -- Applicative context), i.e. -- --- > app ke [] = ke +-- > app ke [] = pure ke -- > app ke [e1,e2,...,en] = ke <$> e1 <*> e2 ... <*> en applicativeE :: ExpQ -> [ExpQ] -> ExpQ applicativeE ke es0 = case es0 of - [] -> ke + [] -> appE (varE 'pure) ke e:es -> app' (ke `dl` e) es where app' e [] = e diff --git a/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs index c11c88e..c366f04 100644 --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -127,4 +127,7 @@ nu :: NewUnion = union | bb :: BasicBinary | j :: JSON + +er :: EmptyRecord + = record |] diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs index 88f4113..4280aca 100644 --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -20,6 +20,7 @@ import Data.API.Types import qualified Data.API.Value as Value import qualified Data.Aeson as JS +import Data.List (find) import Test.Tasty import Test.Tasty.HUnit @@ -114,11 +115,25 @@ smartConstructors = bad_time = unsafeParseUTC "2014-10-13T15:20:10Z" good_time = unsafeParseUTC "2014-10-13T15:20:13Z" +-- | Test that empty record definitions are parsed correctly +emptyRecordParsing :: [TestTree] +emptyRecordParsing = + [ testCase "empty record has no fields" $ + case findNode "EmptyRecord" example2 of + Nothing -> assertFailure "EmptyRecord not found in example2 API" + Just node -> anSpec node @?= SpRecord (SpecRecord []) + ] + where + findNode name = find (\n -> anName n == TypeName name) . concatMap thNode + thNode (ThNode n) = [n] + thNode _ = [] + jsonTests :: TestTree jsonTests = testGroup "JSON" [ testCase "Basic value decoding" basicValueDecoding , testGroup "Decoding invalid data" errorDecoding , testGroup "Smart constructors" smartConstructors + , testGroup "Empty record parsing" emptyRecordParsing , testGroup "Round-trip tests" [ testGroup "example JSON" $ map (uncurry QC.testProperty) exampleTestsJSON , testGroup "example CBOR" $ map (uncurry QC.testProperty) exampleTestsCBOR From 1808e3e599035fd7622cf43a164c5d46607c14ab Mon Sep 17 00:00:00 2001 From: Alfredo Di Napoli Date: Mon, 16 Mar 2026 10:33:41 +0100 Subject: [PATCH 2/2] Fix unused variable warnings in TH-generated code for empty records When a record has zero fields, the TH code generators for various tool instances would bind variables (e.g. lambda parameters) that were never referenced in the body. With -Wall/-Wunused-matches, GHC flags these as warnings in the generated splices. Fix by using wildcard patterns (wildP) instead of named bindings (varP) when srFields is empty, across all affected generators: - Tools/JSON.hs (ToJSON): \x -> object [] => \_ -> object [] - Tools/JSON.hs (FromJSONWithErrs): (Object x) => (Object _) - Tools/QuickCheck.hs (Arbitrary): sized (\x -> pure Con) => sized (\_ -> ...) - Tools/DeepSeq.hs (NFData): \x -> () => \_ -> () - Tools/Example.hs (Example): sized (\x -> pure Con) => sized (\_ -> ...) - Tools/Traversal.hs (traversal): \f r -> pure Con => \_ _ -> pure Con --- src/Data/API/Tools/DeepSeq.hs | 4 +++- src/Data/API/Tools/Example.hs | 4 +++- src/Data/API/Tools/JSON.hs | 9 +++++++-- src/Data/API/Tools/QuickCheck.hs | 4 +++- src/Data/API/Tools/Traversal.hs | 4 +++- 5 files changed, 19 insertions(+), 6 deletions(-) diff --git a/src/Data/API/Tools/DeepSeq.hs b/src/Data/API/Tools/DeepSeq.hs index a50fe7b..5ab14c4 100644 --- a/src/Data/API/Tools/DeepSeq.hs +++ b/src/Data/API/Tools/DeepSeq.hs @@ -31,8 +31,10 @@ gen_sr = mkTool $ \ ts (an, sr) -> do x <- newName "x" optionalInstanceD ts ''NFData [nodeRepT an] [simpleD 'rnf (bdy an sr x)] where - bdy an sr x = lamE [varP x] $ foldr f [e|()|] (srFields sr) + bdy an sr x = lamE [pat] $ foldr f [e|()|] (srFields sr) where + pat | null (srFields sr) = wildP + | otherwise = varP x f (fn,_) r = [e| rnf ($(nodeFieldE an fn) $(varE x)) `seq` $r |] gen_su :: Tool (APINode, SpecUnion) diff --git a/src/Data/API/Tools/Example.hs b/src/Data/API/Tools/Example.hs index e087675..bfeb0a9 100644 --- a/src/Data/API/Tools/Example.hs +++ b/src/Data/API/Tools/Example.hs @@ -108,7 +108,9 @@ gen_sr_ex :: Tool (APINode, SpecRecord) gen_sr_ex = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example (bdy an sr)] where bdy an sr = do x <- newName "x" - appE (varE 'QC.sized) $ lamE [varP x] $ + let pat | null (srFields sr) = wildP + | otherwise = varP x + appE (varE 'QC.sized) $ lamE [pat] $ applicativeE (nodeConE an) $ replicate (length $ srFields sr) $ [e| QC.resize ($(varE x) `div` 2) example |] diff --git a/src/Data/API/Tools/JSON.hs b/src/Data/API/Tools/JSON.hs index b1b103d..6c63c49 100644 --- a/src/Data/API/Tools/JSON.hs +++ b/src/Data/API/Tools/JSON.hs @@ -118,10 +118,13 @@ gen_sr_to = mkTool $ \ ts (an, sr) -> do x <- newName "x" optionalInstanceD ts ''ToJSON [nodeRepT an] [simpleD 'toJSON (bdy an sr x)] where - bdy an sr x = lamE [varP x] $ + bdy an sr x = lamE [pat] $ varE 'object `appE` listE [ [e| $(fieldNameE fn) .= $(nodeFieldE an fn) $(varE x) |] | (fn, _) <- srFields sr ] + where + pat | null (srFields sr) = wildP + | otherwise = varP x {- @@ -142,8 +145,10 @@ gen_sr_fm = mkTool $ \ ts (an, sr) -> do optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an] [funD 'parseJSONWithErrs [cl an sr x, clNull, cl' x]] where - cl an sr x = clause [conP 'Object [varP x]] (normalB bdy) [] + cl an sr x = clause [conP 'Object [pat]] (normalB bdy) [] where + pat | null (srFields sr) = wildP + | otherwise = varP x bdy = applicativeE (nodeConE an) $ map project (srFields sr) project (fn, ft) = [e| withDefaultField ro (fmap defaultValueAsJsValue mb_dv) $(fieldNameE fn) parseJSONWithErrs $(varE x) |] where ro = ftReadOnly ft diff --git a/src/Data/API/Tools/QuickCheck.hs b/src/Data/API/Tools/QuickCheck.hs index 2c237cb..c3de353 100644 --- a/src/Data/API/Tools/QuickCheck.hs +++ b/src/Data/API/Tools/QuickCheck.hs @@ -125,7 +125,9 @@ gen_sr_ab = mkTool $ \ ts (an, sr) -> mkArbitraryInstance ts (nodeRepT an) (bdy -- by giving an arbitrary implementation like this: -- sized (\ x -> JobSpecId <$> resize (x `div` 2) arbitrary <*> ...) bdy an sr = do x <- newName "x" - appE (varE 'QC.sized) $ lamE [varP x] $ + let pat | null (srFields sr) = wildP + | otherwise = varP x + appE (varE 'QC.sized) $ lamE [pat] $ applicativeE (nodeConE an) $ replicate (length $ srFields sr) $ [e| QC.resize ($(varE x) `div` 2) arbitrary |] diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs index eb7101f..a425230 100644 --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -112,7 +112,9 @@ traversalRecord napi targets x an sr bdy = do f <- newName "f" r <- newName "r" - lamE [varP f, varP r] $ applicativeE (nodeConE an) $ map (traverseField f r) (srFields sr) + let (patF, patR) | null (srFields sr) = (wildP, wildP) + | otherwise = (varP f, varP r) + lamE [patF, patR] $ applicativeE (nodeConE an) $ map (traverseField f r) (srFields sr) traverseField f r (fn, fty) = [e| $(traverser napi targets x (ftType fty)) $(varE f) ($(nodeFieldE an fn) $(varE r)) |]