Package.hs 18.6 KB
Newer Older
ijones's avatar
ijones committed
1
{-# OPTIONS -cpp -DDEBUG #-}
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Package
-- Copyright   :  Isaac Jones 2003-2004
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  
--
-- Explanation: <FIX>
-- WHERE DOES THIS MODULE FIT IN AT A HIGH-LEVEL <FIX>

{- Copyright (c) 2003-2004, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

45
module Distribution.Package (
simonmar's avatar
simonmar committed
46
47
	PackageIdentifier(..), 
	showPackageId,
48
	PackageDescription(..),
ijones's avatar
ijones committed
49
	emptyPackageDescription,
50
        parsePackageDesc,
ijones's avatar
ijones committed
51
#ifdef DEBUG        
52
        hunitTests,
ijones's avatar
ijones committed
53
        test
ijones's avatar
ijones committed
54
#endif
55
  ) where
56

md9ms's avatar
md9ms committed
57
58
59
60
import Control.Monad.State
import Control.Monad(when, foldM)
import Control.Monad.Error
import Data.Char(isSpace, toLower)
md9ms's avatar
md9ms committed
61
import Data.List(isPrefixOf)
ijones's avatar
ijones committed
62

63
64
import Distribution.Version(Version(..), VersionRange(..),
                            showVersion, parseVersion, parseVersionRange)
md9ms's avatar
md9ms committed
65
import Distribution.Misc(License(..), Dependency(..), Extension(..))
md9ms's avatar
md9ms committed
66
import Distribution.Setup(CompilerFlavor(..))
67

68
69
import System.IO(openFile, IOMode(..), hGetContents)

ijones's avatar
ijones committed
70
71
import Text.ParserCombinators.Parsec

ijones's avatar
ijones committed
72
#ifdef DEBUG
ijones's avatar
ijones committed
73
import HUnit (Test(..), (~:), (~=?), assertEqual, assertBool, Assertion, runTestTT)
ijones's avatar
ijones committed
74
75
#endif

76
77
data PackageIdentifier
    = PackageIdentifier {pkgName::String, pkgVersion::Version}
simonmar's avatar
simonmar committed
78
      deriving (Read, Show, Eq)
79

simonmar's avatar
simonmar committed
80
showPackageId :: PackageIdentifier -> String
ijones's avatar
ijones committed
81
showPackageId (PackageIdentifier n (Version [] _)) = n -- if no version, don't show version.
simonmar's avatar
simonmar committed
82
83
84
showPackageId pkgid = 
  pkgName pkgid ++ '-': showVersion (pkgVersion pkgid)

85
86
87
88
89
90
91
92
93
94
-- | This data type is the internal representation of the file @pkg.descr@.
-- It contains two kinds of information about the package: information
-- which is needed for all packages, such as the package name and version, and 
-- information which is needed for the simple build system only, such as 
-- the compiler options and library name.
-- 
data PackageDescription
    =  PackageDescription {
	-- the following are required by all packages:
	package        :: PackageIdentifier,
95
        license        :: License,
96
97
98
99
100
101
        copyright      :: String,
        maintainer     :: String,
        stability      :: String,

	-- the following are required by the simple build infrastructure only:
        buildDepends   :: [ Dependency ],
ijones's avatar
ijones committed
102
103
        allModules     :: [ String ],
        mainModules    :: [ String ],
simonmar's avatar
simonmar committed
104
        cSources       :: [ FilePath ],
ijones's avatar
ijones committed
105
	hsSourceDir    :: FilePath,
106
107
108
109
110
111
112
	exposedModules :: [ String ],
        extensions     :: [ Extension ],
        extraLibs      :: [ String ],
        includeDirs    :: [ FilePath ],
        includes       :: [ FilePath ],
        options        :: [ (CompilerFlavor, [String]) ]
    }
ijones's avatar
ijones committed
113
114
115
116
117
118
119
120
121
122
123
    deriving (Show, Read, Eq)

-- |Set the name for this package. Convenience function.
setPkgName :: String -> PackageDescription -> PackageDescription
setPkgName n desc@PackageDescription{package=pkgIdent}
    = desc{package=pkgIdent{pkgName=n}}

-- |Set the version for this package. Convenience function.
setPkgVersion :: Version -> PackageDescription -> PackageDescription
setPkgVersion v desc@PackageDescription{package=pkgIdent}
    = desc{package=pkgIdent{pkgVersion=v}}
124

md9ms's avatar
md9ms committed
125
126
127
128
129
-- |Add options for a specific compiler. Convenience function.
setPkgOptions :: CompilerFlavor -> [String] -> PackageDescription -> PackageDescription
setPkgOptions c xs desc@PackageDescription{options=opts}
    = desc{options=(c,xs):opts}

130
131
emptyPackageDescription :: PackageDescription
emptyPackageDescription
ijones's avatar
ijones committed
132
    =  PackageDescription {package      = PackageIdentifier "" (Version [] []),
133
                      license      = AllRightsReserved,
134
135
136
137
138
                      copyright    = "",
                      maintainer   = "",
                      stability    = "",
                      buildDepends = [],
                      allModules   = [],
ijones's avatar
ijones committed
139
                      mainModules   = [],
simonmar's avatar
simonmar committed
140
		      cSources     = [],
141
		      hsSourceDir  = ".", -- FIX: FileUtils.currentDir
142
143
144
145
146
147
		      exposedModules = [],
                      extensions   = [],
                      extraLibs    = [],
                      includeDirs  = [],
                      includes     = [],
                      options      = []
148
                     }
149

ijones's avatar
ijones committed
150
151
152
153
154

-- ------------------------------------------------------------
-- * Parsing
-- ------------------------------------------------------------

ijones's avatar
ijones committed
155
156
157
notImp :: String -> a
notImp s = error $ s ++ " not yet implemented"

158
159
160
161
162
-- |Parse the given package file.  FIX: don't use read / show.
parsePackageDesc :: FilePath -> IO PackageDescription
parsePackageDesc p
    = openFile p ReadMode >>= hGetContents >>= return . read

md9ms's avatar
md9ms committed
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
data PError = Parsec ParseError | FromString String
        deriving Show

instance Error PError where
        strMsg = FromString

parseDescription :: String -> Either PError PackageDescription
parseDescription inp = foldM parseDescHelp emptyPackageDescription (splitLines inp)
  where -- Required fields
        parseDescHelp pkg (f@"name",      val) = return (setPkgName val pkg)
        parseDescHelp pkg (f@"version",   val) =
          do v <- runP f parseVersion val
             return (setPkgVersion v pkg)
        parseDescHelp pkg (f@"copyright", val) = return pkg{copyright=val}
        parseDescHelp pkg (f@"license",   val) =
          do l <- runP f parseLicense val
             return pkg{license=l}
        -- Misc.
        parseDescHelp pkg (f@"maintainer", val) = return pkg{maintainer=val}
        parseDescHelp pkg (f@"stability",  val) = return pkg{stability=val}
        parseDescHelp pkg (f@"extra-libs", val) =
          do xs <- runP f (parseCommaList word) val
             return pkg{extraLibs=xs}
        parseDescHelp pkg (f@"build-depends", val) =
          do xs <- runP f (parseCommaList parseDependency) val
             return pkg{buildDepends=xs}
        -- Paths and stuff
        parseDescHelp pkg (f@"c-sources", val) =
191
192
          do paths <- runP f (parseCommaList parseFilePath) val
             return pkg{cSources=paths}
md9ms's avatar
md9ms committed
193
        parseDescHelp pkg (f@"include-dirs", val) =
194
195
          do paths <- runP f (parseCommaList parseFilePath) val
             return pkg{includeDirs=paths}
md9ms's avatar
md9ms committed
196
        parseDescHelp pkg (f@"includes", val) =
197
198
          do paths <- runP f (parseCommaList parseFilePath) val
             return pkg{includes=paths}
md9ms's avatar
md9ms committed
199
200
        parseDescHelp pkg (f@"hs-source-dir", val) =
          do path <- runP f parseFilePath val
201
             return pkg{hsSourceDir=path}
md9ms's avatar
md9ms committed
202
203
204
205
206
207
208
209
210
211
212
        -- Module related
        parseDescHelp pkg (f@"main-modules", val) =
          do xs <- runP f (parseCommaList moduleName) val
             return pkg{mainModules=xs}
        parseDescHelp pkg (f@"exposed-modules", val) =
          do xs <- runP f (parseCommaList moduleName) val
             return pkg{exposedModules=xs}
        parseDescHelp pkg (f@"modules", val) =
          do xs <- runP f (parseCommaList moduleName) val
             return pkg{allModules=xs}
        parseDescHelp pkg (f@"extensions", val) =
md9ms's avatar
md9ms committed
213
214
          do exts <- runP f (parseCommaList parseExtension) val
             return pkg{extensions=exts}
md9ms's avatar
md9ms committed
215
216
217
218
219
220
        parseDescHelp pkg (f, val) | "options-" `isPrefixOf` f =
          let compilers = [("ghc",GHC),("nhc",NHC),("hugs",Hugs)] -- FIXME
           in case lookup (drop 8 f) compilers of
                Just c -> do xs <- runP f (parseCommaList parseOption) val
                             return (setPkgOptions c xs pkg)
                Nothing -> error $ "Unknown compiler (" ++ drop 8 f ++ ")"
md9ms's avatar
md9ms committed
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
        parseDescHelp pkg (field, val) = error $ "Unknown field :: " ++ field
        -- ...
        runP f p s = case parse p f s of
                       Left pe -> Left (Parsec pe)
                       Right a -> Right a

splitLines :: String -> [(String,String)]
splitLines = merge . filter validLine . lines
  where validLine s = case dropWhile isSpace s of
                        ""        -> False      -- Empty line
                        '-':'-':_ -> False      -- Comment
                        _         -> True
        merge (x:(' ':s):ys) = case dropWhile isSpace s of
                                 "." -> merge ((x++"\n"):ys)
                                 s'  -> merge ((x++"\n"++s'):ys)
        merge (x:ys) = brk x : merge ys
        merge []     = []
        brk xs = case break (==':') xs of
                   (fld, ':':val) -> (map toLower fld, dropWhile isSpace val)
                   (fld, "")      -> error "FIXME"
