dependent-sum-template 0.1.2.0 → 0.2.0.0
raw patch · 7 files changed
+179/−161 lines, 7 filesdep ~template-haskell
Dependency ranges changed: template-haskell
Files
- ChangeLog.md +6/−0
- dependent-sum-template.cabal +8/−8
- src/Data/Dependent/Sum/TH/Internal.hs +0/−128
- src/Data/GADT/Compare/TH.hs +14/−9
- src/Data/GADT/Show/TH.hs +6/−14
- src/Data/GADT/TH/Internal.hs +143/−0
- test/test.hs +2/−2
ChangeLog.md view
@@ -1,5 +1,11 @@ # Revision history for dependent-sum-template +## 0.2.0.0 - 2023-08-01++* Recover compatibility with template-haskell 2.18, which was lost in 0.1.2.0+* deriveGShow will generate code that uses Show instances for every argument to a constructor, apart from those of the type that it is generating an instance for.+* Drop support for GHC 9.2 and 9.4 due to [a bug in reifyInstances](https://gitlab.haskell.org/ghc/ghc/-/issues/23743)+ ## 0.1.2.0 - 2023-07-11 * Rework a lot of the logic using th-abstraction to get structural information about data types and to
dependent-sum-template.cabal view
@@ -1,5 +1,5 @@ name: dependent-sum-template-version: 0.1.2.0+version: 0.2.0.0 stability: experimental cabal-version: >= 1.10@@ -14,12 +14,12 @@ synopsis: Template Haskell code to generate instances of classes in some package description: Template Haskell code to generate instances of classes in some package, such as 'GEq' and 'GCompare'. -tested-with: GHC == 8.0.2,- GHC == 8.2.2,- GHC == 8.4.4,+tested-with: GHC == 8.4.4, GHC == 8.6.5,- GHC == 8.8.3,- GHC == 9.0.1+ GHC == 8.8.4,+ GHC == 8.10.7,+ GHC == 9.0.2,+ GHC == 9.6.1 extra-source-files: ChangeLog.md , ReadMe.md@@ -35,13 +35,13 @@ default-language: Haskell2010 exposed-modules: Data.GADT.Compare.TH Data.GADT.Show.TH- other-modules: Data.Dependent.Sum.TH.Internal+ other-modules: Data.GADT.TH.Internal Data.GADT.Compare.Monad build-depends: base >= 3 && <5, some >= 1.0.1 && < 1.1, containers >= 0.5.9.2, mtl,- template-haskell,+ template-haskell >= 2.11 && < 2.21, th-abstraction >= 0.4 test-suite test
− src/Data/Dependent/Sum/TH/Internal.hs
@@ -1,128 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}---- | Shared functions for dependent-sum-template-module Data.Dependent.Sum.TH.Internal where--import Control.Monad-import Control.Monad.Writer-import Data.List (foldl', drop)-import Data.Maybe-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Map.Merge.Lazy as Map-import Data.Set (Set)-import qualified Data.Set as Set-import Language.Haskell.TH-import Language.Haskell.TH.Datatype-import Language.Haskell.TH.Datatype.TyVarBndr--classHeadToParams :: Type -> (Name, [Type])-classHeadToParams t = (h, reverse reversedParams)- where- (h, reversedParams) = go t- go :: Type -> (Name, [Type])- go t = case t of- AppT f x ->- let (h, reversedParams) = classHeadToParams f- in (h, x : reversedParams)- _ -> (headOfType t, [])---- 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--skolemize :: Set Name -> Type -> Type-skolemize rigids t = case t of- ForallT bndrs cxt t' -> ForallT bndrs cxt (skolemize (Set.difference rigids (Set.fromList (map tvName bndrs))) t')- AppT t1 t2 -> AppT (skolemize rigids t1) (skolemize rigids t2)- SigT t k -> SigT (skolemize rigids t) 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)- _ -> t--reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec]-reifyInstancesWithRigids rigids cls tys = reifyInstances cls (map (skolemize rigids) tys)---- | Determine the type variables which occur freely in a type.-freeTypeVariables :: Type -> Set Name-freeTypeVariables t = case t of- ForallT bndrs _ t' -> Set.difference (freeTypeVariables t') (Set.fromList (map tvName bndrs))- AppT t1 t2 -> Set.union (freeTypeVariables t1) (freeTypeVariables t2)- SigT t _ -> freeTypeVariables t- VarT n -> Set.singleton n- _ -> Set.empty--subst :: Map Name Type -> Type -> Type-subst s = f- where- f = \case- ForallT bndrs cxt t ->- let s' = Map.difference s (Map.fromList [(k,()) | k <- map tvName bndrs])- in ForallT bndrs cxt (subst s' t)- AppT t t' -> AppT (f t) (f t')- SigT t k -> SigT (f t) k- VarT n -> case Map.lookup n s of- Just t -> t- Nothing -> VarT n- InfixT t x t' -> InfixT (f t) x (f t')- UInfixT t x t' -> UInfixT (f t) x (f t')- x -> x---- Invoke the deriver for the given class instance. We assume that the type--- we're deriving for is always the first typeclass parameter, if there are--- multiple.-deriveForDec- :: Name- -> (DatatypeInfo -> WriterT [Type] Q Dec)- -> Dec- -> Q [Dec]-deriveForDec className f (InstanceD overlaps cxt instanceHead decs) = do- let (givenClassName, firstParam : _) = classHeadToParams instanceHead- when (givenClassName /= className) $- fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName- let dataTypeName = headOfType firstParam- dataTypeInfo <- reifyDatatype dataTypeName- let instTypes = datatypeInstTypes dataTypeInfo- paramVars = Set.unions [freeTypeVariables t | t <- instTypes]- instTypes' = case reverse instTypes of- [] -> fail "deriveGEq: Not enough type parameters"- (_:xs) -> reverse xs- generatedInstanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes')- unifiedTypes <- unifyTypes [generatedInstanceHead, instanceHead]- let- newInstanceHead = applySubstitution unifiedTypes instanceHead- newContext = applySubstitution unifiedTypes cxt- -- We are not using the generated context that we collect from f, instead- -- relying on a correct instance head from the user- (dec, _) <- runWriterT $ f dataTypeInfo- return [InstanceD overlaps newContext newInstanceHead [dec]]-deriveForDec className f dataDec = do- dataTypeInfo <- normalizeDec dataDec- let instTypes = datatypeInstTypes dataTypeInfo- paramVars = Set.unions [freeTypeVariables t | t <- instTypes]- instTypes' = case reverse instTypes of- [] -> fail "deriveGEq: Not enough type parameters"- (_:xs) -> reverse xs- instanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes')- (dec, cxt') <- runWriterT (f dataTypeInfo)- return [InstanceD Nothing (datatypeContext dataTypeInfo ++ cxt') instanceHead [dec]]--headOfType :: Type -> Name-headOfType = \case- ForallT _ _ ty -> headOfType ty- VarT name -> name- ConT name -> name- TupleT n -> tupleTypeName n- ArrowT -> ''(->)- ListT -> ''[]- AppT t _ -> headOfType t
src/Data/GADT/Compare/TH.hs view
@@ -14,7 +14,7 @@ import Control.Monad import Control.Monad.Writer-import Data.Dependent.Sum.TH.Internal+import Data.GADT.TH.Internal import Data.Functor.Identity import Data.GADT.Compare import Data.GADT.Compare.Monad@@ -85,10 +85,12 @@ _ -> lift $ noBindS [| guard ($(varE l) == $(varE r)) |] ret <- lift $ noBindS [| return Refl |] - return $ Clause- [ ConP conName (map VarP lArgNames)- , ConP conName (map VarP rArgNames) ]- ( NormalB (doUnqualifiedE (stmts ++ [ret])))+ pats <- lift $ sequence+ [ conP conName (map varP lArgNames)+ , conP conName (map varP rArgNames)+ ]+ pure $ Clause pats+ (NormalB (doUnqualifiedE (stmts ++ [ret]))) [] class DeriveGCompare t where@@ -150,10 +152,13 @@ ret <- lift $ noBindS [| return GEQ |] - let main = Clause- [ ConP conName (map VarP lArgNames)- , ConP conName (map VarP rArgNames) ]- ( NormalB (AppE (VarE 'runGComparing) (doUnqualifiedE (stmts ++ [ret]))))++ pats <- lift $ sequence+ [ conP conName (map varP lArgNames)+ , conP conName (map varP rArgNames)+ ]+ let main = Clause pats+ (NormalB (AppE (VarE 'runGComparing) (doUnqualifiedE (stmts ++ [ret])))) [] lt = Clause [RecP conName [], WildP] (NormalB (ConE 'GLT)) [] gt = Clause [WildP, RecP conName []] (NormalB (ConE 'GGT)) []
src/Data/GADT/Show/TH.hs view
@@ -6,7 +6,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Writer-import Data.Dependent.Sum.TH.Internal+import Data.GADT.TH.Internal import Data.Functor.Identity import Data.GADT.Show import Data.Traversable (for)@@ -66,24 +66,16 @@ argShowExprs <- forM (zip argNames argTypes) $ \(n,t) -> do let useShow = do- tell [AppT (ConT ''Show) t]+ u <- lift $ reifyInstancesWithRigids paramVars ''Show [t]+ case u of+ (_:_) -> return ()+ _ -> tell [AppT (ConT ''Show) t] return [| showsPrec 11 $(varE n) |] case t of AppT tyFun tyArg -> do- let useGShow = do- tell [AppT (ConT ''GShow) tyFun]- return [| gshowsPrec 11 $(varE n) |] if isApplicationOf (ConT typeName) tyFun then return [| gshowsPrec 11 $(varE n) |]- else do- v <- lift $ reifyInstancesWithRigids paramVars ''GShow [tyFun]- case v of- (_:_) -> useGShow- _ -> do- u <- lift $ reifyInstancesWithRigids paramVars ''Show [t]- case u of- (_:_) -> useShow- [] -> useGShow+ else useShow _ -> useShow let precPat = if null argNames
+ src/Data/GADT/TH/Internal.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds #-}++-- | Shared functions for dependent-sum-template+module Data.GADT.TH.Internal where++import Control.Monad+import Control.Monad.Writer+import qualified Data.Kind+import Data.List (foldl', drop)+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Merge.Lazy as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Language.Haskell.TH+import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr++classHeadToParams :: Type -> (Name, [Type])+classHeadToParams t = (h, reverse reversedParams)+ where+ (h, reversedParams) = go t+ go :: Type -> (Name, [Type])+ go t = case t of+ AppT f x ->+ let (h, reversedParams) = classHeadToParams f+ in (h, x : reversedParams)+ _ -> (headOfType t, [])++-- 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++skolemize :: Set Name -> Type -> Type+skolemize rigids t = case t of+ ForallT bndrs cxt t' -> ForallT bndrs cxt (skolemize (Set.difference rigids (Set.fromList (map tvName bndrs))) t')+ AppT t1 t2 -> AppT (skolemize rigids t1) (skolemize rigids t2)+ SigT t k -> SigT (skolemize rigids t) 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)+ _ -> t++reifyInstancesBroken :: Q Bool+reifyInstancesBroken = do+ a <- newName "a"+ ins <- reifyInstancesWithRigids' (Set.singleton a) ''Show [VarT a]+ pure $ not $ null ins++reifyInstancesWithRigids' :: Set Name -> Name -> [Type] -> Q [InstanceDec]+reifyInstancesWithRigids' rigids cls tys = reifyInstances cls (map (skolemize rigids) tys)++reifyInstancesWithRigids :: Set Name -> Name -> [Type] -> Q [InstanceDec]+reifyInstancesWithRigids rigids cls tys = do+ isBroken <- reifyInstancesBroken+ if isBroken+ then fail "Unsupported GHC version: 'reifyInstances' in this version of GHC returns instances when we expect an empty list. See https://gitlab.haskell.org/ghc/ghc/-/issues/23743"+ else reifyInstancesWithRigids' rigids cls tys++-- | Determine the type variables which occur freely in a type.+freeTypeVariables :: Type -> Set Name+freeTypeVariables t = case t of+ ForallT bndrs _ t' -> Set.difference (freeTypeVariables t') (Set.fromList (map tvName bndrs))+ AppT t1 t2 -> Set.union (freeTypeVariables t1) (freeTypeVariables t2)+ SigT t _ -> freeTypeVariables t+ VarT n -> Set.singleton n+ _ -> Set.empty++subst :: Map Name Type -> Type -> Type+subst s = f+ where+ f = \case+ ForallT bndrs cxt t ->+ let s' = Map.difference s (Map.fromList [(k,()) | k <- map tvName bndrs])+ in ForallT bndrs cxt (subst s' t)+ AppT t t' -> AppT (f t) (f t')+ SigT t k -> SigT (f t) k+ VarT n -> case Map.lookup n s of+ Just t -> t+ Nothing -> VarT n+ InfixT t x t' -> InfixT (f t) x (f t')+ UInfixT t x t' -> UInfixT (f t) x (f t')+ x -> x++-- Invoke the deriver for the given class instance. We assume that the type+-- we're deriving for is always the first typeclass parameter, if there are+-- multiple.+deriveForDec+ :: Name+ -> (DatatypeInfo -> WriterT [Type] Q Dec)+ -> Dec+ -> Q [Dec]+deriveForDec className f (InstanceD overlaps cxt instanceHead decs) = do+ let (givenClassName, firstParam : _) = classHeadToParams instanceHead+ when (givenClassName /= className) $+ fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName+ let dataTypeName = headOfType firstParam+ dataTypeInfo <- reifyDatatype dataTypeName+ let instTypes = datatypeInstTypes dataTypeInfo+ paramVars = Set.unions [freeTypeVariables t | t <- instTypes]+ instTypes' = case reverse instTypes of+ [] -> fail "deriveGEq: Not enough type parameters"+ (_:xs) -> reverse xs+ generatedInstanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes')+ unifiedTypes <- unifyTypes [generatedInstanceHead, instanceHead]+ let+ newInstanceHead = applySubstitution unifiedTypes instanceHead+ newContext = applySubstitution unifiedTypes cxt+ -- We are not using the generated context that we collect from f, instead+ -- relying on a correct instance head from the user+ (dec, _) <- runWriterT $ f dataTypeInfo+ return [InstanceD overlaps newContext newInstanceHead [dec]]+deriveForDec className f dataDec = do+ dataTypeInfo <- normalizeDec dataDec+ let instTypes = datatypeInstTypes dataTypeInfo+ paramVars = Set.unions [freeTypeVariables t | t <- instTypes]+ instTypes' = case reverse instTypes of+ [] -> fail "deriveGEq: Not enough type parameters"+ (_:xs) -> reverse xs+ instanceHead = AppT (ConT className) (foldl AppT (ConT $ datatypeName dataTypeInfo) instTypes')+ (dec, cxt') <- runWriterT (f dataTypeInfo)+ return [InstanceD Nothing (datatypeContext dataTypeInfo ++ cxt') instanceHead [dec]]++headOfType :: Type -> Name+headOfType = \case+ ForallT _ _ ty -> headOfType ty+ VarT name -> name+ ConT name -> name+ TupleT n -> tupleTypeName n+ ArrowT -> ''(->)+ ListT -> ''[]+ AppT t _ -> headOfType t
test/test.hs view
@@ -180,7 +180,7 @@ [d| instance GEq a => GEq (SpleebHard a) instance GCompare a => GCompare (SpleebHard a)- instance GShow a => GShow (SpleebHard a)+ instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => GShow (SpleebHard a) |] concat <$> sequence@@ -189,7 +189,7 @@ , deriveGShow gshowInst ] -instance GShow a => Show (SpleebHard a b) where showsPrec = gshowsPrec+instance (Show (a Double), Show (a Int), GShow Qux, GShow Foo) => Show (SpleebHard a b) where showsPrec = gshowsPrec data SpleebHard2 a b where PH2 :: a Double -> Qux b -> SpleebHard2 a b