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
7a936b63
Commit
7a936b63
authored
Aug 01, 2015
by
Andrey Mokhov
Browse files
Clean up and optimise performance.
parent
0be1b62e
Changes
3
Hide whitespace changes
Inline
Side-by-side
src/Oracles/DependencyList.hs
View file @
7a936b63
...
...
@@ -21,7 +21,7 @@ newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
dependencyList
::
FilePath
->
FilePath
->
Action
[
FilePath
]
dependencyList
depFile
objFile
=
do
res
<-
askOracle
$
DependencyListKey
(
depFile
,
objFile
)
return
$
fromMaybe
[]
res
return
.
fromMaybe
[]
$
res
-- Oracle for 'path/dist/*.deps' files
dependencyListOracle
::
Rules
()
...
...
@@ -30,11 +30,11 @@ dependencyListOracle = do
need
[
file
]
putOracle
$
"Reading "
++
file
++
"..."
contents
<-
parseMakefile
<$>
(
liftIO
$
readFile
file
)
return
$
Map
.
fromList
$
map
(
bimap
unifyPath
(
map
unifyPath
))
$
map
(
bimap
head
concat
.
unzip
)
$
groupBy
((
==
)
`
on
`
fst
)
$
sortBy
(
compare
`
on
`
fst
)
contents
return
.
Map
.
fromList
.
map
(
bimap
unifyPath
(
map
unifyPath
))
.
map
(
bimap
head
concat
.
unzip
)
.
groupBy
((
==
)
`
on
`
fst
)
.
sortBy
(
compare
`
on
`
fst
)
$
contents
addOracle
$
\
(
DependencyListKey
(
file
,
obj
))
->
Map
.
lookup
(
unifyPath
obj
)
<$>
deps
(
unifyPath
file
)
return
()
src/Settings/Util.hs
View file @
7a936b63
...
...
@@ -84,7 +84,7 @@ getHsSources = do
(
foundSources
,
missingSources
)
<-
findModuleFiles
dirs
"*hs"
-- Generated source files
will
live in buildPath and have extension "hs"
-- Generated source files live in buildPath and have extension "hs"
let
generatedSources
=
map
(
\
f
->
buildPath
-/-
f
<.>
"hs"
)
missingSources
return
$
foundSources
++
generatedSources
...
...
@@ -103,18 +103,21 @@ decodeModule = splitFileName . replaceEq '.' '/'
-- * 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
ext
=
do
findModuleFiles
dirs
ext
ension
=
do
modules
<-
getPkgDataList
Modules
let
decodedMods
=
sort
.
map
decodeModule
$
modules
modDirFiles
=
map
(
bimap
head
sort
.
unzip
)
.
groupBy
((
==
)
`
on
`
fst
)
$
decodedMods
let
decodedMods
=
sort
.
map
decodeModule
$
modules
modDirFiles
=
map
(
bimap
head
sort
.
unzip
)
.
groupBy
((
==
)
`
on
`
fst
)
$
decodedMods
matchExtension
=
(
?==
)
(
"*"
<.>
extension
)
result
<-
lift
.
fmap
concat
.
forM
dirs
$
\
dir
->
do
todo
<-
filterM
(
doesDirectoryExist
.
(
dir
-/-
)
.
fst
)
modDirFiles
forM
todo
$
\
(
mDir
,
mFiles
)
->
do
let
files
=
[
dir
-/-
mDir
-/-
mFile
<.>
ext
|
mFile
<-
mFiles
]
found
<-
fmap
(
map
unifyPath
)
$
getDirectoryFiles
""
files
return
(
found
,
(
mDir
,
map
takeBaseName
found
))
let
fullDir
=
dir
-/-
mDir
files
<-
fmap
(
filter
matchExtension
)
$
getDirectoryContents
fullDir
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
]
...
...
src/Util.hs
View file @
7a936b63
...
...
@@ -6,7 +6,7 @@ module Util (
unifyPath
,
(
-/-
),
chunksOfSize
,
putColoured
,
redError
,
redError_
,
bimap
,
minusOrd
bimap
,
minusOrd
,
intersectOrd
)
where
import
Data.Char
...
...
@@ -71,7 +71,7 @@ redError_ = void . redError
bimap
::
(
a
->
b
)
->
(
c
->
d
)
->
(
a
,
c
)
->
(
b
,
d
)
bimap
f
g
(
x
,
y
)
=
(
f
x
,
g
y
)
-- Depending on Data.List.Ordered only for th
is
function seems an overkill
-- Depending on Data.List.Ordered only for th
ese two
function
s
seems an overkill
minusOrd
::
Ord
a
=>
[
a
]
->
[
a
]
->
[
a
]
minusOrd
[]
_
=
[]
minusOrd
xs
[]
=
xs
...
...
@@ -79,3 +79,13 @@ minusOrd (x:xs) (y:ys) = case compare x y of
LT
->
x
:
minusOrd
xs
(
y
:
ys
)
EQ
->
minusOrd
xs
ys
GT
->
minusOrd
(
x
:
xs
)
ys
intersectOrd
::
(
a
->
b
->
Ordering
)
->
[
a
]
->
[
b
]
->
[
a
]
intersectOrd
cmp
=
loop
where
loop
[]
_
=
[]
loop
_
[]
=
[]
loop
(
x
:
xs
)
(
y
:
ys
)
=
case
cmp
x
y
of
LT
->
loop
xs
(
y
:
ys
)
EQ
->
x
:
loop
xs
ys
GT
->
loop
(
x
:
xs
)
ys
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