Generic library rules (#571)
authorAlp Mestanogullari <alpmestan@gmail.com>
Tue, 17 Apr 2018 17:03:36 +0000 (19:03 +0200)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Tue, 17 Apr 2018 17:03:36 +0000 (18:03 +0100)
* wip

* debugging output

* Compute ProjectVersion on demand ONLY!

* remove debugging output, boot with --hadrian

* go back to using -c everywhere in .travis.yml

* prioritise libgmp.a rule over catch-all *.a rule, to avoid conflict

* add missing import

* tentative fix for the appveyor script

* use backslashes in appveyor.yml

* less 'cd'ing around in appveyor.yml

* address most of @snowleopard's feedback

* address last bit of feedback

.travis.yml
appveyor.yml
hadrian.cabal
src/Rules.hs
src/Rules/Configure.hs
src/Rules/Gmp.hs
src/Rules/Libffi.hs
src/Rules/Library.hs
src/Settings/Packages.hs
src/Way.hs
src/Way/Type.hs

index 2415903..f80bca6 100644 (file)
@@ -17,10 +17,8 @@ matrix:
               - PATH="/opt/cabal/2.0/bin:$PATH"
 
           script:
-              # boot & configure ghc source tree
-              - ./boot && ./configure
-              # Run internal Hadrian tests
-              - hadrian/build.sh selftest
+              # Run internal Hadrian tests, after boot and configure.
+              - hadrian/build.sh -c selftest
 
         - os: linux
           env: MODE="--flavour=quickest"
@@ -38,11 +36,8 @@ matrix:
               - PATH="/opt/cabal/2.0/bin:$PATH"
 
           script:
-              # boot & configure ghc source tree
-              - ./boot && ./configure
-
               # Build GHC, letting hadrian boot & configure the ghc source tree
-              - hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+              - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=-
 
         - os: linux
           env: MODE="--flavour=quickest --integer-simple"
@@ -60,11 +55,8 @@ matrix:
               - PATH="/opt/cabal/2.2/bin:$PATH"
 
           script:
-              # boot & configure ghc source tree
-              - ./boot && ./configure
-
-              # build GHC
-              - hadrian/build.sh -j $MODE --no-progress --progress-colour=never --profile=-
+              # boot, configure and build GHC
+              - hadrian/build.sh -c -j $MODE --no-progress --progress-colour=never --profile=-
 
               # Test GHC binary
               - _build/stage1/bin/ghc -e 1+2
@@ -78,9 +70,6 @@ matrix:
               - brew upgrade python
 
           script:
-              # boot and configure ghc source tree
-              - ./boot && ./configure
-
               # Due to timeout limit of OS X build on Travis CI,
               # we will ignore selftest and build only stage1
               - hadrian/build.sh -j -c $MODE --no-progress --progress-colour=never --profile=-
index f8fe198..85bfee8 100644 (file)
@@ -34,11 +34,9 @@ build_script:
     - cd ..
     - hadrian\stack exec -- python3 boot
     - hadrian\stack exec -- bash configure --enable-distro-toolchain
-    - cd hadrian
 
     # Build GHC
-    - build -j --flavour=quickest --integer-simple --no-progress --progress-colour=never --profile=-
+    - hadrian\build -j --flavour=quickest --integer-simple --no-progress --progress-colour=never --profile=-
 
     # Test GHC binary
-    - cd ..
-    - _build/stage1/bin/ghc -e 1+2
+    - _build\stage1\bin\ghc -e 1+2
index ca339fb..96d5891 100644 (file)
@@ -118,6 +118,7 @@ executable hadrian
                        , directory            >= 1.2     && < 1.4
                        , extra                >= 1.4.7
                        , mtl                  == 2.2.*
+                       , parsec               >= 3.1     && < 3.2
                        , QuickCheck           >= 2.6     && < 2.11
                        , shake                == 0.16.*
                        , transformers         >= 0.4     && < 0.6
index 100720f..1ecb476 100644 (file)
@@ -98,12 +98,15 @@ packageRules = do
     let contexts        = liftM3 Context        allStages knownPackages allWays
         vanillaContexts = liftM2 vanillaContext allStages knownPackages
 
-    forM_ contexts $ mconcat
-        [ Rules.Compile.compilePackage readPackageDb
-        , Rules.Library.buildPackageLibrary ]
+    -- TODO: we might want to look into converting more and more
+    --       rules to the style introduced in Rules.Library in
+    --       https://github.com/snowleopard/hadrian/pull/571,
+    --       where "catch-all" rules are used to "catch" the need
+    --       for library files, and we then use parsec parsers to
+    --       extract all sorts of information needed to build them, like
+    --       the package, the stage, the way, etc.
 
-    let dynamicContexts = liftM3 Context [Stage1 ..] knownPackages [dynamic]
-    forM_ dynamicContexts Rules.Library.buildDynamicLib
+    forM_ contexts (Rules.Compile.compilePackage readPackageDb)
 
     Rules.Program.buildProgram readPackageDb
 
@@ -118,7 +121,6 @@ packageRules = do
         [ Rules.PackageData.buildPackageData
         , Rules.Dependencies.buildPackageDependencies readPackageDb
         , Rules.Documentation.buildPackageDocumentation
-        , Rules.Library.buildPackageGhciLibrary
         , Rules.Generate.generatePackageCode ]
 
 buildRules :: Rules ()
@@ -129,6 +131,7 @@ buildRules = do
     Rules.Generate.generateRules
     Rules.Gmp.gmpRules
     Rules.Libffi.libffiRules
+    Rules.Library.libraryRules
     packageRules
 
 oracleRules :: Rules ()
index 13dbe9c..1fd07de 100644 (file)
@@ -12,6 +12,7 @@ import Utilities
 
 configureRules :: Rules ()
 configureRules = do
+    -- TODO: consider other files we should track here (rts/rts.cabal etc)
     [configFile, "settings", configH, "compiler/ghc.cabal"] &%> \outs -> do
         skip <- not <$> cmdConfigure
         if skip
@@ -40,4 +41,4 @@ configureRules = do
             need ["configure.ac"]
             putBuild "| Running boot..."
             verbosity <- getVerbosity
-            quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot"
+            quietly $ cmd [EchoStdout (verbosity >= Loud)] "python3 boot --hadrian"
index 8852311..9b45c0e 100644 (file)
@@ -66,8 +66,9 @@ gmpRules = do
             copyFile (gmpPath -/- "gmp.h") header
             copyFile (gmpPath -/- "gmp.h") (gmpPath -/- gmpLibraryInTreeH)
 
-    -- Build in-tree GMP library
-    root <//> gmpLibrary %> \lib -> do
+    -- Build in-tree GMP library, prioritised so that it matches "before"
+    -- the generic .a library rule in Rules.Library, whenever applicable.
+    priority 2.0 $ root <//> gmpLibrary %> \lib -> do
         gmpPath <- gmpBuildPath
         build $ target gmpContext (Make gmpPath) [gmpPath -/- "Makefile"] [lib]
         putSuccess "| Successfully built custom library 'gmp'"
index 9351eb6..a51e758 100644 (file)
@@ -51,7 +51,9 @@ libffiRules = do
         libffiPath <- libffiBuildPath
         need [libffiPath -/- libffiLibrary]
 
-    root <//> libffiLibrary %> \_ -> do
+    -- we set a higher priority because this overlaps
+    -- with the static lib rule from Rules.Library.libraryRules.
+    priority 2.0 $ root <//> libffiLibrary %> \_ -> do
         useSystemFfi <- flag UseSystemFfi
         rtsPath      <- rtsBuildPath
         if useSystemFfi
index 6ce0a71..314d124 100644 (file)
@@ -1,10 +1,8 @@
-module Rules.Library (
-    buildPackageLibrary, buildPackageGhciLibrary, buildDynamicLib
-    ) where
+module Rules.Library (libraryRules) where
 
 import Hadrian.Haskell.Cabal
 import Hadrian.Haskell.Cabal.PackageData as PD
-import Hadrian.Haskell.Cabal.Parse (parseCabalPkgId)
+import Hadrian.Package.Type
 
 import Base
 import Context
@@ -12,105 +10,82 @@ import Expression hiding (way, package)
 import Flavour
 import GHC.Packages
 import Oracles.ModuleFiles
+import Oracles.Setting (libsuf)
 import Rules.Gmp
 import Settings
 import Target
 import Utilities
 
+import Data.Functor
 import qualified System.Directory as IO
+import qualified Text.Parsec      as Parsec
 
-archive :: Way -> String -> String
-archive way pkgId = "libHS" ++ pkgId ++ (waySuffix way <.> "a")
-
--- TODO: This comment is rather vague, make it more precise by listing what
--- exactly gets built and moved where, referencing the corresponding rules.
--- | Building a library consist of building the artefacts, copying it somewhere
--- with Cabal, and finally registering it with the compiler via Cabal in the
--- package database. We assume rules to build all the package artefacts, and
--- provide rules for the library artefacts.
-library :: Context -> Rules ()
-library context@Context{..} = do
-    root <- buildRootRules
-    pkgId <- case pkgCabalFile package of
-        Just file -> liftIO $ parseCabalPkgId file
-        Nothing   -> return $ pkgName package
-
-    root -/- libDir context -/- pkgId -/- archive way pkgId %> \_ ->
-        need =<< mapM (\pkgId -> packageDbPath stage <&> (-/- pkgId <.> "conf")) [pkgId]
+-- * Library 'Rules'
 
-libraryObjects :: Context -> Action [FilePath]
-libraryObjects context@Context{..} = do
-    hsObjs    <- hsObjects    context
-    nonHsObjs <- nonHsObjects context
+libraryRules :: Rules ()
+libraryRules = do
+  root <- buildRootRules
 
-    -- This will create split objects if required (we don't track them
-    -- explicitly as this would needlessly bloat the Shake database).
-    need $ nonHsObjs ++ hsObjs
+  root -/- "//libHS*-*.dylib" %> buildDynamicLibUnix root "dylib"
+  root -/- "//libHS*-*.so"    %> buildDynamicLibUnix root "so"
+  root -/- "//*.a" %> buildStaticLib root
+  priority 2 $ root -/- "//HS*-*.o" %> buildGhciLibO root
 
-    split <- interpretInContext context =<< splitObjects <$> flavour
-    let getSplitObjs = concatForM hsObjs $ \obj -> do
-            let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
-            contents <- liftIO $ IO.getDirectoryContents dir
-            return . map (dir -/-) $ filter (not . all (== '.')) contents
+-- * 'Action's for building libraries
+
+-- | Build a static library ('LibA') under the given build root, whose
+--   path is the second argument.
+buildStaticLib :: FilePath -> FilePath -> Action ()
+buildStaticLib root archivePath = do
+  l@(BuildPath _ stage _ (LibA pkgname _ way))
+    <- parsePath (parseBuildLibA root)
+                 "<.a library (build) path parser>"
+                 archivePath
+  let context = libAContext l
+  objs <- libraryObjects context
+  removeFile archivePath
+  build $ target context (Ar Pack stage) objs [archivePath]
+  synopsis <- pkgSynopsis context
+  putSuccess $ renderLibrary
+    (quote pkgname ++ " (" ++ show stage ++ ", way " ++ show way ++ ").")
+    archivePath synopsis
 
-    (nonHsObjs ++) <$> if split then getSplitObjs else return hsObjs
-
-buildDynamicLib :: Context -> Rules ()
-buildDynamicLib context@Context{..} = do
-    root <- buildRootRules
-    pkgId <- case pkgCabalFile package of
-        Just file -> liftIO $ parseCabalPkgId file
-        Nothing   -> return $ pkgName package
-    let libPrefix = root -/- buildDir context -/- "libHS" ++ pkgId
-    -- OS X
-    libPrefix ++ "*.dylib" %> buildDynamicLibUnix
-    -- Linux
-    libPrefix ++ "*.so"    %> buildDynamicLibUnix
-    -- TODO: Windows
-  where
-    buildDynamicLibUnix lib = do
-        deps <- contextDependencies context
-        need =<< mapM pkgLibraryFile deps
-        objs <- libraryObjects context
-        build $ target context (Ghc LinkHs stage) objs [lib]
-
-buildPackageLibrary :: Context -> Rules ()
-buildPackageLibrary context@Context {..} = do
-    root <- buildRootRules
-    pkgId <- case pkgCabalFile package of
-        Just file -> liftIO $ parseCabalPkgId file
-        Nothing   -> return $ pkgName package
-    let libPrefix = root -/- buildDir context -/- "libHS" ++ pkgId
-        archive = libPrefix ++ (waySuffix way <.> "a")
-    archive %%> \a -> do
-        objs <- libraryObjects context
-        removeFile a
-        build $ target context (Ar Pack stage) objs [a]
-
-        synopsis <- pkgSynopsis context
-        putSuccess $ renderLibrary
-            (quote (pkgName package) ++ " (" ++ show stage ++ ", way "
-            ++ show way ++ ").") a synopsis
-
-    library context
-
-buildPackageGhciLibrary :: Context -> Rules ()
-buildPackageGhciLibrary context@Context {..} = priority 2 $ do
-    root <- buildRootRules
-    -- TODO: Get rid of code duplication for 'pkgId'.
-    pkgId <- case pkgCabalFile package of
-        Just file -> liftIO $ parseCabalPkgId file
-        Nothing   -> return $ pkgName package
-
-    let libPrefix = root -/- buildDir context -/- "HS" ++ pkgId
-    libPrefix ++ "*" ++ (waySuffix way <.> "o") %> \obj -> do
-        objs <- allObjects context
-        need objs
-        build $ target context (Ld stage) objs [obj]
+-- | Build a dynamic library ('LibDyn') under the given build root,
+--   with the given suffix (@.so@ or @.dylib@, @.dll@ in the future),
+--   where the complete path of the archive to build is given as the
+--   third argument.
+buildDynamicLibUnix :: FilePath -> String -> FilePath -> Action ()
+buildDynamicLibUnix root suffix dynlibpath = do
+  dynlib <- parsePath (parseBuildLibDyn root suffix) "<dyn lib parser>" dynlibpath
+  let context = libDynContext dynlib
+  deps <- contextDependencies context
+  need =<< mapM pkgLibraryFile deps
+  objs <- libraryObjects context
+  build $ target context (Ghc LinkHs $ Context.stage context) objs [dynlibpath]
 
+-- | Build a "ghci library" ('LibGhci') under the given build root,
+--   with the complete path of the file to build is given as the second
+--   argument.
+buildGhciLibO :: FilePath -> FilePath -> Action ()
+buildGhciLibO root ghcilibPath = do
+  l@(BuildPath _ stage _ (LibGhci _ _ _))
+    <- parsePath (parseBuildLibGhci root)
+                 "<.o ghci lib (build) path parser>"
+                 ghcilibPath
+  let context = libGhciContext l
+  objs <- allObjects context
+  need objs
+  build $ target context (Ld stage) objs [ghcilibPath]
+
+-- * Helpers
+
+-- | Return all Haskell and non-Haskell object files for the
+--   given 'Context'.
 allObjects :: Context -> Action [FilePath]
 allObjects context = (++) <$> nonHsObjects context <*> hsObjects context
 
+-- | Return all the non-Haskell object files for the given library
+--   context (object files built from C, C-- and sometimes other things).
 nonHsObjects :: Context -> Action [FilePath]
 nonHsObjects context = do
     cObjs   <- cObjects context
@@ -119,6 +94,8 @@ nonHsObjects context = do
     eObjs   <- extraObjects context
     return $ cObjs ++ cmmObjs ++ eObjs
 
+-- | Return all the C object files needed to build the given library
+--   context.
 cObjects :: Context -> Action [FilePath]
 cObjects context = do
     srcs <- interpretInContext context (getPackageData PD.cSrcs)
@@ -127,6 +104,9 @@ cObjects context = do
         then objs
         else filter ((`notElem` ["Evac_thr", "Scav_thr"]) . takeBaseName) objs
 
+-- | Return extra object files needed to build the given library context. The
+--   resulting list is non empty only when the package from the 'Context' is
+--   /integer-gmp/.
 extraObjects :: Context -> Action [FilePath]
 extraObjects context
     | package context == integerGmp = do
@@ -134,3 +114,211 @@ extraObjects context
         need [gmpPath -/- gmpLibraryH]
         map unifyPath <$> getDirectoryFiles "" [gmpPath -/- gmpObjectsDir -/- "*.o"]
     | otherwise         = return []
+
+-- | Return all the object files to be put into the library
+--   we're building for the given 'Context'.
+libraryObjects :: Context -> Action [FilePath]
+libraryObjects context@Context{..} = do
+    hsObjs   <- hsObjects    context
+    noHsObjs <- nonHsObjects context
+
+    -- This will create split objects if required (we don't track them
+    -- explicitly as this would needlessly bloat the Shake database).
+    need $ noHsObjs ++ hsObjs
+
+    split <- interpretInContext context =<< splitObjects <$> flavour
+    let getSplitObjs = concatForM hsObjs $ \obj -> do
+            let dir = dropExtension obj ++ "_" ++ osuf way ++ "_split"
+            contents <- liftIO $ IO.getDirectoryContents dir
+            return . map (dir -/-) $ filter (not . all (== '.')) contents
+
+    (noHsObjs ++) <$> if split then getSplitObjs else return hsObjs
+
+-- * Library paths types and parsers
+
+-- | > libHS<pkg name>-<pkg version>[_<way suffix>].a
+data LibA = LibA String [Integer] Way
+  deriving (Eq, Show)
+
+-- | > <so or dylib>
+data DynLibExt = So | Dylib
+  deriving (Eq, Show)
+
+-- | > libHS<pkg name>-<pkg version>-ghc<ghc version>[_<way suffix>].<so or dylib>
+data LibDyn = LibDyn String [Integer] Way DynLibExt
+  deriving (Eq, Show)
+
+-- | > HS<pkg name>-<pkg version>[_<way suffix>].o
+data LibGhci = LibGhci String [Integer] Way
+  deriving (Eq, Show)
+
+-- | A path of the form
+--
+--   > <build root>/stage<N>/<path/to/pkg/from/ghc/root>/build/<something>
+--
+--   where @something@ describes a library to be build for the given package.
+--
+--   @a@, which represents that @something@, is instantiated as 'LibA', 'LibDyn'
+--   and 'LibGhci' successively in this module, depending on the type of library
+--   we're giving the build rules for.
+data BuildPath a
+  = BuildPath FilePath -- ^ > <build root>/
+              Stage    -- ^ > stage<N>/
+              FilePath -- ^ > <path/to/pkg/from/ghc/root>/build/
+              a        -- ^ > whatever comes after 'build/'
+  deriving (Eq, Show)
+
+-- | Get the 'Context' corresponding to the build path for a given static library.
+libAContext :: BuildPath LibA -> Context
+libAContext (BuildPath _ stage pkgpath (LibA pkgname _ way))
+  = Context stage pkg way
+  where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
+
+-- | Get the 'Context' corresponding to the build path for a given ghci library.
+libGhciContext :: BuildPath LibGhci -> Context
+libGhciContext (BuildPath _ stage pkgpath (LibGhci pkgname _ way))
+  = Context stage pkg way
+  where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
+
+-- | Get the 'Context' corresponding to the build path for a given dynamic library.
+libDynContext :: BuildPath LibDyn -> Context
+libDynContext (BuildPath _ stage pkgpath (LibDyn pkgname _ way _))
+  = Context stage pkg way
+  where pkg = Package (if pkgname == "rts" then C else Haskell) Library pkgname pkgpath
+
+-- | Parse a build path for a library to be built under the given build root,
+--   where the filename will be parsed with the given parser argument.
+parseBuildPath
+  :: FilePath -- ^ build root
+  -> Parsec.Parsec String () a -- ^ what to parse after @build/@
+  -> Parsec.Parsec String () (BuildPath a)
+parseBuildPath root afterBuild = do
+  _ <- Parsec.string root *> Parsec.optional (Parsec.char '/')
+  stage <- parseStage
+  _ <- Parsec.char '/'
+  pkgpath <- Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.string "/build/")
+  a <- afterBuild
+  return (BuildPath root stage pkgpath a)
+
+-- | Parse a path to a static library to be built, making sure the path starts
+--   with the given build root.
+parseBuildLibA :: FilePath -> Parsec.Parsec String () (BuildPath LibA)
+parseBuildLibA root = parseBuildPath root parseLibAFilename
+           Parsec.<?> "build path for a static library"
+
+-- | Parse a path to a ghci library to be built, making sure the path starts
+--   with the given build root.
+parseBuildLibGhci :: FilePath -> Parsec.Parsec String () (BuildPath LibGhci)
+parseBuildLibGhci root = parseBuildPath root parseLibGhciFilename
+              Parsec.<?> "build path for a ghci library"
+
+-- | Parse a path to a dynamic library to be built, making sure the path starts
+--   with the given build root.
+parseBuildLibDyn :: FilePath -> String -> Parsec.Parsec String () (BuildPath LibDyn)
+parseBuildLibDyn root ext = parseBuildPath root (parseLibDynFilename ext)
+                 Parsec.<?> ("build path for a dynamic library with extension " ++ ext)
+
+-- | Parse the filename of a static library to be built into a 'LibA' value.
+parseLibAFilename :: Parsec.Parsec String () LibA
+parseLibAFilename = do
+  _ <- Parsec.string "libHS"
+  (pkgname, pkgver) <- parsePkgId
+  way <- parseWaySuffix vanilla
+  _ <- Parsec.string ".a"
+  return (LibA pkgname pkgver way)
+
+-- | Parse the filename of a ghci library to be built into a 'LibGhci' value.
+parseLibGhciFilename :: Parsec.Parsec String () LibGhci
+parseLibGhciFilename = do
+  _ <- Parsec.string "HS"
+  (pkgname, pkgver) <- parsePkgId
+  way <- parseWaySuffix vanilla
+  _ <- Parsec.string ".o"
+  return (LibGhci pkgname pkgver way)
+
+-- | Parse the filename of a dynamic library to be built into a 'LibDyn' value.
+parseLibDynFilename :: String -> Parsec.Parsec String () LibDyn
+parseLibDynFilename ext = do
+  _ <- Parsec.string "libHS"
+  (pkgname, pkgver) <- parsePkgId
+  _ <- optional $ Parsec.string "-ghc" *> parsePkgVersion
+  way <- addWayUnit Dynamic <$> parseWaySuffix dynamic
+  _ <- Parsec.string ("." ++ ext)
+  return (LibDyn pkgname pkgver way $ if ext == "so" then So else Dylib)
+
+-- To be kept in sync with Stage.hs's stageString function
+-- | Parse @"stageX"@ into a 'Stage'.
+parseStage :: Parsec.Parsec String () Stage
+parseStage = (Parsec.string "stage" *> Parsec.choice
+  [ Parsec.string (show n) $> toEnum n
+  | n <- map fromEnum [minBound .. maxBound :: Stage]
+  ]) Parsec.<?> "stage string"
+
+-- To be kept in sync with the show instances in
+-- Way.Type, until we perhaps use some bidirectional
+-- parsing/pretty printing approach or library.
+-- | Parse a way suffix, returning the argument when no suffix is found
+--   (the argument will be vanilla in most cases, but dynamic when we parse
+--   the way suffix out of a shared library file name.
+parseWaySuffix :: Way -> Parsec.Parsec String () Way
+parseWaySuffix w = Parsec.choice
+  [ Parsec.string "_" *> (wayFromUnits <$> Parsec.sepBy1 parseWayUnit (Parsec.string "_"))
+  , pure w
+  ] Parsec.<?> "way suffix (e.g _thr_p, or none for vanilla)"
+
+  where parseWayUnit = Parsec.choice
+          [ Parsec.string "thr" *> pure Threaded
+          , Parsec.char   'd'   *>
+              (Parsec.choice
+                [ Parsec.string "ebug" *> pure Debug
+                , Parsec.string "yn"   *> pure Dynamic
+                ]
+              )
+          , Parsec.char 'p'     *> pure Profiling
+          , Parsec.char 'l'     *> pure Logging
+          ] Parsec.<?> "way unit (thr, debug, dyn, p, l)"
+
+-- | Parse a @"pkgname-pkgversion"@ string into
+--   the package name and the integers that make up the
+--   package version.
+parsePkgId :: Parsec.Parsec String () (String, [Integer])
+parsePkgId = parsePkgId' "" Parsec.<?> "package identifier (<name>-<version>)"
+
+  where parsePkgId' currName = do
+          s <- Parsec.many1 Parsec.alphaNum
+          _ <- Parsec.char '-'
+          let newName = if null currName then s else currName ++ "-" ++ s
+          Parsec.choice [ (newName,) <$> parsePkgVersion
+                        , parsePkgId' newName
+                        ]
+
+-- | Parse "."-separated integers that describe a package's version.
+parsePkgVersion :: Parsec.Parsec String () [Integer]
+parsePkgVersion = fmap reverse (parsePkgVersion' []) Parsec.<?> "package version"
+
+  where parsePkgVersion' xs = do
+          n <- parseNatural
+          Parsec.choice
+            [ Parsec.try (Parsec.lookAhead (Parsec.char '.' *> (Parsec.letter <|> Parsec.char '_')))
+              $> (n:xs)
+            , Parsec.char '.' *> parsePkgVersion' (n:xs)
+            , pure $ (n:xs)
+            ]
+
+-- | Parse a natural number.
+parseNatural :: Parsec.Parsec String () Integer
+parseNatural = (read <$> Parsec.many1 Parsec.digit)
+    Parsec.<?> "natural number"
+
+-- | Runs the given parser against the given path,
+--   erroring out when the parser fails (because it shouldn't
+--   if the code from this module is correct).
+parsePath
+  :: Parsec.Parsec String () a -- ^ parser to run
+  -> String                    -- ^ string describing the input source
+  -> FilePath                  -- ^ path to parse
+  -> Action a
+parsePath p inp path = case Parsec.parse p inp path of
+  Left err -> fail $ "Rules.Library.parsePath: path="
+                  ++ path ++ ", error:\n" ++ show err
+  Right a  -> pure a
index 91adc61..8081466 100644 (file)
@@ -22,8 +22,6 @@ packageArgs = do
   gmpBuildPath <- expr gmpBuildPath
   let includeGmp = "-I" ++ gmpBuildPath -/- "include"
 
-  version <- getSetting ProjectVersion
-
   mconcat
     [ package base
       ? mconcat [ builder CabalFlags ? arg ('+':integerLibraryName)
@@ -119,7 +117,9 @@ packageArgs = do
                     arg ("--configure-option=CFLAGS=" ++ includeGmp)
                   , arg ("--gcc-options="             ++ includeGmp) ] ]
     , package runGhc
-      ? builder Ghc ? input "//Main.hs" ? pure ["-cpp", "-DVERSION=" ++ show version]
+      ? builder Ghc
+      ? input "//Main.hs"
+      ? (\version -> ["-cpp", "-DVERSION=" ++ show version]) <$> getSetting ProjectVersion
     , package rts
       ? builder CabalFlags ? (any (wayUnit Profiling) rtsWays) ? arg "profiling"
     ]
index aac9afb..2375a12 100644 (file)
@@ -1,5 +1,5 @@
 module Way (
-    WayUnit (..), Way, wayUnit, removeWayUnit, wayFromUnits, allWays,
+    WayUnit (..), Way, wayUnit, addWayUnit, removeWayUnit, wayFromUnits, allWays,
 
     vanilla, profiling, dynamic, profilingDynamic, threaded, debug, logging,
     threadedDebug, threadedProfiling, threadedLogging, threadedDynamic,
index 7d0473a..4055ff4 100644 (file)
@@ -57,6 +57,10 @@ wayToUnits (Way set) = map toEnum . Set.elems $ set
 wayUnit :: WayUnit -> Way -> Bool
 wayUnit unit (Way set) = fromEnum unit `Set.member` set
 
+-- | Add a 'WayUnit' to a 'Way'
+addWayUnit :: WayUnit -> Way -> Way
+addWayUnit unit (Way set) = Way . Set.insert (fromEnum unit) $ set
+
 -- | Remove a 'WayUnit' from 'Way'.
 removeWayUnit :: WayUnit -> Way -> Way
 removeWayUnit unit (Way set) = Way . Set.delete (fromEnum unit) $ set