DSL.hs 16.2 KB
Newer Older
1
2
3
4
{-# LANGUAGE RecordWildCards #-}
-- | DSL for testing the modular solver
module UnitTests.Distribution.Client.Dependency.Modular.DSL (
    ExampleDependency(..)
5
  , Dependencies(..)
6
  , ExPreference(..)
7
  , ExampleDb
8
9
  , ExampleVersionRange
  , ExamplePkgVersion
10
11
  , exAv
  , exInst
12
  , exFlag
13
14
15
16
17
18
19
20
  , exResolve
  , extractInstallPlan
  , withSetupDeps
  ) where

-- base
import Data.Either (partitionEithers)
import Data.Maybe (catMaybes)
21
import Data.List (nub)
22
23
24
25
26
27
28
import Data.Monoid
import Data.Version
import qualified Data.Map as Map

-- Cabal
import qualified Distribution.Compiler             as C
import qualified Distribution.InstalledPackageInfo as C
29
import qualified Distribution.Package              as C
30
  hiding (HasUnitId(..))
31
32
33
34
import qualified Distribution.PackageDescription   as C
import qualified Distribution.Simple.PackageIndex  as C.PackageIndex
import qualified Distribution.System               as C
import qualified Distribution.Version              as C
35
import Language.Haskell.Extension (Extension(..), Language)
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68

-- cabal-install
import Distribution.Client.ComponentDeps (ComponentDeps)
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
import Distribution.Client.Types
import qualified Distribution.Client.InstallPlan   as CI.InstallPlan
import qualified Distribution.Client.PackageIndex  as CI.PackageIndex
import qualified Distribution.Client.ComponentDeps as CD

{-------------------------------------------------------------------------------
  Example package database DSL

  In order to be able to set simple examples up quickly, we define a very
  simple version of the package database here explicitly designed for use in
  tests.

  The design of `ExampleDb` takes the perspective of the solver, not the
  perspective of the package DB. This makes it easier to set up tests for
  various parts of the solver, but makes the mapping somewhat awkward,  because
  it means we first map from "solver perspective" `ExampleDb` to the package
  database format, and then the modular solver internally in `IndexConversion`
  maps this back to the solver specific data structures.

  IMPLEMENTATION NOTES
  --------------------

  TODO: Perhaps these should be made comments of the corresponding data type
  definitions. For now these are just my own conclusions and may be wrong.

  * The difference between `GenericPackageDescription` and `PackageDescription`
    is that `PackageDescription` describes a particular _configuration_ of a
    package (for instance, see documentation for `checkPackage`). A
Mikhail Glushenkov's avatar
Typo.    
Mikhail Glushenkov committed
69
    `GenericPackageDescription` can be turned into a `PackageDescription` in
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
    two ways:

      a. `finalizePackageDescription` does the proper translation, by taking
         into account the platform, available dependencies, etc. and picks a
         flag assignment (or gives an error if no flag assignment can be found)
      b. `flattenPackageDescription` ignores flag assignment and just joins all
         components together.

    The slightly odd thing is that a `GenericPackageDescription` contains a
    `PackageDescription` as a field; both of the above functions do the same
    thing: they take the embedded `PackageDescription` as a basis for the result
    value, but override `library`, `executables`, `testSuites`, `benchmarks`
    and `buildDepends`.
  * The `condTreeComponents` fields of a `CondTree` is a list of triples
    `(condition, then-branch, else-branch)`, where the `else-branch` is
    optional.
-------------------------------------------------------------------------------}

type ExamplePkgName    = String
type ExamplePkgVersion = Int
type ExamplePkgHash    = String  -- for example "installed" packages
type ExampleFlagName   = String
type ExampleTestName   = String
93
type ExampleVersionRange = C.VersionRange
94
data Dependencies = NotBuildable | Buildable [ExampleDependency]
95
96
97
98
99
100
101
102
103

data ExampleDependency =
    -- | Simple dependency on any version
    ExAny ExamplePkgName

    -- | Simple dependency on a fixed version
  | ExFix ExamplePkgName ExamplePkgVersion

    -- | Dependencies indexed by a flag
104
  | ExFlag ExampleFlagName Dependencies Dependencies
105
106
107
108

    -- | Dependency if tests are enabled
  | ExTest ExampleTestName [ExampleDependency]

109
110
111
112
113
114
    -- | Dependency on a language extension
  | ExExt Extension

    -- | Dependency on a language version
  | ExLang Language

115
116
117
118
exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
       -> ExampleDependency
exFlag n t e = ExFlag n (Buildable t) (Buildable e)

119
data ExPreference = ExPref String ExampleVersionRange
120

121
122
123
124
125
126
data ExampleAvailable = ExAv {
    exAvName    :: ExamplePkgName
  , exAvVersion :: ExamplePkgVersion
  , exAvDeps    :: ComponentDeps [ExampleDependency]
  }

127
128
129
130
exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
     -> ExampleAvailable
exAv n v ds = ExAv { exAvName = n, exAvVersion = v
                   , exAvDeps = CD.fromLibraryDeps ds }
131
132
133
134
135
136
137
138
139
140
141
142
143

withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
withSetupDeps ex setupDeps = ex {
      exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps
    }

data ExampleInstalled = ExInst {
    exInstName         :: ExamplePkgName
  , exInstVersion      :: ExamplePkgVersion
  , exInstHash         :: ExamplePkgHash
  , exInstBuildAgainst :: [ExampleInstalled]
  }

144
145
exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash
       -> [ExampleInstalled] -> ExampleInstalled
146
147
148
149
150
151
152
153
154
155
156
exInst = ExInst

type ExampleDb = [Either ExampleInstalled ExampleAvailable]

type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a

exDbPkgs :: ExampleDb -> [ExamplePkgName]
exDbPkgs = map (either exInstName exAvName)

exAvSrcPkg :: ExampleAvailable -> SourcePackage
exAvSrcPkg ex =
157
    let (libraryDeps, testSuites, exts, mlang) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
158
159
160
161
    in SourcePackage {
           packageInfoId        = exAvPkgId ex
         , packageSource        = LocalTarballPackage "<<path>>"
         , packageDescrOverride = Nothing
162
         , packageDescription   = C.GenericPackageDescription {
163
164
165
166
167
168
169
170
171
172
173
               C.packageDescription = C.emptyPackageDescription {
                   C.package        = exAvPkgId ex
                 , C.library        = error "not yet configured: library"
                 , C.executables    = error "not yet configured: executables"
                 , C.testSuites     = error "not yet configured: testSuites"
                 , C.benchmarks     = error "not yet configured: benchmarks"
                 , C.buildDepends   = error "not yet configured: buildDepends"
                 , C.setupBuildInfo = Just C.SetupBuildInfo {
                       C.setupDepends = mkSetupDeps (CD.setupDeps (exAvDeps ex))
                     }
                 }
174
             , C.genPackageFlags = nub $ concatMap extractFlags
175
                                   (CD.libraryDeps (exAvDeps ex))
176
177
178
             , C.condLibrary     = Just $ mkCondTree (extsLib exts <> langLib mlang)
                                                     disableLib
                                                     (Buildable libraryDeps)
179
             , C.condExecutables = []
180
181
182
             , C.condTestSuites  =
                 let mkTree = mkCondTree mempty disableTest . Buildable
                 in map (\(t, deps) -> (t, mkTree deps)) testSuites
183
184
185
186
             , C.condBenchmarks  = []
             }
         }
  where
187
188
    -- Split the set of dependencies into the set of dependencies of the library,
    -- the dependencies of the test suites and extensions.
189
190
191
    splitTopLevel :: [ExampleDependency]
                  -> ( [ExampleDependency]
                     , [(ExampleTestName, [ExampleDependency])]
192
193
                     , [Extension]
                     , Maybe Language
194
                     )
195
196
    splitTopLevel [] =
        ([], [], [], Nothing)
197
    splitTopLevel (ExTest t a:deps) =
198
199
200
201
202
203
204
205
206
207
208
209
210
211
      let (other, testSuites, exts, lang) = splitTopLevel deps
      in (other, (t, a):testSuites, exts, lang)
    splitTopLevel (ExExt ext:deps) =
      let (other, testSuites, exts, lang) = splitTopLevel deps
      in (other, testSuites, ext:exts, lang)
    splitTopLevel (ExLang lang:deps) =
        case splitTopLevel deps of
            (other, testSuites, exts, Nothing) -> (other, testSuites, exts, Just lang)
            _ -> error "Only 1 Language dependency is supported"
    splitTopLevel (dep:deps) =
      let (other, testSuites, exts, lang) = splitTopLevel deps
      in (dep:other, testSuites, exts, lang)

    -- Extract the total set of flags used
212
213
214
215
216
217
    extractFlags :: ExampleDependency -> [C.Flag]
    extractFlags (ExAny _)      = []
    extractFlags (ExFix _ _)    = []
    extractFlags (ExFlag f a b) = C.MkFlag {
                                      C.flagName        = C.FlagName f
                                    , C.flagDescription = ""
218
                                    , C.flagDefault     = True
219
220
                                    , C.flagManual      = False
                                    }
221
222
223
224
225
                                : concatMap extractFlags (deps a ++ deps b)
      where
        deps :: Dependencies -> [ExampleDependency]
        deps NotBuildable = []
        deps (Buildable ds) = ds
226
    extractFlags (ExTest _ a)   = concatMap extractFlags a
227
228
    extractFlags (ExExt _)      = []
    extractFlags (ExLang _)     = []
229

230
231
232
233
234
235
236
237
    mkCondTree :: Monoid a => a -> (a -> a) -> Dependencies -> DependencyTree a
    mkCondTree x dontBuild NotBuildable =
      C.CondNode {
             C.condTreeData        = dontBuild x
           , C.condTreeConstraints = []
           , C.condTreeComponents  = []
           }
    mkCondTree x dontBuild (Buildable deps) =
238
239
      let (directDeps, flaggedDeps) = splitDeps deps
      in C.CondNode {
240
241
             C.condTreeData        = x -- Necessary for language extensions
           , C.condTreeConstraints = map mkDirect directDeps
242
           , C.condTreeComponents  = map (mkFlagged dontBuild) flaggedDeps
243
244
245
246
247
248
249
250
251
           }

    mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency
    mkDirect (dep, Nothing) = C.Dependency (C.PackageName dep) C.anyVersion
    mkDirect (dep, Just n)  = C.Dependency (C.PackageName dep) (C.thisVersion v)
      where
        v = Version [n, 0, 0] []

    mkFlagged :: Monoid a
252
253
              => (a -> a)
              -> (ExampleFlagName, Dependencies, Dependencies)
254
255
              -> (C.Condition C.ConfVar
                 , DependencyTree a, Maybe (DependencyTree a))
256
257
258
259
    mkFlagged dontBuild (f, a, b) = ( C.Var (C.Flag (C.FlagName f))
                                    , mkCondTree mempty dontBuild a
                                    , Just (mkCondTree mempty dontBuild b)
                                    )
260

261
262
263
264
265
266
267
    -- Split a set of dependencies into direct dependencies and flagged
    -- dependencies. A direct dependency is a tuple of the name of package and
    -- maybe its version (no version means any version) meant to be converted
    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
    -- the set of dependencies guarded by a flag.
    --
    -- TODO: Take care of flagged language extensions and language flavours.
268
269
    splitDeps :: [ExampleDependency]
              -> ( [(ExamplePkgName, Maybe Int)]
270
                 , [(ExampleFlagName, Dependencies, Dependencies)]
271
272
273
274
275
276
277
278
279
280
281
282
283
284
                 )
    splitDeps [] =
      ([], [])
    splitDeps (ExAny p:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in ((p, Nothing):directDeps, flaggedDeps)
    splitDeps (ExFix p v:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in ((p, Just v):directDeps, flaggedDeps)
    splitDeps (ExFlag f a b:deps) =
      let (directDeps, flaggedDeps) = splitDeps deps
      in (directDeps, (f, a, b):flaggedDeps)
    splitDeps (ExTest _ _:_) =
      error "Unexpected nested test"
285
    splitDeps (_:deps) = splitDeps deps
286
287
288
289
290
291

    -- Currently we only support simple setup dependencies
    mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
    mkSetupDeps deps =
      let (directDeps, []) = splitDeps deps in map mkDirect directDeps

292
293
294
295
296
297
298
299
300
    -- A 'C.Library' with just the given extensions in its 'BuildInfo'
    extsLib :: [Extension] -> C.Library
    extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }

    -- A 'C.Library' with just the given extensions in its 'BuildInfo'
    langLib :: Maybe Language -> C.Library
    langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }
    langLib _ = mempty

301
302
303
304
305
306
307
308
    disableLib :: C.Library -> C.Library
    disableLib lib =
        lib { C.libBuildInfo = (C.libBuildInfo lib) { C.buildable = False }}

    disableTest :: C.TestSuite -> C.TestSuite
    disableTest test =
        test { C.testBuildInfo = (C.testBuildInfo test) { C.buildable = False }}

309
310
311
312
313
314
315
316
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex = C.PackageIdentifier {
      pkgName    = C.PackageName (exAvName ex)
    , pkgVersion = Version [exAvVersion ex, 0, 0] []
    }

exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo
exInstInfo ex = C.emptyInstalledPackageInfo {
317
      C.installedUnitId    = C.mkUnitId (exInstHash ex)
318
    , C.sourcePackageId    = exInstPkgId ex
319
    , C.depends            = map (C.mkUnitId . exInstHash)
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
                                 (exInstBuildAgainst ex)
    }

exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
exInstPkgId ex = C.PackageIdentifier {
      pkgName    = C.PackageName (exInstName ex)
    , pkgVersion = Version [exInstVersion ex, 0, 0] []
    }

exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage
exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg

exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
exInstIdx = C.PackageIndex.fromList . map exInstInfo

exResolve :: ExampleDb
336
337
338
339
          -- List of extensions supported by the compiler, or Nothing if unknown.
          -> Maybe [Extension]
          -- List of languages supported by the compiler, or Nothing if unknown.
          -> Maybe [Language]
340
341
          -> [ExamplePkgName]
          -> Bool
342
          -> [ExPreference]
343
          -> ([String], Either String CI.InstallPlan.InstallPlan)
344
exResolve db exts langs targets indepGoals prefs = runProgress $
345
    resolveDependencies C.buildPlatform
346
                        compiler
347
348
349
                        Modular
                        params
  where
350
    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
351
352
    compiler = defaultCompiler { C.compilerInfoExtensions = exts
                               , C.compilerInfoLanguages  = langs
353
                               }
354
355
356
357
358
359
    (inst, avai) = partitionEithers db
    instIdx      = exInstIdx inst
    avaiIdx      = SourcePackageDb {
                       packageIndex       = exAvIdx avai
                     , packagePreferences = Map.empty
                     }
360
    enableTests  = fmap (\p -> PackageConstraintStanzas
361
                              (C.PackageName p) [TestStanzas])
362
                       (exDbPkgs db)
363
364
365
366
367
    targets'     = fmap (\p -> NamedPackage (C.PackageName p) []) targets
    params       =   addPreferences (fmap toPref prefs)
                   $ addConstraints (fmap toLpc enableTests)
                   $ (standardInstallPolicy instIdx avaiIdx targets') {
                     depResolverIndependentGoals = indepGoals
368
                     }
369
    toLpc     pc = LabeledPackageConstraint pc ConstraintSourceUnknown
370
    toPref (ExPref n v) = PackageVersionPreference (C.PackageName n) v
371

372
extractInstallPlan :: CI.InstallPlan.InstallPlan
373
374
375
                   -> [(ExamplePkgName, ExamplePkgVersion)]
extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList
  where
376
    confPkg :: CI.InstallPlan.PlanPackage -> Maybe (String, Int)
377
378
379
380
381
    confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg
    confPkg _                               = Nothing

    srcPkg :: ConfiguredPackage -> (String, Int)
    srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) =
382
383
      let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) =
            packageInfoId pkg
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
      in (p, n)

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

-- | Run Progress computation
--
-- Like `runLog`, but for the more general `Progress` type.
runProgress :: Progress step e a -> ([step], Either e a)
runProgress = go
  where
    go (Step s p) = let (ss, result) = go p in (s:ss, result)
    go (Fail e)   = ([], Left e)
    go (Done a)   = ([], Right a)