Binary.hs 4.46 KB
Newer Older
Simon Marlow's avatar
add CPP    
Simon Marlow committed
1
{-# LANGUAGE CPP, RecordWildCards, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
2
3
4
5
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- This module deliberately defines orphan instances for now. Should
-- become unnecessary once we move to using the binary package properly:
{-# OPTIONS_GHC -fno-warn-orphans #-}
6
7
8
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.InstalledPackageInfo.Binary
-- Copyright   :  (c) The University of Glasgow 2009
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Portability :  portable
--

module Distribution.InstalledPackageInfo.Binary (
       readBinPackageDB,
       writeBinPackageDB
  ) where

import Distribution.Version
Simon Marlow's avatar
Simon Marlow committed
24
import Distribution.Package hiding (depends)
25
26
27
import Distribution.License
import Distribution.InstalledPackageInfo as IPI
import Data.Binary as Bin
28
import Control.Exception as Exception
29
30

readBinPackageDB :: Binary m => FilePath -> IO [InstalledPackageInfo_ m]
31
32
33
34
35
36
37
38
39
readBinPackageDB file
    = do xs <- Bin.decodeFile file
         _ <- Exception.evaluate $ length xs
         return xs
      `catchUserError`
      (\err -> error ("While parsing " ++ show file ++ ": " ++ err))

catchUserError :: IO a -> (String -> IO a) -> IO a
catchUserError io f = io `Exception.catch` \(ErrorCall err) -> f err
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58

writeBinPackageDB :: Binary m => FilePath -> [InstalledPackageInfo_ m] -> IO ()
writeBinPackageDB file ipis = Bin.encodeFile file ipis

instance Binary m => Binary (InstalledPackageInfo_ m) where
  put = putInstalledPackageInfo
  get = getInstalledPackageInfo

putInstalledPackageInfo :: Binary m => InstalledPackageInfo_ m -> Put
putInstalledPackageInfo ipi = do
  put (sourcePackageId ipi)
  put (installedPackageId ipi)
  put (license ipi)
  put (copyright ipi)
  put (maintainer ipi)
  put (author ipi)
  put (stability ipi)
  put (homepage ipi)
  put (pkgUrl ipi)
Ian Lynagh's avatar
Ian Lynagh committed
59
  put (synopsis ipi)
60
61
62
63
64
  put (description ipi)
  put (category ipi)
  put (exposed ipi)
  put (exposedModules ipi)
  put (hiddenModules ipi)
65
  put (trusted ipi)
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
  put (importDirs ipi)
  put (libraryDirs ipi)
  put (hsLibraries ipi)
  put (extraLibraries ipi)
  put (extraGHCiLibraries ipi)
  put (includeDirs ipi)
  put (includes ipi)
  put (IPI.depends ipi)
  put (hugsOptions ipi)
  put (ccOptions ipi)
  put (ldOptions ipi)
  put (frameworkDirs ipi)
  put (frameworks ipi)
  put (haddockInterfaces ipi)
  put (haddockHTMLs ipi)

getInstalledPackageInfo :: Binary m => Get (InstalledPackageInfo_ m)
getInstalledPackageInfo = do
  sourcePackageId <- get
  installedPackageId <- get
  license <- get
  copyright <- get
  maintainer <- get
  author <- get
  stability <- get
  homepage <- get
  pkgUrl <- get
Ian Lynagh's avatar
Ian Lynagh committed
93
  synopsis <- get
94
95
96
97
98
  description <- get
  category <- get
  exposed <- get
  exposedModules <- get
  hiddenModules <- get
99
  trusted <- get
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
  importDirs <- get
  libraryDirs <- get
  hsLibraries <- get
  extraLibraries <- get
  extraGHCiLibraries <- get
  includeDirs <- get
  includes <- get
  depends <- get
  hugsOptions <- get
  ccOptions <- get
  ldOptions <- get
  frameworkDirs <- get
  frameworks <- get
  haddockInterfaces <- get
  haddockHTMLs <- get
  return InstalledPackageInfo{..}

instance Binary PackageIdentifier where
  put pid = do put (pkgName pid); put (pkgVersion pid)
  get = do 
    pkgName <- get
    pkgVersion <- get
    return PackageIdentifier{..}

instance Binary License where
  put (GPL v)              = do putWord8 0; put v
  put (LGPL v)             = do putWord8 1; put v
  put BSD3                 = do putWord8 2
  put BSD4                 = do putWord8 3
  put MIT                  = do putWord8 4
  put PublicDomain         = do putWord8 5
  put AllRightsReserved    = do putWord8 6
  put OtherLicense         = do putWord8 7
pcapriotti's avatar
pcapriotti committed
133
134
  put (Apache v)           = do putWord8 8; put v
  put (UnknownLicense str) = do putWord8 9; put str
135
136
137
138
139
140
141
142
143
144
145
146

  get = do
    n <- getWord8
    case n of
      0 -> do v <- get; return (GPL v)
      1 -> do v <- get; return (LGPL v)
      2 -> return BSD3
      3 -> return BSD4
      4 -> return MIT
      5 -> return PublicDomain
      6 -> return AllRightsReserved
      7 -> return OtherLicense
pcapriotti's avatar
pcapriotti committed
147
      8 -> do v <- get; return (Apache v)
Simon Marlow's avatar
Simon Marlow committed
148
      _ -> do str <- get; return (UnknownLicense str)
149
150
151
152
153
154
155

instance Binary Version where
  put v = do put (versionBranch v); put (versionTags v)
  get = do versionBranch <- get; versionTags <- get; return Version{..}

deriving instance Binary PackageName
deriving instance Binary InstalledPackageId