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
95027b82
Commit
95027b82
authored
Nov 23, 2012
by
ian@well-typed.com
Browse files
de-tab hpc
parent
c04a9849
Changes
9
Hide whitespace changes
Inline
Side-by-side
mk/validate-settings.mk
View file @
95027b82
...
...
@@ -23,6 +23,7 @@ SRC_HC_OPTS += $(WERROR) -Wall
GhcStage1HcOpts
+=
-fwarn-tabs
GhcStage2HcOpts
+=
-fwarn-tabs
utils/
hpc_dist-install_EXTRA_HC_OPTS
+=
-fwarn-tabs
#####################
SRC_HC_OPTS
+=
-H64m
-O0
...
...
utils/hpc/HpcCombine.hs
View file @
95027b82
...
...
@@ -3,7 +3,7 @@
-- Andy Gill, Oct 2006
---------------------------------------------------------
module
HpcCombine
(
sum_plugin
,
combine_plugin
,
map_plugin
)
where
module
HpcCombine
(
sum_plugin
,
combine_plugin
,
map_plugin
)
where
import
Trace.Hpc.Tix
import
Trace.Hpc.Util
...
...
@@ -16,70 +16,70 @@ import qualified Data.Map as Map
------------------------------------------------------------------------------
sum_options
::
FlagOptSeq
sum_options
sum_options
=
excludeOpt
.
includeOpt
.
outputOpt
.
unionModuleOpt
.
unionModuleOpt
sum_plugin
::
Plugin
sum_plugin
=
Plugin
{
name
=
"sum"
,
usage
=
"[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
,
options
=
sum_options
,
summary
=
"Sum multiple .tix files in a single .tix file"
,
implementation
=
sum_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
,
usage
=
"[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
,
options
=
sum_options
,
summary
=
"Sum multiple .tix files in a single .tix file"
,
implementation
=
sum_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
combine_options
::
FlagOptSeq
combine_options
combine_options
=
excludeOpt
.
includeOpt
.
outputOpt
.
combineFunOpt
.
combineFunOptInfo
.
unionModuleOpt
.
unionModuleOpt
combine_plugin
::
Plugin
combine_plugin
=
Plugin
{
name
=
"combine"
,
usage
=
"[OPTION] .. <TIX_FILE> <TIX_FILE>"
,
options
=
combine_options
,
summary
=
"Combine two .tix files in a single .tix file"
,
implementation
=
combine_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
,
usage
=
"[OPTION] .. <TIX_FILE> <TIX_FILE>"
,
options
=
combine_options
,
summary
=
"Combine two .tix files in a single .tix file"
,
implementation
=
combine_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
map_options
::
FlagOptSeq
map_options
map_options
=
excludeOpt
.
includeOpt
.
outputOpt
.
mapFunOpt
.
mapFunOpt
.
mapFunOptInfo
.
unionModuleOpt
.
unionModuleOpt
map_plugin
::
Plugin
map_plugin
=
Plugin
{
name
=
"map"
,
usage
=
"[OPTION] .. <TIX_FILE> "
,
options
=
map_options
,
summary
=
"Map a function over a single .tix file"
,
implementation
=
map_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
,
usage
=
"[OPTION] .. <TIX_FILE> "
,
options
=
map_options
,
summary
=
"Map a function over a single .tix file"
,
implementation
=
map_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
------------------------------------------------------------------------------
sum_main
::
Flags
->
[
String
]
->
IO
()
sum_main
_
[]
=
hpcError
sum_plugin
$
"no .tix file specified"
sum_main
_
[]
=
hpcError
sum_plugin
$
"no .tix file specified"
sum_main
flags
(
first_file
:
more_files
)
=
do
Just
tix
<-
readTix
first_file
tix'
<-
foldM
(
mergeTixFile
flags
(
+
))
(
filterTix
flags
tix
)
more_files
tix'
<-
foldM
(
mergeTixFile
flags
(
+
))
(
filterTix
flags
tix
)
more_files
case
outputFile
flags
of
"-"
->
putStrLn
(
show
tix'
)
...
...
@@ -92,10 +92,10 @@ combine_main flags [first_file,second_file] = do
Just
tix1
<-
readTix
first_file
Just
tix2
<-
readTix
second_file
let
tix
=
mergeTix
(
mergeModule
flags
)
f
(
filterTix
flags
tix1
)
(
filterTix
flags
tix2
)
let
tix
=
mergeTix
(
mergeModule
flags
)
f
(
filterTix
flags
tix1
)
(
filterTix
flags
tix2
)
case
outputFile
flags
of
"-"
->
putStrLn
(
show
tix
)
...
...
@@ -110,55 +110,55 @@ map_main flags [first_file] = do
let
(
Tix
inside_tix
)
=
filterTix
flags
tix
let
tix'
=
Tix
[
TixModule
m
p
i
(
map
f
t
)
|
TixModule
m
p
i
t
<-
inside_tix
]
|
TixModule
m
p
i
t
<-
inside_tix
]
case
outputFile
flags
of
"-"
->
putStrLn
(
show
tix'
)
out
->
writeTix
out
tix'
map_main
_
[]
=
hpcError
map_plugin
$
"no .tix file specified"
map_main
_
_
=
hpcError
map_plugin
$
"to many .tix files specified"
map_main
_
[]
=
hpcError
map_plugin
$
"no .tix file specified"
map_main
_
_
=
hpcError
map_plugin
$
"to many .tix files specified"
mergeTixFile
::
Flags
->
(
Integer
->
Integer
->
Integer
)
->
Tix
->
String
->
IO
Tix
mergeTixFile
flags
fn
tix
file_name
=
do
Just
new_tix
<-
readTix
file_name
return
$!
strict
$
mergeTix
(
mergeModule
flags
)
fn
tix
(
filterTix
flags
new_tix
)
-- could allow different numbering on the module info,
-- could allow different numbering on the module info,
-- as long as the total is the same; will require normalization.
mergeTix
::
MergeFun
->
(
Integer
->
Integer
->
Integer
)
->
Tix
->
Tix
->
Tix
->
(
Integer
->
Integer
->
Integer
)
->
Tix
->
Tix
->
Tix
mergeTix
modComb
f
(
Tix
t1
)
(
Tix
t2
)
=
Tix
[
case
(
Map
.
lookup
m
fm1
,
Map
.
lookup
m
fm2
)
of
-- todo, revisit the semantics of this combination
(
Just
(
TixModule
_
hash1
len1
tix1
),
Just
(
TixModule
_
hash2
len2
tix2
))
|
hash1
/=
hash2
||
length
tix1
/=
length
tix2
||
len1
/=
length
tix1
||
len2
/=
length
tix2
->
error
$
"mismatched in module "
++
m
|
otherwise
->
TixModule
m
hash1
len1
(
zipWith
f
tix1
tix2
)
(
Just
m1
,
Nothing
)
->
m1
(
Nothing
,
Just
m2
)
->
m2
_
->
error
"impossible"
|
m
<-
Set
.
toList
(
theMergeFun
modComb
m1s
m2s
)
(
Tix
t1
)
(
Tix
t2
)
=
Tix
[
case
(
Map
.
lookup
m
fm1
,
Map
.
lookup
m
fm2
)
of
-- todo, revisit the semantics of this combination
(
Just
(
TixModule
_
hash1
len1
tix1
),
Just
(
TixModule
_
hash2
len2
tix2
))
|
hash1
/=
hash2
||
length
tix1
/=
length
tix2
||
len1
/=
length
tix1
||
len2
/=
length
tix2
->
error
$
"mismatched in module "
++
m
|
otherwise
->
TixModule
m
hash1
len1
(
zipWith
f
tix1
tix2
)
(
Just
m1
,
Nothing
)
->
m1
(
Nothing
,
Just
m2
)
->
m2
_
->
error
"impossible"
|
m
<-
Set
.
toList
(
theMergeFun
modComb
m1s
m2s
)
]
where
m1s
=
Set
.
fromList
$
map
tixModuleName
t1
where
m1s
=
Set
.
fromList
$
map
tixModuleName
t1
m2s
=
Set
.
fromList
$
map
tixModuleName
t2
fm1
=
Map
.
fromList
[
(
tixModuleName
tix
,
tix
)
|
tix
<-
t1
]
fm2
=
Map
.
fromList
[
(
tixModuleName
tix
,
tix
)
|
tix
<-
t2
]
fm1
=
Map
.
fromList
[
(
tixModuleName
tix
,
tix
)
|
tix
<-
t1
]
fm2
=
Map
.
fromList
[
(
tixModuleName
tix
,
tix
)
|
tix
<-
t2
]
-- What I would give for a hyperstrict :-)
...
...
@@ -172,7 +172,7 @@ instance Strict Integer where
instance
Strict
Int
where
strict
i
=
i
instance
Strict
Hash
where
-- should be fine, because Hash is a newtype round an Int
instance
Strict
Hash
where
-- should be fine, because Hash is a newtype round an Int
strict
i
=
i
instance
Strict
Char
where
...
...
@@ -186,10 +186,10 @@ instance (Strict a, Strict b) => Strict (a,b) where
strict
(
a
,
b
)
=
(((,)
$!
strict
a
)
$!
strict
b
)
instance
Strict
Tix
where
strict
(
Tix
t1
)
=
Tix
$!
strict
t1
strict
(
Tix
t1
)
=
Tix
$!
strict
t1
instance
Strict
TixModule
where
strict
(
TixModule
m1
p1
i1
t1
)
=
((((
TixModule
$!
strict
m1
)
$!
strict
p1
)
$!
strict
i1
)
$!
strict
t1
)
strict
(
TixModule
m1
p1
i1
t1
)
=
((((
TixModule
$!
strict
m1
)
$!
strict
p1
)
$!
strict
i1
)
$!
strict
t1
)
utils/hpc/HpcDraft.hs
View file @
95027b82
...
...
@@ -13,41 +13,41 @@ import Data.Tree
------------------------------------------------------------------------------
draft_options
::
FlagOptSeq
draft_options
draft_options
=
excludeOpt
.
includeOpt
.
srcDirOpt
.
hpcDirOpt
.
outputOpt
draft_plugin
::
Plugin
draft_plugin
=
Plugin
{
name
=
"draft"
,
usage
=
"[OPTION] .. <TIX_FILE>"
,
options
=
draft_options
,
summary
=
"Generate draft overlay that provides 100% coverage"
,
implementation
=
draft_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
,
usage
=
"[OPTION] .. <TIX_FILE>"
,
options
=
draft_options
,
summary
=
"Generate draft overlay that provides 100% coverage"
,
implementation
=
draft_main
,
init_flags
=
default_flags
,
final_flags
=
default_final_flags
}
------------------------------------------------------------------------------
draft_main
::
Flags
->
[
String
]
->
IO
()
draft_main
_
[]
=
error
"draft_main: unhandled case: []"
draft_main
hpcflags
(
progName
:
mods
)
=
do
let
hpcflags1
=
hpcflags
{
includeMods
=
Set
.
fromList
mods
`
Set
.
union
`
includeMods
hpcflags
}
let
prog
=
getTixFileName
$
progName
tix
<-
readTix
prog
let
hpcflags1
=
hpcflags
{
includeMods
=
Set
.
fromList
mods
`
Set
.
union
`
includeMods
hpcflags
}
let
prog
=
getTixFileName
$
progName
tix
<-
readTix
prog
case
tix
of
Just
(
Tix
tickCounts
)
->
do
outs
<-
sequence
[
makeDraft
hpcflags1
tixModule
|
tixModule
@
(
TixModule
m
_
_
_
)
<-
tickCounts
,
allowModule
hpcflags1
m
]
outs
<-
sequence
[
makeDraft
hpcflags1
tixModule
|
tixModule
@
(
TixModule
m
_
_
_
)
<-
tickCounts
,
allowModule
hpcflags1
m
]
case
outputFile
hpcflags1
of
"-"
->
putStrLn
(
unlines
outs
)
out
->
writeFile
out
(
unlines
outs
)
...
...
@@ -55,13 +55,13 @@ draft_main hpcflags (progName:mods) = do
makeDraft
::
Flags
->
TixModule
->
IO
String
makeDraft
hpcflags
tix
=
do
makeDraft
hpcflags
tix
=
do
let
modu
=
tixModuleName
tix
tixs
=
tixModuleTixs
tix
(
Mix
filepath
_
_
_
entries
)
<-
readMixWithFlags
hpcflags
(
Right
tix
)
let
forest
=
createMixEntryDom
let
forest
=
createMixEntryDom
[
(
srcspan
,(
box
,
v
>
0
))
|
((
srcspan
,
box
),
v
)
<-
zip
entries
tixs
]
...
...
@@ -77,7 +77,7 @@ makeDraft hpcflags tix = do
hsMap
=
Map
.
fromList
(
zip
[
1
..
]
$
lines
hs
)
let
quoteString
=
show
let
firstLine
pos
=
case
fromHpcPos
pos
of
(
ln
,
_
,
_
,
_
)
->
ln
...
...
@@ -88,10 +88,10 @@ makeDraft hpcflags tix = do
++
"on line "
++
show
(
firstLine
pos
)
++
";"
showPleaseTick
d
(
TickExp
pos
)
=
spaces
d
++
"tick "
++
if
'
\n
'
`
elem
`
txt
++
if
'
\n
'
`
elem
`
txt
then
"at position "
++
show
pos
++
";"
else
quoteString
txt
++
" "
++
"on line "
++
show
(
firstLine
pos
)
++
";"
where
txt
=
grabHpcPos
hsMap
pos
...
...
@@ -133,8 +133,8 @@ findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
findNotTickedFromTree
(
Node
(
pos
,(
LocalBox
nm
,
False
)
:
_
)
_
)
=
[
TickFun
nm
pos
]
findNotTickedFromTree
(
Node
(
pos
,(
TopLevelBox
nm
,
True
)
:
_
)
children
)
=
mkTickInside
nm
pos
(
findNotTickedFromList
children
)
[]
findNotTickedFromTree
(
Node
(
pos
,
_
:
others
)
children
)
=
=
mkTickInside
nm
pos
(
findNotTickedFromList
children
)
[]
findNotTickedFromTree
(
Node
(
pos
,
_
:
others
)
children
)
=
findNotTickedFromTree
(
Node
(
pos
,
others
)
children
)
findNotTickedFromTree
(
Node
(
_
,
[]
)
children
)
=
findNotTickedFromList
children
...
...
utils/hpc/HpcFlags.hs
View file @
95027b82
...
...
@@ -9,29 +9,29 @@ import Trace.Hpc.Tix
import
Trace.Hpc.Mix
import
System.Exit
data
Flags
=
Flags
{
outputFile
::
String
data
Flags
=
Flags
{
outputFile
::
String
,
includeMods
::
Set
.
Set
String
,
excludeMods
::
Set
.
Set
String
,
hpcDir
::
String
,
srcDirs
::
[
String
]
,
destDir
::
String
,
hpcDir
::
String
,
srcDirs
::
[
String
]
,
destDir
::
String
,
perModule
::
Bool
,
decList
::
Bool
,
xmlOutput
::
Bool
,
perModule
::
Bool
,
decList
::
Bool
,
xmlOutput
::
Bool
,
funTotals
::
Bool
,
altHighlight
::
Bool
,
combineFun
::
CombineFun
-- tick-wise combine
,
postFun
::
PostFun
--
,
mergeModule
::
MergeFun
-- module-wise merge
,
combineFun
::
CombineFun
-- tick-wise combine
,
postFun
::
PostFun
--
,
mergeModule
::
MergeFun
-- module-wise merge
}
default_flags
::
Flags
default_flags
=
Flags
{
outputFile
=
"-"
{
outputFile
=
"-"
,
includeMods
=
Set
.
empty
,
excludeMods
=
Set
.
empty
,
hpcDir
=
".hpc"
...
...
@@ -39,15 +39,15 @@ default_flags = Flags
,
destDir
=
"."
,
perModule
=
False
,
decList
=
False
,
xmlOutput
=
False
,
decList
=
False
,
xmlOutput
=
False
,
funTotals
=
False
,
altHighlight
=
False
,
combineFun
=
ADD
,
postFun
=
ID
,
mergeModule
=
INTERSECTION
,
mergeModule
=
INTERSECTION
}
...
...
@@ -55,10 +55,10 @@ default_flags = Flags
-- depends on if specific flags we used.
default_final_flags
::
Flags
->
Flags
default_final_flags
flags
=
flags
default_final_flags
flags
=
flags
{
srcDirs
=
if
null
(
srcDirs
flags
)
then
[
"."
]
else
srcDirs
flags
then
[
"."
]
else
srcDirs
flags
}
type
FlagOptSeq
=
[
OptDescr
(
Flags
->
Flags
)]
->
[
OptDescr
(
Flags
->
Flags
)]
...
...
@@ -76,10 +76,10 @@ excludeOpt, includeOpt, hpcDirOpt, srcDirOpt, destDirOpt, outputOpt,
perModuleOpt
,
decListOpt
,
xmlOutputOpt
,
funTotalsOpt
,
altHighlightOpt
,
combineFunOpt
,
combineFunOptInfo
,
mapFunOpt
,
mapFunOptInfo
,
unionModuleOpt
::
FlagOptSeq
excludeOpt
=
anArg
"exclude"
"exclude MODULE and/or PACKAGE"
"[PACKAGE:][MODULE]"
excludeOpt
=
anArg
"exclude"
"exclude MODULE and/or PACKAGE"
"[PACKAGE:][MODULE]"
$
\
a
f
->
f
{
excludeMods
=
a
`
Set
.
insert
`
excludeMods
f
}
includeOpt
=
anArg
"include"
"include MODULE and/or PACKAGE"
"[PACKAGE:][MODULE]"
includeOpt
=
anArg
"include"
"include MODULE and/or PACKAGE"
"[PACKAGE:][MODULE]"
$
\
a
f
->
f
{
includeMods
=
a
`
Set
.
insert
`
includeMods
f
}
hpcDirOpt
=
anArg
"hpcdir"
"sub-directory that contains .mix files"
"DIR"
...
...
@@ -87,92 +87,92 @@ hpcDirOpt = anArg "hpcdir" "sub-directory that contains .mix files" "
.
infoArg
"default .hpc [rarely used]"
srcDirOpt
=
anArg
"srcdir"
"path to source directory of .hs files"
"DIR"
(
\
a
f
->
f
{
srcDirs
=
srcDirs
f
++
[
a
]
})
.
infoArg
"multi-use of srcdir possible"
(
\
a
f
->
f
{
srcDirs
=
srcDirs
f
++
[
a
]
})
.
infoArg
"multi-use of srcdir possible"
destDirOpt
=
anArg
"destdir"
"path to write output to"
"DIR"
$
\
a
f
->
f
{
destDir
=
a
}
$
\
a
f
->
f
{
destDir
=
a
}
outputOpt
=
anArg
"output"
"output FILE"
"FILE"
$
\
a
f
->
f
{
outputFile
=
a
}
-- markup
perModuleOpt
=
noArg
"per-module"
"show module level detail"
$
\
f
->
f
{
perModule
=
True
}
decListOpt
=
noArg
"decl-list"
"show unused decls"
$
\
f
->
f
{
decList
=
True
}
xmlOutputOpt
=
noArg
"xml-output"
"show output in XML"
$
\
f
->
f
{
xmlOutput
=
True
}
funTotalsOpt
=
noArg
"fun-entry-count"
"show top-level function entry counts"
$
\
f
->
f
{
funTotals
=
True
}
altHighlightOpt
=
noArg
"highlight-covered"
"highlight covered code, rather that code gaps"
$
\
f
->
f
{
altHighlight
=
True
}
combineFunOpt
=
anArg
"function"
"combine .tix files with join function, default = ADD"
"FUNCTION"
$
\
a
f
->
case
reads
(
map
toUpper
a
)
of
[(
c
,
""
)]
->
f
{
combineFun
=
c
}
_
->
error
$
"no such combine function : "
++
a
combineFunOptInfo
=
infoArg
$
"FUNCTION = "
++
foldr1
(
\
a
b
->
a
++
" | "
++
b
)
(
map
fst
foldFuns
)
decListOpt
=
noArg
"decl-list"
"show unused decls"
$
\
f
->
f
{
decList
=
True
}
xmlOutputOpt
=
noArg
"xml-output"
"show output in XML"
$
\
f
->
f
{
xmlOutput
=
True
}
funTotalsOpt
=
noArg
"fun-entry-count"
"show top-level function entry counts"
$
\
f
->
f
{
funTotals
=
True
}
altHighlightOpt
=
noArg
"highlight-covered"
"highlight covered code, rather that code gaps"
$
\
f
->
f
{
altHighlight
=
True
}
combineFunOpt
=
anArg
"function"
"combine .tix files with join function, default = ADD"
"FUNCTION"
$
\
a
f
->
case
reads
(
map
toUpper
a
)
of
[(
c
,
""
)]
->
f
{
combineFun
=
c
}
_
->
error
$
"no such combine function : "
++
a
combineFunOptInfo
=
infoArg
$
"FUNCTION = "
++
foldr1
(
\
a
b
->
a
++
" | "
++
b
)
(
map
fst
foldFuns
)
mapFunOpt
=
anArg
"function"
"apply function to .tix files, default = ID"
"FUNCTION"
$
\
a
f
->
case
reads
(
map
toUpper
a
)
of
[(
c
,
""
)]
->
f
{
postFun
=
c
}
_
->
error
$
"no such combine function : "
++
a
mapFunOptInfo
=
infoArg
$
"FUNCTION = "
++
foldr1
(
\
a
b
->
a
++
" | "
++
b
)
(
map
fst
postFuns
)
"apply function to .tix files, default = ID"
"FUNCTION"
$
\
a
f
->
case
reads
(
map
toUpper
a
)
of
[(
c
,
""
)]
->
f
{
postFun
=
c
}
_
->
error
$
"no such combine function : "
++
a
mapFunOptInfo
=
infoArg
$
"FUNCTION = "
++
foldr1
(
\
a
b
->
a
++
" | "
++
b
)
(
map
fst
postFuns
)
unionModuleOpt
=
noArg
"union"
"use the union of the module namespace (default is intersection)"
$
\
f
->
f
{
mergeModule
=
UNION
}
"use the union of the module namespace (default is intersection)"
$
\
f
->
f
{
mergeModule
=
UNION
}
-------------------------------------------------------------------------------
readMixWithFlags
::
Flags
->
Either
String
TixModule
->
IO
Mix
readMixWithFlags
flags
modu
=
readMix
[
dir
++
"/"
++
hpcDir
flags
|
dir
<-
srcDirs
flags
|
dir
<-
srcDirs
flags
]
modu
-------------------------------------------------------------------------------
command_usage
::
Plugin
->
IO
()
command_usage
plugin
=
command_usage
plugin
=
putStrLn
$
"Usage: hpc "
++
(
name
plugin
)
++
" "
++
(
usage
plugin
)
++
"
\n
"
++
summary
plugin
++
"
\n
"
++
if
null
(
options
plugin
[]
)
then
""
else
usageInfo
"
\n\n
Options:
\n
"
(
options
plugin
[]
)
"Usage: hpc "
++
(
name
plugin
)
++
" "
++
(
usage
plugin
)
++
"
\n
"
++
summary
plugin
++
"
\n
"
++
if
null
(
options
plugin
[]
)
then
""
else
usageInfo
"
\n\n
Options:
\n
"
(
options
plugin
[]
)
hpcError
::
Plugin
->
String
->
IO
a
hpcError
plugin
msg
=
do
putStrLn
$
"Error: "
++
msg
command_usage
plugin
exitFailure
-------------------------------------------------------------------------------
data
Plugin
=
Plugin
{
name
::
String
,
usage
::
String
,
options
::
FlagOptSeq
,
summary
::
String
,
implementation
::
Flags
->
[
String
]
->
IO
()
,
init_flags
::
Flags
,
final_flags
::
Flags
->
Flags
}
,
usage
::
String
,
options
::
FlagOptSeq
,
summary
::
String
,
implementation
::
Flags
->
[
String
]
->
IO
()
,
init_flags
::
Flags
,
final_flags
::
Flags
->
Flags
}
------------------------------------------------------------------------------
-- filterModules takes a list of candidate modules,
-- and
-- filterModules takes a list of candidate modules,
-- and
-- * excludes the excluded modules
-- * includes the rest if there are no explicity included modules
-- * otherwise, accepts just the included modules.
allowModule
::
Flags
->
String
->
Bool
allowModule
flags
full_mod
allowModule
flags
full_mod
|
full_mod'
`
Set
.
member
`
excludeMods
flags
=
False
|
pkg_name
`
Set
.
member
`
excludeMods
flags
=
False
|
mod_name
`
Set
.
member
`
excludeMods
flags
=
False
...
...
@@ -180,38 +180,38 @@ allowModule flags full_mod
|
full_mod'
`
Set
.
member
`
includeMods
flags
=
True
|
pkg_name
`
Set
.
member
`
includeMods
flags
=
True
|
mod_name
`
Set
.
member
`
includeMods
flags
=
True
|
otherwise
=
False
|
otherwise
=
False
where
full_mod'
=
pkg_name
++
mod_name
-- pkg name always ends with '/', main
(
pkg_name
,
mod_name
)
=
case
span
(
/=
'/'
)
full_mod
of
(
p
,
'/'
:
m
)
->
(
p
++
":"
,
m
)
(
m
,
[]
)
->
(
":"
,
m
)
_
->
error
"impossible case in allowModule"
-- pkg name always ends with '/', main
(
pkg_name
,
mod_name
)
=
case
span
(
/=
'/'
)
full_mod
of
(
p
,
'/'
:
m
)
->
(
p
++
":"
,
m
)
(
m
,
[]
)
->
(
":"
,
m
)
_
->
error
"impossible case in allowModule"
filterTix
::
Flags
->
Tix
->
Tix
filterTix
flags
(
Tix
tixs
)
=
Tix
$
filter
(
allowModule
flags
.
tixModuleName
)
tixs