ijones's avatar
ijones committed
241

242
-- |parse a module name
md9ms's avatar
md9ms committed
243
moduleName = many (alphaNum <|> oneOf "_'.") <?> "moduleName"
ijones's avatar
ijones committed
244

245
-- |FIX: must learn to escape whitespace
246
247
248
249
250
251
parseFilePath :: GenParser Char st FilePath
parseFilePath = liftM concat (many1 (
                        do try word
                           <|> toStr digit
                           <|> toStr (oneOf "!@#$%^&*()?></\\|]}[{.")
                       ))
md9ms's avatar
md9ms committed
252
        <?> "parseFilePath"
253

254
parseDependency :: GenParser Char st Dependency
md9ms's avatar
md9ms committed
255
parseDependency = do name <- many1 (letter <|> digit <|> oneOf "-_")
256
                     skipMany parseWhite
257
                     ver <- parseVersionRange <|> return AnyVersion
258
259
                     skipMany parseWhite
                     return $ Dependency name ver
md9ms's avatar
md9ms committed
260
        <?> "parseDependency"
261

262
263
264
265
parseLicense :: GenParser Char st License
parseLicense = choice [ try (string s >> return l) | (s,l) <- licenses]
        <?> "parseLicense"

ijones's avatar
ijones committed
266
267
268
269
270
271
272
273
274
-- |Mapping between the licenses and their names
licenses :: [(String, License)]
licenses= [("GPL", GPL),
           ("LGPL", LGPL),
           ("BSD3", BSD3),
           ("BSD4", BSD4),
           ("PublicDomain", PublicDomain),
           ("AllRightsReserved", AllRightsReserved)]

