aeson-gadt-th 0.1.2.1 → 0.2.0.0

raw patch · 5 files changed

+180/−17 lines, 5 filesdep +HUnitdep +aeson-qqdep +hspecdep ~basedep ~dependent-sumPVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, aeson-qq, hspec

Dependency ranges changed: base, dependent-sum

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• aeson-gadt-th.cabal +16/−1
• src/Data/Aeson/GADT/TH.hs +53/−16
• test/Expectations.hs +39/−0
• test/Test.hs +65/−0

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

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

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

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

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