1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3-- For PackageDescription and friends 4{-# OPTIONS_GHC -fno-warn-orphans #-} 5-- For encodeCtrN/decodeCtrBodyN/etc 6{-# OPTIONS_GHC -fno-warn-missing-signatures #-} 7module Macro.CBOR (serialise, deserialise, deserialiseNull) where 8 9import Macro.Types 10 11import Codec.Serialise.Class 12import Codec.Serialise.Encoding hiding (Tokens(..)) 13import Codec.Serialise.Decoding hiding (DecodeAction(Done, Fail)) 14import Codec.CBOR.Read 15import Codec.CBOR.Write 16 17#if ! MIN_VERSION_base(4,11,0) 18import Data.Monoid 19#endif 20 21import qualified Data.ByteString.Lazy as BS 22import qualified Data.ByteString.Builder as BS 23 24import Control.Exception (throw) 25#if !MIN_VERSION_base(4,8,0) 26import Control.Applicative 27import Data.Word 28#endif 29 30serialise :: [GenericPackageDescription] -> BS.ByteString 31--serialise :: Serialise a => a -> BS.ByteString 32serialise = BS.toLazyByteString . toBuilder . encode 33 34deserialise :: BS.ByteString -> [GenericPackageDescription] 35deserialise = either throw snd . deserialiseFromBytes decode 36 37deserialiseNull :: BS.ByteString -> () 38deserialiseNull = either throw snd . deserialiseFromBytes decodeListNull 39 where 40 decodeListNull :: Decoder s () 41 decodeListNull = do decodeListLenIndef; go 42 43 go = do stop <- decodeBreakOr 44 if stop then return () 45 else do !_ <- decode :: Decoder s GenericPackageDescription 46 go 47 48encodeCtr0 n = encodeListLen 1 <> encode (n :: Word) 49encodeCtr1 n a = encodeListLen 2 <> encode (n :: Word) <> encode a 50encodeCtr2 n a b = encodeListLen 3 <> encode (n :: Word) <> encode a <> encode b 51encodeCtr3 n a b c 52 = encodeListLen 4 <> encode (n :: Word) <> encode a <> encode b 53 <> encode c 54encodeCtr4 n a b c d 55 = encodeListLen 5 <> encode (n :: Word) <> encode a <> encode b 56 <> encode c <> encode d 57encodeCtr6 n a b c d e f 58 = encodeListLen 7 <> encode (n :: Word) <> encode a <> encode b 59 <> encode c <> encode d <> encode e <> encode f 60encodeCtr7 n a b c d e f g 61 = encodeListLen 8 <> encode (n :: Word) <> encode a <> encode b 62 <> encode c <> encode d <> encode e <> encode f 63 <> encode g 64 65{-# INLINE encodeCtr0 #-} 66{-# INLINE encodeCtr1 #-} 67{-# INLINE encodeCtr2 #-} 68{-# INLINE encodeCtr3 #-} 69{-# INLINE encodeCtr4 #-} 70{-# INLINE encodeCtr6 #-} 71{-# INLINE encodeCtr7 #-} 72 73{-# INLINE decodeCtrTag #-} 74{-# INLINE decodeCtrBody0 #-} 75{-# INLINE decodeCtrBody1 #-} 76{-# INLINE decodeCtrBody2 #-} 77 78decodeCtrTag = (\len tag -> (tag, len)) <$> decodeListLen <*> decodeWord 79 80decodeCtrBody0 1 f = pure f 81decodeCtrBody0 x _ = error $ "decodeCtrBody0: impossible tag " ++ show x 82decodeCtrBody1 2 f = do x1 <- decode 83 return $! f x1 84decodeCtrBody1 x _ = error $ "decodeCtrBody1: impossible tag " ++ show x 85decodeCtrBody2 3 f = do x1 <- decode 86 x2 <- decode 87 return $! f x1 x2 88decodeCtrBody2 x _ = error $ "decodeCtrBody2: impossible tag " ++ show x 89 90{-# INLINE decodeSingleCtr1 #-} 91{-# INLINE decodeSingleCtr2 #-} 92{-# INLINE decodeSingleCtr3 #-} 93{-# INLINE decodeSingleCtr4 #-} 94{-# INLINE decodeSingleCtr6 #-} 95{-# INLINE decodeSingleCtr7 #-} 96 97decodeSingleCtr1 v f = decodeListLenOf 2 *> decodeWordOf v *> pure f <*> decode 98decodeSingleCtr2 v f = decodeListLenOf 3 *> decodeWordOf v *> pure f <*> decode <*> decode 99decodeSingleCtr3 v f = decodeListLenOf 4 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode 100decodeSingleCtr4 v f = decodeListLenOf 5 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode 101decodeSingleCtr6 v f = decodeListLenOf 7 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode 102decodeSingleCtr7 v f = decodeListLenOf 8 *> decodeWordOf v *> pure f <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode <*> decode 103 104 105instance Serialise PackageName where 106 encode (PackageName a) = encodeCtr1 1 a 107 decode = decodeSingleCtr1 1 PackageName 108 109instance Serialise Version where 110 encode (Version a b) = encodeCtr2 1 a b 111 decode = decodeSingleCtr2 1 Version 112 113instance Serialise PackageId where 114 encode (PackageId a b) = encodeCtr2 1 a b 115 decode = decodeSingleCtr2 1 PackageId 116 117instance Serialise VersionRange where 118 encode AnyVersion = encodeCtr0 1 119 encode (ThisVersion a) = encodeCtr1 2 a 120 encode (LaterVersion a) = encodeCtr1 3 a 121 encode (EarlierVersion a) = encodeCtr1 4 a 122 encode (WildcardVersion a) = encodeCtr1 5 a 123 encode (UnionVersionRanges a b) = encodeCtr2 6 a b 124 encode (IntersectVersionRanges a b) = encodeCtr2 7 a b 125 encode (VersionRangeParens a) = encodeCtr1 8 a 126 127 decode = do 128 (t,l) <- decodeCtrTag 129 case t of 130 1 -> decodeCtrBody0 l AnyVersion 131 2 -> decodeCtrBody1 l ThisVersion 132 3 -> decodeCtrBody1 l LaterVersion 133 4 -> decodeCtrBody1 l EarlierVersion 134 5 -> decodeCtrBody1 l WildcardVersion 135 6 -> decodeCtrBody2 l UnionVersionRanges 136 7 -> decodeCtrBody2 l IntersectVersionRanges 137 8 -> decodeCtrBody1 l VersionRangeParens 138 x -> error $ "Serialise VersionRange: decode: impossible tag " ++ show x 139 140 141instance Serialise Dependency where 142 encode (Dependency a b) = encodeCtr2 1 a b 143 decode = decodeSingleCtr2 1 Dependency 144 145instance Serialise CompilerFlavor where 146 encode GHC = encodeCtr0 1 147 encode NHC = encodeCtr0 2 148 encode YHC = encodeCtr0 3 149 encode Hugs = encodeCtr0 4 150 encode HBC = encodeCtr0 5 151 encode Helium = encodeCtr0 6 152 encode JHC = encodeCtr0 7 153 encode LHC = encodeCtr0 8 154 encode UHC = encodeCtr0 9 155 encode (HaskellSuite a) = encodeCtr1 10 a 156 encode (OtherCompiler a) = encodeCtr1 11 a 157 158 decode = do 159 (t,l) <- decodeCtrTag 160 case t of 161 1 -> decodeCtrBody0 l GHC 162 2 -> decodeCtrBody0 l NHC 163 3 -> decodeCtrBody0 l YHC 164 4 -> decodeCtrBody0 l Hugs 165 5 -> decodeCtrBody0 l HBC 166 6 -> decodeCtrBody0 l Helium 167 7 -> decodeCtrBody0 l JHC 168 8 -> decodeCtrBody0 l LHC 169 9 -> decodeCtrBody0 l UHC 170 10 -> decodeCtrBody1 l HaskellSuite 171 11 -> decodeCtrBody1 l OtherCompiler 172 x -> error $ "Serialise CompilerFlavor: decode: impossible tag " ++ show x 173 174instance Serialise License where 175 encode (GPL a) = encodeCtr1 1 a 176 encode (AGPL a) = encodeCtr1 2 a 177 encode (LGPL a) = encodeCtr1 3 a 178 encode BSD3 = encodeCtr0 4 179 encode BSD4 = encodeCtr0 5 180 encode MIT = encodeCtr0 6 181 encode (Apache a) = encodeCtr1 7 a 182 encode PublicDomain = encodeCtr0 8 183 encode AllRightsReserved = encodeCtr0 9 184 encode OtherLicense = encodeCtr0 10 185 encode (UnknownLicense a) = encodeCtr1 11 a 186 187 decode = do 188 (t,l) <- decodeCtrTag 189 case t of 190 1 -> decodeCtrBody1 l GPL 191 2 -> decodeCtrBody1 l AGPL 192 3 -> decodeCtrBody1 l LGPL 193 4 -> decodeCtrBody0 l BSD3 194 5 -> decodeCtrBody0 l BSD4 195 6 -> decodeCtrBody0 l MIT 196 7 -> decodeCtrBody1 l Apache 197 8 -> decodeCtrBody0 l PublicDomain 198 9 -> decodeCtrBody0 l AllRightsReserved 199 10 -> decodeCtrBody0 l OtherLicense 200 11 -> decodeCtrBody1 l UnknownLicense 201 x -> error $ "Serialise License: decode: impossible tag " ++ show x 202 203instance Serialise SourceRepo where 204 encode (SourceRepo a b c d e f g) = encodeCtr7 1 a b c d e f g 205 decode = decodeSingleCtr7 1 SourceRepo 206 207instance Serialise RepoKind where 208 encode RepoHead = encodeCtr0 1 209 encode RepoThis = encodeCtr0 2 210 encode (RepoKindUnknown a) = encodeCtr1 3 a 211 decode = do 212 (t,l) <- decodeCtrTag 213 case t of 214 1 -> decodeCtrBody0 l RepoHead 215 2 -> decodeCtrBody0 l RepoThis 216 3 -> decodeCtrBody1 l RepoKindUnknown 217 x -> error $ "Serialise RepoKind: decode: impossible tag " ++ show x 218 219instance Serialise RepoType where 220 encode Darcs = encodeCtr0 1 221 encode Git = encodeCtr0 2 222 encode SVN = encodeCtr0 3 223 encode CVS = encodeCtr0 4 224 encode Mercurial = encodeCtr0 5 225 encode GnuArch = encodeCtr0 6 226 encode Bazaar = encodeCtr0 7 227 encode Monotone = encodeCtr0 8 228 encode (OtherRepoType a) = encodeCtr1 9 a 229 230 decode = do 231 (t,l) <- decodeCtrTag 232 case t of 233 1 -> decodeCtrBody0 l Darcs 234 2 -> decodeCtrBody0 l Git 235 3 -> decodeCtrBody0 l SVN 236 4 -> decodeCtrBody0 l CVS 237 5 -> decodeCtrBody0 l Mercurial 238 6 -> decodeCtrBody0 l GnuArch 239 7 -> decodeCtrBody0 l Bazaar 240 8 -> decodeCtrBody0 l Monotone 241 9 -> decodeCtrBody1 l OtherRepoType 242 x -> error $ "Serialise RepoType: decode: impossible tag " ++ show x 243 244instance Serialise BuildType where 245 encode Simple = encodeCtr0 1 246 encode Configure = encodeCtr0 2 247 encode Make = encodeCtr0 3 248 encode Custom = encodeCtr0 4 249 encode (UnknownBuildType a) = encodeCtr1 5 a 250 251 decode = do 252 (t,l) <- decodeCtrTag 253 case t of 254 1 -> decodeCtrBody0 l Simple 255 2 -> decodeCtrBody0 l Configure 256 3 -> decodeCtrBody0 l Make 257 4 -> decodeCtrBody0 l Custom 258 5 -> decodeCtrBody1 l UnknownBuildType 259 x -> error $ "Serialise BuildType: decode: impossible tag " ++ show x 260 261instance Serialise Library where 262 encode (Library a b c) = encodeCtr3 1 a b c 263 decode = decodeSingleCtr3 1 Library 264 265instance Serialise Executable where 266 encode (Executable a b c) = encodeCtr3 1 a b c 267 decode = decodeSingleCtr3 1 Executable 268 269instance Serialise TestSuite where 270 encode (TestSuite a b c d) = encodeCtr4 1 a b c d 271 decode = decodeSingleCtr4 1 TestSuite 272 273instance Serialise TestSuiteInterface where 274 encode (TestSuiteExeV10 a b) = encodeCtr2 1 a b 275 encode (TestSuiteLibV09 a b) = encodeCtr2 2 a b 276 encode (TestSuiteUnsupported a) = encodeCtr1 3 a 277 278 decode = do 279 (t,l) <- decodeCtrTag 280 case t of 281 1 -> decodeCtrBody2 l TestSuiteExeV10 282 2 -> decodeCtrBody2 l TestSuiteLibV09 283 3 -> decodeCtrBody1 l TestSuiteUnsupported 284 x -> error $ 285 "Serialise TestSuiteInterface: decode: impossible tag " ++ show x 286 287instance Serialise TestType where 288 encode (TestTypeExe a) = encodeCtr1 1 a 289 encode (TestTypeLib a) = encodeCtr1 2 a 290 encode (TestTypeUnknown a b) = encodeCtr2 3 a b 291 292 decode = do 293 (t,l) <- decodeCtrTag 294 case t of 295 1 -> decodeCtrBody1 l TestTypeExe 296 2 -> decodeCtrBody1 l TestTypeLib 297 3 -> decodeCtrBody2 l TestTypeUnknown 298 x -> error $ "Serialise TestType: decode: impossible tag " ++ show x 299 300instance Serialise Benchmark where 301 encode (Benchmark a b c d) = encodeCtr4 1 a b c d 302 decode = decodeSingleCtr4 1 Benchmark 303 304instance Serialise BenchmarkInterface where 305 encode (BenchmarkExeV10 a b) = encodeCtr2 1 a b 306 encode (BenchmarkUnsupported a) = encodeCtr1 2 a 307 308 decode = do 309 (t,l) <- decodeCtrTag 310 case t of 311 1 -> decodeCtrBody2 l BenchmarkExeV10 312 2 -> decodeCtrBody1 l BenchmarkUnsupported 313 x -> error $ 314 "Serialise BenchmarkInterface: decode: impossible tag " ++ show x 315 316instance Serialise BenchmarkType where 317 encode (BenchmarkTypeExe a) = encodeCtr1 1 a 318 encode (BenchmarkTypeUnknown a b) = encodeCtr2 2 a b 319 320 decode = do 321 (t,l) <- decodeCtrTag 322 case t of 323 1 -> decodeCtrBody1 l BenchmarkTypeExe 324 2 -> decodeCtrBody2 l BenchmarkTypeUnknown 325 x -> error $ "Serialise BenchmarkType: decode: impossible tag " ++ show x 326 327instance Serialise ModuleName where 328 encode (ModuleName a) = encodeCtr1 1 a 329 decode = decodeSingleCtr1 1 ModuleName 330 331instance Serialise BuildInfo where 332 encode (BuildInfo a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 333 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 334 a21 a22 a23 a24 a25) = 335 encodeListLen 26 <> encode (1 :: Word) <> 336 encode a1 <> encode a2 <> encode a3 <> encode a4 <> encode a5 <> 337 encode a6 <> encode a7 <> encode a8 <> encode a9 <> encode a10 <> 338 encode a11 <> encode a12 <> encode a13 <> encode a14 <> encode a15 <> 339 encode a16 <> encode a17 <> encode a18 <> encode a19 <> encode a20 <> 340 encode a21 <> encode a22 <> encode a23 <> encode a24 <> encode a25 341 342 decode = decodeListLenOf 26 *> decodeWordOf 1 *> 343 pure BuildInfo <*> decode <*> decode <*> decode <*> decode <*> decode 344 <*> decode <*> decode <*> decode <*> decode <*> decode 345 <*> decode <*> decode <*> decode <*> decode <*> decode 346 <*> decode <*> decode <*> decode <*> decode <*> decode 347 <*> decode <*> decode <*> decode <*> decode <*> decode 348 349instance Serialise Language where 350 encode Haskell98 = encodeCtr0 1 351 encode Haskell2010 = encodeCtr0 2 352 encode (UnknownLanguage a) = encodeCtr1 3 a 353 354 decode = do 355 (t,l) <- decodeCtrTag 356 case t of 357 1 -> decodeCtrBody0 l Haskell98 358 2 -> decodeCtrBody0 l Haskell2010 359 3 -> decodeCtrBody1 l UnknownLanguage 360 x -> error $ "Serialise Language: decode: impossible tag " ++ show x 361 362instance Serialise Extension where 363 encode (EnableExtension a) = encodeCtr1 1 a 364 encode (DisableExtension a) = encodeCtr1 2 a 365 encode (UnknownExtension a) = encodeCtr1 3 a 366 367 decode = do 368 (t,l) <- decodeCtrTag 369 case t of 370 1 -> decodeCtrBody1 l EnableExtension 371 2 -> decodeCtrBody1 l DisableExtension 372 3 -> decodeCtrBody1 l UnknownExtension 373 x -> error $ "Serialise Extension: decode: impossible tag " ++ show x 374 375instance Serialise KnownExtension where 376 encode ke = encodeCtr1 1 (fromEnum ke) 377 decode = decodeSingleCtr1 1 toEnum 378 379instance Serialise PackageDescription where 380 encode (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 381 a11 a12 a13 a14 a15 a16 a17 a18 a19 a20 382 a21 a22 a23 a24 a25 a26 a27 a28) = 383 encodeListLen 29 <> encode (1 :: Word) <> 384 encode a1 <> encode a2 <> encode a3 <> encode a4 <> encode a5 <> 385 encode a6 <> encode a7 <> encode a8 <> encode a9 <> encode a10 <> 386 encode a11 <> encode a12 <> encode a13 <> encode a14 <> encode a15 <> 387 encode a16 <> encode a17 <> encode a18 <> encode a19 <> encode a20 <> 388 encode a21 <> encode a22 <> encode a23 <> encode a24 <> encode a25 <> 389 encode a26 <> encode a27 <> encode a28 390 391 decode = decodeListLenOf 29 *> decodeWordOf 1 *> 392 pure PackageDescription 393 <*> decode <*> decode <*> decode <*> decode <*> decode 394 <*> decode <*> decode <*> decode <*> decode <*> decode 395 <*> decode <*> decode <*> decode <*> decode <*> decode 396 <*> decode <*> decode <*> decode <*> decode <*> decode 397 <*> decode <*> decode <*> decode <*> decode <*> decode 398 <*> decode <*> decode <*> decode 399 400instance Serialise OS where 401 encode Linux = encodeCtr0 1 402 encode Windows = encodeCtr0 2 403 encode OSX = encodeCtr0 3 404 encode FreeBSD = encodeCtr0 4 405 encode OpenBSD = encodeCtr0 5 406 encode NetBSD = encodeCtr0 6 407 encode Solaris = encodeCtr0 7 408 encode AIX = encodeCtr0 8 409 encode HPUX = encodeCtr0 9 410 encode IRIX = encodeCtr0 10 411 encode HaLVM = encodeCtr0 11 412 encode IOS = encodeCtr0 12 413 encode (OtherOS a) = encodeCtr1 13 a 414 415 decode = do 416 (t,l) <- decodeCtrTag 417 case t of 418 1 -> decodeCtrBody0 l Linux 419 2 -> decodeCtrBody0 l Windows 420 3 -> decodeCtrBody0 l OSX 421 4 -> decodeCtrBody0 l FreeBSD 422 5 -> decodeCtrBody0 l OpenBSD 423 6 -> decodeCtrBody0 l NetBSD 424 7 -> decodeCtrBody0 l Solaris 425 8 -> decodeCtrBody0 l AIX 426 9 -> decodeCtrBody0 l HPUX 427 10 -> decodeCtrBody0 l IRIX 428 11 -> decodeCtrBody0 l HaLVM 429 12 -> decodeCtrBody0 l IOS 430 13 -> decodeCtrBody1 l OtherOS 431 x -> error $ "Serialise OS: decode: impossible tag " ++ show x 432 433instance Serialise Arch where 434 encode I386 = encodeCtr0 1 435 encode X86_64 = encodeCtr0 2 436 encode PPC = encodeCtr0 3 437 encode PPC64 = encodeCtr0 4 438 encode Sparc = encodeCtr0 5 439 encode Arm = encodeCtr0 6 440 encode Mips = encodeCtr0 7 441 encode SH = encodeCtr0 8 442 encode IA64 = encodeCtr0 9 443 encode S390 = encodeCtr0 10 444 encode Alpha = encodeCtr0 11 445 encode Hppa = encodeCtr0 12 446 encode Rs6000 = encodeCtr0 13 447 encode M68k = encodeCtr0 14 448 encode (OtherArch a) = encodeCtr1 15 a 449 encode Vax = encodeCtr0 16 450 451 decode = do 452 (t,l) <- decodeCtrTag 453 case t of 454 1 -> decodeCtrBody0 l I386 455 2 -> decodeCtrBody0 l X86_64 456 3 -> decodeCtrBody0 l PPC 457 4 -> decodeCtrBody0 l PPC64 458 5 -> decodeCtrBody0 l Sparc 459 6 -> decodeCtrBody0 l Arm 460 7 -> decodeCtrBody0 l Mips 461 8 -> decodeCtrBody0 l SH 462 9 -> decodeCtrBody0 l IA64 463 10 -> decodeCtrBody0 l S390 464 11 -> decodeCtrBody0 l Alpha 465 12 -> decodeCtrBody0 l Hppa 466 13 -> decodeCtrBody0 l Rs6000 467 14 -> decodeCtrBody0 l M68k 468 15 -> decodeCtrBody1 l OtherArch 469 16 -> decodeCtrBody0 l Vax 470 x -> error $ "Serialise Arch: decode: impossible tag " ++ show x 471 472instance Serialise Flag where 473 encode (MkFlag a b c d) = encodeCtr4 1 a b c d 474 decode = decodeSingleCtr4 1 MkFlag 475 476instance Serialise FlagName where 477 encode (FlagName a) = encodeCtr1 1 a 478 decode = decodeSingleCtr1 1 FlagName 479 480instance (Serialise a, Serialise b, Serialise c) => Serialise (CondTree a b c) where 481 encode (CondNode a b c) = encodeCtr3 1 a b c 482 decode = decodeSingleCtr3 1 CondNode 483 484 {-# SPECIALIZE instance Serialise c => Serialise (CondTree ConfVar [Dependency] c) #-} 485 486instance Serialise ConfVar where 487 encode (OS a) = encodeCtr1 1 a 488 encode (Arch a) = encodeCtr1 2 a 489 encode (Flag a) = encodeCtr1 3 a 490 encode (Impl a b) = encodeCtr2 4 a b 491 492 decode = do 493 (t,l) <- decodeCtrTag 494 case t of 495 1 -> decodeCtrBody1 l OS 496 2 -> decodeCtrBody1 l Arch 497 3 -> decodeCtrBody1 l Flag 498 4 -> decodeCtrBody2 l Impl 499 x -> error $ "Serialise ConfVar: decode: impossible tag " ++ show x 500 501instance Serialise a => Serialise (Condition a) where 502 encode (Var a) = encodeCtr1 1 a 503 encode (Lit a) = encodeCtr1 2 a 504 encode (CNot a) = encodeCtr1 3 a 505 encode (COr a b) = encodeCtr2 4 a b 506 encode (CAnd a b) = encodeCtr2 5 a b 507 508 decode = do 509 (t,l) <- decodeCtrTag 510 case t of 511 1 -> decodeCtrBody1 l Var 512 2 -> decodeCtrBody1 l Lit 513 3 -> decodeCtrBody1 l CNot 514 4 -> decodeCtrBody2 l COr 515 5 -> decodeCtrBody2 l CAnd 516 x -> error $ "Serialise (Condition a): decode: impossible tag " ++ show x 517 518 {-# SPECIALIZE instance Serialise (Condition ConfVar) #-} 519 520instance Serialise GenericPackageDescription where 521 encode (GenericPackageDescription a b c d e f) = encodeCtr6 1 a b c d e f 522 decode = decodeSingleCtr6 1 GenericPackageDescription 523 524