[Pkg-ganeti-devel] [ganeti] 06/06: WiP
Apollon Oikonomopoulos
apoikos at moszumanska.debian.org
Mon Dec 12 13:57:43 UTC 2016
This is an automated email from the git hooks/post-receive script.
apoikos pushed a commit to branch ghc8
in repository ganeti.
commit ee7faec481ca009edba8862fac08349cb1798888
Author: Apollon Oikonomopoulos <apoikos at debian.org>
Date: Thu Nov 24 18:01:06 2016 +0200
WiP
---
...p-dependency-on-MonadCatchIO-transformers.patch | 29 ---
debian/patches/0001-GHC-8-support.patch | 66 -----
debian/patches/ghc8-fixes | 280 +++++++++++++++++++++
debian/patches/series | 1 +
4 files changed, 281 insertions(+), 95 deletions(-)
diff --git a/debian/patches/0001-Drop-dependency-on-MonadCatchIO-transformers.patch b/debian/patches/0001-Drop-dependency-on-MonadCatchIO-transformers.patch
index 7674da1..27a1c11 100644
--- a/debian/patches/0001-Drop-dependency-on-MonadCatchIO-transformers.patch
+++ b/debian/patches/0001-Drop-dependency-on-MonadCatchIO-transformers.patch
@@ -20,32 +20,3 @@ unstable. Replace it with Control.Exception.
, network >= 2.3.0.13 && < 2.7
, parallel >= 3.2.0.2 && < 3.3
, regex-pcre >= 0.94.2 && < 0.95
---- a/src/Ganeti/Metad/WebServer.hs
-+++ b/src/Ganeti/Metad/WebServer.hs
-@@ -39,7 +39,7 @@
- import Control.Concurrent (MVar, readMVar)
- import Control.Monad.Error.Class (MonadError, catchError, throwError)
- import Control.Monad.IO.Class (liftIO)
--import qualified Control.Monad.CatchIO as CatchIO (catch)
-+import qualified Control.Exception as Exception (catch)
- import qualified Data.CaseInsensitive as CI
- import Data.List (intercalate)
- import Data.Map (Map)
-@@ -105,7 +105,7 @@
- maybeResult (JSON.readJSON instParams >>=
- Config.getPublicOsParams >>=
- getOsPackage) $ \package ->
-- serveFile package `CatchIO.catch` \err ->
-+ serveFile package `Exception.catch` \err ->
- throwError $ "Could not serve OS package: " ++ show (err :: IOError)
- where getOsPackage osParams =
- case lookup key (JSON.fromJSObject osParams) of
-@@ -130,7 +130,7 @@
- throwError $ "Could not find OS script " ++ show (os </> script)
- serveScript os (d:ds) =
- serveFile (d </> os </> script)
-- `CatchIO.catch`
-+ `Exception.catch`
- \err -> do let _ = err :: IOError
- serveScript os ds
-
diff --git a/debian/patches/0001-GHC-8-support.patch b/debian/patches/0001-GHC-8-support.patch
index a8ca000..05fbfdf 100644
--- a/debian/patches/0001-GHC-8-support.patch
+++ b/debian/patches/0001-GHC-8-support.patch
@@ -44,33 +44,6 @@ Date: Wed Sep 9 12:10:27 2015 +0200
{-| TemplateHaskell helper for Ganeti Haskell code.
-@@ -105,6 +105,8 @@
- import Ganeti.PyValue
- import Ganeti.THH.PyType
-
-+myNotStrict :: Bang
-+myNotStrict = Bang NoSourceUnpackedness NoSourceStrictness
-
- -- * Exported types
-
-@@ -417,7 +419,7 @@
- buildConsField :: Q Type -> StrictTypeQ
- buildConsField ftype = do
- ftype' <- ftype
-- return (NotStrict, ftype')
-+ return (myNotStrict, ftype')
-
- -- | Builds a constructor based on a simple definition (not field-based).
- buildSimpleCons :: Name -> SimpleObject -> Q Dec
-@@ -425,7 +427,7 @@
- decl_d <- mapM (\(cname, fields) -> do
- fields' <- mapM (buildConsField . snd) fields
- return $ NormalC (mkName cname) fields') cons
-- return $ DataD [] tname [] decl_d [''Show, ''Eq]
-+ return $ DataD [] tname [] Nothing decl_d <$> mapM conT [''Show, ''Eq]
-
- -- | Generate the save function for a given type.
- genSaveSimpleObj :: Name -- ^ Object type
@@ -482,7 +484,7 @@
genFromRaw :: Name -> Name -> Name -> [(String, Either String Name)] -> Q [Dec]
genFromRaw traw fname tname constructors = do
@@ -80,42 +53,3 @@ Date: Wed Sep 9 12:10:27 2015 +0200
-- clauses for a guarded pattern
let varp = mkName "s"
varpe = varE varp
-@@ -911,7 +913,7 @@
- decl_d <- mapM (\(cname, fields) -> do
- -- we only need the type of the field, without Q
- fields' <- mapM actualFieldType fields
-- let fields'' = zip (repeat NotStrict) fields'
-+ let fields'' = zip (repeat myNotStrict) fields'
- return $ NormalC (mkName cname) fields'')
- cons
- let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
-@@ -949,7 +951,7 @@
- fieldTypeInfo field_pfx fd = do
- t <- actualFieldType fd
- let n = mkName . (field_pfx ++) . fieldRecordName $ fd
-- return (n, NotStrict, t)
-+ return (n, myNotStrict, t)
-
- -- | Build an object declaration.
- buildObject :: String -> String -> [Field] -> Q [Dec]
-@@ -1056,9 +1058,9 @@
- (map makeOptional fields)
- let name = mkName sname
- real_d = NormalC (mkName real_nm)
-- [(NotStrict, ConT (mkName real_data_nm))]
-+ [(myNotStrict, ConT (mkName real_data_nm))]
- forth_d = NormalC (mkName forth_nm)
-- [(NotStrict, ConT (mkName forth_data_nm))]
-+ [(myNotStrict, ConT (mkName forth_data_nm))]
- declD = DataD [] name [] [real_d, forth_d] [''Show, ''Eq]
-
- read_body <- [| branchOnField "forthcoming"
-@@ -1324,7 +1326,7 @@
- paramFieldTypeInfo :: String -> Field -> VarStrictTypeQ
- paramFieldTypeInfo field_pfx fd = do
- t <- actualFieldType fd
-- return (snd $ paramFieldNames field_pfx fd, NotStrict, AppT (ConT ''Maybe) t)
-+ return (snd $ paramFieldNames field_pfx fd, myNotStrict, AppT (ConT ''Maybe) t)
-
- -- | Build a parameter declaration.
- --
diff --git a/debian/patches/ghc8-fixes b/debian/patches/ghc8-fixes
new file mode 100644
index 0000000..fe99364
--- /dev/null
+++ b/debian/patches/ghc8-fixes
@@ -0,0 +1,280 @@
+--- a/src/Ganeti/Metad/WebServer.hs
++++ b/src/Ganeti/Metad/WebServer.hs
+@@ -39,7 +39,7 @@
+ import Control.Concurrent (MVar, readMVar)
+ import Control.Monad.Error.Class (MonadError, catchError, throwError)
+ import Control.Monad.IO.Class (liftIO)
+-import qualified Control.Monad.CatchIO as CatchIO (catch)
++import Control.Exception.Lifted (catch)
+ import qualified Data.CaseInsensitive as CI
+ import Data.List (intercalate)
+ import Data.Map (Map)
+@@ -105,7 +105,7 @@
+ maybeResult (JSON.readJSON instParams >>=
+ Config.getPublicOsParams >>=
+ getOsPackage) $ \package ->
+- serveFile package `CatchIO.catch` \err ->
++ serveFile package `catch` \err ->
+ throwError $ "Could not serve OS package: " ++ show (err :: IOError)
+ where getOsPackage osParams =
+ case lookup key (JSON.fromJSObject osParams) of
+@@ -130,7 +130,7 @@
+ throwError $ "Could not find OS script " ++ show (os </> script)
+ serveScript os (d:ds) =
+ serveFile (d </> os </> script)
+- `CatchIO.catch`
++ `catch`
+ \err -> do let _ = err :: IOError
+ serveScript os ds
+
+--- a/src/Ganeti/THH.hs
++++ b/src/Ganeti/THH.hs
+@@ -105,6 +105,8 @@
+ import Ganeti.PyValue
+ import Ganeti.THH.PyType
+
++myNotStrict :: Bang
++myNotStrict = Bang NoSourceUnpackedness NoSourceStrictness
+
+ -- * Exported types
+
+@@ -417,15 +419,16 @@
+ buildConsField :: Q Type -> StrictTypeQ
+ buildConsField ftype = do
+ ftype' <- ftype
+- return (NotStrict, ftype')
++ return (myNotStrict, ftype')
+
+ -- | Builds a constructor based on a simple definition (not field-based).
+ buildSimpleCons :: Name -> SimpleObject -> Q Dec
+ buildSimpleCons tname cons = do
++ names <- mapM conT [''Show, ''Eq]
+ decl_d <- mapM (\(cname, fields) -> do
+ fields' <- mapM (buildConsField . snd) fields
+ return $ NormalC (mkName cname) fields') cons
+- return $ DataD [] tname [] decl_d [''Show, ''Eq]
++ return $ DataD [] tname [] Nothing decl_d names
+
+ -- | Generate the save function for a given type.
+ genSaveSimpleObj :: Name -- ^ Object type
+@@ -444,11 +447,11 @@
+ -- | Generates a data type declaration.
+ --
+ -- The type will have a fixed list of instances.
+-strADTDecl :: Name -> [String] -> Dec
+-strADTDecl name constructors =
+- DataD [] name []
++strADTDecl :: Name -> [String] -> Q Dec
++strADTDecl name constructors = do
++ DataD [] name [] Nothing
+ (map (flip NormalC [] . mkName) constructors)
+- [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
++ <$> mapM conT [''Show, ''Eq, ''Enum, ''Bounded, ''Ord]
+
+ -- | Generates a toRaw function.
+ --
+@@ -522,9 +525,9 @@
+ :: (a -> Either String Name) -> Name -> String -> [(String, a)] -> Q [Dec]
+ declareADT fn traw sname cons = do
+ let name = mkName sname
+- ddecl = strADTDecl name (map fst cons)
+ -- process cons in the format expected by genToRaw
+ cons' = map (second fn) cons
++ ddecl <- strADTDecl (mkName sname) (map fst cons)
+ toraw <- genToRaw traw (toRawName sname) name cons'
+ fromraw <- genFromRaw traw (fromRawName sname) name cons'
+ return $ ddecl:toraw ++ fromraw
+@@ -592,7 +595,7 @@
+ let base = nameBase name
+ showJ <- genShowJSON base
+ readJ <- genReadJSON base
+- return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
++ return [InstanceD Nothing [] (AppT (ConT ''JSON.JSON) (ConT name)) [readJ,showJ]]
+
+ -- * Template code for opcodes
+
+@@ -617,7 +620,7 @@
+ reifyConsNames name = do
+ reify_result <- reify name
+ case reify_result of
+- TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons
++ TyConI (DataD _ _ _ Nothing cons _) -> mapM (liftM nameBase . constructorName) cons
+ o -> fail $ "Unhandled name passed to reifyConsNames, expected\
+ \ type constructor but got '" ++ show o ++ "'"
+
+@@ -766,7 +769,7 @@
+ genOpCodeDictObject tname savefn loadfn cons = do
+ tdclauses <- genSaveOpCode cons savefn
+ fdclauses <- genLoadOpCode cons loadfn
+- return [ InstanceD [] (AppT (ConT ''DictObject) (ConT tname))
++ return [ InstanceD Nothing [] (AppT (ConT ''DictObject) (ConT tname))
+ [ FunD 'toDict tdclauses
+ , FunD 'fromDictWKeys fdclauses
+ ]]
+@@ -787,7 +790,7 @@
+ fields' <- mapM (fieldTypeInfo "op") fields
+ return $ RecC (mkName cname) fields')
+ cons
+- let declD = DataD [] tname [] decl_d [''Show, ''Eq]
++ declD <- DataD [] tname [] Nothing decl_d <$> mapM conT [''Show, ''Eq]
+ let (allfsig, allffn) = genAllOpFields "allOpFields" cons
+ -- DictObject
+ let luxiCons = map opcodeConsToLuxiCons cons
+@@ -911,10 +914,10 @@
+ decl_d <- mapM (\(cname, fields) -> do
+ -- we only need the type of the field, without Q
+ fields' <- mapM actualFieldType fields
+- let fields'' = zip (repeat NotStrict) fields'
++ let fields'' = zip (repeat myNotStrict) fields'
+ return $ NormalC (mkName cname) fields'')
+ cons
+- let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq]
++ declD <- DataD [] (mkName name) [] Nothing decl_d <$> mapM conT [''Show, ''Eq]
+ -- generate DictObject instance
+ dictObjInst <- genOpCodeDictObject tname saveLuxiConstructor
+ loadOpConstructor cons
+@@ -949,7 +952,7 @@
+ fieldTypeInfo field_pfx fd = do
+ t <- actualFieldType fd
+ let n = mkName . (field_pfx ++) . fieldRecordName $ fd
+- return (n, NotStrict, t)
++ return (n, myNotStrict, t)
+
+ -- | Build an object declaration.
+ buildObject :: String -> String -> [Field] -> Q [Dec]
+@@ -961,7 +964,7 @@
+ let name = mkName sname
+ fields_d <- mapM (fieldTypeInfo field_pfx) fields
+ let decl_d = RecC name fields_d
+- let declD = DataD [] name [] [decl_d] [''Show, ''Eq]
++ declD <- DataD [] name [] Nothing [decl_d] <$> mapM conT [''Show, ''Eq]
+ ser_decls <- buildObjectSerialisation sname fields
+ return $ declD:ser_decls
+
+@@ -1056,10 +1059,10 @@
+ (map makeOptional fields)
+ let name = mkName sname
+ real_d = NormalC (mkName real_nm)
+- [(NotStrict, ConT (mkName real_data_nm))]
++ [(myNotStrict, ConT (mkName real_data_nm))]
+ forth_d = NormalC (mkName forth_nm)
+- [(NotStrict, ConT (mkName forth_data_nm))]
+- declD = DataD [] name [] [real_d, forth_d] [''Show, ''Eq]
++ [(myNotStrict, ConT (mkName forth_data_nm))]
++ declD <- DataD [] name [] Nothing [real_d, forth_d] <$> mapM conT [''Show, ''Eq]
+
+ read_body <- [| branchOnField "forthcoming"
+ (liftM $(conE $ mkName forth_nm) . JSON.readJSON)
+@@ -1075,7 +1078,7 @@
+ , Clause [ConP (mkName forth_nm) [VarP x]]
+ (NormalB show_forth_body) []
+ ]
+- instJSONdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
++ instJSONdecl = InstanceD Nothing [] (AppT (ConT ''JSON.JSON) (ConT name))
+ [rdjson, shjson]
+ accessors <- liftM concat . flip mapM fields
+ $ buildAccessor (mkName forth_nm) forth_pfx
+@@ -1100,7 +1103,7 @@
+ ]
+ fromdict = FunD 'fromDictWKeys [ Clause [VarP xs]
+ (NormalB fromDictWKeysbody) [] ]
+- instDict = InstanceD [] (AppT (ConT ''DictObject) (ConT name))
++ instDict = InstanceD Nothing [] (AppT (ConT ''DictObject) (ConT name))
+ [todict, fromdict]
+ instArray <- genArrayObjectInstance name
+ (simpleField "forthcoming" [t| Bool |] : fields)
+@@ -1127,7 +1130,7 @@
+ (loadsig, loadfn) <- genLoadObject sname
+ shjson <- objectShowJSON sname
+ rdjson <- objectReadJSON sname
+- let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
++ let instdecl = InstanceD Nothing [] (AppT (ConT ''JSON.JSON) (ConT name))
+ [rdjson, shjson]
+ return $ dictdecls ++ savedecls ++ [loadsig, loadfn, instdecl]
+
+@@ -1193,7 +1196,7 @@
+ -- the ArrayObject instance generated from DictObject
+ arrdec <- genArrayObjectInstance name fields
+ -- the final instance
+- return $ [InstanceD [] (AppT (ConT ''DictObject) (ConT name))
++ return $ [InstanceD Nothing [] (AppT (ConT ''DictObject) (ConT name))
+ [ FunD 'toDict [tdclause]
+ , FunD 'fromDictWKeys [fdclause]
+ ]]
+@@ -1324,7 +1327,7 @@
+ paramFieldTypeInfo :: String -> Field -> VarStrictTypeQ
+ paramFieldTypeInfo field_pfx fd = do
+ t <- actualFieldType fd
+- return (snd $ paramFieldNames field_pfx fd, NotStrict, AppT (ConT ''Maybe) t)
++ return (snd $ paramFieldNames field_pfx fd, myNotStrict, AppT (ConT ''Maybe) t)
+
+ -- | Build a parameter declaration.
+ --
+@@ -1343,8 +1346,8 @@
+ fields_p <- mapM (paramFieldTypeInfo field_pfx) fields
+ let decl_f = RecC name_f fields_f
+ decl_p = RecC name_p fields_p
+- let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq]
+- declP = DataD [] name_p [] [decl_p] [''Show, ''Eq]
++ declF <- DataD [] name_f [] Nothing [decl_f] <$> mapM conT [''Show, ''Eq]
++ declP <- DataD [] name_p [] Nothing [decl_p] <$> mapM conT [''Show, ''Eq]
+ ser_decls_f <- buildObjectSerialisation sname_f fields
+ ser_decls_p <- buildPParamSerialisation sname_p fields
+ fill_decls <- fillParam sname field_pfx fields
+@@ -1368,7 +1371,7 @@
+ (loadsig, loadfn) <- genLoadObject sname
+ shjson <- objectShowJSON sname
+ rdjson <- objectReadJSON sname
+- let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))
++ let instdecl = InstanceD Nothing [] (AppT (ConT ''JSON.JSON) (ConT name))
+ [rdjson, shjson]
+ return $ dictdecls ++ savedecls ++ [loadsig, loadfn, instdecl]
+
+@@ -1438,12 +1441,12 @@
+ mappendClause = Clause [pConP, pConP2] (NormalB mappendExp) []
+ let monoidType = AppT (ConT ''Monoid) (ConT name_p)
+ -- the instances combined
+- return [ InstanceD [] instType
++ return [ InstanceD Nothing [] instType
+ [ FunD 'fillParams [fclause]
+ , FunD 'toPartial [tpclause]
+ , FunD 'toFilled [tfclause]
+ ]
+- , InstanceD [] monoidType
++ , InstanceD Nothing [] monoidType
+ [ FunD 'mempty [memptyClause]
+ , FunD 'mappend [mappendClause]
+ ]]
+--- a/src/Ganeti/THH/HsRPC.hs
++++ b/src/Ganeti/THH/HsRPC.hs
+@@ -73,7 +73,7 @@
+ #if MIN_VERSION_monad_control(1,0,0)
+ -- Needs Undecidable instances
+ type StM RpcClientMonad b = StM (ReaderT Client ResultG) b
+- liftBaseWith f = RpcClientMonad . liftBaseWith
++ liftBaseWith f = RpcClientMonad $ liftBaseWith
+ $ \r -> f (r . runRpcClientMonad)
+ restoreM = RpcClientMonad . restoreM
+ #else
+--- a/src/Ganeti/THH/Types.hs
++++ b/src/Ganeti/THH/Types.hs
+@@ -68,7 +68,7 @@
+ typeOfFun name = reify name >>= args
+ where
+ args :: Info -> Q Type
+- args (VarI _ tp _ _) = return tp
++ args (VarI _ tp _) = return tp
+ args _ = fail $ "Not a function: " ++ show name
+
+ -- | Splits a function type into the types of its arguments and the result.
+--- a/src/Ganeti/WConfd/Monad.hs
++++ b/src/Ganeti/WConfd/Monad.hs
+@@ -181,7 +181,7 @@
+ #if MIN_VERSION_monad_control(1,0,0)
+ -- Needs Undecidable instances
+ type StM WConfdMonadInt b = StM WConfdMonadIntType b
+- liftBaseWith f = WConfdMonadInt . liftBaseWith
++ liftBaseWith f = WConfdMonadInt $ liftBaseWith
+ $ \r -> f (r . getWConfdMonadInt)
+ restoreM = WConfdMonadInt . restoreM
+ #else
diff --git a/debian/patches/series b/debian/patches/series
index 9cf0382..e82fd23 100644
--- a/debian/patches/series
+++ b/debian/patches/series
@@ -8,3 +8,4 @@ fix_ftbfs_with_sphinx_1.4
use-proper-cabal-dev.patch
0001-Drop-dependency-on-MonadCatchIO-transformers.patch
0001-GHC-8-support.patch
+ghc8-fixes
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-ganeti/ganeti.git
More information about the Pkg-ganeti-devel
mailing list