From 8bd66bfd0b2e7951fded58666a57ae7ca680294b Mon Sep 17 00:00:00 2001 From: Cary Robbins Date: Thu, 28 Mar 2019 11:43:33 -0500 Subject: [PATCH 1/4] Add basic test suite --- aeson-gadt-th.cabal | 14 ++++++++++++++ test/Expectations.hs | 39 +++++++++++++++++++++++++++++++++++++++ test/Test.hs | 39 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 92 insertions(+) create mode 100644 test/Expectations.hs create mode 100644 test/Test.hs diff --git a/aeson-gadt-th.cabal b/aeson-gadt-th.cabal index 21fbdea..77a35a0 100644 --- a/aeson-gadt-th.cabal +++ b/aeson-gadt-th.cabal @@ -32,6 +32,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 diff --git a/test/Expectations.hs b/test/Expectations.hs new file mode 100644 index 0000000..c786d1a --- /dev/null +++ b/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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 index 0000000..935fd0b --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,39 @@ +{-# 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)) -> ()) + +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 + +deriveJSONGADT ''Foo From 3b3be25f0836cd5de73e0153a6d11484c4a0570c Mon Sep 17 00:00:00 2001 From: Cary Robbins Date: Thu, 28 Mar 2019 13:03:06 -0500 Subject: [PATCH 2/4] Support customizing TH via options --- src/Data/Aeson/GADT/TH.hs | 59 +++++++++++++++++++++++++++++---------- test/Test.hs | 22 +++++++++++++++ 2 files changed, 66 insertions(+), 15 deletions(-) diff --git a/src/Data/Aeson/GADT/TH.hs b/src/Data/Aeson/GADT/TH.hs index 4779b44..4fe5159 100644 --- a/src/Data/Aeson/GADT/TH.hs +++ b/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,7 +81,10 @@ 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 @@ -67,19 +92,19 @@ deriveToJSONGADT n = do 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 ] @@ -87,7 +112,10 @@ conMatchesToJSON topVars c = do 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 @@ -96,7 +124,7 @@ deriveFromJSONGADT n = do 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 +190,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)) |] ] diff --git a/test/Test.hs b/test/Test.hs index 935fd0b..b69a30d 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -27,6 +27,15 @@ main = hspec $ do fromJSON [aesonQQ| ["Baz", 1.2] |] `shouldMatchPattern_` (\case Success (This (Baz 1.2)) -> ()) + 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)) -> ()) + data Foo a where Bar :: Char -> Foo Char Baz :: Float -> Foo Float @@ -36,4 +45,17 @@ 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 From 5a545a0bffbe3def4b6d1778234b5a51d533b628 Mon Sep 17 00:00:00 2001 From: Cary Robbins Date: Thu, 28 Mar 2019 15:22:47 -0500 Subject: [PATCH 3/4] Improve error reporting --- src/Data/Aeson/GADT/TH.hs | 10 +++++++++- test/Test.hs | 4 ++++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/src/Data/Aeson/GADT/TH.hs b/src/Data/Aeson/GADT/TH.hs index 4fe5159..34f177b 100644 --- a/src/Data/Aeson/GADT/TH.hs +++ b/src/Data/Aeson/GADT/TH.hs @@ -120,7 +120,15 @@ deriveFromJSONGADTWithOptions opts n = do 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 diff --git a/test/Test.hs b/test/Test.hs index b69a30d..f97e9ca 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -26,6 +26,8 @@ main = hspec $ do `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"] |] @@ -35,6 +37,8 @@ main = hspec $ do `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 From 856dede0cceb56d9a6828d7b124b60e636998d92 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 16:59:25 -0400 Subject: [PATCH 4/4] Add changelog --- ChangeLog.md | 7 +++++++ aeson-gadt-th.cabal | 3 ++- 2 files changed, 9 insertions(+), 1 deletion(-) create mode 100644 ChangeLog.md diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..e515c8b --- /dev/null +++ b/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 diff --git a/aeson-gadt-th.cabal b/aeson-gadt-th.cabal index 77a35a0..da99071 100644 --- a/aeson-gadt-th.cabal +++ b/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 for examples. @@ -11,6 +11,7 @@ maintainer: maintainer@obsidian.systems copyright: 2019 Obsidian Systems LLC build-type: Simple extra-source-files: README.md + ChangeLog.md library exposed-modules: Data.Aeson.GADT.TH