Skip to content

Add support for GHC-9.0.1 #57

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Sep 11, 2021
Merged

Add support for GHC-9.0.1 #57

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 4 additions & 2 deletions dependent-sum-template/dependent-sum-template.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,8 @@ tested-with: GHC == 8.0.2,
GHC == 8.2.2,
GHC == 8.4.4,
GHC == 8.6.5,
GHC == 8.8.3
GHC == 8.8.3,
GHC == 9.0.1

extra-source-files: ChangeLog.md

Expand All @@ -36,7 +37,8 @@ Library
build-depends: base >= 3 && <5,
dependent-sum >= 0.4.1 && < 0.8,
template-haskell,
th-extras >= 0.0.0.2
th-extras >= 0.0.0.2,
th-abstraction

test-suite test
if impl(ghc < 8.0)
Expand Down
18 changes: 13 additions & 5 deletions dependent-sum-template/src/Data/Dependent/Sum/TH/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -10,6 +10,7 @@ module Data.Dependent.Sum.TH.Internal where
import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Extras
import Language.Haskell.TH.Datatype.TyVarBndr

classHeadToParams :: Type -> (Name, [Type])
classHeadToParams t = (h, reverse reversedParams)
Expand All @@ -24,8 +25,11 @@ classHeadToParams t = (h, reverse reversedParams)
-- 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 -> (Q Type -> Q Type) -> ([TyVarBndr] -> [Con] -> Q Dec) -> Dec -> Q [Dec]
deriveForDec className _ f (InstanceD overlaps cxt classHead decs) = do
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' :: Name -> (Q Type -> Q Type) -> ([TyVarBndrUnit] -> [Con] -> Q Dec) -> Dec -> Q [Dec]
deriveForDec' className _ f (InstanceD overlaps cxt classHead decs) = do
let (givenClassName, firstParam : _) = classHeadToParams classHead
when (givenClassName /= className) $
fail $ "while deriving " ++ show className ++ ": wrong class name in prototype declaration: " ++ show givenClassName
Expand All @@ -36,20 +40,24 @@ deriveForDec className _ f (InstanceD overlaps cxt classHead decs) = do
dec <- f 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
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
#if __GLASGOW_HASKELL__ >= 808
deriveForDec className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst
deriveForDec' className makeClassHead f (DataInstD dataCxt tvBndrs ty _ cons _) = return <$> inst
#else
deriveForDec className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst
deriveForDec' className makeClassHead f (DataInstD dataCxt name tyArgs _ cons _) = return <$> inst
#endif
where
inst = instanceD (cxt (map return dataCxt)) clhead [dec]
#if __GLASGOW_HASKELL__ >= 808
clhead = makeClassHead $ return $ initTy ty
#if __GLASGOW_HASKELL__ >= 900
bndrs = [PlainTV v x | PlainTV v x <- maybe [] id tvBndrs]
#else
bndrs = [PlainTV v | PlainTV v <- maybe [] id tvBndrs]
#endif
initTy (AppT ty _) = ty
#else
clhead = makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs))
Expand Down