Skip to content
Snippets Groups Projects
Commit 26cfeb06 authored by Hannes Siebenhandl's avatar Hannes Siebenhandl
Browse files

Add patches for ghcide dependencies

parent 508510d7
No related branches found
No related tags found
No related merge requests found
diff --git a/dependent-sum-template.cabal b/dependent-sum-template.cabal
index 1d2d17f..4b7f1c7 100644
--- a/dependent-sum-template.cabal
+++ b/dependent-sum-template.cabal
@@ -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
@@ -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)
diff --git a/src/Data/Dependent/Sum/TH/Internal.hs b/src/Data/Dependent/Sum/TH/Internal.hs
index 0bf5afd..01e78c1 100644
--- a/src/Data/Dependent/Sum/TH/Internal.hs
+++ b/src/Data/Dependent/Sum/TH/Internal.hs
@@ -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)
@@ -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
@@ -36,20 +40,20 @@ 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
- bndrs = [PlainTV v | PlainTV v <- maybe [] id tvBndrs]
+ bndrs = [tvb | tvb@PlainTV{} <- maybe [] id tvBndrs]
initTy (AppT ty _) = ty
#else
clhead = makeClassHead $ foldl1 appT (map return $ (ConT name : init tyArgs))
diff --git a/src/Data/GADT/Show/TH.hs b/src/Data/GADT/Show/TH.hs
index ca15c0b..b02fafe 100644
--- a/src/Data/GADT/Show/TH.hs
+++ b/src/Data/GADT/Show/TH.hs
@@ -10,7 +10,7 @@ import Data.Dependent.Sum.TH.Internal
import Data.Functor.Identity
import Data.GADT.Show
import Data.Traversable (for)
-import Data.List
+import Data.List (intersperse)
import Language.Haskell.TH
import Language.Haskell.TH.Extras
diff --git a/test/test.hs b/test/test.hs
index 499554c..39379fc 100644
--- a/test/test.hs
+++ b/test/test.hs
@@ -96,23 +96,22 @@ data Qux a where
deriveGEq ''Foo
deriveGEq ''Bar
-deriveGEq ''Baz
deriveGEq ''Qux
+deriveGEq ''Baz
deriveGCompare ''Foo
deriveGCompare ''Bar
-deriveGCompare ''Baz
deriveGCompare ''Qux
+deriveGCompare ''Baz
+deriveGShow ''Foo
instance Show (Foo a) where showsPrec = gshowsPrec
+deriveGShow ''Bar
instance Show (Bar a) where showsPrec = gshowsPrec
-instance Show (Baz a) where showsPrec = gshowsPrec
+deriveGShow ''Qux
instance Show (Qux a) where showsPrec = gshowsPrec
-
-deriveGShow ''Foo
-deriveGShow ''Bar
deriveGShow ''Baz
-deriveGShow ''Qux
+instance Show (Baz a) where showsPrec = gshowsPrec
data Squudge a where
E :: Ord a => Foo a -> Squudge a
diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs
index 9da19e3..2f50b0a 100644
--- a/src/Language/Haskell/TH/Extras.hs
+++ b/src/Language/Haskell/TH/Extras.hs
@@ -6,6 +6,7 @@ import Data.Generics
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Datatype.TyVarBndr
intIs64 :: Bool
intIs64 = toInteger (maxBound :: Int) > 2^32
@@ -39,23 +40,21 @@ argTypesOfCon (GadtC _ args _) = map snd args
argTypesOfCon (RecGadtC _ args _) = [t | (_,_,t) <- args]
#endif
-nameOfBinder :: TyVarBndr -> Name
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700
-nameOfBinder (PlainTV n) = n
-nameOfBinder (KindedTV n _) = n
-#else
-nameOfBinder = id
-type TyVarBndr = Name
-#endif
+nameOfBinder :: TyVarBndr_ a -> Name
+nameOfBinder = tvName
-varsBoundInCon :: Con -> [TyVarBndr]
+varsBoundInCon :: Con -> [TyVarBndrSpec]
varsBoundInCon (ForallC bndrs _ con) = bndrs ++ varsBoundInCon con
varsBoundInCon _ = []
namesBoundInPat :: Pat -> [Name]
namesBoundInPat (VarP name) = [name]
namesBoundInPat (TupP pats) = pats >>= namesBoundInPat
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 902
+namesBoundInPat (ConP _ _ pats) = pats >>= namesBoundInPat
+#else
namesBoundInPat (ConP _ pats) = pats >>= namesBoundInPat
+#endif
namesBoundInPat (InfixP p1 _ p2) = namesBoundInPat p1 ++ namesBoundInPat p2
namesBoundInPat (TildeP pat) = namesBoundInPat pat
namesBoundInPat (AsP name pat) = name : namesBoundInPat pat
@@ -141,7 +140,7 @@ headOfType (UnboxedTupleT n) = unboxedTupleTypeName n
occursInType :: Name -> Type -> Bool
occursInType var ty = case ty of
ForallT bndrs _ ty
- | any (var ==) (map nameOfBinder bndrs)
+ | any (var ==) (map tvName bndrs)
-> False
| otherwise
-> occursInType var ty
diff --git a/th-extras.cabal b/th-extras.cabal
index dcc4996..5eda8ab 100644
--- a/th-extras.cabal
+++ b/th-extras.cabal
@@ -2,7 +2,7 @@ name: th-extras
version: 0.0.0.4
stability: experimental
-cabal-version: >= 1.6
+cabal-version: >= 1.8
build-type: Simple
author: James Cook <mokus@deepbondi.net>
@@ -33,7 +33,8 @@ Library
hs-source-dirs: src
exposed-modules: Language.Haskell.TH.Extras
build-depends: base >= 3 && < 5,
- template-haskell
-
+ template-haskell < 2.18,
+ th-abstraction >= 0.4 && < 0.5
+
if flag(base4)
build-depends: base >= 4, syb
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment