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/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)) |] 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