aeson-gadt-th 0.2.4 → 0.2.5.0
raw patch · 6 files changed
+71/−47 lines, 6 filesdep ~aesondep ~basedep ~dependent-mapPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson, base, dependent-map, dependent-sum, template-haskell, th-abstraction
API changes (from Hackage documentation)
Files
- ChangeLog.md +7/−0
- README.lhs +5/−0
- README.md +5/−0
- aeson-gadt-th.cabal +10/−9
- src/Data/Aeson/GADT/TH.hs +36/−38
- test/Test.hs +8/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for aeson-gadt-th +## 0.2.5.0++* Support for GHC 8.10+* Support for aeson 1.5.*+* Fix [#21](https://github.com/obsidiansystems/aeson-gadt-th/issues/21): deriveJSONGADT requires `toJSON` and `parseJSON` to be in scope+* Fix [#25](https://github.com/obsidiansystems/aeson-gadt-th/issues/25): Test suite does not compile (on GHC 8.10)+ ## 0.2.4 * Support for GHC 8.8
README.lhs view
@@ -1,5 +1,6 @@ aeson-gadt-th =============+[](https://haskell.org) [](https://hackage.haskell.org/package/aeson-gadt-th) [](https://matrix.hackage.haskell.org/#/package/aeson-gadt-th) [](https://github.com/obsidiansystems/aeson-gadt-th/actions) [](https://github.com/obsidiansystems/aeson-gadt-th/blob/master/LICENSE) Provides Template Haskell expressions for deriving `ToJSON` and `FromJSON` instances for GADTs. @@ -108,3 +109,7 @@ > _-> "Failed" > ] ```++***++[](https://obsidian.systems)
README.md view
@@ -1,5 +1,6 @@ aeson-gadt-th =============+[](https://haskell.org) [](https://hackage.haskell.org/package/aeson-gadt-th) [](https://matrix.hackage.haskell.org/#/package/aeson-gadt-th) [](https://github.com/obsidiansystems/aeson-gadt-th/actions) [](https://github.com/obsidiansystems/aeson-gadt-th/blob/master/LICENSE) Provides Template Haskell expressions for deriving `ToJSON` and `FromJSON` instances for GADTs. @@ -108,3 +109,7 @@ > _-> "Failed" > ] ```++***++[](https://obsidian.systems)
aeson-gadt-th.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.0+cabal-version: 1.24 name: aeson-gadt-th-version: 0.2.4+version: 0.2.5.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,7 +11,7 @@ copyright: 2019 Obsidian Systems LLC build-type: Simple tested-with:- GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || == 8.8.3+ GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 extra-source-files: README.md ChangeLog.md @@ -20,18 +20,19 @@ library exposed-modules: Data.Aeson.GADT.TH- build-depends: base >= 4.8 && < 4.14- , aeson >= 1.4 && < 1.5+ build-depends: base >= 4.8 && < 4.15+ , aeson >= 1.3 && < 1.6 , containers >= 0.5 && < 0.7- , dependent-sum >= 0.6.1 && < 0.8+ , dependent-sum >= 0.4 && < 0.8 , transformers >= 0.5 && < 0.6- , template-haskell >= 2.11.0 && < 2.16- , th-abstraction >= 0.3.1.0 && < 0.4+ , template-haskell >= 2.11.0 && < 2.17+ , th-abstraction >= 0.2.8.0 && < 0.4 , th-extras >= 0.0.0.4 && < 0.1 if impl(ghc < 8.2) build-depends: dependent-sum < 0.6.2.2 hs-source-dirs: src default-language: Haskell2010+ ghc-options: -Wall executable readme if !flag(build-readme)@@ -40,7 +41,7 @@ , aeson , dependent-sum , dependent-sum-template >= 0.1 && < 0.2- , dependent-map >= 0.3 && < 0.4+ , dependent-map >= 0.3 && < 0.5 , aeson-gadt-th default-language: Haskell2010 main-is: README.lhs
src/Data/Aeson/GADT/TH.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -32,24 +33,25 @@ ) where -import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer-import Data.Aeson-import Data.List+import Control.Monad (forM, replicateM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)+import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.List (group, intercalate, partition, sort) import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe+import Data.Set (Set) import qualified Data.Set as Set-import Data.Some (Some (..))+import Data.Some (Some(..)) import Language.Haskell.TH hiding (cxt)+import Language.Haskell.TH.Datatype (ConstructorInfo(..), applySubstitution, datatypeCons, reifyDatatype, unifyTypes) import Language.Haskell.TH.Extras (nameOfBinder)-import Data.Set (Set)-import qualified Data.Set as Set -import Language.Haskell.TH.Datatype--import System.IO (hFlush, stdout)+#if MIN_VERSION_dependent_sum(0,5,0)+#else+pattern Some :: tag a -> Some tag+pattern Some x = This x+#endif -- Do not export this type family, it must remain empty. It's used as a way to trick GHC into not unifying certain type variables. type family Skolem :: k -> k@@ -63,13 +65,13 @@ skolemize rigids t = case t of ForallT bndrs cxt t' -> ForallT bndrs cxt (skolemize (Set.difference rigids (Set.fromList (map tyVarBndrName bndrs))) t') AppT t1 t2 -> AppT (skolemize rigids t1) (skolemize rigids t2)- SigT t k -> SigT (skolemize rigids t) k+ SigT t1 k -> SigT (skolemize rigids t1) k VarT v -> if Set.member v rigids then AppT (ConT ''Skolem) (VarT v) else t InfixT t1 n t2 -> InfixT (skolemize rigids t1) n (skolemize rigids t2) UInfixT t1 n t2 -> UInfixT (skolemize rigids t1) n (skolemize rigids t2)- ParensT t -> ParensT (skolemize rigids t)+ ParensT t1 -> ParensT (skolemize rigids t1) _ -> t reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec]@@ -80,7 +82,7 @@ freeTypeVariables t = case t of ForallT bndrs _ t' -> Set.difference (freeTypeVariables t') (Set.fromList (map nameOfBinder bndrs)) AppT t1 t2 -> Set.union (freeTypeVariables t1) (freeTypeVariables t2)- SigT t _ -> freeTypeVariables t+ SigT t1 _ -> freeTypeVariables t1 VarT n -> Set.singleton n _ -> Set.empty @@ -111,9 +113,8 @@ topVars <- makeTopVars n let n' = foldl (\c v -> AppT c (VarT v)) (ConT n) topVars (matches, constraints') <- runWriterT (mapM (fmap pure . conMatchesToJSON opts topVars) cons)- m <- sequence matches let constraints = map head . group . sort $ constraints' -- This 'head' is safe because 'group' returns a list of non-empty lists- impl <- funD (mkName "toJSON")+ impl <- funD 'toJSON [ clause [] (normalB $ lamCaseE matches) [] ] return [ InstanceD Nothing constraints (AppT (ConT ''ToJSON) n') [impl] ]@@ -146,7 +147,7 @@ (matches, constraints') <- runWriterT $ mapM (conMatchesParseJSON opts topVars [|_v'|]) cons let constraints = map head . group . sort $ constraints' -- This 'head' is safe because 'group' returns a list of non-empty lists v <- newName "v"- parser <- funD (mkName "parseJSON")+ parser <- funD 'parseJSON [ clause [varP v] (normalB [e| do (tag', _v') <- parseJSON $(varE v) $(caseE [|tag' :: String|] $ map pure matches ++ [wild])@@ -167,7 +168,14 @@ base = gadtConstructorModifier opts $ nameBase name toJSONExp e = [| toJSON $(e) |] vars <- lift . forM (constructorFields c) $ \_ -> newName "x"- let body = toJSONExp $ tupE [ [| base :: String |] , tupE $ map (toJSONExp . varE) vars ]+ let body = toJSONExp $ tupE+ [ [| base :: String |]+ -- The singleton is special-cased because of+ -- https://downloads.haskell.org/ghc/8.10.1-rc1/docs/html/users_guide/8.10.1-notes.html#template-haskell+ , case vars of+ [v] -> toJSONExp $ varE v+ vs -> tupE $ map (toJSONExp . varE) vs+ ] _ <- conMatches ''ToJSON topVars lastVar c lift $ match (conP name (map varP vars)) (normalB body) [] @@ -189,8 +197,7 @@ -> ConstructorInfo -> WriterT [Type] Q (Pat, Exp) conMatches clsName topVars ixVar c = do- let mkConstraint = AppT (ConT clsName)- name = constructorName c+ let name = constructorName c types = constructorFields c (constraints, equalities') = flip partition (constructorContext c) $ \case AppT (AppT EqualityT _) _ -> False@@ -211,7 +218,7 @@ -- We filter out constraints which don't mention variables from the instance head mostly to avoid warnings, -- but a good deal more of these occur than one might expect due to the normalisation done by reifyDatatype. tellCxt cs = do- tell [c | c <- applySubstitution ixSpecialization cs ]+ tell $ applySubstitution ixSpecialization cs tellCxt constraints vars <- forM types $ \typ -> do x <- lift $ newName "x"@@ -241,25 +248,16 @@ _ -> do demandInstanceIfNecessary return (VarP x, VarE x)- let pat = TupP (map fst vars)+ -- The singleton is special-cased because of+ -- https://downloads.haskell.org/ghc/8.10.1-rc1/docs/html/users_guide/8.10.1-notes.html#template-haskell+ let pat = case vars of+ [v] -> fst v+ vs -> TupP (map fst vs) conApp = foldl AppE (ConE name) (map snd vars) return (pat, conApp) ----------------------------------------------------------------------------------------------------- --- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which--- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas--- in a type signature in the where clause).-conName :: Con -> Name-conName c = case c of- NormalC n _ -> n- RecC n _ -> n- InfixC _ n _ -> n- ForallC _ _ c' -> conName c'- GadtC [n] _ _ -> n- RecGadtC [n] _ _ -> n- _ -> error "conName: GADT constructors with multiple names not yet supported"- -- | Determine the arity of a kind. kindArity :: Kind -> Int kindArity = \case@@ -275,8 +273,8 @@ -- If the supplied 'Name' is anything other than a data or newtype, produces an error. tyConArity' :: Name -> Q ([TyVarBndr], Int) tyConArity' n = reify n >>= return . \case- TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk))- TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk))+ TyConI (DataD _ _ ts mk _ _) -> (ts, maybe 0 kindArity mk)+ TyConI (NewtypeD _ _ ts mk _ _) -> (ts, maybe 0 kindArity mk) _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " ++ show n
test/Test.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-}@@ -14,6 +16,12 @@ import Data.Aeson.GADT.TH import Expectations import Test.Hspec++#if MIN_VERSION_dependent_sum(0,5,0)+#else+pattern Some :: tag a -> Some tag+pattern Some x = This x+#endif main :: IO () main = hspec $ do