md9ms's avatar
md9ms committed
275
276
277
278
279
280
281
282
283
parseExtension :: GenParser Char st Extension
parseExtension = choice [ try (string s >> return e) | (s,e) <- extensionsMap ]
        <?> "parseExtension"

-- |Mapping between extensions and their names
extensionsMap = [("OverlappingInstances", OverlappingInstances),
                 ("TypeSynonymInstances", TypeSynonymInstances),
                 ("TemplateHaskell", TemplateHaskell)]

md9ms's avatar
md9ms committed
284
285
parseOption = many1 (letter <|> digit <|> oneOf "-+/\\._") -- FIXME

286
toStr c = c >>= \x -> return [x]
ijones's avatar
ijones committed
287
288

word :: GenParser Char st String
ijones's avatar
ijones committed
289
290
291
292
293
294
295
word = many1 letter <?> "word"

parseCommaList :: GenParser Char st a -- ^The parser for the stuff between commas
               -> GenParser Char st [a]
parseCommaList p
    = do words <- sepBy1 p separator
         return words
md9ms's avatar
md9ms committed
296
    where separator = spaces >> char ',' >> spaces
ijones's avatar
ijones committed
297
298

parseWhite = try parseSpaceNotNewline
299
            <|> (try (char '\n' >> parseWhite))
