Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
7e652279
Commit
7e652279
authored
Dec 18, 2015
by
Ben Gamari
🐢
Browse files
Make PackageName into a proper newtype
parent
01538648
Changes
11
Hide whitespace changes
Inline
Side-by-side
src/GHC.hs
View file @
7e652279
{-# 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
$
pkgName
String
pkg
_
->
Nothing
|
isProgram
pkg
=
case
stage
of
Stage0
->
Just
.
inplaceProgram
$
pkgName
pkg
_
->
Just
.
installProgram
$
pkgName
pkg
Stage0
->
Just
.
inplaceProgram
$
pkgName
String
pkg
_
->
Just
.
installProgram
$
pkgName
String
pkg
|
otherwise
=
Nothing
where
inplaceProgram
name
=
programInplacePath
-/-
name
<.>
exe
...
...
src/Oracles/ModuleFiles.hs
View file @
7e652279
...
...
@@ -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 "
++
pkgName
String
pkg
++
"..."
unless
(
null
extraDirs
)
$
putOracle
$
"Extra directory = "
++
show
extraDirs
(
srcDirs
,
modules
)
<-
packageInfo
pkg
...
...
src/Oracles/PackageDeps.hs
View file @
7e652279
...
...
@@ -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
()
src/Package.hs
View file @
7e652279
{-# 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 p
ackage
n
ame
s from strings.
type
PackageName
=
String
instance
Show
P
ackage
N
ame
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
...
...
src/Rules/Cabal.hs
View file @
7e652279
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
=
D
istribution
.
Package
.
pkgName
identifier
let
identifier
=
package
.
packageDescription
$
pd
version
=
showVersion
.
pkgVersion
$
identifier
DP
.
PackageName
name
=
D
P
.
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
$
pkgName
String
pkg
:
sort
depNames
writeFileChanged
out
.
unlines
$
pkgDeps
collectDeps
::
Maybe
(
CondTree
v
[
Dependency
]
a
)
->
[
Dependency
]
...
...
src/Rules/Documentation.hs
View file @
7e652279
...
...
@@ -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
...
...
src/Rules/Generate.hs
View file @
7e652279
...
...
@@ -147,7 +147,7 @@ generateConfigHs = do
,
"cStage :: String"
,
"cStage = show (STAGE :: Int)"
,
"cIntegerLibrary :: String"
,
"cIntegerLibrary = "
++
quote
(
pkgName
integerLibrary
)
,
"cIntegerLibrary = "
++
quote
(
pkgName
String
integerLibrary
)
,
"cIntegerLibraryType :: IntegerLibrary"
,
"cIntegerLibraryType = "
++
cIntegerLibraryType
,
"cSupportsSplitObjs :: String"
...
...
src/Rules/Library.hs
View file @
7e652279
...
...
@@ -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
++
pkgName
String
pkg
++
"' ("
++
show
stage
++
", way "
++
show
way
++
")."
,
"Package synopsis: "
++
dropWhileEnd
isPunctuation
synopsis
++
"."
]
...
...
src/Rules/Program.hs
View file @
7e652279
...
...
@@ -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
++
")."
++
pkgName
String
pkg
++
"' ("
++
show
stage
++
")."
,
"Executable: "
++
bin
,
"Package synopsis: "
++
dropWhileEnd
isPunctuation
synopsis
++
"."
]
src/Settings/Builders/Haddock.hs
View file @
7e652279
...
...
@@ -24,14 +24,14 @@ haddockArgs = builder Haddock ? do
,
arg
$
"--dump-interface="
++
output
,
arg
"--html"
,
arg
"--hoogle"
,
arg
$
"--title="
++
pkgName
pkg
++
"-"
++
version
++
": "
++
synopsis
,
arg
$
"--title="
++
pkgName
String
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"
...
...
src/Settings/TargetDirectory.hs
View file @
7e652279
...
...
@@ -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"
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment