never executed always true always false
1 {-# LANGUAGE CPP #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 {-# LANGUAGE DeriveGeneric #-}
4 {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : Distribution.Client.Targets
9 -- Copyright : (c) Duncan Coutts 2011
10 -- License : BSD-like
11 --
12 -- Maintainer : duncan@community.haskell.org
13 --
14 -- Handling for user-specified targets
15 -----------------------------------------------------------------------------
16 module Distribution.Client.Targets (
17 -- * User targets
18 UserTarget(..),
19 readUserTargets,
20
21 -- * Resolving user targets to package specifiers
22 resolveUserTargets,
23
24 -- ** Detailed interface
25 UserTargetProblem(..),
26 readUserTarget,
27 reportUserTargetProblems,
28 expandUserTarget,
29
30 PackageTarget(..),
31 fetchPackageTarget,
32 readPackageTarget,
33
34 PackageTargetProblem(..),
35 reportPackageTargetProblems,
36
37 disambiguatePackageTargets,
38 disambiguatePackageName,
39
40 -- * User constraints
41 UserQualifier(..),
42 UserConstraintScope(..),
43 UserConstraint(..),
44 userConstraintPackageName,
45 readUserConstraint,
46 userToPackageConstraint,
47
48 ) where
49
50 import Prelude ()
51 import Distribution.Client.Compat.Prelude
52
53 import Distribution.Package
54 ( Package(..), PackageName, unPackageName, mkPackageName
55 , packageName )
56 import Distribution.Types.Dependency
57 import Distribution.Client.Types
58 ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage
59 , PackageSpecifier(..) )
60
61 import Distribution.Solver.Types.OptionalStanza
62 import Distribution.Solver.Types.PackageConstraint
63 import Distribution.Solver.Types.PackagePath
64 import Distribution.Solver.Types.PackageIndex (PackageIndex)
65 import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
66 import Distribution.Solver.Types.SourcePackage
67
68 import qualified Distribution.Client.World as World
69 import qualified Codec.Archive.Tar as Tar
70 import qualified Codec.Archive.Tar.Entry as Tar
71 import qualified Distribution.Client.Tar as Tar
72 import Distribution.Client.FetchUtils
73 import Distribution.Client.Utils ( tryFindPackageDesc )
74 import Distribution.Client.GlobalFlags
75 ( RepoContext(..) )
76 import Distribution.Types.PackageVersionConstraint
77 ( PackageVersionConstraint (..) )
78
79 import Distribution.PackageDescription
80 ( GenericPackageDescription )
81 import Distribution.Types.Flag
82 ( nullFlagAssignment, parsecFlagAssignmentNonEmpty )
83 import Distribution.Version
84 ( anyVersion, isAnyVersion )
85 import Distribution.Simple.Utils
86 ( die', warn, lowercase )
87
88 import Distribution.PackageDescription.Parsec
89 ( readGenericPackageDescription, parseGenericPackageDescriptionMaybe )
90
91 import qualified Data.Map as Map
92 import qualified Data.ByteString.Lazy as BS
93 import qualified Distribution.Client.GZipUtils as GZipUtils
94 import qualified Distribution.Compat.CharParsing as P
95 import System.FilePath
96 ( takeExtension, dropExtension, takeDirectory, splitPath )
97 import System.Directory
98 ( doesFileExist, doesDirectoryExist )
99 import Network.URI
100 ( URI(..), URIAuth(..), parseAbsoluteURI )
101
102 -- ------------------------------------------------------------
103 -- * User targets
104 -- ------------------------------------------------------------
105
106 -- | Various ways that a user may specify a package or package collection.
107 --
108 data UserTarget =
109
110 -- | A partially specified package, identified by name and possibly with
111 -- an exact version or a version constraint.
112 --
113 -- > cabal install foo
114 -- > cabal install foo-1.0
115 -- > cabal install 'foo < 2'
116 --
117 UserTargetNamed PackageVersionConstraint
118
119 -- | A special virtual package that refers to the collection of packages
120 -- recorded in the world file that the user specifically installed.
121 --
122 -- > cabal install world
123 --
124 | UserTargetWorld
125
126 -- | A specific package that is unpacked in a local directory, often the
127 -- current directory.
128 --
129 -- > cabal install .
130 -- > cabal install ../lib/other
131 --
132 -- * Note: in future, if multiple @.cabal@ files are allowed in a single
133 -- directory then this will refer to the collection of packages.
134 --
135 | UserTargetLocalDir FilePath
136
137 -- | A specific local unpacked package, identified by its @.cabal@ file.
138 --
139 -- > cabal install foo.cabal
140 -- > cabal install ../lib/other/bar.cabal
141 --
142 | UserTargetLocalCabalFile FilePath
143
144 -- | A specific package that is available as a local tarball file
145 --
146 -- > cabal install dist/foo-1.0.tar.gz
147 -- > cabal install ../build/baz-1.0.tar.gz
148 --
149 | UserTargetLocalTarball FilePath
150
151 -- | A specific package that is available as a remote tarball file
152 --
153 -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
154 --
155 | UserTargetRemoteTarball URI
156 deriving (Show,Eq)
157
158
159 -- ------------------------------------------------------------
160 -- * Parsing and checking user targets
161 -- ------------------------------------------------------------
162
163 readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
164 readUserTargets verbosity targetStrs = do
165 (problems, targets) <- liftM partitionEithers
166 (traverse readUserTarget targetStrs)
167 reportUserTargetProblems verbosity problems
168 return targets
169
170
171 data UserTargetProblem
172 = UserTargetUnexpectedFile String
173 | UserTargetNonexistantFile String
174 | UserTargetUnexpectedUriScheme String
175 | UserTargetUnrecognisedUri String
176 | UserTargetUnrecognised String
177 | UserTargetBadWorldPkg
178 deriving Show
179
180 readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
181 readUserTarget targetstr =
182 case eitherParsec targetstr of
183 Right (PackageVersionConstraint pkgn verrange)
184 | pkgn == mkPackageName "world"
185 -> return $ if verrange == anyVersion
186 then Right UserTargetWorld
187 else Left UserTargetBadWorldPkg
188 Right dep -> return (Right (UserTargetNamed dep))
189 Left _err -> do
190 fileTarget <- testFileTargets targetstr
191 case fileTarget of
192 Just target -> return target
193 Nothing ->
194 case testUriTargets targetstr of
195 Just target -> return target
196 Nothing -> return (Left (UserTargetUnrecognised targetstr))
197 where
198 testFileTargets filename = do
199 isDir <- doesDirectoryExist filename
200 isFile <- doesFileExist filename
201 parentDirExists <- case takeDirectory filename of
202 [] -> return False
203 dir -> doesDirectoryExist dir
204 let result
205 | isDir
206 = Just (Right (UserTargetLocalDir filename))
207
208 | isFile && extensionIsTarGz filename
209 = Just (Right (UserTargetLocalTarball filename))
210
211 | isFile && takeExtension filename == ".cabal"
212 = Just (Right (UserTargetLocalCabalFile filename))
213
214 | isFile
215 = Just (Left (UserTargetUnexpectedFile filename))
216
217 | parentDirExists
218 = Just (Left (UserTargetNonexistantFile filename))
219
220 | otherwise
221 = Nothing
222 return result
223
224 testUriTargets str =
225 case parseAbsoluteURI str of
226 Just uri@URI {
227 uriScheme = scheme,
228 uriAuthority = Just URIAuth { uriRegName = host }
229 }
230 | scheme /= "http:" && scheme /= "https:" ->
231 Just (Left (UserTargetUnexpectedUriScheme targetstr))
232
233 | null host ->
234 Just (Left (UserTargetUnrecognisedUri targetstr))
235
236 | otherwise ->
237 Just (Right (UserTargetRemoteTarball uri))
238 _ -> Nothing
239
240 extensionIsTarGz f = takeExtension f == ".gz"
241 && takeExtension (dropExtension f) == ".tar"
242
243 reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()
244 reportUserTargetProblems verbosity problems = do
245 case [ target | UserTargetUnrecognised target <- problems ] of
246 [] -> return ()
247 target -> die' verbosity
248 $ unlines
249 [ "Unrecognised target '" ++ name ++ "'."
250 | name <- target ]
251 ++ "Targets can be:\n"
252 ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
253 ++ " - the special 'world' target\n"
254 ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
255 ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"
256
257 case [ () | UserTargetBadWorldPkg <- problems ] of
258 [] -> return ()
259 _ -> die' verbosity "The special 'world' target does not take any version."
260
261 case [ target | UserTargetNonexistantFile target <- problems ] of
262 [] -> return ()
263 target -> die' verbosity
264 $ unlines
265 [ "The file does not exist '" ++ name ++ "'."
266 | name <- target ]
267
268 case [ target | UserTargetUnexpectedFile target <- problems ] of
269 [] -> return ()
270 target -> die' verbosity
271 $ unlines
272 [ "Unrecognised file target '" ++ name ++ "'."
273 | name <- target ]
274 ++ "File targets can be either package tarballs 'pkgname.tar.gz' "
275 ++ "or cabal files 'pkgname.cabal'."
276
277 case [ target | UserTargetUnexpectedUriScheme target <- problems ] of
278 [] -> return ()
279 target -> die' verbosity
280 $ unlines
281 [ "URL target not supported '" ++ name ++ "'."
282 | name <- target ]
283 ++ "Only 'http://' and 'https://' URLs are supported."
284
285 case [ target | UserTargetUnrecognisedUri target <- problems ] of
286 [] -> return ()
287 target -> die' verbosity
288 $ unlines
289 [ "Unrecognise URL target '" ++ name ++ "'."
290 | name <- target ]
291
292
293 -- ------------------------------------------------------------
294 -- * Resolving user targets to package specifiers
295 -- ------------------------------------------------------------
296
297 -- | Given a bunch of user-specified targets, try to resolve what it is they
298 -- refer to. They can either be specific packages (local dirs, tarballs etc)
299 -- or they can be named packages (with or without version info).
300 --
301 resolveUserTargets :: Package pkg
302 => Verbosity
303 -> RepoContext
304 -> FilePath
305 -> PackageIndex pkg
306 -> [UserTarget]
307 -> IO [PackageSpecifier UnresolvedSourcePackage]
308 resolveUserTargets verbosity repoCtxt worldFile available userTargets = do
309
310 -- given the user targets, get a list of fully or partially resolved
311 -- package references
312 packageTargets <- traverse (readPackageTarget verbosity)
313 =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat
314 =<< traverse (expandUserTarget verbosity worldFile) userTargets
315
316 -- users are allowed to give package names case-insensitively, so we must
317 -- disambiguate named package references
318 let (problems, packageSpecifiers) =
319 disambiguatePackageTargets available availableExtra packageTargets
320
321 -- use any extra specific available packages to help us disambiguate
322 availableExtra = [ packageName pkg
323 | PackageTargetLocation pkg <- packageTargets ]
324
325 reportPackageTargetProblems verbosity problems
326
327 return packageSpecifiers
328
329
330 -- ------------------------------------------------------------
331 -- * Package targets
332 -- ------------------------------------------------------------
333
334 -- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.
335 -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.
336 --
337 data PackageTarget pkg =
338 PackageTargetNamed PackageName [PackageProperty] UserTarget
339
340 -- | A package identified by name, but case insensitively, so it needs
341 -- to be resolved to the right case-sensitive name.
342 | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget
343 | PackageTargetLocation pkg
344 deriving (Show, Functor, Foldable, Traversable)
345
346
347 -- ------------------------------------------------------------
348 -- * Converting user targets to package targets
349 -- ------------------------------------------------------------
350
351 -- | Given a user-specified target, expand it to a bunch of package targets
352 -- (each of which refers to only one package).
353 --
354 expandUserTarget :: Verbosity
355 -> FilePath
356 -> UserTarget
357 -> IO [PackageTarget (PackageLocation ())]
358 expandUserTarget verbosity worldFile userTarget = case userTarget of
359
360 UserTargetNamed (PackageVersionConstraint name vrange) ->
361 let props = [ PackagePropertyVersion vrange
362 | not (isAnyVersion vrange) ]
363 in return [PackageTargetNamedFuzzy name props userTarget]
364
365 UserTargetWorld -> do
366 worldPkgs <- World.getContents verbosity worldFile
367 --TODO: should we warn if there are no world targets?
368 return [ PackageTargetNamed name props userTarget
369 | World.WorldPkgInfo (Dependency name vrange _) flags <- worldPkgs
370 , let props = [ PackagePropertyVersion vrange
371 | not (isAnyVersion vrange) ]
372 ++ [ PackagePropertyFlags flags
373 | not (nullFlagAssignment flags) ] ]
374
375 UserTargetLocalDir dir ->
376 return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
377
378 UserTargetLocalCabalFile file -> do
379 let dir = takeDirectory file
380 _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check
381 return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
382
383 UserTargetLocalTarball tarballFile ->
384 return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]
385
386 UserTargetRemoteTarball tarballURL ->
387 return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]
388
389 localPackageError :: FilePath -> String
390 localPackageError dir =
391 "Error reading local package.\nCouldn't find .cabal file in: " ++ dir
392
393 -- ------------------------------------------------------------
394 -- * Fetching and reading package targets
395 -- ------------------------------------------------------------
396
397
398 -- | Fetch any remote targets so that they can be read.
399 --
400 fetchPackageTarget :: Verbosity
401 -> RepoContext
402 -> PackageTarget (PackageLocation ())
403 -> IO (PackageTarget ResolvedPkgLoc)
404 fetchPackageTarget verbosity repoCtxt = traverse $
405 fetchPackage verbosity repoCtxt . fmap (const Nothing)
406
407
408 -- | Given a package target that has been fetched, read the .cabal file.
409 --
410 -- This only affects targets given by location, named targets are unaffected.
411 --
412 readPackageTarget :: Verbosity
413 -> PackageTarget ResolvedPkgLoc
414 -> IO (PackageTarget UnresolvedSourcePackage)
415 readPackageTarget verbosity = traverse modifyLocation
416 where
417 modifyLocation location = case location of
418
419 LocalUnpackedPackage dir -> do
420 pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=
421 readGenericPackageDescription verbosity
422 return SourcePackage
423 { srcpkgPackageId = packageId pkg
424 , srcpkgDescription = pkg
425 , srcpkgSource = fmap Just location
426 , srcpkgDescrOverride = Nothing
427 }
428
429 LocalTarballPackage tarballFile ->
430 readTarballPackageTarget location tarballFile tarballFile
431
432 RemoteTarballPackage tarballURL tarballFile ->
433 readTarballPackageTarget location tarballFile (show tarballURL)
434
435 RepoTarballPackage _repo _pkgid _ ->
436 error "TODO: readPackageTarget RepoTarballPackage"
437 -- For repo tarballs this info should be obtained from the index.
438
439 RemoteSourceRepoPackage _srcRepo _ ->
440 error "TODO: readPackageTarget RemoteSourceRepoPackage"
441 -- This can't happen, because it would have errored out already
442 -- in fetchPackage, via fetchPackageTarget before it gets to this
443 -- function.
444 --
445 -- When that is corrected, this will also need to be fixed.
446
447 readTarballPackageTarget location tarballFile tarballOriginalLoc = do
448 (filename, content) <- extractTarballPackageCabalFile
449 tarballFile tarballOriginalLoc
450 case parsePackageDescription' content of
451 Nothing -> die' verbosity $ "Could not parse the cabal file "
452 ++ filename ++ " in " ++ tarballFile
453 Just pkg ->
454 return SourcePackage
455 { srcpkgPackageId = packageId pkg
456 , srcpkgDescription = pkg
457 , srcpkgSource = fmap Just location
458 , srcpkgDescrOverride = Nothing
459 }
460
461 extractTarballPackageCabalFile :: FilePath -> String
462 -> IO (FilePath, BS.ByteString)
463 extractTarballPackageCabalFile tarballFile tarballOriginalLoc =
464 either (die' verbosity . formatErr) return
465 . check
466 . accumEntryMap
467 . Tar.filterEntries isCabalFile
468 . Tar.read
469 . GZipUtils.maybeDecompress
470 =<< BS.readFile tarballFile
471 where
472 formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg
473
474 accumEntryMap = Tar.foldlEntries
475 (\m e -> Map.insert (Tar.entryTarPath e) e m)
476 Map.empty
477
478 check (Left e) = Left (show e)
479 check (Right m) = case Map.elems m of
480 [] -> Left noCabalFile
481 [file] -> case Tar.entryContent file of
482 Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
483 _ -> Left noCabalFile
484 _files -> Left multipleCabalFiles
485 where
486 noCabalFile = "No cabal file found"
487 multipleCabalFiles = "Multiple cabal files found"
488
489 isCabalFile e = case splitPath (Tar.entryPath e) of
490 [ _dir, file] -> takeExtension file == ".cabal"
491 [".", _dir, file] -> takeExtension file == ".cabal"
492 _ -> False
493
494 parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription
495 parsePackageDescription' bs =
496 parseGenericPackageDescriptionMaybe (BS.toStrict bs)
497
498 -- ------------------------------------------------------------
499 -- * Checking package targets
500 -- ------------------------------------------------------------
501
502 data PackageTargetProblem
503 = PackageNameUnknown PackageName UserTarget
504 | PackageNameAmbiguous PackageName [PackageName] UserTarget
505 deriving Show
506
507
508 -- | Users are allowed to give package names case-insensitively, so we must
509 -- disambiguate named package references.
510 --
511 disambiguatePackageTargets :: Package pkg'
512 => PackageIndex pkg'
513 -> [PackageName]
514 -> [PackageTarget pkg]
515 -> ( [PackageTargetProblem]
516 , [PackageSpecifier pkg] )
517 disambiguatePackageTargets availablePkgIndex availableExtra targets =
518 partitionEithers (map disambiguatePackageTarget targets)
519 where
520 disambiguatePackageTarget packageTarget = case packageTarget of
521 PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)
522
523 PackageTargetNamed pkgname props userTarget
524 | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)
525 -> Left (PackageNameUnknown pkgname userTarget)
526 | otherwise -> Right (NamedPackage pkgname props)
527
528 PackageTargetNamedFuzzy pkgname props userTarget ->
529 case disambiguatePackageName packageNameEnv pkgname of
530 None -> Left (PackageNameUnknown
531 pkgname userTarget)
532 Ambiguous pkgnames -> Left (PackageNameAmbiguous
533 pkgname pkgnames userTarget)
534 Unambiguous pkgname' -> Right (NamedPackage pkgname' props)
535
536 -- use any extra specific available packages to help us disambiguate
537 packageNameEnv :: PackageNameEnv
538 packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)
539 (extraPackageNameEnv availableExtra)
540
541
542 -- | Report problems to the user. That is, if there are any problems
543 -- then raise an exception.
544 reportPackageTargetProblems :: Verbosity
545 -> [PackageTargetProblem] -> IO ()
546 reportPackageTargetProblems verbosity problems = do
547 case [ pkg | PackageNameUnknown pkg originalTarget <- problems
548 , not (isUserTagetWorld originalTarget) ] of
549 [] -> return ()
550 pkgs -> die' verbosity $ unlines
551 [ "There is no package named '" ++ prettyShow name ++ "'. "
552 | name <- pkgs ]
553 ++ "You may need to run 'cabal update' to get the latest "
554 ++ "list of available packages."
555
556 case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of
557 [] -> return ()
558 ambiguities -> die' verbosity $ unlines
559 [ "There is no package named '" ++ prettyShow name ++ "'. "
560 ++ (if length matches > 1
561 then "However, the following package names exist: "
562 else "However, the following package name exists: ")
563 ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches]
564 ++ "."
565 | (name, matches) <- ambiguities ]
566
567 case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of
568 [] -> return ()
569 pkgs -> warn verbosity $
570 "The following 'world' packages will be ignored because "
571 ++ "they refer to packages that cannot be found: "
572 ++ intercalate ", " (map prettyShow pkgs) ++ "\n"
573 ++ "You can suppress this warning by correcting the world file."
574 where
575 isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False
576
577
578 -- ------------------------------------------------------------
579 -- * Disambiguating package names
580 -- ------------------------------------------------------------
581
582 data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]
583
584 -- | Given a package name and a list of matching names, figure out
585 -- which one it might be referring to. If there is an exact
586 -- case-sensitive match then that's ok (i.e. returned via
587 -- 'Unambiguous'). If it matches just one package case-insensitively
588 -- or if it matches multiple packages case-insensitively, in that case
589 -- the result is 'Ambiguous'.
590 --
591 -- Note: Before cabal 2.2, when only a single package matched
592 -- case-insensitively it would be considered 'Unambigious'.
593 --
594 disambiguatePackageName :: PackageNameEnv
595 -> PackageName
596 -> MaybeAmbiguous PackageName
597 disambiguatePackageName (PackageNameEnv pkgNameLookup) name =
598 case nub (pkgNameLookup name) of
599 [] -> None
600 names -> case find (name==) names of
601 Just name' -> Unambiguous name'
602 Nothing -> Ambiguous names
603
604
605 newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])
606
607 instance Monoid PackageNameEnv where
608 mempty = PackageNameEnv (const [])
609 mappend = (<>)
610
611 instance Semigroup PackageNameEnv where
612 PackageNameEnv lookupA <> PackageNameEnv lookupB =
613 PackageNameEnv (\name -> lookupA name ++ lookupB name)
614
615 indexPackageNameEnv :: PackageIndex pkg -> PackageNameEnv
616 indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup
617 where
618 pkgNameLookup pname =
619 map fst (PackageIndex.searchByName pkgIndex $ unPackageName pname)
620
621 extraPackageNameEnv :: [PackageName] -> PackageNameEnv
622 extraPackageNameEnv names = PackageNameEnv pkgNameLookup
623 where
624 pkgNameLookup pname =
625 [ pname'
626 | let lname = lowercase (unPackageName pname)
627 , pname' <- names
628 , lowercase (unPackageName pname') == lname ]
629
630
631 -- ------------------------------------------------------------
632 -- * Package constraints
633 -- ------------------------------------------------------------
634
635 -- | Version of 'Qualifier' that a user may specify on the
636 -- command line.
637 data UserQualifier =
638 -- | Top-level dependency.
639 UserQualToplevel
640
641 -- | Setup dependency.
642 | UserQualSetup PackageName
643
644 -- | Executable dependency.
645 | UserQualExe PackageName PackageName
646 deriving (Eq, Show, Generic)
647
648 instance Binary UserQualifier
649 instance Structured UserQualifier
650
651 -- | Version of 'ConstraintScope' that a user may specify on the
652 -- command line.
653 data UserConstraintScope =
654 -- | Scope that applies to the package when it has the specified qualifier.
655 UserQualified UserQualifier PackageName
656
657 -- | Scope that applies to the package when it has a setup qualifier.
658 | UserAnySetupQualifier PackageName
659
660 -- | Scope that applies to the package when it has any qualifier.
661 | UserAnyQualifier PackageName
662 deriving (Eq, Show, Generic)
663
664 instance Binary UserConstraintScope
665 instance Structured UserConstraintScope
666
667 fromUserQualifier :: UserQualifier -> Qualifier
668 fromUserQualifier UserQualToplevel = QualToplevel
669 fromUserQualifier (UserQualSetup name) = QualSetup name
670 fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2
671
672 fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
673 fromUserConstraintScope (UserQualified q pn) =
674 ScopeQualified (fromUserQualifier q) pn
675 fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
676 fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
677
678 -- | Version of 'PackageConstraint' that the user can specify on
679 -- the command line.
680 data UserConstraint =
681 UserConstraint UserConstraintScope PackageProperty
682 deriving (Eq, Show, Generic)
683
684 instance Binary UserConstraint
685 instance Structured UserConstraint
686
687 userConstraintPackageName :: UserConstraint -> PackageName
688 userConstraintPackageName (UserConstraint scope _) = scopePN scope
689 where
690 scopePN (UserQualified _ pn) = pn
691 scopePN (UserAnyQualifier pn) = pn
692 scopePN (UserAnySetupQualifier pn) = pn
693
694 userToPackageConstraint :: UserConstraint -> PackageConstraint
695 userToPackageConstraint (UserConstraint scope prop) =
696 PackageConstraint (fromUserConstraintScope scope) prop
697
698 readUserConstraint :: String -> Either String UserConstraint
699 readUserConstraint str =
700 case explicitEitherParsec parsec str of
701 Left err -> Left $ msgCannotParse ++ err
702 Right c -> Right c
703 where
704 msgCannotParse =
705 "expected a (possibly qualified) package name followed by a " ++
706 "constraint, which is either a version range, 'installed', " ++
707 "'source', 'test', 'bench', or flags. "
708
709 instance Pretty UserConstraint where
710 pretty (UserConstraint scope prop) =
711 dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop
712
713 instance Parsec UserConstraint where
714 parsec = do
715 scope <- parseConstraintScope
716 P.spaces
717 prop <- P.choice
718 [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-"
719 , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be)
720 , PackagePropertyInstalled <$ P.string "installed"
721 , PackagePropertySource <$ P.string "source"
722 , PackagePropertyStanzas [TestStanzas] <$ P.string "test"
723 , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
724 ]
725 return (UserConstraint scope prop)
726
727 where
728 parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
729 parseConstraintScope = do
730 pn <- parsec
731 P.choice
732 [ P.char '.' *> withDot pn
733 , P.char ':' *> withColon pn
734 , return (UserQualified UserQualToplevel pn)
735 ]
736 where
737 withDot :: PackageName -> m UserConstraintScope
738 withDot pn
739 | pn == mkPackageName "any" = UserAnyQualifier <$> parsec
740 | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
741 | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
742
743 withColon :: PackageName -> m UserConstraintScope
744 withColon pn = UserQualified (UserQualSetup pn)
745 <$ P.string "setup."
746 <*> parsec