Commit 7e652279 authored by Ben Gamari's avatar Ben Gamari 🐢
Browse files

Make PackageName into a proper newtype

parent 01538648
{-# LANGUAGE OverloadedStrings #-}
module GHC (
array, base, binary, bytestring, cabal, compiler, containers, compareSizes,
deepseq, deriveConstants, directory, dllSplit, filepath, genapply,
......@@ -103,11 +104,11 @@ defaultProgramPath :: Stage -> Package -> Maybe FilePath
defaultProgramPath stage pkg
| pkg == ghc = Just . inplaceProgram $ "ghc-stage" ++ show (fromEnum stage + 1)
| pkg == haddock || pkg == ghcTags = case stage of
Stage2 -> Just . inplaceProgram $ pkgName pkg
Stage2 -> Just . inplaceProgram $ pkgNameString pkg
_ -> Nothing
| isProgram pkg = case stage of
Stage0 -> Just . inplaceProgram $ pkgName pkg
_ -> Just . installProgram $ pkgName pkg
Stage0 -> Just . inplaceProgram $ pkgNameString pkg
_ -> Just . installProgram $ pkgNameString pkg
| otherwise = Nothing
where
inplaceProgram name = programInplacePath -/- name <.> exe
......
......@@ -64,7 +64,7 @@ packageInfo pkg
moduleFilesOracle :: Rules ()
moduleFilesOracle = do
answer <- newCache $ \(pkg, extraDirs) -> do
putOracle $ "Searching module files of package " ++ pkgName pkg ++ "..."
putOracle $ "Searching module files of package " ++ pkgNameString pkg ++ "..."
unless (null extraDirs) $ putOracle $ "Extra directory = " ++ show extraDirs
(srcDirs, modules) <- packageInfo pkg
......
......@@ -23,6 +23,6 @@ packageDepsOracle = do
putOracle $ "Reading package dependencies..."
contents <- readFileLines packageDependencies
return . Map.fromList
$ [ (head ps, tail ps) | line <- contents, let ps = words line ]
$ [ (head ps, tail ps) | line <- contents, let ps = map PackageName $ words line ]
_ <- addOracle $ \(PackageDepsKey pkg) -> Map.lookup pkg <$> deps ()
return ()
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Package (
Package (..), PackageName, PackageType (..),
Package (..), PackageName(..), PackageType (..),
-- * Queries
pkgNameString,
pkgCabalFile,
matchPackageNames,
-- * Helpers for constructing and using 'Package's
......@@ -10,9 +13,15 @@ module Package (
import Base
import GHC.Generics (Generic)
import Data.String
-- | The name of a Cabal package
newtype PackageName = PackageName { getPackageName :: String }
deriving ( Eq, Ord, IsString, Generic, Binary, Hashable
, NFData)
-- | It is helpful to distinguish package names from strings.
type PackageName = String
instance Show PackageName where
show (PackageName name) = name
-- | We regard packages as either being libraries or programs. This is
-- bit of a convenient lie as Cabal packages can be both, but it works
......@@ -29,18 +38,21 @@ data Package = Package
}
deriving Generic
-- Relative path to cabal file, e.g.: "libraries/Cabal/Cabal/Cabal.cabal"
pkgNameString :: Package -> String
pkgNameString = getPackageName . pkgName
-- | Relative path to cabal file, e.g.: "libraries/Cabal/Cabal/Cabal.cabal"
pkgCabalFile :: Package -> FilePath
pkgCabalFile pkg = pkgPath pkg -/- pkgName pkg <.> "cabal"
pkgCabalFile pkg = pkgPath pkg -/- getPackageName (pkgName pkg) <.> "cabal"
topLevel :: PackageName -> Package
topLevel name = Package name name Library
topLevel name = Package name (getPackageName name) Library
library :: PackageName -> Package
library name = Package name ("libraries" -/- name) Library
library name = Package name ("libraries" -/- getPackageName name) Library
utility :: PackageName -> Package
utility name = Package name ("utils" -/- name) Program
utility name = Package name ("utils" -/- getPackageName name) Program
setPath :: Package -> FilePath -> Package
setPath pkg path = pkg { pkgPath = path }
......@@ -57,7 +69,7 @@ isProgram (Package {pkgType=Program}) = True
isProgram _ = False
instance Show Package where
show = pkgName
show = show . pkgName
instance Eq Package where
(==) = (==) `on` pkgName
......
module Rules.Cabal (cabalRules) where
import Data.Version
import Distribution.Package hiding (Package)
import Distribution.Package as DP hiding (Package)
import Distribution.PackageDescription
import Distribution.PackageDescription.Parse
import Distribution.Verbosity
......@@ -19,9 +19,9 @@ cabalRules = do
constraints <- forM (sort pkgs) $ \pkg -> do
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
let identifier = package . packageDescription $ pd
version = showVersion . pkgVersion $ identifier
PackageName name = Distribution.Package.pkgName identifier
let identifier = package . packageDescription $ pd
version = showVersion . pkgVersion $ identifier
DP.PackageName name = DP.pkgName identifier
return $ name ++ " == " ++ version
writeFileChanged out . unlines $ constraints
......@@ -34,8 +34,8 @@ cabalRules = do
let depsLib = collectDeps $ condLibrary pd
depsExes = map (collectDeps . Just . snd) $ condExecutables pd
deps = concat $ depsLib : depsExes
depNames = [ name | Dependency (PackageName name) _ <- deps ]
return . unwords $ Package.pkgName pkg : sort depNames
depNames = [ name | Dependency (DP.PackageName name) _ <- deps ]
return . unwords $ pkgNameString pkg : sort depNames
writeFileChanged out . unlines $ pkgDeps
collectDeps :: Maybe (CondTree v [Dependency] a) -> [Dependency]
......
......@@ -16,7 +16,7 @@ buildPackageDocumentation _ target @ (PartialTarget stage pkg) =
in when (stage == Stage1) $ do
haddockFile %> \file -> do
srcs <- interpretPartial target getPackageSources
deps <- interpretPartial target $ getPkgDataList DepNames
deps <- map PackageName <$> interpretPartial target (getPkgDataList DepNames)
let haddocks = [ pkgHaddockFile depPkg
| Just depPkg <- map findKnownPackage deps ]
need $ srcs ++ haddocks
......
......@@ -147,7 +147,7 @@ generateConfigHs = do
, "cStage :: String"
, "cStage = show (STAGE :: Int)"
, "cIntegerLibrary :: String"
, "cIntegerLibrary = " ++ quote (pkgName integerLibrary)
, "cIntegerLibrary = " ++ quote (pkgNameString integerLibrary)
, "cIntegerLibraryType :: IntegerLibrary"
, "cIntegerLibraryType = " ++ cIntegerLibraryType
, "cSupportsSplitObjs :: String"
......
......@@ -49,7 +49,7 @@ buildPackageLibrary _ target @ (PartialTarget stage pkg) = do
synopsis <- interpretPartial target $ getPkgData Synopsis
unless isLib0 . putSuccess $ renderBox
[ "Successfully built package library '"
++ pkgName pkg
++ pkgNameString pkg
++ "' (" ++ show stage ++ ", way "++ show way ++ ")."
, "Package synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]
......
......@@ -33,7 +33,7 @@ buildProgram _ target @ (PartialTarget stage pkg) = do
libTarget = PartialTarget libStage pkg
pkgs <- interpretPartial libTarget getPackages
ghciFlag <- interpretPartial libTarget $ getPkgData BuildGhciLib
let deps = matchPackageNames (sort pkgs) (sort depNames)
let deps = matchPackageNames (sort pkgs) (map PackageName $ sort depNames)
ghci = ghciFlag == "YES" && stage == Stage1
libs <- fmap concat . forM deps $ \dep -> do
let depTarget = PartialTarget libStage dep
......@@ -52,6 +52,6 @@ buildProgram _ target @ (PartialTarget stage pkg) = do
synopsis <- interpretPartial target $ getPkgData Synopsis
putSuccess $ renderBox
[ "Successfully built program '"
++ pkgName pkg ++ "' (" ++ show stage ++ ")."
++ pkgNameString pkg ++ "' (" ++ show stage ++ ")."
, "Executable: " ++ bin
, "Package synopsis: " ++ dropWhileEnd isPunctuation synopsis ++ "." ]
......@@ -24,14 +24,14 @@ haddockArgs = builder Haddock ? do
, arg $ "--dump-interface=" ++ output
, arg "--html"
, arg "--hoogle"
, arg $ "--title=" ++ pkgName pkg ++ "-" ++ version ++ ": " ++ synopsis
, arg $ "--title=" ++ pkgNameString pkg ++ "-" ++ version ++ ": " ++ synopsis
, arg $ "--prologue=" ++ path -/- "haddock-prologue.txt"
, append $ map ("--hide=" ++) hidden
, append $ [ "--read-interface=../" ++ dep
++ ",../" ++ dep ++ "/src/%{MODULE/./-}.html\\#%{NAME},"
++ pkgHaddockFile depPkg
| (dep, depName) <- zip deps depNames
, Just depPkg <- [findKnownPackage depName] ]
, Just depPkg <- [findKnownPackage $ PackageName depName] ]
, append [ "--optghc=" ++ opt | opt <- ghcOpts ]
, specified HsColour ?
arg "--source-module=src/%{MODULE/./-}.html"
......
......@@ -22,8 +22,9 @@ pkgDataFile stage pkg = targetPath stage pkg -/- "package-data.mk"
-- Relative path to a package haddock file, e.g.:
-- "libraries/array/dist-install/doc/html/array/array.haddock"
pkgHaddockFile :: Package -> FilePath
pkgHaddockFile pkg @ (Package name _ _) =
pkgHaddockFile pkg =
targetPath Stage1 pkg -/- "doc/html" -/- name -/- name <.> "haddock"
where name = pkgNameString pkg
-- Relative path to a package library file, e.g.:
-- "libraries/array/dist-install/build/libHSarray-0.5.1.0.a"
......
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