Skip to content
GitLab
Menu
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
c50e0dc4
Commit
c50e0dc4
authored
Jan 20, 2016
by
Andrey Mokhov
Browse files
Refactor CmdLineFlag.hs.
parent
30883f8d
Changes
5
Hide whitespace changes
Inline
Side-by-side
shaking-up-ghc.cabal
View file @
c50e0dc4
...
...
@@ -19,12 +19,12 @@ executable ghc-shake
hs-source-dirs: src
other-modules: Base
, Builder
, CmdLineFlag
, Expression
, GHC
, Oracles
, Oracles.ArgsHash
, Oracles.Config
, Oracles.Config.CmdLineFlag
, Oracles.Config.Flag
, Oracles.Config.Setting
, Oracles.Dependencies
...
...
src/CmdLineFlag.hs
0 → 100644
View file @
c50e0dc4
module
CmdLineFlag
(
putCmdLineFlags
,
flags
,
cmdProgressInfo
,
ProgressInfo
(
..
)
)
where
import
Base
import
Data.Char
(
toLower
)
import
System.Console.GetOpt
import
Data.IORef
import
System.IO.Unsafe
(
unsafePerformIO
)
-- Command line flags
data
ProgressInfo
=
None
|
Brief
|
Normal
|
Unicorn
deriving
(
Eq
,
Show
)
-- | 'CmdLineFlag.Untracked' is a collection of flags that can be passed via the
-- command line. These flags are not tracked, that is they do not force any
-- build rules to be rurun.
data
Untracked
=
Untracked
{
progressInfo
::
ProgressInfo
}
deriving
(
Eq
,
Show
)
-- | Default values for 'CmdLineFlag.Untracked'.
defaultUntracked
::
Untracked
defaultUntracked
=
Untracked
{
progressInfo
=
Normal
}
readProgressInfo
::
Maybe
String
->
Either
String
(
Untracked
->
Untracked
)
readProgressInfo
ms
=
maybe
(
Left
"no parse"
)
(
Right
.
mkClosure
)
(
go
=<<
fmap
(
map
toLower
)
ms
)
where
go
::
String
->
Maybe
ProgressInfo
go
"none"
=
Just
None
go
"brief"
=
Just
Brief
go
"normal"
=
Just
Normal
go
"unicorn"
=
Just
Unicorn
go
_
=
Nothing
-- Left "no parse"
mkClosure
::
ProgressInfo
->
Untracked
->
Untracked
mkClosure
flag
opts
=
opts
{
progressInfo
=
flag
}
flags
::
[
OptDescr
(
Either
String
(
Untracked
->
Untracked
))]
flags
=
[
Option
[]
[
"progress-info"
]
(
OptArg
readProgressInfo
""
)
"Progress Info Style (None, Brief, Normal, or Unicorn)"
]
-- TODO: Get rid of unsafePerformIO by using shakeExtra.
{-# NOINLINE cmdLineFlags #-}
cmdLineFlags
::
IORef
Untracked
cmdLineFlags
=
unsafePerformIO
$
newIORef
defaultUntracked
putCmdLineFlags
::
[
Untracked
->
Untracked
]
->
IO
()
putCmdLineFlags
opts
=
modifyIORef
cmdLineFlags
(
\
o
->
foldl
(
flip
id
)
o
opts
)
getCmdLineFlags
::
Action
Untracked
getCmdLineFlags
=
liftIO
$
readIORef
cmdLineFlags
cmdProgressInfo
::
Action
ProgressInfo
cmdProgressInfo
=
progressInfo
<$>
getCmdLineFlags
src/Main.hs
View file @
c50e0dc4
...
...
@@ -3,6 +3,7 @@ module Main (main) where
import
Development.Shake
import
qualified
Base
import
CmdLineFlag
import
qualified
Rules
import
qualified
Rules.Cabal
import
qualified
Rules.Config
...
...
@@ -12,13 +13,13 @@ import qualified Rules.Libffi
import
qualified
Rules.Oracles
import
qualified
Rules.Perl
import
qualified
Test
import
Oracles.Config.CmdLineFlag
(
putOptions
,
flags
)
main
::
IO
()
main
=
shakeArgsWith
options
flags
$
\
cmdLineFlags
targets
->
do
putOptions
cmdLineFlags
return
.
Just
$
if
null
targets
then
rules
else
want
targets
>>
withoutActions
rules
putCmdLineFlags
cmdLineFlags
return
.
Just
$
if
null
targets
then
rules
else
want
targets
>>
withoutActions
rules
where
rules
::
Rules
()
rules
=
mconcat
...
...
src/Oracles/Config/CmdLineFlag.hs
deleted
100644 → 0
View file @
30883f8d
module
Oracles.Config.CmdLineFlag
(
putOptions
,
buildInfo
,
flags
,
BuildInfoFlag
(
..
))
where
import
Data.Char
(
toLower
)
import
System.Console.GetOpt
import
System.IO.Unsafe
(
unsafePerformIO
)
import
Data.IORef
-- Flags
data
BuildInfoFlag
=
None
|
Brief
|
Normal
|
Unicorn
deriving
(
Eq
,
Show
)
data
CmdLineOptions
=
CmdLineOptions
{
flagBuildInfo
::
BuildInfoFlag
}
deriving
(
Eq
,
Show
)
defaultCmdLineOptions
::
CmdLineOptions
defaultCmdLineOptions
=
CmdLineOptions
{
flagBuildInfo
=
Normal
}
readBuildInfoFlag
::
Maybe
String
->
Either
String
(
CmdLineOptions
->
CmdLineOptions
)
readBuildInfoFlag
ms
=
maybe
(
Left
"no parse"
)
(
Right
.
mkClosure
)
(
go
=<<
fmap
(
map
toLower
)
ms
)
where
go
::
String
->
Maybe
BuildInfoFlag
go
"none"
=
Just
None
go
"brief"
=
Just
Brief
go
"normal"
=
Just
Normal
go
"unicorn"
=
Just
Unicorn
go
_
=
Nothing
-- Left "no parse"
mkClosure
::
BuildInfoFlag
->
CmdLineOptions
->
CmdLineOptions
mkClosure
flag
opts
=
opts
{
flagBuildInfo
=
flag
}
flags
::
[
OptDescr
(
Either
String
(
CmdLineOptions
->
CmdLineOptions
))]
flags
=
[
Option
[]
[
"progress-info"
]
(
OptArg
readBuildInfoFlag
""
)
"Build Info Style (None, Brief, Normal, or Unicorn)"
]
-- IO -- We use IO here instead of Oracles, as Oracles form part of shakes cache
-- hence, changing command line arguments, would cause a full rebuild. And we
-- likely do *not* want to rebuild everything if only the @--build-info@ flag
-- was changed.
{-# NOINLINE cmdLineOpts #-}
cmdLineOpts
::
IORef
CmdLineOptions
cmdLineOpts
=
unsafePerformIO
$
newIORef
defaultCmdLineOptions
putOptions
::
[
CmdLineOptions
->
CmdLineOptions
]
->
IO
()
putOptions
opts
=
modifyIORef
cmdLineOpts
(
\
o
->
foldl
(
flip
id
)
o
opts
)
{-# NOINLINE getOptions #-}
getOptions
::
CmdLineOptions
getOptions
=
unsafePerformIO
$
readIORef
cmdLineOpts
buildInfo
::
BuildInfoFlag
buildInfo
=
flagBuildInfo
getOptions
src/Rules/Actions.hs
View file @
c50e0dc4
...
...
@@ -9,10 +9,10 @@ import qualified System.Directory as IO
import
System.Console.ANSI
import
Base
import
CmdLineFlag
import
Expression
import
Oracles
import
Oracles.ArgsHash
import
Oracles.Config.CmdLineFlag
(
buildInfo
,
BuildInfoFlag
(
..
))
import
Settings
import
Settings.Args
import
Settings.Builders.Ar
...
...
@@ -67,7 +67,7 @@ captureStdout target path argList = do
copyFile
::
FilePath
->
FilePath
->
Action
()
copyFile
source
target
=
do
putProgressInfo
$
renderAction
"Copy file"
source
target
putProgressInfo
=<<
renderAction
"Copy file"
source
target
copyFileChanged
source
target
createDirectory
::
FilePath
->
Action
()
...
...
@@ -83,7 +83,7 @@ removeDirectory dir = do
-- Note, the source directory is untracked
moveDirectory
::
FilePath
->
FilePath
->
Action
()
moveDirectory
source
target
=
do
putProgressInfo
$
renderAction
"Move directory"
source
target
putProgressInfo
=<<
renderAction
"Move directory"
source
target
liftIO
$
IO
.
renameDirectory
source
target
-- Transform a given file by applying a function to its contents
...
...
@@ -145,7 +145,7 @@ makeExecutable file = do
-- Print out key information about the command being executed
putInfo
::
Target
.
Target
->
Action
()
putInfo
Target
.
Target
{
..
}
=
putProgressInfo
$
renderAction
putInfo
Target
.
Target
{
..
}
=
putProgressInfo
=<<
renderAction
(
"Run "
++
show
builder
++
" ("
++
stageInfo
++
"package = "
++
pkgNameString
package
++
wayInfo
++
")"
)
(
digest
inputs
)
...
...
@@ -157,22 +157,25 @@ putInfo Target.Target {..} = putProgressInfo $ renderAction
digest
[
x
]
=
x
digest
(
x
:
xs
)
=
x
++
" (and "
++
show
(
length
xs
)
++
" more)"
-- | Switch for @putBuild@ filtered through @
build
Info@
-- | Switch for @putBuild@ filtered through @
progress
Info@
putProgressInfo
::
String
->
Action
()
putProgressInfo
s
|
buildInfo
/=
None
=
putBuild
s
putProgressInfo
_
=
pure
()
putProgressInfo
msg
=
do
skip
<-
(
None
==
)
<$>
cmdProgressInfo
unless
skip
$
putBuild
msg
-- | Render an action.
renderAction
::
String
->
String
->
String
->
String
renderAction
what
input
output
=
case
buildInfo
of
Normal
->
renderBox
[
what
,
" input: "
++
input
,
" => output: "
++
output
]
Brief
->
"> "
++
what
++
": "
++
input
++
" => "
++
output
Unicorn
->
renderUnicorn
[
what
renderAction
::
String
->
String
->
String
->
Action
String
renderAction
what
input
output
=
do
style
<-
cmdProgressInfo
return
$
case
style
of
Normal
->
renderBox
[
what
,
" input: "
++
input
,
" => output: "
++
output
]
None
->
""
Brief
->
"| "
++
what
++
": "
++
input
++
" => "
++
output
Unicorn
->
renderUnicorn
[
what
,
" input: "
++
input
,
" => output: "
++
output
]
None
->
""
-- | Render the successful build of a program
renderProgram
::
String
->
String
->
String
->
String
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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