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
Packages
Cabal
Commits
d1b84d3b
Commit
d1b84d3b
authored
Jan 02, 2017
by
Edward Z. Yang
Committed by
Edward Z. Yang
Jan 06, 2017
Browse files
Create CondBranch type to represent CondTree triple.
Signed-off-by:
Edward Z. Yang
<
ezyang@cs.stanford.edu
>
parent
c373c77e
Changes
8
Hide whitespace changes
Inline
Side-by-side
Cabal/Distribution/PackageDescription/Check.hs
View file @
d1b84d3b
...
...
@@ -46,6 +46,7 @@ import Distribution.Simple.CCompiler
import
Distribution.Types.ComponentRequestedSpec
import
Distribution.Types.Dependency
import
Distribution.Types.UnqualComponentName
import
Distribution.Types.CondTree
import
Distribution.Simple.Utils
hiding
(
findPackageDesc
,
notice
)
import
Distribution.Version
import
Distribution.Package
...
...
@@ -1495,7 +1496,7 @@ checkConditionals pkg =
++
concatMap
(
fvs
.
snd
)
(
condTestSuites
pkg
)
++
concatMap
(
fvs
.
snd
)
(
condBenchmarks
pkg
)
fvs
(
CondNode
_
_
ifs
)
=
concatMap
compfv
ifs
-- free variables
compfv
(
c
,
ct
,
mct
)
=
condfv
c
++
fvs
ct
++
maybe
[]
fvs
mct
compfv
(
CondBranch
c
ct
mct
)
=
condfv
c
++
fvs
ct
++
maybe
[]
fvs
mct
condfv
c
=
case
c
of
Var
v
->
[
v
]
Lit
_
->
[]
...
...
@@ -1624,11 +1625,11 @@ checkDevelopmentOnlyFlags pkg =
:
concat
[
go
(
condition
:
conditions
)
ifThen
|
(
condition
,
ifThen
,
_
)
<-
condTreeComponents
condNode
]
|
(
CondBranch
condition
ifThen
_
)
<-
condTreeComponents
condNode
]
++
concat
[
go
(
condition
:
conditions
)
elseThen
|
(
condition
,
_
,
Just
elseThen
)
<-
condTreeComponents
condNode
]
|
(
CondBranch
condition
_
(
Just
elseThen
)
)
<-
condTreeComponents
condNode
]
-- ------------------------------------------------------------
...
...
Cabal/Distribution/PackageDescription/Configuration.hs
View file @
d1b84d3b
...
...
@@ -52,6 +52,7 @@ import Distribution.Types.ForeignLib
import
Distribution.Types.Component
import
Distribution.Types.Dependency
import
Distribution.Types.UnqualComponentName
import
Distribution.Types.CondTree
import
qualified
Data.Map
as
Map
import
Data.Tree
(
Tree
(
Node
)
)
...
...
@@ -161,8 +162,10 @@ mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
mapCondTree
fa
fc
fcnd
(
CondNode
a
c
ifs
)
=
CondNode
(
fa
a
)
(
fc
c
)
(
map
g
ifs
)
where
g
(
cnd
,
t
,
me
)
=
(
fcnd
cnd
,
mapCondTree
fa
fc
fcnd
t
,
fmap
(
mapCondTree
fa
fc
fcnd
)
me
)
g
(
CondBranch
cnd
t
me
)
=
CondBranch
(
fcnd
cnd
)
(
mapCondTree
fa
fc
fcnd
t
)
(
fmap
(
mapCondTree
fa
fc
fcnd
)
me
)
mapTreeConstrs
::
(
c
->
d
)
->
CondTree
v
c
a
->
CondTree
v
d
a
mapTreeConstrs
f
=
mapCondTree
id
f
id
...
...
@@ -290,7 +293,7 @@ addBuildableCondition getInfo t =
case
extractCondition
(
buildable
.
getInfo
)
t
of
Lit
True
->
t
Lit
False
->
CondNode
mempty
mempty
[]
c
->
CondNode
mempty
mempty
[
(
c
,
t
,
Nothing
)
]
c
->
CondNode
mempty
mempty
[
condIfThen
c
t
]
-- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
-- type.
...
...
@@ -309,7 +312,7 @@ addBuildableConditionPDTagged t =
case
extractCondition
(
buildable
.
getInfo
)
t
of
Lit
True
->
t
Lit
False
->
deleteConstraints
t
c
->
CondNode
mempty
mempty
[
(
c
,
t
,
Jus
t
(
deleteConstraints
t
)
)
]
c
->
CondNode
mempty
mempty
[
condIfThenElse
c
t
(
deleteConstraints
t
)]
where
deleteConstraints
=
mapTreeConstrs
(
const
mempty
)
...
...
@@ -344,7 +347,7 @@ extractCondition p = go
|
otherwise
=
goList
cs
goList
[]
=
Lit
True
goList
(
(
c
,
t
,
e
)
:
cs
)
=
goList
(
CondBranch
c
t
e
:
cs
)
=
let
ct
=
go
t
ce
=
maybe
(
Lit
True
)
go
e
...
...
@@ -404,7 +407,7 @@ simplifyCondTree :: (Monoid a, Monoid d) =>
simplifyCondTree
env
(
CondNode
a
d
ifs
)
=
mconcat
$
(
d
,
a
)
:
mapMaybe
simplifyIf
ifs
where
simplifyIf
(
cnd
,
t
,
me
)
=
simplifyIf
(
CondBranch
cnd
t
me
)
=
case
simplifyCondition
cnd
env
of
(
Lit
True
,
_
)
->
Just
$
simplifyCondTree
env
t
(
Lit
False
,
_
)
->
fmap
(
simplifyCondTree
env
)
me
...
...
@@ -415,14 +418,14 @@ simplifyCondTree env (CondNode a d ifs) =
-- choices this may not result in a \"sane\" result.
ignoreConditions
::
(
Monoid
a
,
Monoid
c
)
=>
CondTree
v
c
a
->
(
a
,
c
)
ignoreConditions
(
CondNode
a
c
ifs
)
=
(
a
,
c
)
`
mappend
`
mconcat
(
concatMap
f
ifs
)
where
f
(
_
,
t
,
me
)
=
ignoreConditions
t
where
f
(
CondBranch
_
t
me
)
=
ignoreConditions
t
:
maybeToList
(
fmap
ignoreConditions
me
)
freeVars
::
CondTree
ConfVar
c
a
->
[
FlagName
]
freeVars
t
=
[
f
|
Flag
f
<-
freeVars'
t
]
where
freeVars'
(
CondNode
_
_
ifs
)
=
concatMap
compfv
ifs
compfv
(
c
,
ct
,
mct
)
=
condfv
c
++
freeVars'
ct
++
maybe
[]
freeVars'
mct
compfv
(
CondBranch
c
ct
mct
)
=
condfv
c
++
freeVars'
ct
++
maybe
[]
freeVars'
mct
condfv
c
=
case
c
of
Var
v
->
[
v
]
Lit
_
->
[]
...
...
Cabal/Distribution/PackageDescription/Parse.hs
View file @
d1b84d3b
...
...
@@ -53,6 +53,7 @@ import Distribution.Types.Dependency
import
Distribution.Types.ForeignLib
import
Distribution.Types.ForeignLibType
import
Distribution.Types.UnqualComponentName
import
Distribution.Types.CondTree
import
Distribution.ParseUtils
hiding
(
parseFields
)
import
Distribution.PackageDescription
import
Distribution.PackageDescription.Utils
...
...
@@ -1117,7 +1118,7 @@ parsePackageDescription file = do
[]
->
return
Nothing
es
->
do
fs
<-
collectFields
parser
es
return
(
Just
fs
)
return
(
cnd
,
t'
,
e'
)
return
(
CondBranch
cnd
t'
e'
)
processIfs
_
=
cabalBug
"processIfs called with wrong field type"
parseLibFields
::
[
Field
]
->
PM
Library
...
...
@@ -1181,9 +1182,9 @@ onAllBranches p = go mempty
in
p
acc'
||
any
(
goBranch
acc'
)
(
condTreeComponents
ct
)
-- Both the 'true' and the 'false' block must satisfy the property.
goBranch
::
a
->
(
cond
,
CondTree
v
c
a
,
Maybe
(
CondTree
v
c
a
))
->
Bool
goBranch
_
(
_
,
_
,
Nothing
)
=
False
goBranch
acc
(
_
,
t
,
Just
e
)
=
go
acc
t
&&
go
acc
e
goBranch
::
a
->
CondBranch
v
c
a
->
Bool
goBranch
_
(
CondBranch
_
_
Nothing
)
=
False
goBranch
acc
(
CondBranch
_
t
(
Just
e
)
)
=
go
acc
t
&&
go
acc
e
-- | Parse a list of fields, given a list of field descriptions,
-- a structure to accumulate the parsed fields, and a function
...
...
Cabal/Distribution/PackageDescription/Parsec.hs
View file @
d1b84d3b
...
...
@@ -50,6 +50,7 @@ import Distribution.Simple.Utils
(
die
,
fromUTF8BS
,
warn
)
import
Distribution.Text
(
display
)
import
Distribution.Types.ForeignLib
import
Distribution.Types.CondTree
import
Distribution.Types.UnqualComponentName
(
UnqualComponentName
,
mkUnqualComponentName
)
import
Distribution.Verbosity
(
Verbosity
)
...
...
@@ -400,7 +401,7 @@ parseFields descrs _unknown = foldM go
fieldParsers
=
Map
.
fromList
$
map
(
\
x
->
(
fieldName
x
,
fieldParser
x
))
descrs
type
C
c
a
=
(
Cond
ition
ConfVar
,
CondTree
ConfVar
c
a
,
Maybe
(
CondTree
ConfVar
c
a
))
type
C
c
a
=
Cond
Branch
ConfVar
c
a
parseCondTree
::
forall
a
c
.
...
...
@@ -460,10 +461,10 @@ parseCondTree descs unknown cond ini = impl
alt'
<-
case
alt
of
[]
->
pure
Nothing
_
->
Just
<$>
impl
alt
let
ieb
=
(
tes
,
con
,
alt'
)
let
ieb
=
(
CondBranch
tes
con
alt'
)
goFields
(
x
,
SnocList
.
snoc
xs
ieb
)
fields
goElse
tes
con
(
x
,
xs
)
fields
=
do
let
ieb
=
(
tes
,
con
,
Nothing
)
let
ieb
=
(
CondBranch
tes
con
Nothing
)
goFields
(
x
,
SnocList
.
snoc
xs
ieb
)
fields
fieldParsers
::
Map
FieldName
(
a
->
FieldParser
a
)
...
...
Cabal/Distribution/PackageDescription/PrettyPrint.hs
View file @
d1b84d3b
...
...
@@ -32,6 +32,7 @@ import Distribution.Compat.Prelude
import
Distribution.Types.Dependency
import
Distribution.Types.ForeignLib
import
Distribution.Types.UnqualComponentName
import
Distribution.Types.CondTree
import
Distribution.PackageDescription
import
Distribution.Simple.Utils
...
...
@@ -239,8 +240,8 @@ ppCondTree ct@(CondNode it _ ifs) mbIt ppIt =
else
res
where
-- TODO: this ends up printing trailing spaces when combined with nest.
ppIf
(
c
,
thenTree
,
Just
elseTree
)
=
ppIfElse
it
ppIt
c
thenTree
elseTree
ppIf
(
c
,
thenTree
,
Nothing
)
=
ppIf'
it
ppIt
c
thenTree
ppIf
(
CondBranch
c
thenTree
(
Just
elseTree
)
)
=
ppIfElse
it
ppIt
c
thenTree
elseTree
ppIf
(
CondBranch
c
thenTree
Nothing
)
=
ppIf'
it
ppIt
c
thenTree
ppIfCondition
::
(
Condition
ConfVar
)
->
Doc
ppIfCondition
c
=
(
emptyLine
$
text
"if"
<+>
ppCondition
c
)
...
...
Cabal/Distribution/Types/CondTree.hs
View file @
d1b84d3b
...
...
@@ -6,6 +6,9 @@
module
Distribution.Types.CondTree
(
CondTree
(
..
),
CondBranch
(
..
),
condIfThen
,
condIfThenElse
,
)
where
import
Prelude
()
...
...
@@ -16,10 +19,30 @@ import Distribution.Types.Condition
data
CondTree
v
c
a
=
CondNode
{
condTreeData
::
a
,
condTreeConstraints
::
c
,
condTreeComponents
::
[(
Condition
v
,
CondTree
v
c
a
,
Maybe
(
CondTree
v
c
a
))]
,
condTreeComponents
::
[
CondBranch
v
c
a
]
}
deriving
(
Show
,
Eq
,
Typeable
,
Data
,
Generic
,
Functor
,
Foldable
,
Traversable
)
instance
(
Binary
v
,
Binary
c
,
Binary
a
)
=>
Binary
(
CondTree
v
c
a
)
data
CondBranch
v
c
a
=
CondBranch
{
condBranchCondition
::
Condition
v
,
condBranchIfTrue
::
CondTree
v
c
a
,
condBranchIfFalse
::
Maybe
(
CondTree
v
c
a
)
}
deriving
(
Show
,
Eq
,
Typeable
,
Data
,
Generic
,
Functor
,
Traversable
)
-- This instance is written by hand because GHC 8.0.1/8.0.2 infinite
-- loops when trying to derive it with optimizations. See
-- https://ghc.haskell.org/trac/ghc/ticket/13056
instance
Foldable
(
CondBranch
v
c
)
where
foldMap
f
(
CondBranch
_
c
Nothing
)
=
foldMap
f
c
foldMap
f
(
CondBranch
_
c
(
Just
a
))
=
foldMap
f
c
`
mappend
`
foldMap
f
a
instance
(
Binary
v
,
Binary
c
,
Binary
a
)
=>
Binary
(
CondBranch
v
c
a
)
condIfThen
::
Condition
v
->
CondTree
v
c
a
->
CondBranch
v
c
a
condIfThen
c
t
=
CondBranch
c
t
Nothing
condIfThenElse
::
Condition
v
->
CondTree
v
c
a
->
CondTree
v
c
a
->
CondBranch
v
c
a
condIfThenElse
c
t
e
=
CondBranch
c
t
(
Just
e
)
cabal-install/Distribution/Solver/Modular/IndexConversion.hs
View file @
d1b84d3b
...
...
@@ -16,6 +16,7 @@ import Distribution.Types.Dependency -- from Cabal
import
Distribution.Types.LegacyExeDependency
-- from Cabal
import
Distribution.Types.PkgconfigDependency
-- from Cabal
import
Distribution.Types.UnqualComponentName
-- from Cabal
import
Distribution.Types.CondTree
-- from Cabal
import
Distribution.PackageDescription
as
PD
-- from Cabal
import
Distribution.PackageDescription.Configuration
as
PDC
import
qualified
Distribution.Simple.PackageIndex
as
SI
...
...
@@ -256,10 +257,9 @@ convBranch :: OS -> Arch -> CompilerInfo ->
(
a
->
BuildInfo
)
->
IPNs
->
SolveExecutables
->
(
Condition
ConfVar
,
CondTree
ConfVar
[
Dependency
]
a
,
Maybe
(
CondTree
ConfVar
[
Dependency
]
a
))
->
FlaggedDeps
Component
PN
convBranch
os
arch
cinfo
pi
@
(
PI
pn
_
)
fds
comp
getInfo
ipns
sexes
(
c'
,
t'
,
mf'
)
=
CondBranch
ConfVar
[
Dependency
]
a
->
FlaggedDeps
Component
PN
convBranch
os
arch
cinfo
pi
@
(
PI
pn
_
)
fds
comp
getInfo
ipns
sexes
(
CondBranch
c'
t'
mf'
)
=
go
c'
(
convCondTree
os
arch
cinfo
pi
fds
comp
getInfo
ipns
sexes
t'
)
(
maybe
[]
(
convCondTree
os
arch
cinfo
pi
fds
comp
getInfo
ipns
sexes
)
mf'
)
where
...
...
cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
View file @
d1b84d3b
...
...
@@ -51,6 +51,7 @@ import qualified Distribution.Types.Dependency as C
import
qualified
Distribution.Types.LegacyExeDependency
as
C
import
qualified
Distribution.Types.PkgconfigDependency
as
C
import
qualified
Distribution.Types.UnqualComponentName
as
C
import
qualified
Distribution.Types.CondTree
as
C
import
qualified
Distribution.PackageDescription
as
C
import
qualified
Distribution.PackageDescription.Check
as
C
import
qualified
Distribution.Simple.PackageIndex
as
C.PackageIndex
...
...
@@ -257,9 +258,7 @@ type ExampleDb = [Either ExampleInstalled ExampleAvailable]
type
DependencyTree
a
=
C
.
CondTree
C
.
ConfVar
[
C
.
Dependency
]
a
type
DependencyComponent
a
=
(
C
.
Condition
C
.
ConfVar
,
DependencyTree
a
,
Maybe
(
DependencyTree
a
))
type
DependencyComponent
a
=
C
.
CondBranch
C
.
ConfVar
[
C
.
Dependency
]
a
exDbPkgs
::
ExampleDb
->
[
ExamplePkgName
]
exDbPkgs
=
map
(
either
exInstName
exAvName
)
...
...
@@ -414,7 +413,7 @@ exAvSrcPkg ex =
goComponents
::
[
DependencyComponent
C
.
BuildInfo
]
->
[
DependencyComponent
a
]
goComponents
comps
=
[
(
cond
,
go
t
,
go
<$>
me
)
|
(
cond
,
t
,
me
)
<-
comps
]
goComponents
comps
=
[
C
.
CondBranch
cond
(
go
t
)
(
go
<$>
me
)
|
C
.
CondBranch
cond
t
me
<-
comps
]
mkBuildInfoTree
::
Dependencies
->
DependencyTree
C
.
BuildInfo
mkBuildInfoTree
NotBuildable
=
...
...
@@ -455,13 +454,11 @@ exAvSrcPkg ex =
mkDirect
(
dep
,
v
)
=
C
.
Dependency
(
C
.
mkPackageName
dep
)
$
mkVersion
$
v
mkFlagged
::
(
ExampleFlagName
,
Dependencies
,
Dependencies
)
->
(
C
.
Condition
C
.
ConfVar
,
DependencyTree
C
.
BuildInfo
,
Maybe
(
DependencyTree
C
.
BuildInfo
))
mkFlagged
(
f
,
a
,
b
)
=
(
C
.
Var
(
C
.
Flag
(
C
.
mkFlagName
f
))
,
mkBuildInfoTree
a
,
Just
(
mkBuildInfoTree
b
)
)
->
DependencyComponent
C
.
BuildInfo
mkFlagged
(
f
,
a
,
b
)
=
C
.
CondBranch
(
C
.
Var
(
C
.
Flag
(
C
.
mkFlagName
f
)))
(
mkBuildInfoTree
a
)
(
Just
(
mkBuildInfoTree
b
))
-- Split a set of dependencies into direct dependencies and flagged
-- dependencies. A direct dependency is a tuple of the name of package and
...
...
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