Merge branch 'carymrobbins-options' into develop

* carymrobbins-options:
  Add changelog
  Improve error reporting
  Support customizing TH via options
  Add basic test suite

ChangeLog.md

@@ -0,0 +1,7 @@
+# Revision history for aeson-gadt-th
+
+## 0.2.0.0
+
+* Add changelog
+* Add option to modify constructor tag in derived JSON
+* Add test suite

aeson-gadt-th.cabal

@@ -1,6 +1,6 @@
 cabal-version: >=2.0
 name: aeson-gadt-th
-version: 0.1.2.1
+version: 0.2.0.0
 synopsis: Derivation of Aeson instances for GADTs
 category: JSON
 description: Template Haskell for generating ToJSON and FromJSON instances for GADTs. See <https://github.com/obsidiansystems/aeson-gadt-th/blob/master/README.md README.md> for examples.
@@ -11,6 +11,7 @@ maintainer: [email protected]
 copyright: 2019 Obsidian Systems LLC
 build-type: Simple
 extra-source-files: README.md
+                    ChangeLog.md
 
 library
   exposed-modules: Data.Aeson.GADT.TH
@@ -32,6 +33,20 @@ executable readme
   ghc-options: -pgmL markdown-unlit -Wall
   build-tool-depends: markdown-unlit:markdown-unlit
 
+test-suite aeson-gadt-th-test
+  type: exitcode-stdio-1.0
+  build-depends: base
+               , aeson
+               , aeson-qq
+               , dependent-sum
+               , aeson-gadt-th
+               , hspec
+               , HUnit
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: Test.hs
+  other-modules: Expectations
+
 source-repository head
   type:     git
   location: git://github.com/obsidiansystems/aeson-gadt-th.git

src/Data/Aeson/GADT/TH.hs

@@ -15,7 +15,19 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Data.Aeson.GADT.TH (deriveJSONGADT, deriveToJSONGADT, deriveFromJSONGADT) where
+module Data.Aeson.GADT.TH
+  ( deriveJSONGADT
+  , deriveToJSONGADT
+  , deriveFromJSONGADT
+
+  , deriveJSONGADTWithOptions
+  , deriveToJSONGADTWithOptions
+  , deriveFromJSONGADTWithOptions
+
+  , JSONGADTOptions(JSONGADTOptions, gadtConstructorModifier)
+  , defaultJSONGADTOptions
+
+  ) where
 
 import Control.Monad
 import Control.Monad.Trans.Class
@@ -26,11 +38,21 @@ import Data.Maybe
 import Data.Some (Some (..))
 import Language.Haskell.TH
 
+newtype JSONGADTOptions = JSONGADTOptions
+  { gadtConstructorModifier :: String -> String }
+
+defaultJSONGADTOptions :: JSONGADTOptions
+defaultJSONGADTOptions = JSONGADTOptions
+  { gadtConstructorModifier = id }
+
 -- | Derive 'ToJSON' and 'FromJSON' instances for the named GADT
 deriveJSONGADT :: Name -> DecsQ
-deriveJSONGADT n = do
-  tj <- deriveToJSONGADT n
-  fj <- deriveFromJSONGADT n
+deriveJSONGADT = deriveJSONGADTWithOptions defaultJSONGADTOptions
+
+deriveJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
+deriveJSONGADTWithOptions opts n = do
+  tj <- deriveToJSONGADTWithOptions opts n
+  fj <- deriveFromJSONGADTWithOptions opts n
   return (tj ++ fj)
 
 decCons :: Dec -> [Con]
@@ -59,44 +81,58 @@ conArity c = case c of
   RecGadtC _ ts _ -> length ts
 
 deriveToJSONGADT :: Name -> DecsQ
-deriveToJSONGADT n = do
+deriveToJSONGADT = deriveToJSONGADTWithOptions defaultJSONGADTOptions
+
+deriveToJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
+deriveToJSONGADTWithOptions opts n = do
   x <- reify n
   let cons = case x of
        TyConI d -> decCons d
        _ -> error "undefined"
   arity <- tyConArity n
   tyVars <- replicateM arity (newName "topvar")
   let n' = foldr (\v c -> AppT c (VarT v)) (ConT n) tyVars
