From 29f68236e9c09bbc186dd9e7996e2706ecafb111 Mon Sep 17 00:00:00 2001 From: Eric Conlon Date: Mon, 1 Jun 2026 07:50:37 -0700 Subject: [PATCH] Bump minor versions with changes for some-1.1 and GHC 9.12 --- .gitignore | 2 +- dependent-sum-template/ChangeLog.md | 4 + .../dependent-sum-template.cabal | 21 +- .../src/Data/Dependent/Sum/TH/Internal.hs | 10 +- .../src/Data/GADT/Compare/TH.hs | 231 +++++++++++++++++- dependent-sum-template/test/test.hs | 9 +- dependent-sum/ChangeLog.md | 4 + dependent-sum/dependent-sum.cabal | 20 +- stack.yaml | 6 + stack.yaml.lock | 19 ++ 10 files changed, 287 insertions(+), 39 deletions(-) create mode 100644 stack.yaml create mode 100644 stack.yaml.lock diff --git a/.gitignore b/.gitignore index 47d1f2c..e7b5755 100644 --- a/.gitignore +++ b/.gitignore @@ -23,5 +23,5 @@ dist-newstyle *.hi *.chi *.chs.h - +.stack-work diff --git a/dependent-sum-template/ChangeLog.md b/dependent-sum-template/ChangeLog.md index 1fe54e2..462cbca 100644 --- a/dependent-sum-template/ChangeLog.md +++ b/dependent-sum-template/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for dependent-sum-template +## 0.2.0.0 - 2026-xx-xx + +Upgrade to `some-1.1` and drop support for `GHC < 9.12`. + ## 0.1.1.1 - 2021-12-30 * Fix warning with GHC 9.2 about non-canonical `return`. diff --git a/dependent-sum-template/dependent-sum-template.cabal b/dependent-sum-template/dependent-sum-template.cabal index 24ced93..25674ff 100644 --- a/dependent-sum-template/dependent-sum-template.cabal +++ b/dependent-sum-template/dependent-sum-template.cabal @@ -1,5 +1,5 @@ name: dependent-sum-template -version: 0.1.1.1 +version: 0.2.0.0 stability: experimental cabal-version: >= 1.10 @@ -14,12 +14,7 @@ category: Unclassified synopsis: Template Haskell code to generate instances of classes in dependent-sum package description: Template Haskell code to generate instances of classes in dependent-sum package, such as 'GEq' and 'GCompare'. -tested-with: GHC == 8.0.2, - GHC == 8.2.2, - GHC == 8.4.4, - GHC == 8.6.5, - GHC == 8.8.3, - GHC == 9.0.1 +tested-with: GHC == 9.12.4 extra-source-files: ChangeLog.md @@ -28,22 +23,18 @@ source-repository head location: https://github.com/obsidiansystems/dependent-sum Library - if impl(ghc < 7.10) - buildable: False hs-source-dirs: src default-language: Haskell2010 exposed-modules: Data.GADT.Compare.TH Data.GADT.Show.TH other-modules: Data.Dependent.Sum.TH.Internal - build-depends: base >= 3 && <5, - dependent-sum >= 0.4.1 && < 0.8, + build-depends: base >= 4.21 && <5, + dependent-sum >=0.4.1 && <0.9, template-haskell, - th-extras >= 0.0.0.2, - th-abstraction >= 0.4 + th-extras >=0.0.0.9 && < 0.1, + th-abstraction >=0.7.2.0 && <0.8 test-suite test - if impl(ghc < 8.0) - buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 diff --git a/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs b/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs index 16ed953..ca4255a 100644 --- a/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs +++ b/dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs @@ -26,9 +26,9 @@ classHeadToParams t = (h, reverse reversedParams) -- we're deriving for is always the first typeclass parameter, if there are -- multiple. deriveForDec :: Name -> (Q Type -> Q Type) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec] -deriveForDec className makeClassHead f dec = deriveForDec' className makeClassHead (f . changeTVFlags specifiedSpec) dec +deriveForDec = deriveForDec' -deriveForDec' :: Name -> (Q Type -> Q Type) -> ([TyVarBndrUnit] -> [Con] -> Q Dec) -> Dec -> Q [Dec] +deriveForDec' :: Name -> (Q Type -> Q Type) -> ([TyVarBndrSpec] -> [Con] -> Q Dec) -> Dec -> Q [Dec] deriveForDec' className _ f (InstanceD overlaps cxt classHead decs) = do let (givenClassName, firstParam : _) = classHeadToParams classHead when (givenClassName /= className) $ @@ -37,13 +37,13 @@ deriveForDec' className _ f (InstanceD overlaps cxt classHead decs) = do dataTypeInfo <- reify dataTypeName case dataTypeInfo of TyConI (DataD dataCxt name bndrs _ cons _) -> do - dec <- f bndrs cons + dec <- f (changeTVFlags specifiedSpec bndrs) cons return [InstanceD overlaps cxt classHead [dec]] _ -> fail $ "while deriving " ++ show className ++ ": the name of an algebraic data type constructor is required" deriveForDec' className makeClassHead f (DataD dataCxt name bndrs _ cons _) = return <$> inst where inst = instanceD (cxt (map return dataCxt)) (makeClassHead $ conT name) [dec] - dec = f bndrs cons + dec = f (changeTVFlags specifiedSpec bndrs) cons #if __GLASGOW_HASKELL__ >= 808 deriveForDec' className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst #else @@ -64,4 +64,4 @@ deriveForDec' className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) -- TODO: figure out proper number of family parameters vs instance parameters bndrs = [PlainTV v | VarT v <- tail tyArgs ] #endif - dec = f bndrs cons + dec = f (changeTVFlags specifiedSpec bndrs) cons diff --git a/dependent-sum-template/src/Data/GADT/Compare/TH.hs b/dependent-sum-template/src/Data/GADT/Compare/TH.hs index 1f20c6e..8939933 100644 --- a/dependent-sum-template/src/Data/GADT/Compare/TH.hs +++ b/dependent-sum-template/src/Data/GADT/Compare/TH.hs @@ -7,6 +7,8 @@ module Data.GADT.Compare.TH ( DeriveGEQ(..) , DeriveGCompare(..) + , deriveGEqSuperclasses + , deriveGCompareSuperclasses , GComparing, runGComparing, geq', compare' ) where @@ -20,6 +22,7 @@ import Data.Traversable (for) import Data.Type.Equality ((:~:) (..)) import Language.Haskell.TH import Language.Haskell.TH.Extras +import Language.Haskell.TH.Datatype.TyVarBndr -- A type class purely for overloading purposes class DeriveGEQ t where @@ -33,7 +36,15 @@ instance DeriveGEQ Name where _ -> fail "deriveGEq: the name of a type constructor is required" instance DeriveGEQ Dec where - deriveGEq = deriveForDec ''GEq (\t -> [t| GEq $t |]) geqFunction + deriveGEq dec = do + eqPName <- superclassNamed ''GEq "EqP" + eqpName <- classMethodNamed eqPName "eqp" + eqDecs <- deriveEqForDec eqpName dec + liftA2 (++) + (return eqDecs) + (liftA2 (++) + (deriveEqPForDec eqPName eqpName dec) + (deriveForDec ''GEq (\t -> [t| GEq $t |]) geqFunction dec)) instance DeriveGEQ t => DeriveGEQ [t] where deriveGEq [it] = deriveGEq it @@ -42,6 +53,119 @@ instance DeriveGEQ t => DeriveGEQ [t] where instance DeriveGEQ t => DeriveGEQ (Q t) where deriveGEq = (>>= deriveGEq) +deriveGEqSuperclasses :: Name -> Q [Dec] +deriveGEqSuperclasses typeName = do + eqPName <- superclassNamed ''GEq "EqP" + eqpName <- classMethodNamed eqPName "eqp" + TyConI (DataD dataCxt name bndrs _ _ _) <- reify typeName + eqType <- applyType name bndrs + eqExists <- isInstance' ''Eq [eqType] + let eqDec = instanceD (cxt (map return dataCxt)) (appT (conT ''Eq) (return eqType)) + [geqBoolFunction '(==)] + eqPDec <- instanceD (cxt (map return dataCxt)) (appT (conT eqPName) (conT name)) + [geqBoolFunction eqpName] + if eqExists then return [eqPDec] else (: [eqPDec]) <$> eqDec + +geqBoolFunction funName = funD funName + [clause [varP x, varP y] + (normalB [| case geq $(varE x) $(varE y) of + Just Refl -> True + Nothing -> False + |]) []] + where + x = mkName "x" + y = mkName "y" + +superclassNamed className superclassBase = do + ClassI (ClassD superCxt _ _ _ _) _ <- reify className + case [ name | predType <- superCxt + , let (name, _) = classHeadToParams predType + , nameBase name == superclassBase + ] of + [name] -> return name + _ -> fail $ "deriveGEq: could not find superclass " ++ superclassBase ++ " of " ++ show className + +classMethodNamed className methodBase = do + ClassI (ClassD _ _ _ _ decs) _ <- reify className + case [ name | SigD name _ <- decs, nameBase name == methodBase ] of + [name] -> return name + _ -> fail $ "deriveGEq: could not find method " ++ methodBase ++ " of " ++ show className + +deriveEqForDec eqpName (InstanceD _ cxt classHead _) = do + let (_, firstParam : _) = classHeadToParams classHead + (dataTypeName, fixedArgs) = classHeadToParams firstParam + dataTypeInfo <- reify dataTypeName + case dataTypeInfo of + TyConI (DataD dataCxt name bndrs _ cons _) -> deriveEqInstanceForType eqpName (cxt ++ dataCxt) (instanceType name fixedArgs bndrs) bndrs cons + _ -> return [] +deriveEqForDec eqpName (DataD dataCxt name bndrs _ cons _) = deriveEqInstance eqpName dataCxt name bndrs cons +deriveEqForDec _ _ = return [] + +deriveEqPForDec eqPName eqpName (InstanceD _ instCxt classHead _) = do + let (_, firstParam : _) = classHeadToParams classHead + dataTypeName = headOfType firstParam + dataTypeInfo <- reify dataTypeName + case dataTypeInfo of + TyConI (DataD dataCxt _ bndrs _ cons _) -> (:[]) <$> instanceD (cxt (map return (instCxt ++ dataCxt))) (appT (conT eqPName) (return firstParam)) + [eqpFunction eqpName (changeTVFlags specifiedSpec bndrs) cons] + _ -> return [] +deriveEqPForDec eqPName eqpName (DataD dataCxt name bndrs _ cons _) = (:[]) <$> instanceD (cxt (map return dataCxt)) (appT (conT eqPName) (conT name)) + [eqpFunction eqpName (changeTVFlags specifiedSpec bndrs) cons] +deriveEqPForDec _ _ _ = return [] + +deriveEqInstance eqpName dataCxt name bndrs cons = do + eqType <- applyType name bndrs + deriveEqInstanceForType eqpName dataCxt (return eqType) bndrs cons + +deriveEqInstanceForType eqpName dataCxt eqTypeQ bndrs cons = do + eqType <- eqTypeQ + exists <- isInstance' ''Eq [eqType] + if exists + then return [] + else (:[]) <$> instanceD (cxt (map return dataCxt)) (appT (conT ''Eq) (return eqType)) + [eqFunction '(==) eqpName (changeTVFlags specifiedSpec bndrs) cons] + +instanceType name fixedArgs bndrs = foldl appT (conT name) (map return fixedArgs ++ map (varT . nameOfBinder) (drop (length fixedArgs) bndrs)) + +applyType name bndrs = foldl appT (conT name) (map (varT . nameOfBinder) bndrs) + +isInstance' className types = recover (return False) (isInstance className types) + +eqFunction eqName eqpName bndrs cons = funD eqName + ( map (eqpClause eqpName bndrs) cons + ++ [ clause [wildP, wildP] (normalB [| False |]) [] + | length cons /= 1 + ] + ) + +eqpFunction eqpName bndrs cons = funD eqpName + ( map (eqpClause eqpName bndrs) cons + ++ [ clause [wildP, wildP] (normalB [| False |]) [] + | length cons /= 1 + ] + ) + +eqpClause eqpName bndrs con = do + let argTypes = argTypesOfCon con + needsEqP argType = any ((`occursInType` argType) . nameOfBinder) (bndrs ++ varsBoundInCon con) + + nArgs = length argTypes + lArgNames <- replicateM nArgs (newName "x") + rArgNames <- replicateM nArgs (newName "y") + + clause [ conP conName (map varP lArgNames) + , conP conName (map varP rArgNames) + ] + ( normalB $ foldr (\(lArg, rArg, argType) rest -> + [| $(if needsEqP argType + then [| $(varE eqpName) $(varE lArg) $(varE rArg) |] + else [| $(varE lArg) == $(varE rArg) |]) + && $rest |]) + [| True |] + (zip3 lArgNames rArgNames argTypes) + ) [] + where conName = nameOfCon con + geqFunction bndrs cons = funD 'geq ( map (geqClause bndrs) cons ++ [ clause [wildP, wildP] (normalB [| Nothing |]) [] @@ -107,7 +231,15 @@ instance DeriveGCompare Name where _ -> fail "deriveGCompare: the name of a type constructor is required" instance DeriveGCompare Dec where - deriveGCompare = deriveForDec ''GCompare (\t -> [t| GCompare $t |]) gcompareFunction + deriveGCompare dec = do + ordPName <- superclassNamed ''GCompare "OrdP" + comparepName <- classMethodNamed ordPName "comparep" + ordDecs <- deriveOrdForDec comparepName dec + liftA2 (++) + (return ordDecs) + (liftA2 (++) + (deriveOrdPForDec ordPName comparepName dec) + (deriveForDec ''GCompare (\t -> [t| GCompare $t |]) gcompareFunction dec)) instance DeriveGCompare t => DeriveGCompare [t] where deriveGCompare [it] = deriveGCompare it @@ -116,6 +248,101 @@ instance DeriveGCompare t => DeriveGCompare [t] where instance DeriveGCompare t => DeriveGCompare (Q t) where deriveGCompare = (>>= deriveGCompare) +deriveGCompareSuperclasses :: Name -> Q [Dec] +deriveGCompareSuperclasses typeName = do + ordPName <- superclassNamed ''GCompare "OrdP" + comparepName <- classMethodNamed ordPName "comparep" + TyConI (DataD dataCxt name bndrs _ _ _) <- reify typeName + ordType <- applyType name bndrs + ordExists <- isInstance' ''Ord [ordType] + let ordDec = instanceD (cxt (map return dataCxt)) (appT (conT ''Ord) (return ordType)) + [gcompareOrderingFunction 'compare] + ordPDec <- instanceD (cxt (map return dataCxt)) (appT (conT ordPName) (conT name)) + [gcompareOrderingFunction comparepName] + if ordExists then return [ordPDec] else (: [ordPDec]) <$> ordDec + +gcompareOrderingFunction funName = funD funName + [clause [varP x, varP y] + (normalB [| case gcompare $(varE x) $(varE y) of + GLT -> LT + GEQ -> EQ + GGT -> GT + |]) []] + where + x = mkName "x" + y = mkName "y" + +deriveOrdForDec comparepName (InstanceD _ cxt classHead _) = do + let (_, firstParam : _) = classHeadToParams classHead + (dataTypeName, fixedArgs) = classHeadToParams firstParam + dataTypeInfo <- reify dataTypeName + case dataTypeInfo of + TyConI (DataD dataCxt name bndrs _ cons _) -> deriveOrdInstanceForType comparepName (cxt ++ dataCxt) (instanceType name fixedArgs bndrs) bndrs cons + _ -> return [] +deriveOrdForDec comparepName (DataD dataCxt name bndrs _ cons _) = deriveOrdInstance comparepName dataCxt name bndrs cons +deriveOrdForDec _ _ = return [] + +deriveOrdPForDec ordPName comparepName (InstanceD _ instCxt classHead _) = do + let (_, firstParam : _) = classHeadToParams classHead + dataTypeName = headOfType firstParam + dataTypeInfo <- reify dataTypeName + case dataTypeInfo of + TyConI (DataD dataCxt _ bndrs _ cons _) -> (:[]) <$> instanceD (cxt (map return (instCxt ++ dataCxt))) (appT (conT ordPName) (return firstParam)) + [ordpFunction comparepName (changeTVFlags specifiedSpec bndrs) cons] + _ -> return [] +deriveOrdPForDec ordPName comparepName (DataD dataCxt name bndrs _ cons _) = (:[]) <$> instanceD (cxt (map return dataCxt)) (appT (conT ordPName) (conT name)) + [ordpFunction comparepName (changeTVFlags specifiedSpec bndrs) cons] +deriveOrdPForDec _ _ _ = return [] + +deriveOrdInstance comparepName dataCxt name bndrs cons = do + ordType <- applyType name bndrs + deriveOrdInstanceForType comparepName dataCxt (return ordType) bndrs cons + +deriveOrdInstanceForType comparepName dataCxt ordTypeQ bndrs cons = do + ordType <- ordTypeQ + exists <- isInstance' ''Ord [ordType] + if exists + then return [] + else (:[]) <$> instanceD (cxt (map return dataCxt)) (appT (conT ''Ord) (return ordType)) + [comparepFunction 'compare comparepName (changeTVFlags specifiedSpec bndrs) cons] + +ordpFunction comparepName boundVars cons + = comparepFunction comparepName comparepName boundVars cons + +comparepFunction compareName comparepName boundVars cons + | null cons = funD compareName [clause [] (normalB [| \x y -> seq x (seq y undefined) |]) []] + | otherwise = funD compareName (concatMap comparepClauses cons) + where + comparepClauses con = + [ mainClause con + , clause [recP conName [], wildP] (normalB [| LT |]) [] + , clause [wildP, recP conName []] (normalB [| GT |]) [] + ] where conName = nameOfCon con + + needsOrdP argType con = any ((`occursInType` argType) . nameOfBinder) (boundVars ++ varsBoundInCon con) + + mainClause con = do + let conName = nameOfCon con + argTypes = argTypesOfCon con + nArgs = length argTypes + + lArgNames <- replicateM nArgs (newName "x") + rArgNames <- replicateM nArgs (newName "y") + + clause [ conP conName (map varP lArgNames) + , conP conName (map varP rArgNames) + ] + ( normalB $ foldr (\(lArg, rArg, argType) rest -> + [| case $(if needsOrdP argType con + then [| $(varE comparepName) $(varE lArg) $(varE rArg) |] + else [| compare $(varE lArg) $(varE rArg) |]) of + EQ -> $rest + o -> o + |]) + [| EQ |] + (zip3 lArgNames rArgNames argTypes) + ) [] + gcompareFunction boundVars cons | null cons = funD 'gcompare [clause [] (normalB [| \x y -> seq x (seq y undefined) |]) []] | otherwise = funD 'gcompare (concatMap gcompareClauses cons) diff --git a/dependent-sum-template/test/test.hs b/dependent-sum-template/test/test.hs index a06a230..863e3df 100644 --- a/dependent-sum-template/test/test.hs +++ b/dependent-sum-template/test/test.hs @@ -14,6 +14,7 @@ {-# LANGUAGE UndecidableInstances #-} import Control.Monad import Data.Dependent.Sum +import Data.Kind (Type) import Data.Functor.Identity import Data.Constraint.Extras.TH import Data.GADT.Compare @@ -22,7 +23,7 @@ import Data.GADT.Show import Data.GADT.Show.TH import Data.Type.Equality -data MySum :: * -> * where +data MySum :: Type -> Type where MySum_Int :: MySum Int MySum_String :: MySum String @@ -35,7 +36,7 @@ deriveGEq ''MySum deriveGCompare ''MySum deriveArgDict ''MySum -data MyNestedSum :: * -> * where +data MyNestedSum :: Type -> Type where MyNestedSum_MySum :: MySum a -> MyNestedSum a MyNestedSum_Int :: Int -> MyNestedSum Int MyNestedSum_String :: [Int] -> MyNestedSum String @@ -130,6 +131,8 @@ data Splort a where -- it's something I want to try to automagically support. It would require actually -- matching on sub-constructors, which could get pretty ugly, especially since it may -- not even be the case that a finite number of matches would suffice. +deriveGEqSuperclasses ''Splort + instance GEq Splort where geq (Splort (E x1) x2) (Splort (E y1) y2) = do Refl <- geq x1 y1 @@ -138,6 +141,8 @@ instance GEq Splort where deriving instance Show a => Show (Splort a) +deriveGCompareSuperclasses ''Splort + instance GCompare Splort where gcompare (Splort (E x1) x2) (Splort (E y1) y2) = runGComparing $ do diff --git a/dependent-sum/ChangeLog.md b/dependent-sum/ChangeLog.md index cb75d4d..57aceb0 100644 --- a/dependent-sum/ChangeLog.md +++ b/dependent-sum/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for dependent-sum +## 0.8.0.0 - 2026-xx-xx + +Upgrade to `some-1.1` and drop support for `GHC < 9.12`. + ## 0.7.2.0 revision 2 - 2023-11-20 Bump upper bound of `some` from `1.0.5` to `1.0.6`. diff --git a/dependent-sum/dependent-sum.cabal b/dependent-sum/dependent-sum.cabal index b97a33f..2a0d8a5 100644 --- a/dependent-sum/dependent-sum.cabal +++ b/dependent-sum/dependent-sum.cabal @@ -1,5 +1,5 @@ name: dependent-sum -version: 0.7.2.0 +version: 0.8.0.0 stability: provisional cabal-version: 1.22 @@ -24,11 +24,7 @@ description: A dependent sum is a generalization of a dependent sum types by using your own \"tag\" types. -tested-with: GHC == 8.0.2, - GHC == 8.2.2, - GHC == 8.4.4, - GHC == 8.6.5, - GHC == 8.8.3 +tested-with: GHC == 9.12.4 extra-source-files: ChangeLog.md , examples/*.hs @@ -45,11 +41,7 @@ Library Data.GADT.Show, Data.Some other-extensions: PatternSynonyms - build-depends: base >= 4.9 && <5 - , constraints-extras >= 0.2 && < 0.5 - - -- tight bounds, so re-exported API is versioned properly. - build-depends: some >= 1.0.4 && < 1.0.7 - - if impl(ghc >= 7.2) - ghc-options: -trust base + build-depends: base >=4.21 && <5 + , constraints-extras >=0.4.0.2 && <0.5 + , some >=1.1 && <1.2 + ghc-options: -trust base diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..88a93d0 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,6 @@ +snapshot: nightly-2026-05-27 +extra-deps: +- some-1.1 +packages: +- dependent-sum +- dependent-sum-template diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000..affcdc7 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,19 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/topics/lock_files + +packages: +- completed: + hackage: some-1.1@sha256:cf90efa97e997615d684ee116fe9ea092d174db786108d9f1acfd9517d848322,1914 + pantry-tree: + sha256: a260707e5cf6351fc5ef245152ac21f833f908d8f2d9beeea6eb42ac88804e26 + size: 823 + original: + hackage: some-1.1 +snapshots: +- completed: + sha256: 53ca0201488b1213f9c4215808984f82686a1ec047c696c01d6b1b498d70869c + size: 753583 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2026/5/27.yaml + original: nightly-2026-05-27