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
cf825feb
Commit
cf825feb
authored
Dec 23, 2015
by
Andrey Mokhov
Browse files
Implement ModuleFiles oracle for caching the search of module files of a package.
parent
ecdeae76
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/Oracles/ModuleFiles.hs
0 → 100644
View file @
cf825feb
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
module
Oracles.ModuleFiles
(
moduleFiles
,
haskellModuleFiles
,
moduleFilesOracle
)
where
import
Base
hiding
(
exe
)
import
Distribution.ModuleName
import
Distribution.PackageDescription
import
Distribution.PackageDescription.Parse
import
Distribution.Verbosity
import
GHC
import
Oracles.PackageData
import
Package
hiding
(
library
)
import
Stage
import
Settings.TargetDirectory
newtype
ModuleFilesKey
=
ModuleFilesKey
(
Package
,
[
FilePath
])
deriving
(
Show
,
Typeable
,
Eq
,
Hashable
,
Binary
,
NFData
)
moduleFiles
::
Stage
->
Package
->
Action
[
FilePath
]
moduleFiles
stage
pkg
=
do
let
path
=
targetPath
stage
pkg
modules
<-
fmap
sort
.
pkgDataList
$
Modules
path
(
found
,
_
::
[
FilePath
])
<-
askOracle
$
ModuleFilesKey
(
pkg
,
[]
)
let
cmp
(
m1
,
_
)
m2
=
compare
m1
m2
foundFiles
=
map
snd
$
intersectOrd
cmp
found
modules
return
foundFiles
haskellModuleFiles
::
Stage
->
Package
->
Action
([
FilePath
],
[
String
])
haskellModuleFiles
stage
pkg
=
do
let
path
=
targetPath
stage
pkg
autogen
=
path
-/-
"build/autogen"
modules
<-
fmap
sort
.
pkgDataList
$
Modules
path
(
found
,
missingMods
)
<-
askOracle
$
ModuleFilesKey
(
pkg
,
[
autogen
])
let
cmp
(
m1
,
_
)
m2
=
compare
m1
m2
foundFiles
=
map
snd
$
intersectOrd
cmp
found
modules
otherMods
=
map
(
replaceEq
'/'
'.'
.
dropExtension
)
otherFiles
(
haskellFiles
,
otherFiles
)
=
partition
(
"//*hs"
?==
)
foundFiles
return
(
haskellFiles
,
missingMods
++
otherMods
)
extract
::
Monoid
a
=>
Maybe
(
CondTree
v
c
a
)
->
a
extract
Nothing
=
mempty
extract
(
Just
(
CondNode
leaf
_
ifs
))
=
leaf
<>
mconcat
(
map
f
ifs
)
where
f
(
_
,
t
,
mt
)
=
extract
(
Just
t
)
<>
extract
mt
-- Look up Haskell source directories and module names of a package
packageInfo
::
Package
->
Action
([
FilePath
],
[
ModuleName
])
packageInfo
pkg
|
pkg
==
hp2ps
=
return
([
"."
],
[]
)
|
otherwise
=
do
need
[
pkgCabalFile
pkg
]
pd
<-
liftIO
.
readPackageDescription
silent
$
pkgCabalFile
pkg
let
lib
=
extract
$
condLibrary
pd
exe
=
extract
.
Just
.
snd
.
head
$
condExecutables
pd
let
(
srcDirs
,
modules
)
=
if
lib
/=
mempty
then
(
hsSourceDirs
$
libBuildInfo
lib
,
libModules
lib
)
else
(
hsSourceDirs
$
buildInfo
exe
,
[
fromString
.
dropExtension
$
modulePath
exe
]
++
exeModules
exe
)
return
(
if
null
srcDirs
then
[
"."
]
else
srcDirs
,
modules
)
moduleFilesOracle
::
Rules
()
moduleFilesOracle
=
do
answer
<-
newCache
$
\
(
pkg
,
extraDirs
)
->
do
putOracle
$
"Searching module files of package "
++
pkgName
pkg
++
"..."
unless
(
null
extraDirs
)
$
putOracle
$
"Extra directory = "
++
show
extraDirs
(
srcDirs
,
modules
)
<-
packageInfo
pkg
let
dirs
=
extraDirs
++
[
pkgPath
pkg
-/-
dir
|
dir
<-
srcDirs
]
decodedPairs
=
sort
$
map
(
splitFileName
.
toFilePath
)
modules
modDirFiles
=
map
(
bimap
head
sort
.
unzip
)
.
groupBy
((
==
)
`
on
`
fst
)
$
decodedPairs
result
<-
fmap
concat
.
forM
dirs
$
\
dir
->
do
todo
<-
filterM
(
doesDirectoryExist
.
(
dir
-/-
)
.
fst
)
modDirFiles
forM
todo
$
\
(
mDir
,
mFiles
)
->
do
let
fullDir
=
dir
-/-
mDir
files
<-
getDirectoryFiles
fullDir
[
"*"
]
let
noBoot
=
filter
(
not
.
(
isSuffixOf
"-boot"
))
files
cmp
fe
f
=
compare
(
dropExtension
fe
)
f
found
=
intersectOrd
cmp
noBoot
mFiles
return
(
map
(
fullDir
-/-
)
found
,
(
mDir
,
map
dropExtension
found
))
let
foundFiles
=
sort
[
(
encodeModule
d
f
,
f
)
|
(
fs
,
(
d
,
_
))
<-
result
,
f
<-
fs
]
foundPairs
=
[
(
d
,
f
)
|
(
d
,
fs
)
<-
map
snd
result
,
f
<-
fs
]
missingPairs
=
decodedPairs
`
minusOrd
`
sort
foundPairs
missingMods
=
map
(
uncurry
encodeModule
)
missingPairs
return
(
foundFiles
,
missingMods
)
_
<-
addOracle
$
\
(
ModuleFilesKey
query
)
->
answer
query
return
()
src/Rules/Generate.hs
View file @
cf825feb
...
...
@@ -3,6 +3,7 @@ module Rules.Generate (generatePackageCode) where
import
Expression
import
GHC
import
Oracles
import
Oracles.ModuleFiles
import
Rules.Actions
import
Rules.Resources
(
Resources
)
import
Settings
...
...
@@ -25,16 +26,14 @@ determineBuilder file = fmap fst $ find (\(_, e) -> e == ext) knownGenerators
generatePackageCode
::
Resources
->
PartialTarget
->
Rules
()
generatePackageCode
_
target
@
(
PartialTarget
stage
pkg
)
=
let
path
=
targetPath
stage
pkg
packagePath
=
pkgPath
pkg
buildPath
=
path
-/-
"build"
primopsTxt
=
targetPath
stage
compiler
-/-
"build/primops.txt"
platformH
=
targetPath
stage
compiler
-/-
"ghc_boot_platform.h"
generated
f
=
(
buildPath
++
"//*.hs"
)
?==
f
&&
not
(
"//autogen/*"
?==
f
)
in
do
generated
?>
\
file
->
do
dirs
<-
interpretPartial
target
$
getPkgDataList
SrcDirs
files
<-
getDirectoryFiles
""
$
[
packagePath
-/-
d
++
"//"
++
takeBaseName
file
<.>
"*"
|
d
<-
dirs
]
let
pattern
=
"//"
++
takeBaseName
file
<.>
"*"
files
<-
fmap
(
filter
(
pattern
?==
))
$
moduleFiles
stage
pkg
let
gens
=
[
(
f
,
b
)
|
f
<-
files
,
Just
b
<-
[
determineBuilder
f
]
]
when
(
length
gens
/=
1
)
.
putError
$
"Exactly one generator expected for "
++
file
...
...
src/Rules/Oracles.hs
View file @
cf825feb
...
...
@@ -3,12 +3,14 @@ module Rules.Oracles (oracleRules) where
import
Base
import
Oracles
import
Oracles.ArgsHash
import
Oracles.ModuleFiles
oracleRules
::
Rules
()
oracleRules
=
do
argsHashOracle
-- see Oracles.ArgsHash
configOracle
-- see Oracles.Config
dependenciesOracle
-- see Oracles.Dependencies
moduleFilesOracle
-- see Oracles.ModuleFiles
packageDataOracle
-- see Oracles.PackageData
packageDepsOracle
-- see Oracles.PackageDeps
dependenciesOracle
-- see Oracles.Dependencies
argsHashOracle
-- see Oracles.ArgsHash
windowsRootOracle
-- see Oracles.WindowsRoot
src/Settings.hs
View file @
cf825feb
...
...
@@ -4,11 +4,12 @@ module Settings (
module
Settings
.
User
,
module
Settings
.
Ways
,
getPkgData
,
getPkgDataList
,
programPath
,
isLibrary
,
getPackagePath
,
getTargetDirectory
,
getTargetPath
,
getPackageSources
,
getPackagePath
,
getTargetDirectory
,
getTargetPath
,
getPackageSources
)
where
import
Expression
import
Oracles
import
Oracles.ModuleFiles
import
Settings.Packages
import
Settings.TargetDirectory
import
Settings.User
...
...
@@ -32,53 +33,17 @@ getPkgDataList key = lift . pkgDataList . key =<< getTargetPath
programPath
::
Stage
->
Package
->
Maybe
FilePath
programPath
=
userProgramPath
-- Find all Haskell source files for the current target
. TODO: simplify.
--
|
Find all Haskell source files for the current target
getPackageSources
::
Expr
[
FilePath
]
getPackageSources
=
do
path
<-
getTargetPath
packagePath
<-
getPackagePath
srcDirs
<-
getPkgDataList
SrcDirs
stage
<-
getStage
pkg
<-
getPackage
path
<-
getTargetPath
let
buildPath
=
path
-/-
"build"
autogen
=
buildPath
-/-
"autogen"
dirs
=
autogen
:
map
(
packagePath
-/-
)
srcDirs
(
foundSources
,
missingSources
)
<-
findModuleFiles
dirs
"*hs"
(
found
,
missingMods
)
<-
lift
$
haskellModuleFiles
stage
pkg
-- Generated source files live in buildPath and have extension "hs"...
let
generated
Sources
=
[
buildPath
-/-
s
<.>
"hs"
|
s
<-
missing
Source
s
]
-- ...except that GHC/Prim.hs lives in autogen. TODO: fix?
let
generated
=
[
buildPath
-/-
(
replaceEq
'.'
'/'
m
)
<.>
"hs"
|
m
<-
missing
Mod
s
]
-- ...except that GHC/Prim.hs lives in autogen. TODO: fix
the inconsistency
?
fixGhcPrim
=
replaceEq
(
buildPath
-/-
"GHC/Prim.hs"
)
(
autogen
-/-
"GHC/Prim.hs"
)
return
$
foundSources
++
fixGhcPrim
generatedSources
-- findModuleFiles scans a list of given directories and finds files matching a
-- given pattern (e.g., "*hs") that correspond to modules of the currently built
-- package. Missing module files are returned in a separate list. The returned
-- pair contains the following:
-- * a list of found module files, with paths being relative to one of given
-- directories, e.g. "codeGen/CodeGen/Platform.hs" for the compiler package.
-- * a list of module files that have not been found, with paths being relative
-- to the module directory, e.g. "CodeGen/Platform", and with no extension.
findModuleFiles
::
[
FilePath
]
->
FilePattern
->
Expr
([
FilePath
],
[
FilePath
])
findModuleFiles
dirs
pattern
=
do
modules
<-
getPkgDataList
Modules
let
decodedMods
=
sort
.
map
decodeModule
$
modules
modDirFiles
=
map
(
bimap
head
sort
.
unzip
)
.
groupBy
((
==
)
`
on
`
fst
)
$
decodedMods
result
<-
lift
.
fmap
concat
.
forM
dirs
$
\
dir
->
do
todo
<-
filterM
(
doesDirectoryExist
.
(
dir
-/-
)
.
fst
)
modDirFiles
forM
todo
$
\
(
mDir
,
mFiles
)
->
do
let
fullDir
=
dir
-/-
mDir
files
<-
getDirectoryFiles
fullDir
[
pattern
]
let
cmp
fe
f
=
compare
(
dropExtension
fe
)
f
found
=
intersectOrd
cmp
files
mFiles
return
(
map
(
fullDir
-/-
)
found
,
(
mDir
,
map
dropExtension
found
))
let
foundFiles
=
concatMap
fst
result
foundMods
=
[
(
d
,
f
)
|
(
d
,
fs
)
<-
map
snd
result
,
f
<-
fs
]
missingMods
=
decodedMods
`
minusOrd
`
sort
foundMods
missingFiles
=
map
(
uncurry
(
-/-
))
missingMods
return
(
foundFiles
,
missingFiles
)
return
$
found
++
fixGhcPrim
generated
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