-  (matches, typs) <- runWriterT (mapM (fmap pure . conMatchesToJSON tyVars) cons)
+  (matches, typs) <- runWriterT (mapM (fmap pure . conMatchesToJSON opts tyVars) cons)
   let nubbedTypes = map head . group . sort $ typs -- This 'head' is safe because 'group' returns a list of non-empty lists
       constraints = map (AppT (ConT ''ToJSON)) nubbedTypes
   impl <- funD (mkName "toJSON")
     [ clause [] (normalB $ lamCaseE matches) []
     ]
   return [ InstanceD Nothing constraints (AppT (ConT ''ToJSON) n') [impl] ]
-  
+
 -- | Implementation of 'toJSON'
-conMatchesToJSON :: [Name] -> Con -> WriterT [Type] Q Match
-conMatchesToJSON topVars c = do
+conMatchesToJSON :: JSONGADTOptions -> [Name] -> Con -> WriterT [Type] Q Match
+conMatchesToJSON opts topVars c = do
   let name = conName c
-      base = nameBase name
+      base = gadtConstructorModifier opts $ nameBase name
       toJSONExp e = [| toJSON $(e) |]
   vars <- lift $ replicateM (conArity c) (newName "x")
   let body = toJSONExp $ tupE [ [| base :: String |] , tupE $ map (toJSONExp . varE) vars ]
   _ <- conMatches topVars c
   lift $ match (conP name (map varP vars)) (normalB body) []
 
 deriveFromJSONGADT :: Name -> DecsQ
-deriveFromJSONGADT n = do
+deriveFromJSONGADT = deriveFromJSONGADTWithOptions defaultJSONGADTOptions
+
+deriveFromJSONGADTWithOptions :: JSONGADTOptions -> Name -> DecsQ
+deriveFromJSONGADTWithOptions opts n = do
   x <- reify n
   let cons = case x of
        TyConI d -> decCons d
        _ -> error "undefined"
-  let wild = match wildP (normalB [|fail "deriveFromJSONGADT: Supposedly-complete GADT pattern match fell through in generated code. This shouldn't happen."|]) []
+  let allConNames =
+        intercalate ", " $
+          map (gadtConstructorModifier opts . nameBase . conName) cons
+  wildName <- newName "s"
+  let wild = match (varP wildName) (normalB [e|
+        fail $
+          "Expected tag to be one of [" <> allConNames <> "] but got: "
+          <> $(varE wildName)
+        |]) []
   arity <- tyConArity n
   tyVars <- replicateM (arity - 1) (newName "topvar")
   let n' = foldr (\v c -> AppT c (VarT v)) (ConT n) tyVars
-  (matches, typs) <- runWriterT $ mapM (conMatchesParseJSON tyVars [|_v'|]) cons
+  (matches, typs) <- runWriterT $ mapM (conMatchesParseJSON opts tyVars [|_v'|]) cons
   let nubbedTypes = map head . group . sort $ typs -- This 'head' is safe because 'group' returns a list of non-empty lists
       constraints = map (AppT (ConT ''FromJSON)) nubbedTypes
   v <- newName "v"
@@ -162,10 +198,11 @@ conMatches topVars c = do
     --NormalC _ tys -> forTypes (map snd tys) -- nb: If this comes up in a GADT-style declaration, please open an issue on the github repo with an example.
     _ -> error "conMatches: Unmatched constructor type"
 
-conMatchesParseJSON :: [Name] -> ExpQ -> Con -> WriterT [Type] Q Match
-conMatchesParseJSON topVars e c = do
+-- | Implementation of 'parseJSON'
+conMatchesParseJSON :: JSONGADTOptions -> [Name] -> ExpQ -> Con -> WriterT [Type] Q Match
+conMatchesParseJSON opts topVars e c = do
   (pat, conApp) <- conMatches topVars c
-  let match' = match (litP (StringL (nameBase (conName c))))
+  let match' = match (litP (StringL (gadtConstructorModifier opts $ nameBase (conName c))))
       body = doE [ bindS (return pat) [| parseJSON $e |]
                  , noBindS [| return (This $(return conApp)) |]
                  ]

test/Expectations.hs

@@ -0,0 +1,39 @@
+-- | Some useful helper expectations for use with Hspec.
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Expectations where
+
+import Control.Exception (PatternMatchFail, evaluate, throwIO, try)
+import Data.Maybe
+import GHC.Stack (HasCallStack, callStack, getCallStack, SrcLoc)
+import Test.Hspec
+import qualified Test.HUnit.Lang as HUnit
+
+-- | Assert that a pattern match succeeds; may require -fno-warn-incomplete-patterns
+expectPattern :: (HasCallStack, Show a) => (a -> b) -> a -> IO b
+expectPattern f a =
+  try (evaluate $ f a) >>= \case
+    Right b -> pure b
+    Left (e :: PatternMatchFail) ->
+      throwHUnit $ "Pattern match failed, value was: " <> show a
+
+-- | Same as 'expectPattern' but with its arguments flipped.
+shouldMatchPattern :: (HasCallStack, Show a) => a -> (a -> b) -> IO b
+shouldMatchPattern = flip expectPattern
+
+-- | Same as 'shouldMatchPattern' but with the return type specialized as unit.
+-- Useful for pattern matching on GADTs.
+shouldMatchPattern_ :: (HasCallStack, Show a) => a -> (a -> ()) -> IO ()
+shouldMatchPattern_ = shouldMatchPattern
+
+-- | Obtain the source location given a reverse call stack index.
+callStackLoc :: (HasCallStack) => Int -> Maybe SrcLoc
+callStackLoc index = fmap snd $ listToMaybe $ drop index $ reverse $ getCallStack callStack
+
+-- | Throw an test failed exception, defaulting the source location to the caller's caller.
+throwHUnit :: (HasCallStack) => String -> IO a
+throwHUnit = throwHUnitWithLoc 0
+
+-- | Throw a test failure exception with source location determined by the supplied reverse call stack index.
+throwHUnitWithLoc :: (HasCallStack) => Int -> String -> IO a
+throwHUnitWithLoc index msg = throwIO $ HUnit.HUnitFailure (callStackLoc index) $ HUnit.Reason msg

test/Test.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Data.GADT.Show
+import Data.Some
+import Data.Aeson
+import Data.Aeson.QQ
+import Data.Aeson.GADT.TH
+import Expectations
+import Test.Hspec
+
+main :: IO ()
+main = hspec $ do
+  describe "aeson-gadt-th" $ do
+    it "should generate an expected ToJSON instance" $ do
+      toJSON (Bar 'a') `shouldBe` [aesonQQ| ["Bar", "a"] |]
+      toJSON (Baz 1.2) `shouldBe` [aesonQQ| ["Baz", 1.2] |]
+    it "should generate an expected FromJSON Some instance" $ do
+      fromJSON [aesonQQ| ["Bar", "a"] |]
+        `shouldMatchPattern_` (\case Success (This (Bar 'a')) -> ())
+      fromJSON [aesonQQ| ["Baz", 1.2] |]
+        `shouldMatchPattern_` (\case Success (This (Baz 1.2)) -> ())
+      (fromJSON [aesonQQ| ["bad", "input"] |] :: Result (Some Foo))
+        `shouldMatchPattern_` (\case Error "Expected tag to be one of [Bar, Baz] but got: bad" -> ())
+
+    it "should generate an expected ToJSON instance with options" $ do
+      toJSON (Spam'Eggs 'a') `shouldBe` [aesonQQ| ["Eggs", "a"] |]
+      toJSON (Spam'Life 1.2) `shouldBe` [aesonQQ| ["Life", 1.2] |]
+    it "should generate an expected FromJSON Some instance with options" $ do
+      fromJSON [aesonQQ| ["Eggs", "a"] |]
+        `shouldMatchPattern_` (\case Success (This (Spam'Eggs 'a')) -> ())
+      fromJSON [aesonQQ| ["Life", 1.2] |]
+        `shouldMatchPattern_` (\case Success (This (Spam'Life 1.2)) -> ())
+      (fromJSON [aesonQQ| ["bad", "input"] |] :: Result (Some Spam))
+        `shouldMatchPattern_` (\case Error "Expected tag to be one of [Eggs, Life] but got: bad" -> ())
+
+data Foo a where
+  Bar :: Char -> Foo Char
+  Baz :: Float -> Foo Float
+
+deriving instance Show (Foo a)
+deriving instance Eq (Foo a)
+
+instance GShow Foo where gshowsPrec = showsPrec
+
+data Spam a where
+  Spam'Eggs :: Char -> Spam Char
+  Spam'Life :: Float -> Spam Float
+
+deriving instance Show (Spam a)
+deriving instance Eq (Spam a)
+
+instance GShow Spam where gshowsPrec = showsPrec
+
+deriveJSONGADT ''Foo
+
+deriveJSONGADTWithOptions
+  (JSONGADTOptions { gadtConstructorModifier = drop 5 })
+  ''Spam