Support empty record definitions in parser

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

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

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)

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

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

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

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

tests/Data/API/Test/DSL.hs

@@ -127,4 +127,7 @@ nu :: NewUnion
     = union
       | bb :: BasicBinary
       | j  :: JSON
+
+er :: EmptyRecord
+    = record
 |]

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