diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,5 +1,6 @@ aeson-gadt-th ============= +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/aeson-gadt-th.svg)](https://hackage.haskell.org/package/aeson-gadt-th) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/aeson-gadt-th/badge)](https://matrix.hackage.haskell.org/#/package/aeson-gadt-th) [![Github CI](https://github.com/obsidiansystems/aeson-gadt-th/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/aeson-gadt-th/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](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" > ] ``` + +*** + +[![Obsidian Systems](https://obsidian.systems/static/images/ObsidianSystemsLogo.svg)](https://obsidian.systems) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,6 @@ aeson-gadt-th ============= +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/aeson-gadt-th.svg)](https://hackage.haskell.org/package/aeson-gadt-th) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/aeson-gadt-th/badge)](https://matrix.hackage.haskell.org/#/package/aeson-gadt-th) [![Github CI](https://github.com/obsidiansystems/aeson-gadt-th/workflows/github-action/badge.svg)](https://github.com/obsidiansystems/aeson-gadt-th/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](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" > ] ``` + +*** + +[![Obsidian Systems](https://obsidian.systems/static/images/ObsidianSystemsLogo.svg)](https://obsidian.systems) 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 +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 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 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 @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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