ijones's avatar
ijones committed
300
301
302
303
304
305

parseSpaceNotNewline = (satisfy isSpaceNotNewline <?> "space, not newline")
    where isSpaceNotNewline :: Char -> Bool
          isSpaceNotNewline '\n' = False
          isSpaceNotNewline n    = isSpace n

ijones's avatar
ijones committed
306
307
308
309
-- ------------------------------------------------------------
-- * Testing
-- ------------------------------------------------------------
#ifdef DEBUG
310
311
312
313
314
315
316
317
318
319
320
321
322
323
testPkgDesc = unlines [
        "-- Required",
        "Name: Cabal",
        "Version: 0.1.1.1.1-rain",
        "License: LGPL",
        "Copyright: Free Text String",
        "-- Optional - may be in source?",
        "Stability: Free Text String",
        "Build-Depends: haskell-src, HUnit>=1.0.0-rain",
        "Modules: Distribution.Package, Distribution.Version, Distribution.Simple.GHCPackageConfig",
        "Main-Modules: Distribution.Main",
        "C-Sources: not/even/rain.c, such/small/hands",
        "HS-Source-Dir: src",
        "Exposed-Modules: Distribution.Void, Foo.Bar",
md9ms's avatar
md9ms committed
324
        "Extensions: OverlappingInstances, TypeSynonymInstances",
325
326
327
        "Extra-Libs: libfoo, bar, bang",
        "Include-Dirs: your/slightest, look/will",
        "Includes: /easily/unclose, /me",
md9ms's avatar
md9ms committed
328
329
        "Options-ghc: -fTH",
        "Options-hugs: +TH"
330
        ]
ijones's avatar
ijones committed
331
332
333

testPkgDescAnswer = 
 PackageDescription {package = PackageIdentifier {pkgName = "Cabal",
ijones's avatar
ijones committed
334
                                                 pkgVersion = Version {versionBranch = [0,1,1,1,1],
md9ms's avatar
md9ms committed
335
                                                 versionTags = ["rain"]}},
ijones's avatar
ijones committed
336
                    license = LGPL,
ijones's avatar
ijones committed
337
                    copyright = "Free Text String",
ijones's avatar
ijones committed
338
                    maintainer = "",
ijones's avatar
ijones committed
339
                    stability = "Free Text String",
ijones's avatar
ijones committed
340
                    buildDepends = [Dependency "haskell-src" AnyVersion,
ijones's avatar
ijones committed
341
                                    Dependency "HUnit"
md9ms's avatar
md9ms committed
342
343
                                     (UnionVersionRanges (ThisVersion (Version [1,0,0] ["rain"]))
                                      (LaterVersion (Version [1,0,0] ["rain"])))],
ijones's avatar
ijones committed
344
345

                    allModules = ["Distribution.Package","Distribution.Version",
ijones's avatar
ijones committed
346
347
348
                                  "Distribution.Simple.GHCPackageConfig"],

                    mainModules = ["Distribution.Main"],
349
                    cSources = ["not/even/rain.c", "such/small/hands"],
ijones's avatar
ijones committed
350
351
                    hsSourceDir = "src",
                    exposedModules = ["Distribution.Void", "Foo.Bar"],
md9ms's avatar
md9ms committed
352
                    extensions = [OverlappingInstances, TypeSynonymInstances],
ijones's avatar
ijones committed
353
                    extraLibs = ["libfoo", "bar", "bang"],
354
355
                    includeDirs = ["your/slightest", "look/will"],
                    includes = ["/easily/unclose", "/me"],
md9ms's avatar
md9ms committed
356
                    options = [(Hugs,["+TH"]), (GHC,["-fTH"])] -- Note reversed order
ijones's avatar
ijones committed
357
358
}

