diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /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 --- 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 @@ copyright: 2019 Obsidian Systems LLC build-type: Simple extra-source-files: README.md + ChangeLog.md library exposed-modules: Data.Aeson.GADT.TH @@ -31,6 +32,20 @@ main-is: README.lhs 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 diff --git a/src/Data/Aeson/GADT/TH.hs b/src/Data/Aeson/GADT/TH.hs --- a/src/Data/Aeson/GADT/TH.hs +++ b/src/Data/Aeson/GADT/TH.hs @@ -15,8 +15,20 @@ {-# 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 import Control.Monad.Trans.Writer @@ -26,11 +38,21 @@ 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 @@ 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 @@ 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,16 +112,27 @@ 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 @@ --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/Expectations.hs b/test/Expectations.hs new file mode 100644 --- /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 --- /dev/null +++ b/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