mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
gnu: ganeti: Fix build.
* gnu/packages/patches/ganeti-lens-compat.patch, gnu/packages/patches/ganeti-procps-compat.patch, gnu/packages/patches/ganeti-relax-dependencies.patch, gnu/packages/patches/ganeti-reorder-arbitrary-definitions.patch, gnu/packages/patches/ganeti-template-haskell-2.17.patch, gnu/packages/patches/ganeti-template-haskell-2.18.patch: New files. * gnu/local.mk (dist_patch_DATA): Adjust accordingly. * gnu/packages/virtualization.scm (ganeti)[source](patches): Add them.
This commit is contained in:
parent
d4645d5d25
commit
b41ea5dcd4
8 changed files with 464 additions and 1 deletions
|
@ -1178,9 +1178,15 @@ dist_patch_DATA = \
|
|||
%D%/packages/patches/gajim-honour-GAJIM_PLUGIN_PATH.patch \
|
||||
%D%/packages/patches/ganeti-disable-version-symlinks.patch \
|
||||
%D%/packages/patches/ganeti-haskell-pythondir.patch \
|
||||
%D%/packages/patches/ganeti-lens-compat.patch \
|
||||
%D%/packages/patches/ganeti-pyyaml-compat.patch \
|
||||
%D%/packages/patches/ganeti-procps-compat.patch \
|
||||
%D%/packages/patches/ganeti-reorder-arbitrary-definitions.patch \
|
||||
%D%/packages/patches/ganeti-relax-dependencies.patch \
|
||||
%D%/packages/patches/ganeti-shepherd-master-failover.patch \
|
||||
%D%/packages/patches/ganeti-shepherd-support.patch \
|
||||
%D%/packages/patches/ganeti-template-haskell-2.17.patch \
|
||||
%D%/packages/patches/ganeti-template-haskell-2.18.patch \
|
||||
%D%/packages/patches/gawk-shell.patch \
|
||||
%D%/packages/patches/gcc-arm-bug-71399.patch \
|
||||
%D%/packages/patches/gcc-arm-link-spec-fix.patch \
|
||||
|
|
40
gnu/packages/patches/ganeti-lens-compat.patch
Normal file
40
gnu/packages/patches/ganeti-lens-compat.patch
Normal file
|
@ -0,0 +1,40 @@
|
|||
Fix building against Lens 5 by commenting out type signatures(!).
|
||||
|
||||
Taken from upstream:
|
||||
|
||||
https://github.com/ganeti/ganeti/commit/5e30bad1bba63c9f6c782003ef2560f107a0ba24
|
||||
|
||||
diff --git a/src/Ganeti/Network.hs b/src/Ganeti/Network.hs
|
||||
index 1cb6aa1ec..696c1cd1b 100644
|
||||
--- a/src/Ganeti/Network.hs
|
||||
+++ b/src/Ganeti/Network.hs
|
||||
@@ -87,11 +87,11 @@ data PoolPart = PoolInstances | PoolExt
|
||||
addressPoolIso :: Iso' AddressPool BA.BitArray
|
||||
addressPoolIso = iso apReservations AddressPool
|
||||
|
||||
-poolLens :: PoolPart -> Lens' Network (Maybe AddressPool)
|
||||
+--poolLens :: PoolPart -> Lens' Network (Maybe AddressPool)
|
||||
poolLens PoolInstances = networkReservationsL
|
||||
poolLens PoolExt = networkExtReservationsL
|
||||
|
||||
-poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray)
|
||||
+--poolArrayLens :: PoolPart -> Lens' Network (Maybe BA.BitArray)
|
||||
poolArrayLens part = poolLens part . mapping addressPoolIso
|
||||
|
||||
netIpv4NumHosts :: Network -> Integer
|
||||
diff --git a/src/Ganeti/Utils/MultiMap.hs b/src/Ganeti/Utils/MultiMap.hs
|
||||
index d54da3ab0..279e9335a 100644
|
||||
--- a/src/Ganeti/Utils/MultiMap.hs
|
||||
+++ b/src/Ganeti/Utils/MultiMap.hs
|
||||
@@ -91,7 +91,7 @@ multiMap :: (Ord k, Ord v) => M.Map k (S.Set v) -> MultiMap k v
|
||||
multiMap = MultiMap . M.filter (not . S.null)
|
||||
|
||||
-- | A 'Lens' that allows to access a set under a given key in a multi-map.
|
||||
-multiMapL :: (Ord k, Ord v) => k -> Lens' (MultiMap k v) (S.Set v)
|
||||
+--multiMapL :: (Ord k, Ord v) => k -> Lens' (MultiMap k v) (S.Set v)
|
||||
multiMapL k f = fmap MultiMap
|
||||
. at k (fmap (mfilter (not . S.null) . Just)
|
||||
. f . fromMaybe S.empty)
|
||||
--
|
||||
2.41.0
|
||||
|
45
gnu/packages/patches/ganeti-procps-compat.patch
Normal file
45
gnu/packages/patches/ganeti-procps-compat.patch
Normal file
|
@ -0,0 +1,45 @@
|
|||
Fix compatibility with procps 4.
|
||||
|
||||
Negative UIDs are no longer allowed. Use a very high one instead.
|
||||
|
||||
Taken from upstream:
|
||||
|
||||
https://github.com/ganeti/ganeti/commit/9cd67e6a81c66ed326d68ea8c3241d14eea6550b
|
||||
|
||||
diff --git a/test/py/ganeti.uidpool_unittest.py b/test/py/ganeti.uidpool_unittest.py
|
||||
index b2f5bc5cf2..2d9227cbf5 100755
|
||||
--- a/test/py/ganeti.uidpool_unittest.py
|
||||
+++ b/test/py/ganeti.uidpool_unittest.py
|
||||
@@ -106,23 +106,24 @@ def testRequestUnusedUid(self):
|
||||
|
||||
# Check with a single, known unused user-id
|
||||
#
|
||||
- # We use "-1" here, which is not a valid user-id, so it's
|
||||
- # guaranteed that it's unused.
|
||||
- uid = uidpool.RequestUnusedUid(set([-1]))
|
||||
- self.assertEqualValues(uid.GetUid(), -1)
|
||||
+ # We use 2^30+42 here, which is a valid UID, but unlikely to be used on
|
||||
+ # most systems (even as a subuid).
|
||||
+ free_uid = 2**30 + 42
|
||||
+ uid = uidpool.RequestUnusedUid(set([free_uid]))
|
||||
+ self.assertEqualValues(uid.GetUid(), free_uid)
|
||||
|
||||
# Check uid-pool exhaustion
|
||||
#
|
||||
- # uid "-1" is locked now, so RequestUnusedUid is expected to fail
|
||||
+ # free_uid is locked now, so RequestUnusedUid is expected to fail
|
||||
self.assertRaises(errors.LockError,
|
||||
uidpool.RequestUnusedUid,
|
||||
- set([-1]))
|
||||
+ set([free_uid]))
|
||||
|
||||
# Check unlocking
|
||||
uid.Unlock()
|
||||
# After unlocking, "-1" should be available again
|
||||
- uid = uidpool.RequestUnusedUid(set([-1]))
|
||||
- self.assertEqualValues(uid.GetUid(), -1)
|
||||
+ uid = uidpool.RequestUnusedUid(set([free_uid]))
|
||||
+ self.assertEqualValues(uid.GetUid(), free_uid)
|
||||
|
||||
|
||||
if __name__ == "__main__":
|
28
gnu/packages/patches/ganeti-relax-dependencies.patch
Normal file
28
gnu/packages/patches/ganeti-relax-dependencies.patch
Normal file
|
@ -0,0 +1,28 @@
|
|||
Relax version constraints to work with Stackage LTS 19.
|
||||
|
||||
Taken from upstream:
|
||||
|
||||
https://github.com/ganeti/ganeti/commit/4f8d61ea0101721eae1c6f43be8430d819e5e611
|
||||
|
||||
diff --git a/cabal/ganeti.template.cabal b/cabal/ganeti.template.cabal
|
||||
index bb4ff8053..98491dd9f 100644
|
||||
--- a/cabal/ganeti.template.cabal
|
||||
+++ b/cabal/ganeti.template.cabal
|
||||
@@ -63,14 +63,14 @@ library
|
||||
, unix >= 2.5.1.0
|
||||
, utf8-string >= 0.3.7
|
||||
|
||||
- , attoparsec >= 0.10.1.1 && < 0.14
|
||||
- , base64-bytestring >= 1.0.0.1 && < 1.2
|
||||
+ , attoparsec >= 0.10.1.1 && < 0.15
|
||||
+ , base64-bytestring >= 1.0.0.1 && < 1.3
|
||||
, case-insensitive >= 0.4.0.1 && < 1.3
|
||||
, curl >= 1.3.7 && < 1.4
|
||||
, hinotify >= 0.3.2 && < 0.5
|
||||
, hslogger >= 1.1.4 && < 1.4
|
||||
, json >= 0.5 && < 1.0
|
||||
- , lens >= 3.10 && < 5.0
|
||||
+ , lens >= 3.10 && < 6.0
|
||||
, lifted-base >= 0.2.0.3 && < 0.3
|
||||
, monad-control >= 0.3.1.3 && < 1.1
|
||||
, parallel >= 3.2.0.2 && < 3.3
|
|
@ -0,0 +1,90 @@
|
|||
Fix ordering of Arbitrary definitions for GHC 9 compatibility.
|
||||
|
||||
Taken from upstream:
|
||||
|
||||
https://github.com/ganeti/ganeti/commit/feab8faa8fe055c89205497e4f277ae4c7b8caad
|
||||
|
||||
diff --git a/test/hs/Test/Ganeti/Objects.hs b/test/hs/Test/Ganeti/Objects.hs
|
||||
index 97ceb36dca..8d80be9e80 100644
|
||||
--- a/test/hs/Test/Ganeti/Objects.hs
|
||||
+++ b/test/hs/Test/Ganeti/Objects.hs
|
||||
@@ -93,8 +93,14 @@ instance Arbitrary (Container DataCollectorConfig) where
|
||||
instance Arbitrary BS.ByteString where
|
||||
arbitrary = genPrintableByteString
|
||||
|
||||
+instance Arbitrary a => Arbitrary (Private a) where
|
||||
+ arbitrary = Private <$> arbitrary
|
||||
+
|
||||
$(genArbitrary ''PartialNDParams)
|
||||
|
||||
+instance Arbitrary (Container J.JSValue) where
|
||||
+ arbitrary = return $ GenericContainer Map.empty
|
||||
+
|
||||
instance Arbitrary Node where
|
||||
arbitrary = Node <$> genFQDN <*> genFQDN <*> genFQDN
|
||||
<*> arbitrary <*> arbitrary <*> arbitrary <*> genFQDN
|
||||
@@ -297,10 +303,6 @@ genDisk = genDiskWithChildren 3
|
||||
-- validation rules.
|
||||
$(genArbitrary ''PartialISpecParams)
|
||||
|
||||
--- | FIXME: This generates completely random data, without normal
|
||||
--- validation rules.
|
||||
-$(genArbitrary ''PartialIPolicy)
|
||||
-
|
||||
$(genArbitrary ''FilledISpecParams)
|
||||
$(genArbitrary ''MinMaxISpecs)
|
||||
$(genArbitrary ''FilledIPolicy)
|
||||
@@ -309,6 +311,10 @@ $(genArbitrary ''FilledNDParams)
|
||||
$(genArbitrary ''FilledNicParams)
|
||||
$(genArbitrary ''FilledBeParams)
|
||||
|
||||
+-- | FIXME: This generates completely random data, without normal
|
||||
+-- validation rules.
|
||||
+$(genArbitrary ''PartialIPolicy)
|
||||
+
|
||||
-- | No real arbitrary instance for 'ClusterHvParams' yet.
|
||||
instance Arbitrary ClusterHvParams where
|
||||
arbitrary = return $ GenericContainer Map.empty
|
||||
@@ -331,18 +337,12 @@ instance Arbitrary OsParams where
|
||||
instance Arbitrary Objects.ClusterOsParamsPrivate where
|
||||
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
|
||||
|
||||
-instance Arbitrary a => Arbitrary (Private a) where
|
||||
- arbitrary = Private <$> arbitrary
|
||||
-
|
||||
instance Arbitrary ClusterOsParams where
|
||||
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
|
||||
|
||||
instance Arbitrary ClusterBeParams where
|
||||
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
|
||||
|
||||
-instance Arbitrary IAllocatorParams where
|
||||
- arbitrary = return $ GenericContainer Map.empty
|
||||
-
|
||||
$(genArbitrary ''Cluster)
|
||||
|
||||
instance Arbitrary ConfigData where
|
||||
diff --git a/test/hs/Test/Ganeti/Query/Language.hs b/test/hs/Test/Ganeti/Query/Language.hs
|
||||
index 04fb8c3898..fa50196f00 100644
|
||||
--- a/test/hs/Test/Ganeti/Query/Language.hs
|
||||
+++ b/test/hs/Test/Ganeti/Query/Language.hs
|
||||
@@ -59,6 +59,9 @@ import Ganeti.Query.Language
|
||||
instance Arbitrary (Filter FilterField) where
|
||||
arbitrary = genFilter
|
||||
|
||||
+instance Arbitrary FilterRegex where
|
||||
+ arbitrary = genName >>= mkRegex -- a name should be a good regex
|
||||
+
|
||||
-- | Custom 'Filter' generator (top-level), which enforces a
|
||||
-- (sane) limit on the depth of the generated filters.
|
||||
genFilter :: Gen (Filter FilterField)
|
||||
@@ -97,9 +100,6 @@ $(genArbitrary ''QueryTypeLuxi)
|
||||
|
||||
$(genArbitrary ''ItemType)
|
||||
|
||||
-instance Arbitrary FilterRegex where
|
||||
- arbitrary = genName >>= mkRegex -- a name should be a good regex
|
||||
-
|
||||
$(genArbitrary ''ResultStatus)
|
||||
|
||||
$(genArbitrary ''FieldType)
|
69
gnu/packages/patches/ganeti-template-haskell-2.17.patch
Normal file
69
gnu/packages/patches/ganeti-template-haskell-2.17.patch
Normal file
|
@ -0,0 +1,69 @@
|
|||
Handle GHC 9 changes in a backwards compatible manner.
|
||||
|
||||
Taken from upstream:
|
||||
|
||||
https://github.com/ganeti/ganeti/commit/b279fa738fd5b30320584f79f4d2f0e894315aab
|
||||
|
||||
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
|
||||
index 818c11f84..9ab93d5e3 100644
|
||||
--- a/src/Ganeti/THH.hs
|
||||
+++ b/src/Ganeti/THH.hs
|
||||
@@ -884,7 +884,7 @@ genLoadOpCode opdefs fn = do
|
||||
) $ zip mexps opdefs
|
||||
defmatch = Match WildP (NormalB fails) []
|
||||
cst = NoBindS $ CaseE (VarE opid) $ mpats++[defmatch]
|
||||
- body = DoE [st, cst]
|
||||
+ body = mkDoE [st, cst]
|
||||
-- include "OP_ID" to the list of used keys
|
||||
bodyAndOpId <- [| $(return body)
|
||||
<* tell (mkUsedKeys . S.singleton . T.pack $ opidKey) |]
|
||||
@@ -1541,7 +1541,7 @@ loadExcConstructor inname sname fields = do
|
||||
[x] -> BindS (ListP [VarP x])
|
||||
_ -> BindS (TupP (map VarP f_names))
|
||||
cval = appCons name $ map VarE f_names
|
||||
- return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
|
||||
+ return $ mkDoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
|
||||
|
||||
{-| Generates the loadException function.
|
||||
|
||||
diff --git a/src/Ganeti/THH/Compat.hs b/src/Ganeti/THH/Compat.hs
|
||||
index d29e30d18..1f51e49d7 100644
|
||||
--- a/src/Ganeti/THH/Compat.hs
|
||||
+++ b/src/Ganeti/THH/Compat.hs
|
||||
@@ -40,9 +40,11 @@ module Ganeti.THH.Compat
|
||||
, extractDataDConstructors
|
||||
, myNotStrict
|
||||
, nonUnaryTupE
|
||||
+ , mkDoE
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
+import Language.Haskell.TH.Syntax
|
||||
|
||||
-- | Convert Names to DerivClauses
|
||||
--
|
||||
@@ -61,7 +63,11 @@ derivesFromNames names = map ConT names
|
||||
--
|
||||
-- Handle TH 2.11 and 2.12 changes in a transparent manner using the pre-2.11
|
||||
-- API.
|
||||
+#if MIN_VERSION_template_haskell(2,17,0)
|
||||
+gntDataD :: Cxt -> Name -> [TyVarBndr ()] -> [Con] -> [Name] -> Dec
|
||||
+#else
|
||||
gntDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec
|
||||
+#endif
|
||||
gntDataD x y z a b =
|
||||
#if MIN_VERSION_template_haskell(2,12,0)
|
||||
DataD x y z Nothing a $ derivesFromNames b
|
||||
@@ -114,3 +120,12 @@ nonUnaryTupE es = TupE $ map Just es
|
||||
#else
|
||||
nonUnaryTupE es = TupE $ es
|
||||
#endif
|
||||
+
|
||||
+-- | DoE is now qualified with an optional ModName
|
||||
+mkDoE :: [Stmt] -> Exp
|
||||
+mkDoE s =
|
||||
+#if MIN_VERSION_template_haskell(2,17,0)
|
||||
+ DoE Nothing s
|
||||
+#else
|
||||
+ DoE s
|
||||
+#endif
|
179
gnu/packages/patches/ganeti-template-haskell-2.18.patch
Normal file
179
gnu/packages/patches/ganeti-template-haskell-2.18.patch
Normal file
|
@ -0,0 +1,179 @@
|
|||
Fix compatibility with Template Haskell 2.18 and GHC 9.2.
|
||||
|
||||
|
||||
diff --git a/src/Ganeti/BasicTypes.hs b/src/Ganeti/BasicTypes.hs
|
||||
index 10d0426cd..d68bc7d5b 100644
|
||||
--- a/src/Ganeti/BasicTypes.hs
|
||||
+++ b/src/Ganeti/BasicTypes.hs
|
||||
@@ -206,12 +206,12 @@ instance MonadTrans (ResultT a) where
|
||||
instance (MonadIO m, Error a) => MonadIO (ResultT a m) where
|
||||
liftIO = ResultT . liftIO
|
||||
. liftM (either (failError . show) return)
|
||||
- . (try :: IO a -> IO (Either IOError a))
|
||||
+ . (try :: IO α -> IO (Either IOError α))
|
||||
|
||||
instance (MonadBase IO m, Error a) => MonadBase IO (ResultT a m) where
|
||||
liftBase = ResultT . liftBase
|
||||
. liftM (either (failError . show) return)
|
||||
- . (try :: IO a -> IO (Either IOError a))
|
||||
+ . (try :: IO α -> IO (Either IOError α))
|
||||
|
||||
instance (Error a) => MonadTransControl (ResultT a) where
|
||||
#if MIN_VERSION_monad_control(1,0,0)
|
||||
diff --git a/src/Ganeti/Lens.hs b/src/Ganeti/Lens.hs
|
||||
index faa5900ed..747366e6a 100644
|
||||
--- a/src/Ganeti/Lens.hs
|
||||
+++ b/src/Ganeti/Lens.hs
|
||||
@@ -93,14 +93,14 @@ makeCustomLenses' name lst = makeCustomLensesFiltered f name
|
||||
-- Most often the @g@ functor is @(,) r@ and 'traverseOf2' is used to
|
||||
-- traverse an effectful computation that also returns an additional output
|
||||
-- value.
|
||||
-traverseOf2 :: Over (->) (Compose f g) s t a b
|
||||
- -> (a -> f (g b)) -> s -> f (g t)
|
||||
+-- traverseOf2 :: Over (->) (Compose f g) s t a b
|
||||
+-- -> (a -> f (g b)) -> s -> f (g t)
|
||||
traverseOf2 k f = getCompose . traverseOf k (Compose . f)
|
||||
|
||||
-- | Traverses over a composition of a monad and a functor.
|
||||
-- See 'traverseOf2'.
|
||||
-mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
|
||||
- -> (a -> m (g b)) -> s -> m (g t)
|
||||
+-- mapMOf2 :: Over (->) (Compose (WrappedMonad m) g) s t a b
|
||||
+-- -> (a -> m (g b)) -> s -> m (g t)
|
||||
mapMOf2 k f = unwrapMonad . traverseOf2 k (WrapMonad . f)
|
||||
|
||||
-- | A helper lens over sets.
|
||||
diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs
|
||||
index 9ab93d5e3..9a10a9a07 100644
|
||||
--- a/src/Ganeti/THH.hs
|
||||
+++ b/src/Ganeti/THH.hs
|
||||
@@ -996,8 +996,8 @@ buildAccessor fnm fpfx rnm rpfx nm pfx field = do
|
||||
f_body = AppE (VarE fpfx_name) $ VarE x
|
||||
return $ [ SigD pfx_name $ ArrowT `AppT` ConT nm `AppT` ftype
|
||||
, FunD pfx_name
|
||||
- [ Clause [ConP rnm [VarP x]] (NormalB r_body) []
|
||||
- , Clause [ConP fnm [VarP x]] (NormalB f_body) []
|
||||
+ [ Clause [myConP rnm [VarP x]] (NormalB r_body) []
|
||||
+ , Clause [myConP fnm [VarP x]] (NormalB f_body) []
|
||||
]]
|
||||
|
||||
-- | Build lense declartions for a field.
|
||||
@@ -1037,10 +1037,10 @@ buildLens (fnm, fdnm) (rnm, rdnm) nm pfx ar (field, i) = do
|
||||
(ConE cdn)
|
||||
$ zip [0..] vars
|
||||
let setterE = LamE [VarP context, VarP var] $ CaseE (VarE context)
|
||||
- [ Match (ConP fnm [ConP fdnm . set (element i) WildP
|
||||
+ [ Match (myConP fnm [myConP fdnm . set (element i) WildP
|
||||
$ map VarP vars])
|
||||
(body (not isSimple) fnm fdnm) []
|
||||
- , Match (ConP rnm [ConP rdnm . set (element i) WildP
|
||||
+ , Match (myConP rnm [myConP rdnm . set (element i) WildP
|
||||
$ map VarP vars])
|
||||
(body False rnm rdnm) []
|
||||
]
|
||||
@@ -1098,9 +1098,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
|
||||
$ JSON.showJSON $(varE x) |]
|
||||
let rdjson = FunD 'JSON.readJSON [Clause [] (NormalB read_body) []]
|
||||
shjson = FunD 'JSON.showJSON
|
||||
- [ Clause [ConP (mkName real_nm) [VarP x]]
|
||||
+ [ Clause [myConP (mkName real_nm) [VarP x]]
|
||||
(NormalB show_real_body) []
|
||||
- , Clause [ConP (mkName forth_nm) [VarP x]]
|
||||
+ , Clause [myConP (mkName forth_nm) [VarP x]]
|
||||
(NormalB show_forth_body) []
|
||||
]
|
||||
instJSONdecl = gntInstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
|
||||
@@ -1121,9 +1121,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
|
||||
(fromDictWKeys $(varE xs)) |]
|
||||
todictx_r <- [| toDict $(varE x) |]
|
||||
todictx_f <- [| ("forthcoming", JSON.JSBool True) : toDict $(varE x) |]
|
||||
- let todict = FunD 'toDict [ Clause [ConP (mkName real_nm) [VarP x]]
|
||||
+ let todict = FunD 'toDict [ Clause [myConP (mkName real_nm) [VarP x]]
|
||||
(NormalB todictx_r) []
|
||||
- , Clause [ConP (mkName forth_nm) [VarP x]]
|
||||
+ , Clause [myConP (mkName forth_nm) [VarP x]]
|
||||
(NormalB todictx_f) []
|
||||
]
|
||||
fromdict = FunD 'fromDictWKeys [ Clause [VarP xs]
|
||||
@@ -1136,9 +1136,9 @@ buildObjectWithForthcoming sname field_pfx fields = do
|
||||
let forthPredDecls = [ SigD forthPredName
|
||||
$ ArrowT `AppT` ConT name `AppT` ConT ''Bool
|
||||
, FunD forthPredName
|
||||
- [ Clause [ConP (mkName real_nm) [WildP]]
|
||||
+ [ Clause [myConP (mkName real_nm) [WildP]]
|
||||
(NormalB $ ConE 'False) []
|
||||
- , Clause [ConP (mkName forth_nm) [WildP]]
|
||||
+ , Clause [myConP (mkName forth_nm) [WildP]]
|
||||
(NormalB $ ConE 'True) []
|
||||
]
|
||||
]
|
||||
@@ -1412,9 +1412,9 @@ savePParamField fvar field = do
|
||||
normalexpr <- saveObjectField actualVal field
|
||||
-- we have to construct the block here manually, because we can't
|
||||
-- splice-in-splice
|
||||
- return $ CaseE (VarE fvar) [ Match (ConP 'Nothing [])
|
||||
+ return $ CaseE (VarE fvar) [ Match (myConP 'Nothing [])
|
||||
(NormalB (ConE '[])) []
|
||||
- , Match (ConP 'Just [VarP actualVal])
|
||||
+ , Match (myConP 'Just [VarP actualVal])
|
||||
(NormalB normalexpr) []
|
||||
]
|
||||
|
||||
@@ -1440,9 +1440,9 @@ fillParam sname field_pfx fields = do
|
||||
-- due to apparent bugs in some older GHC versions, we need to add these
|
||||
-- prefixes to avoid "binding shadows ..." errors
|
||||
fbinds <- mapM (newName . ("f_" ++) . nameBase) fnames
|
||||
- let fConP = ConP name_f (map VarP fbinds)
|
||||
+ let fConP = myConP name_f (map VarP fbinds)
|
||||
pbinds <- mapM (newName . ("p_" ++) . nameBase) pnames
|
||||
- let pConP = ConP name_p (map VarP pbinds)
|
||||
+ let pConP = myConP name_p (map VarP pbinds)
|
||||
-- PartialParams instance --------
|
||||
-- fillParams
|
||||
let fromMaybeExp fn pn = AppE (AppE (VarE 'fromMaybe) (VarE fn)) (VarE pn)
|
||||
@@ -1462,7 +1462,7 @@ fillParam sname field_pfx fields = do
|
||||
memptyClause = Clause [] (NormalB memptyExp) []
|
||||
-- mappend
|
||||
pbinds2 <- mapM (newName . ("p2_" ++) . nameBase) pnames
|
||||
- let pConP2 = ConP name_p (map VarP pbinds2)
|
||||
+ let pConP2 = myConP name_p (map VarP pbinds2)
|
||||
-- note the reversal of 'l' and 'r' in the call to <|>
|
||||
-- as we want the result to be the rightmost value
|
||||
let altExp = zipWith (\l r -> AppE (AppE (VarE '(<|>)) (VarE r)) (VarE l))
|
||||
@@ -1575,9 +1575,9 @@ genLoadExc tname sname opdefs = do
|
||||
opdefs
|
||||
-- the first function clause; we can't use [| |] due to TH
|
||||
-- limitations, so we have to build the AST by hand
|
||||
- let clause1 = Clause [ConP 'JSON.JSArray
|
||||
- [ListP [ConP 'JSON.JSString [VarP exc_name],
|
||||
- VarP exc_args]]]
|
||||
+ let clause1 = Clause [myConP 'JSON.JSArray
|
||||
+ [ListP [myConP 'JSON.JSString [VarP exc_name],
|
||||
+ VarP exc_args]]]
|
||||
(NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
|
||||
(VarE exc_name))
|
||||
(str_matches ++ [defmatch]))) []
|
||||
diff --git a/src/Ganeti/THH/Compat.hs b/src/Ganeti/THH/Compat.hs
|
||||
index 1f51e49d7..9b07c47ef 100644
|
||||
--- a/src/Ganeti/THH/Compat.hs
|
||||
+++ b/src/Ganeti/THH/Compat.hs
|
||||
@@ -41,6 +41,7 @@ module Ganeti.THH.Compat
|
||||
, myNotStrict
|
||||
, nonUnaryTupE
|
||||
, mkDoE
|
||||
+ , myConP
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
@@ -129,3 +130,11 @@ mkDoE s =
|
||||
#else
|
||||
DoE s
|
||||
#endif
|
||||
+
|
||||
+-- | ConP is now qualified with an optional [Type].
|
||||
+myConP :: Name -> [Pat] -> Pat
|
||||
+myConP n patterns = ConP n
|
||||
+#if MIN_VERSION_template_haskell(2,18,0)
|
||||
+ []
|
||||
+#endif
|
||||
+ patterns
|
|
@ -668,7 +668,13 @@ (define-public ganeti
|
|||
"ganeti-shepherd-master-failover.patch"
|
||||
"ganeti-haskell-pythondir.patch"
|
||||
"ganeti-pyyaml-compat.patch"
|
||||
"ganeti-disable-version-symlinks.patch"))))
|
||||
"ganeti-procps-compat.patch"
|
||||
"ganeti-disable-version-symlinks.patch"
|
||||
"ganeti-lens-compat.patch"
|
||||
"ganeti-template-haskell-2.17.patch"
|
||||
"ganeti-template-haskell-2.18.patch"
|
||||
"ganeti-reorder-arbitrary-definitions.patch"
|
||||
"ganeti-relax-dependencies.patch"))))
|
||||
(build-system gnu-build-system)
|
||||
(arguments
|
||||
`(#:imported-modules (,@%gnu-build-system-modules
|
||||
|
|
Loading…
Reference in a new issue