ijones's avatar
ijones committed
359
hunitTests :: [Test]
360
361
362
363
364
hunitTests = [TestLabel "newline before word (parsewhite)" $ TestCase $
              do assertRight "newline before word 1"
                  "foo" (parse (skipMany parseWhite>>char '\n'>>word) "" "   \n  \nfoo")
                 assertRight "newline before word 2"
                  "foo" (parse (skipMany parseWhite>>char '\n'>>word) "" "   \n \t    \n  \nfoo"),
ijones's avatar
ijones committed
365
366

              TestLabel "skip spaces not newlines" $ TestCase $
367
368
369
370
371
372
373
374
              do assertRight "spaces with newlines"
                  "foo" (parse (skipMany parseWhite>>word) "" "   \n  foo")
                 assertRight "spaces with newlines"
                  "foo" (parse (skipMany parseWhite>>word) "" "   \n \t\n   foo")
                 assertRight "no preceding spaces"
                  "foo" (parse (skipMany parseWhite>>word) "" "foo")
                 assertBool "newline before data without in-between spaces"
                  (isError (parse (skipMany parseWhite>>word) "" "   \n  \nfoo")),
ijones's avatar
ijones committed
375

md9ms's avatar
md9ms committed
376
377
378
379
380
381
--              TestLabel "basic fields" $ TestCase $
--              do let p1 = parse (do w1 <- parseField "Foo" False parseVersion
--                                    skipMany parseWhite
--                                    w2 <- parseField "Bar" True word
--                                    return (w1, w2)
--                                ) ""
md9ms's avatar
md9ms committed
382
--                     knownVal1 = (Version {versionBranch = [3,2], versionTags = ["one"]},"boo")
md9ms's avatar
md9ms committed
383
384
385
386
387
388
389
390
391
392
393
394
--                 assertRight "basic spaces 1"
--                   knownVal1 (p1 "Foo: 3.2-one\nBar: boo")
--                 assertRight "basic spaces 2"
--                   knownVal1 (p1 "Foo: 3.2-one \t   \nBar: boo")
--                 assertRight "basic spaces 3"
--                   knownVal1 (p1 "Foo : 3.2-one \t   \nBar:    boo  ")
--                 assertRight "basic spaces 3"
--                   knownVal1 (p1 "Foo:3.2-one \t   \nBar:    boo  ")
--                 assertRight "basic spaces with newline"
--                   knownVal1 (p1 "Foo:\n 3.2-one \t   \nBar:    boo  ")
--                 assertRight "basic spaces with newline"
--                   knownVal1 (p1 "Foo:\n 3.2-one \t \n  \nBar:    boo  "),
ijones's avatar
ijones committed
395

ijones's avatar
ijones committed
396
397
398
399
400
              TestCase (assertRight "BSD4" BSD4 (parse parseLicense "" "BSD4")),

              TestLabel "license parsers" $ 
                        TestCase (sequence_ [assertRight ("license " ++ lName) lVal
                                                    (parse parseLicense "" lName)
ijones's avatar
ijones committed
401
402
403
404
405
                                             | (lName, lVal) <- licenses]),

              TestLabel "Required fields" $ TestCase $
                 do assertRight "some fields"
                       emptyPackageDescription{package=(PackageIdentifier "foo"
md9ms's avatar
md9ms committed
406
                                                        (Version [0,0] ["asdf"]))}
ijones's avatar
ijones committed
407
408
409
410
                       (parseDescription "Name: foo\nVersion: 0.0-asdf")

                    assertRight "more fields foo"
                       emptyPackageDescription{package=(PackageIdentifier "foo"
md9ms's avatar
md9ms committed
411
                                                        (Version [0,0]["asdf"])),
ijones's avatar
ijones committed
412
413
414
415
416
                                               license=GPL}
                       (parseDescription "Name: foo\nVersion:0.0-asdf\nLicense: GPL")

                    assertRight "required fields for foo"
                       emptyPackageDescription{package=(PackageIdentifier "foo"
md9ms's avatar
md9ms committed
417
                                                        (Version [0,0]["asdf"])),
ijones's avatar
ijones committed
418
419
420
421
422
423
424
                                        license=GPL, copyright="2004 isaac jones"}
                       (parseDescription "Name: foo\nVersion:0.0-asdf\nCopyright: 2004 isaac jones\nLicense: GPL"),
                                          

             TestLabel "Package description" $ TestCase $ 
                assertRight "entire package description" testPkgDescAnswer
                                                         (parseDescription testPkgDesc)
md9ms's avatar
md9ms committed
425

ijones's avatar
ijones committed
426
427
             ]

ijones's avatar
ijones committed
428

ijones's avatar
ijones committed
429
430
431
432
433
434
435
436
437
438
assertRight :: (Eq val) => String -> val -> (Either a val) -> Assertion
assertRight mes expected actual
    =  assertBool mes
           (case actual of
             (Right v) -> v == expected
             _         -> False)

isError (Left _) = True
isError _        = False

ijones's avatar
ijones committed
439
test = runTestTT (TestList hunitTests)
ijones's avatar
ijones committed
440
#endif