Commit b67fba28 authored by Ben Gamari's avatar Ben Gamari 🐢

Fix cql-4.0.1 patch

parent 104f6282
diff --git a/src/Database/CQL/Protocol/Codec.hs b/src/Database/CQL/Protocol/Codec.hs
index 4378751..3ad7b22 100644
--- a/src/Database/CQL/Protocol/Codec.hs
+++ b/src/Database/CQL/Protocol/Codec.hs
@@ -249,9 +249,9 @@ encodeSockAddr (SockAddrInet6 p _ (a, b, c, d) _) = do
putWord32host c
putWord32host d
putWord32be (fromIntegral p)
-encodeSockAddr (SockAddrUnix _) = fail "encode-socket: unix address not allowed"
+encodeSockAddr (SockAddrUnix _) = error "encode-socket: unix address not allowed"
#if MIN_VERSION_network(2,6,1) && !MIN_VERSION_network(3,0,0)
-encodeSockAddr (SockAddrCan _) = fail "encode-socket: can address not allowed"
+encodeSockAddr (SockAddrCan _) = error "encode-socket: can address not allowed"
#endif
decodeSockAddr :: Get SockAddr
@@ -307,7 +307,7 @@ decodeConsistency = decodeShort >>= mapCode
mapCode 0x08 = return Serial
mapCode 0x09 = return LocalSerial
mapCode 0x0A = return LocalOne
- mapCode code = fail $ "decode-consistency: unknown: " ++ show code
+ mapCode code = error $ "decode-consistency: unknown: " ++ show code
------------------------------------------------------------------------------
-- OpCode
@@ -431,13 +431,13 @@ putValue _ (CqlDecimal x) = toBytes $ do
put (fromIntegral (decimalPlaces x) :: Int32)
integer2bytes (decimalMantissa x)
putValue V4 (CqlDate x) = toBytes $ put x
-putValue _ v@(CqlDate _) = fail $ "putValue: date: " ++ show v
+putValue _ v@(CqlDate _) = error $ "putValue: date: " ++ show v
putValue V4 (CqlTime x) = toBytes $ put x
-putValue _ v@(CqlTime _) = fail $ "putValue: time: " ++ show v
+putValue _ v@(CqlTime _) = error $ "putValue: time: " ++ show v
putValue V4 (CqlSmallInt x) = toBytes $ put x
-putValue _ v@(CqlSmallInt _) = fail $ "putValue: smallint: " ++ show v
+putValue _ v@(CqlSmallInt _) = error $ "putValue: smallint: " ++ show v
putValue V4 (CqlTinyInt x) = toBytes $ put x
-putValue _ v@(CqlTinyInt _) = fail $ "putValue: tinyint: " ++ show v
+putValue _ v@(CqlTinyInt _) = error $ "putValue: tinyint: " ++ show v
putValue v (CqlUdt x) = toBytes $ mapM_ (putValue v . snd) x
putValue v (CqlList x) = toBytes $ do
encodeInt (fromIntegral (length x))
diff --git a/src/Database/CQL/Protocol/Record.hs b/src/Database/CQL/Protocol/Record.hs
index c69e454..d4ad7f2 100644
index c69e454..51cedf1 100644
--- a/src/Database/CQL/Protocol/Record.hs
+++ b/src/Database/CQL/Protocol/Record.hs
@@ -13,8 +13,10 @@ import Language.Haskell.TH
......@@ -14,3 +57,43 @@ index c69e454..d4ad7f2 100644
#endif
type family TupleType a
@@ -99,7 +101,11 @@ asTupleDecl c =
go n t = do
vars <- replicateM (length t) (newName "a")
return $ Clause [ConP n (map VarP vars)] (body vars) []
+#if MIN_VERSION_template_haskell(2,16,0)
+ body = NormalB . TupE . map (Just . VarE)
+#else
body = NormalB . TupE . map VarE
+#endif
asRecrdDecl ::Con -> Q Clause
asRecrdDecl c =
diff --git a/src/Database/CQL/Protocol/Tuple/TH.hs b/src/Database/CQL/Protocol/Tuple/TH.hs
index 7f8fa50..e0bcd47 100644
--- a/src/Database/CQL/Protocol/Tuple/TH.hs
+++ b/src/Database/CQL/Protocol/Tuple/TH.hs
@@ -74,7 +74,11 @@ tupleDecl n = do
star = flip UInfixE (var "<*>")
comb = do
names <- replicateM n (newName "x")
+#if MIN_VERSION_template_haskell(2,16,0)
+ let f = NormalB $ TupE (map (Just . VarE) names)
+#else
let f = NormalB $ TupE (map VarE names)
+#endif
return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]
-- store v (a, b) = put (2 :: Word16) >> putValue v (toCql a) >> putValue v (toCql b)
@@ -151,7 +155,11 @@ cqlInstances n = do
fn names = map (AppE (var "fromCql") . VarE) names
combine = do
names <- replicateM n (newName "x")
+#if MIN_VERSION_template_haskell(0,16,0)
+ let f = NormalB $ TupE (map (Just . VarE) names)
+#else
let f = NormalB $ TupE (map VarE names)
+#endif
return [ FunD (mkName "combine") [Clause (map VarP names) f []] ]
failure = LitE (StringL $ "Expected CqlTuple with " ++ show n ++ " elements")
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment