1{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, 2 RecordWildCards, NamedFieldPuns #-} 3-- TODO 4{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} 5----------------------------------------------------------------------------- 6-- | 7-- Module : Distribution.Client.TargetSelector 8-- Copyright : (c) Duncan Coutts 2012, 2015, 2016 9-- License : BSD-like 10-- 11-- Maintainer : duncan@community.haskell.org 12-- 13-- Handling for user-specified target selectors. 14-- 15----------------------------------------------------------------------------- 16module Distribution.Client.TargetSelector ( 17 18 -- * Target selectors 19 TargetSelector(..), 20 TargetImplicitCwd(..), 21 ComponentKind(..), 22 ComponentKindFilter, 23 SubComponentTarget(..), 24 QualLevel(..), 25 componentKind, 26 27 -- * Reading target selectors 28 readTargetSelectors, 29 TargetSelectorProblem(..), 30 reportTargetSelectorProblems, 31 showTargetSelector, 32 TargetString(..), 33 showTargetString, 34 parseTargetString, 35 -- ** non-IO 36 readTargetSelectorsWith, 37 DirActions(..), 38 defaultDirActions, 39 ) where 40 41import Prelude () 42import Distribution.Client.Compat.Prelude 43 44import Distribution.Package 45 ( Package(..), PackageId, PackageName, packageName ) 46import Distribution.Types.UnqualComponentName 47 ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName 48 , packageNameToUnqualComponentName ) 49import Distribution.Client.Types 50 ( PackageLocation(..), PackageSpecifier(..) ) 51 52import Distribution.Verbosity 53import Distribution.PackageDescription 54 ( PackageDescription 55 , Executable(..) 56 , TestSuite(..), TestSuiteInterface(..), testModules 57 , Benchmark(..), BenchmarkInterface(..), benchmarkModules 58 , BuildInfo(..), explicitLibModules, exeModules ) 59import Distribution.PackageDescription.Configuration 60 ( flattenPackageDescription ) 61import Distribution.Solver.Types.SourcePackage 62 ( SourcePackage(..) ) 63import Distribution.ModuleName 64 ( ModuleName, toFilePath ) 65import Distribution.Simple.LocalBuildInfo 66 ( Component(..), ComponentName(..), LibraryName(..) 67 , pkgComponents, componentName, componentBuildInfo ) 68import Distribution.Types.ForeignLib 69 70import Distribution.Deprecated.Text 71 ( Text, display, simpleParse ) 72import Distribution.Simple.Utils 73 ( die', lowercase, ordNub ) 74import Distribution.Client.Utils 75 ( makeRelativeCanonical ) 76 77import Data.Either 78 ( partitionEithers ) 79import Data.Function 80 ( on ) 81import Data.List 82 ( stripPrefix, partition, groupBy ) 83import qualified Data.List.NonEmpty as NE 84import Data.Ord 85 ( comparing ) 86import qualified Data.Map.Lazy as Map.Lazy 87import qualified Data.Map.Strict as Map 88import qualified Data.Set as Set 89import Control.Arrow ((&&&)) 90import Control.Monad 91 hiding ( mfilter ) 92import qualified Distribution.Deprecated.ReadP as Parse 93import Distribution.Deprecated.ReadP 94 ( (+++), (<++) ) 95import Distribution.Deprecated.ParseUtils 96 ( readPToMaybe ) 97import System.FilePath as FilePath 98 ( takeExtension, dropExtension 99 , splitDirectories, joinPath, splitPath ) 100import qualified System.Directory as IO 101 ( doesFileExist, doesDirectoryExist, canonicalizePath 102 , getCurrentDirectory ) 103import System.FilePath 104 ( (</>), (<.>), normalise, dropTrailingPathSeparator ) 105import Text.EditDistance 106 ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) 107 108import qualified Prelude (foldr1) 109 110-- ------------------------------------------------------------ 111-- * Target selector terms 112-- ------------------------------------------------------------ 113 114-- | A target selector is expression selecting a set of components (as targets 115-- for a actions like @build@, @run@, @test@ etc). A target selector 116-- corresponds to the user syntax for referring to targets on the command line. 117-- 118-- From the users point of view a target can be many things: packages, dirs, 119-- component names, files etc. Internally we consider a target to be a specific 120-- component (or module\/file within a component), and all the users' notions 121-- of targets are just different ways of referring to these component targets. 122-- 123-- So target selectors are expressions in the sense that they are interpreted 124-- to refer to one or more components. For example a 'TargetPackage' gets 125-- interpreted differently by different commands to refer to all or a subset 126-- of components within the package. 127-- 128-- The syntax has lots of optional parts: 129-- 130-- > [ package name | package dir | package .cabal file ] 131-- > [ [lib:|exe:] component name ] 132-- > [ module name | source file ] 133-- 134data TargetSelector = 135 136 -- | One (or more) packages as a whole, or all the components of a 137 -- particular kind within the package(s). 138 -- 139 -- These are always packages that are local to the project. In the case 140 -- that there is more than one, they all share the same directory location. 141 -- 142 TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) 143 144 -- | A package specified by name. This may refer to @extra-packages@ from 145 -- the @cabal.project@ file, or a dependency of a known project package or 146 -- could refer to a package from a hackage archive. It needs further 147 -- context to resolve to a specific package. 148 -- 149 | TargetPackageNamed PackageName (Maybe ComponentKindFilter) 150 151 -- | All packages, or all components of a particular kind in all packages. 152 -- 153 | TargetAllPackages (Maybe ComponentKindFilter) 154 155 -- | A specific component in a package within the project. 156 -- 157 | TargetComponent PackageId ComponentName SubComponentTarget 158 159 -- | A component in a package, but where it cannot be verified that the 160 -- package has such a component, or because the package is itself not 161 -- known. 162 -- 163 | TargetComponentUnknown PackageName 164 (Either UnqualComponentName ComponentName) 165 SubComponentTarget 166 deriving (Eq, Ord, Show, Generic) 167 168-- | Does this 'TargetPackage' selector arise from syntax referring to a 169-- package in the current directory (e.g. @tests@ or no giving no explicit 170-- target at all) or does it come from syntax referring to a package name 171-- or location. 172-- 173data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed 174 deriving (Eq, Ord, Show, Generic) 175 176data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind 177 deriving (Eq, Ord, Enum, Show) 178 179type ComponentKindFilter = ComponentKind 180 181-- | Either the component as a whole or detail about a file or module target 182-- within a component. 183-- 184data SubComponentTarget = 185 186 -- | The component as a whole 187 WholeComponent 188 189 -- | A specific module within a component. 190 | ModuleTarget ModuleName 191 192 -- | A specific file within a component. 193 | FileTarget FilePath 194 deriving (Eq, Ord, Show, Generic) 195 196instance Binary SubComponentTarget 197instance Structured SubComponentTarget 198 199 200-- ------------------------------------------------------------ 201-- * Top level, do everything 202-- ------------------------------------------------------------ 203 204 205-- | Parse a bunch of command line args as 'TargetSelector's, failing with an 206-- error if any are unrecognised. The possible target selectors are based on 207-- the available packages (and their locations). 208-- 209readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] 210 -> Maybe ComponentKindFilter 211 -- ^ This parameter is used when there are ambiguous selectors. 212 -- If it is 'Just', then we attempt to resolve ambiguitiy 213 -- by applying it, since otherwise there is no way to allow 214 -- contextually valid yet syntactically ambiguous selectors. 215 -- (#4676, #5461) 216 -> [String] 217 -> IO (Either [TargetSelectorProblem] [TargetSelector]) 218readTargetSelectors = readTargetSelectorsWith defaultDirActions 219 220readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m 221 -> [PackageSpecifier (SourcePackage (PackageLocation a))] 222 -> Maybe ComponentKindFilter 223 -> [String] 224 -> m (Either [TargetSelectorProblem] [TargetSelector]) 225readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = 226 case parseTargetStrings targetStrs of 227 ([], usertargets) -> do 228 usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets 229 knowntargets <- getKnownTargets dirActions pkgs 230 case resolveTargetSelectors knowntargets usertargets' mfilter of 231 ([], btargets) -> return (Right btargets) 232 (problems, _) -> return (Left problems) 233 (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) 234 235 236data DirActions m = DirActions { 237 doesFileExist :: FilePath -> m Bool, 238 doesDirectoryExist :: FilePath -> m Bool, 239 canonicalizePath :: FilePath -> m FilePath, 240 getCurrentDirectory :: m FilePath 241 } 242 243defaultDirActions :: DirActions IO 244defaultDirActions = 245 DirActions { 246 doesFileExist = IO.doesFileExist, 247 doesDirectoryExist = IO.doesDirectoryExist, 248 -- Workaround for <https://github.com/haskell/directory/issues/63> 249 canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator, 250 getCurrentDirectory = IO.getCurrentDirectory 251 } 252 253makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath 254makeRelativeToCwd DirActions{..} path = 255 makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory 256 257 258-- ------------------------------------------------------------ 259-- * Parsing target strings 260-- ------------------------------------------------------------ 261 262-- | The outline parse of a target selector. It takes one of the forms: 263-- 264-- > str1 265-- > str1:str2 266-- > str1:str2:str3 267-- > str1:str2:str3:str4 268-- 269data TargetString = 270 TargetString1 String 271 | TargetString2 String String 272 | TargetString3 String String String 273 | TargetString4 String String String String 274 | TargetString5 String String String String String 275 | TargetString7 String String String String String String String 276 deriving (Show, Eq) 277 278-- | Parse a bunch of 'TargetString's (purely without throwing exceptions). 279-- 280parseTargetStrings :: [String] -> ([String], [TargetString]) 281parseTargetStrings = 282 partitionEithers 283 . map (\str -> maybe (Left str) Right (parseTargetString str)) 284 285parseTargetString :: String -> Maybe TargetString 286parseTargetString = 287 readPToMaybe parseTargetApprox 288 where 289 parseTargetApprox :: Parse.ReadP r TargetString 290 parseTargetApprox = 291 (do a <- tokenQ 292 return (TargetString1 a)) 293 +++ (do a <- tokenQ0 294 _ <- Parse.char ':' 295 b <- tokenQ 296 return (TargetString2 a b)) 297 +++ (do a <- tokenQ0 298 _ <- Parse.char ':' 299 b <- tokenQ 300 _ <- Parse.char ':' 301 c <- tokenQ 302 return (TargetString3 a b c)) 303 +++ (do a <- tokenQ0 304 _ <- Parse.char ':' 305 b <- token 306 _ <- Parse.char ':' 307 c <- tokenQ 308 _ <- Parse.char ':' 309 d <- tokenQ 310 return (TargetString4 a b c d)) 311 +++ (do a <- tokenQ0 312 _ <- Parse.char ':' 313 b <- token 314 _ <- Parse.char ':' 315 c <- tokenQ 316 _ <- Parse.char ':' 317 d <- tokenQ 318 _ <- Parse.char ':' 319 e <- tokenQ 320 return (TargetString5 a b c d e)) 321 +++ (do a <- tokenQ0 322 _ <- Parse.char ':' 323 b <- token 324 _ <- Parse.char ':' 325 c <- tokenQ 326 _ <- Parse.char ':' 327 d <- tokenQ 328 _ <- Parse.char ':' 329 e <- tokenQ 330 _ <- Parse.char ':' 331 f <- tokenQ 332 _ <- Parse.char ':' 333 g <- tokenQ 334 return (TargetString7 a b c d e f g)) 335 336 token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') 337 tokenQ = parseHaskellString <++ token 338 token0 = Parse.munch (\x -> not (isSpace x) && x /= ':') 339 tokenQ0= parseHaskellString <++ token0 340 parseHaskellString :: Parse.ReadP r String 341 parseHaskellString = Parse.readS_to_P reads 342 343 344-- | Render a 'TargetString' back as the external syntax. This is mainly for 345-- error messages. 346-- 347showTargetString :: TargetString -> String 348showTargetString = intercalate ":" . components 349 where 350 components (TargetString1 s1) = [s1] 351 components (TargetString2 s1 s2) = [s1,s2] 352 components (TargetString3 s1 s2 s3) = [s1,s2,s3] 353 components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4] 354 components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5] 355 components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7] 356 357showTargetSelector :: TargetSelector -> String 358showTargetSelector ts = 359 case [ t | ql <- [QL1 .. QLFull] 360 , t <- renderTargetSelector ql ts ] 361 of (t':_) -> showTargetString (forgetFileStatus t') 362 [] -> "" 363 364showTargetSelectorKind :: TargetSelector -> String 365showTargetSelectorKind bt = case bt of 366 TargetPackage TargetExplicitNamed _ Nothing -> "package" 367 TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter" 368 TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package" 369 TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter" 370 TargetPackageNamed _ Nothing -> "named-package" 371 TargetPackageNamed _ (Just _) -> "named-package:filter" 372 TargetAllPackages Nothing -> "package *" 373 TargetAllPackages (Just _) -> "package *:filter" 374 TargetComponent _ _ WholeComponent -> "component" 375 TargetComponent _ _ ModuleTarget{} -> "module" 376 TargetComponent _ _ FileTarget{} -> "file" 377 TargetComponentUnknown _ _ WholeComponent -> "unknown-component" 378 TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module" 379 TargetComponentUnknown _ _ FileTarget{} -> "unknown-file" 380 381 382-- ------------------------------------------------------------ 383-- * Checking if targets exist as files 384-- ------------------------------------------------------------ 385 386data TargetStringFileStatus = 387 TargetStringFileStatus1 String FileStatus 388 | TargetStringFileStatus2 String FileStatus String 389 | TargetStringFileStatus3 String FileStatus String String 390 | TargetStringFileStatus4 String String String String 391 | TargetStringFileStatus5 String String String String String 392 | TargetStringFileStatus7 String String String String String String String 393 deriving (Eq, Ord, Show) 394 395data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath 396 | FileStatusExistsDir FilePath -- the canonicalised filepath 397 | FileStatusNotExists Bool -- does the parent dir exist even? 398 deriving (Eq, Ord, Show) 399 400noFileStatus :: FileStatus 401noFileStatus = FileStatusNotExists False 402 403getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m 404 -> TargetString -> m TargetStringFileStatus 405getTargetStringFileStatus DirActions{..} t = 406 case t of 407 TargetString1 s1 -> 408 (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 409 TargetString2 s1 s2 -> 410 (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 411 TargetString3 s1 s2 s3 -> 412 (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 413 TargetString4 s1 s2 s3 s4 -> 414 return (TargetStringFileStatus4 s1 s2 s3 s4) 415 TargetString5 s1 s2 s3 s4 s5 -> 416 return (TargetStringFileStatus5 s1 s2 s3 s4 s5) 417 TargetString7 s1 s2 s3 s4 s5 s6 s7 -> 418 return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) 419 where 420 fileStatus f = do 421 fexists <- doesFileExist f 422 dexists <- doesDirectoryExist f 423 case splitPath f of 424 _ | fexists -> FileStatusExistsFile <$> canonicalizePath f 425 | dexists -> FileStatusExistsDir <$> canonicalizePath f 426 (d:_) -> FileStatusNotExists <$> doesDirectoryExist d 427 _ -> pure (FileStatusNotExists False) 428 429forgetFileStatus :: TargetStringFileStatus -> TargetString 430forgetFileStatus t = case t of 431 TargetStringFileStatus1 s1 _ -> TargetString1 s1 432 TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2 433 TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3 434 TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4 435 TargetStringFileStatus5 s1 s2 s3 s4 436 s5 -> TargetString5 s1 s2 s3 s4 s5 437 TargetStringFileStatus7 s1 s2 s3 s4 438 s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7 439 440 441-- ------------------------------------------------------------ 442-- * Resolving target strings to target selectors 443-- ------------------------------------------------------------ 444 445 446-- | Given a bunch of user-specified targets, try to resolve what it is they 447-- refer to. 448-- 449resolveTargetSelectors :: KnownTargets 450 -> [TargetStringFileStatus] 451 -> Maybe ComponentKindFilter 452 -> ([TargetSelectorProblem], 453 [TargetSelector]) 454-- default local dir target if there's no given target: 455resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = 456 ([TargetSelectorNoTargetsInProject], []) 457 458resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ = 459 ([TargetSelectorNoTargetsInCwd], []) 460 461resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = 462 ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) 463 where 464 pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] 465 466resolveTargetSelectors knowntargets targetStrs mfilter = 467 partitionEithers 468 . map (resolveTargetSelector knowntargets mfilter) 469 $ targetStrs 470 471resolveTargetSelector :: KnownTargets 472 -> Maybe ComponentKindFilter 473 -> TargetStringFileStatus 474 -> Either TargetSelectorProblem TargetSelector 475resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = 476 case findMatch (matcher targetStrStatus) of 477 478 Unambiguous _ 479 | projectIsEmpty -> Left TargetSelectorNoTargetsInProject 480 481 Unambiguous (TargetPackage TargetImplicitCwd [] _) 482 -> Left (TargetSelectorNoCurrentPackage targetStr) 483 484 Unambiguous target -> Right target 485 486 None errs 487 | projectIsEmpty -> Left TargetSelectorNoTargetsInProject 488 | otherwise -> Left (classifyMatchErrors errs) 489 490 Ambiguous _ targets 491 | Just kfilter <- mfilter 492 , [target] <- applyKindFilter kfilter targets -> Right target 493 494 Ambiguous exactMatch targets -> 495 case disambiguateTargetSelectors 496 matcher targetStrStatus exactMatch 497 targets of 498 Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') 499 Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) 500 Left [] -> internalError "resolveTargetSelector" 501 where 502 matcher = matchTargetSelector knowntargets 503 504 targetStr = forgetFileStatus targetStrStatus 505 506 projectIsEmpty = null knownPackagesAll 507 508 classifyMatchErrors errs 509 | Just expectedNE <- NE.nonEmpty expected 510 = let (things, got:|_) = NE.unzip expectedNE in 511 TargetSelectorExpected targetStr (NE.toList things) got 512 513 | not (null nosuch) 514 = TargetSelectorNoSuch targetStr nosuch 515 516 | otherwise 517 = internalError $ "classifyMatchErrors: " ++ show errs 518 where 519 expected = [ (thing, got) 520 | (_, MatchErrorExpected thing got) 521 <- map (innerErr Nothing) errs ] 522 -- Trim the list of alternatives by dropping duplicates and 523 -- retaining only at most three most similar (by edit distance) ones. 524 nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ 525 [ ((inside, thing, got), Set.fromList alts) 526 | (inside, MatchErrorNoSuch thing got alts) 527 <- map (innerErr Nothing) errs 528 ] 529 530 genResults (inside, thing, got) alts acc = ( 531 inside 532 , thing 533 , got 534 , take maxResults 535 $ map fst 536 $ takeWhile distanceLow 537 $ sortBy (comparing snd) 538 $ map addLevDist 539 $ Set.toList alts 540 ) : acc 541 where 542 addLevDist = id &&& restrictedDamerauLevenshteinDistance 543 defaultEditCosts got 544 545 distanceLow (_, dist) = dist < length got `div` 2 546 547 maxResults = 3 548 549 innerErr _ (MatchErrorIn kind thing m) 550 = innerErr (Just (kind,thing)) m 551 innerErr c m = (c,m) 552 553 applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] 554 applyKindFilter kfilter = filter go 555 where 556 go (TargetPackage _ _ (Just filter')) = kfilter == filter' 557 go (TargetPackageNamed _ (Just filter')) = kfilter == filter' 558 go (TargetAllPackages (Just filter')) = kfilter == filter' 559 go (TargetComponent _ cname _) 560 | CLibName _ <- cname = kfilter == LibKind 561 | CFLibName _ <- cname = kfilter == FLibKind 562 | CExeName _ <- cname = kfilter == ExeKind 563 | CTestName _ <- cname = kfilter == TestKind 564 | CBenchName _ <- cname = kfilter == BenchKind 565 go _ = True 566 567-- | The various ways that trying to resolve a 'TargetString' to a 568-- 'TargetSelector' can fail. 569-- 570data TargetSelectorProblem 571 = TargetSelectorExpected TargetString [String] String 572 -- ^ [expected thing] (actually got) 573 | TargetSelectorNoSuch TargetString 574 [(Maybe (String, String), String, String, [String])] 575 -- ^ [([in thing], no such thing, actually got, alternatives)] 576 | TargetSelectorAmbiguous TargetString 577 [(TargetString, TargetSelector)] 578 579 | MatchingInternalError TargetString TargetSelector 580 [(TargetString, [TargetSelector])] 581 | TargetSelectorUnrecognised String 582 -- ^ Syntax error when trying to parse a target string. 583 | TargetSelectorNoCurrentPackage TargetString 584 | TargetSelectorNoTargetsInCwd 585 | TargetSelectorNoTargetsInProject 586 deriving (Show, Eq) 587 588data QualLevel = QL1 | QL2 | QL3 | QLFull 589 deriving (Eq, Enum, Show) 590 591disambiguateTargetSelectors 592 :: (TargetStringFileStatus -> Match TargetSelector) 593 -> TargetStringFileStatus -> MatchClass 594 -> [TargetSelector] 595 -> Either [(TargetSelector, [(TargetString, [TargetSelector])])] 596 [(TargetString, TargetSelector)] 597disambiguateTargetSelectors matcher matchInput exactMatch matchResults = 598 case partitionEithers results of 599 (errs@(_:_), _) -> Left errs 600 ([], ok) -> Right ok 601 where 602 -- So, here's the strategy. We take the original match results, and make a 603 -- table of all their renderings at all qualification levels. 604 -- Note there can be multiple renderings at each qualification level. 605 matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])] 606 matchResultsRenderings = 607 [ (matchResult, matchRenderings) 608 | matchResult <- matchResults 609 , let matchRenderings = 610 [ rendering 611 | ql <- [QL1 .. QLFull] 612 , rendering <- renderTargetSelector ql matchResult ] 613 ] 614 615 -- Of course the point is that we're looking for renderings that are 616 -- unambiguous matches. So we build another memo table of all the matches 617 -- for all of those renderings. So by looking up in this table we can see 618 -- if we've got an unambiguous match. 619 620 memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector) 621 memoisedMatches = 622 -- avoid recomputing the main one if it was an exact match 623 (if exactMatch == Exact 624 then Map.insert matchInput (Match Exact 0 matchResults) 625 else id) 626 $ Map.Lazy.fromList 627 [ (rendering, matcher rendering) 628 | rendering <- concatMap snd matchResultsRenderings ] 629 630 -- Finally, for each of the match results, we go through all their 631 -- possible renderings (in order of qualification level, though remember 632 -- there can be multiple renderings per level), and find the first one 633 -- that has an unambiguous match. 634 results :: [Either (TargetSelector, [(TargetString, [TargetSelector])]) 635 (TargetString, TargetSelector)] 636 results = 637 [ case findUnambiguous originalMatch matchRenderings of 638 Just unambiguousRendering -> 639 Right ( forgetFileStatus unambiguousRendering 640 , originalMatch) 641 642 -- This case is an internal error, but we bubble it up and report it 643 Nothing -> 644 Left ( originalMatch 645 , [ (forgetFileStatus rendering, matches) 646 | rendering <- matchRenderings 647 , let Match m _ matches = 648 memoisedMatches Map.! rendering 649 , m /= Inexact 650 ] ) 651 652 | (originalMatch, matchRenderings) <- matchResultsRenderings ] 653 654 findUnambiguous :: TargetSelector 655 -> [TargetStringFileStatus] 656 -> Maybe TargetStringFileStatus 657 findUnambiguous _ [] = Nothing 658 findUnambiguous t (r:rs) = 659 case memoisedMatches Map.! r of 660 Match Exact _ [t'] | t == t' 661 -> Just r 662 Match Exact _ _ -> findUnambiguous t rs 663 Match Unknown _ _ -> findUnambiguous t rs 664 Match Inexact _ _ -> internalError "Match Inexact" 665 NoMatch _ _ -> internalError "NoMatch" 666 667internalError :: String -> a 668internalError msg = 669 error $ "TargetSelector: internal error: " ++ msg 670 671 672-- | Throw an exception with a formatted message if there are any problems. 673-- 674reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a 675reportTargetSelectorProblems verbosity problems = do 676 677 case [ str | TargetSelectorUnrecognised str <- problems ] of 678 [] -> return () 679 targets -> 680 die' verbosity $ unlines 681 [ "Unrecognised target syntax for '" ++ name ++ "'." 682 | name <- targets ] 683 684 case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of 685 [] -> return () 686 ((target, originalMatch, renderingsAndMatches):_) -> 687 die' verbosity $ "Internal error in target matching. It should always " 688 ++ "be possible to find a syntax that's sufficiently qualified to " 689 ++ "give an unambiguous match. However when matching '" 690 ++ showTargetString target ++ "' we found " 691 ++ showTargetSelector originalMatch 692 ++ " (" ++ showTargetSelectorKind originalMatch ++ ") which does " 693 ++ "not have an unambiguous syntax. The possible syntax and the " 694 ++ "targets they match are as follows:\n" 695 ++ unlines 696 [ "'" ++ showTargetString rendering ++ "' which matches " 697 ++ intercalate ", " 698 [ showTargetSelector match ++ 699 " (" ++ showTargetSelectorKind match ++ ")" 700 | match <- matches ] 701 | (rendering, matches) <- renderingsAndMatches ] 702 703 case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of 704 [] -> return () 705 targets -> 706 die' verbosity $ unlines 707 [ "Unrecognised target '" ++ showTargetString target 708 ++ "'.\n" 709 ++ "Expected a " ++ intercalate " or " expected 710 ++ ", rather than '" ++ got ++ "'." 711 | (target, expected, got) <- targets ] 712 713 case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of 714 [] -> return () 715 targets -> 716 die' verbosity $ unlines 717 [ "Unknown target '" ++ showTargetString target ++ 718 "'.\n" ++ unlines 719 [ (case inside of 720 Just (kind, "") 721 -> "The " ++ kind ++ " has no " 722 Just (kind, thing) 723 -> "The " ++ kind ++ " " ++ thing ++ " has no " 724 Nothing -> "There is no ") 725 ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" 726 | (thing, got, _alts) <- nosuch' ] ++ "." 727 ++ if null alternatives then "" else 728 "\nPerhaps you meant " ++ intercalate ";\nor " 729 [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" 730 | (thing, alts) <- alternatives ] 731 | (inside, nosuch') <- groupByContainer nosuch 732 , let alternatives = 733 [ (thing, alts) 734 | (thing,_got,alts@(_:_)) <- nosuch' ] 735 ] 736 | (target, nosuch) <- targets 737 , let groupByContainer = 738 map (\g@((inside,_,_,_):_) -> 739 (inside, [ (thing,got,alts) 740 | (_,thing,got,alts) <- g ])) 741 . groupBy ((==) `on` (\(x,_,_,_) -> x)) 742 . sortBy (compare `on` (\(x,_,_,_) -> x)) 743 ] 744 where 745 mungeThing "file" = "file target" 746 mungeThing thing = thing 747 748 case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of 749 [] -> return () 750 targets -> 751 die' verbosity $ unlines 752 [ "Ambiguous target '" ++ showTargetString target 753 ++ "'. It could be:\n " 754 ++ unlines [ " "++ showTargetString ut ++ 755 " (" ++ showTargetSelectorKind bt ++ ")" 756 | (ut, bt) <- amb ] 757 | (target, amb) <- targets ] 758 759 case [ t | TargetSelectorNoCurrentPackage t <- problems ] of 760 [] -> return () 761 target:_ -> 762 die' verbosity $ 763 "The target '" ++ showTargetString target ++ "' refers to the " 764 ++ "components in the package in the current directory, but there " 765 ++ "is no package in the current directory (or at least not listed " 766 ++ "as part of the project)." 767 --TODO: report a different error if there is a .cabal file but it's 768 -- not a member of the project 769 770 case [ () | TargetSelectorNoTargetsInCwd <- problems ] of 771 [] -> return () 772 _:_ -> 773 die' verbosity $ 774 "No targets given and there is no package in the current " 775 ++ "directory. Use the target 'all' for all packages in the " 776 ++ "project or specify packages or components by name or location. " 777 ++ "See 'cabal build --help' for more details on target options." 778 779 case [ () | TargetSelectorNoTargetsInProject <- problems ] of 780 [] -> return () 781 _:_ -> 782 die' verbosity $ 783 "There is no <pkgname>.cabal package file or cabal.project file. " 784 ++ "To build packages locally you need at minimum a <pkgname>.cabal " 785 ++ "file. You can use 'cabal init' to create one.\n" 786 ++ "\n" 787 ++ "For non-trivial projects you will also want a cabal.project " 788 ++ "file in the root directory of your project. This file lists the " 789 ++ "packages in your project and all other build configuration. " 790 ++ "See the Cabal user guide for full details." 791 792 fail "reportTargetSelectorProblems: internal error" 793 794 795---------------------------------- 796-- Syntax type 797-- 798 799-- | Syntax for the 'TargetSelector': the matcher and renderer 800-- 801data Syntax = Syntax QualLevel Matcher Renderer 802 | AmbiguousAlternatives Syntax Syntax 803 | ShadowingAlternatives Syntax Syntax 804 805type Matcher = TargetStringFileStatus -> Match TargetSelector 806type Renderer = TargetSelector -> [TargetStringFileStatus] 807 808foldSyntax :: (a -> a -> a) -> (a -> a -> a) 809 -> (QualLevel -> Matcher -> Renderer -> a) 810 -> (Syntax -> a) 811foldSyntax ambiguous unambiguous syntax = go 812 where 813 go (Syntax ql match render) = syntax ql match render 814 go (AmbiguousAlternatives a b) = ambiguous (go a) (go b) 815 go (ShadowingAlternatives a b) = unambiguous (go a) (go b) 816 817 818---------------------------------- 819-- Top level renderer and matcher 820-- 821 822renderTargetSelector :: QualLevel -> TargetSelector 823 -> [TargetStringFileStatus] 824renderTargetSelector ql ts = 825 foldSyntax 826 (++) (++) 827 (\ql' _ render -> guard (ql == ql') >> render ts) 828 syntax 829 where 830 syntax = syntaxForms emptyKnownTargets 831 -- don't need known targets for rendering 832 833matchTargetSelector :: KnownTargets 834 -> TargetStringFileStatus 835 -> Match TargetSelector 836matchTargetSelector knowntargets = \usertarget -> 837 nubMatchesBy (==) $ 838 839 let ql = targetQualLevel usertarget in 840 foldSyntax 841 (<|>) (<//>) 842 (\ql' match _ -> guard (ql == ql') >> match usertarget) 843 syntax 844 where 845 syntax = syntaxForms knowntargets 846 847 targetQualLevel TargetStringFileStatus1{} = QL1 848 targetQualLevel TargetStringFileStatus2{} = QL2 849 targetQualLevel TargetStringFileStatus3{} = QL3 850 targetQualLevel TargetStringFileStatus4{} = QLFull 851 targetQualLevel TargetStringFileStatus5{} = QLFull 852 targetQualLevel TargetStringFileStatus7{} = QLFull 853 854 855---------------------------------- 856-- Syntax forms 857-- 858 859-- | All the forms of syntax for 'TargetSelector'. 860-- 861syntaxForms :: KnownTargets -> Syntax 862syntaxForms KnownTargets { 863 knownPackagesAll = pinfo, 864 knownPackagesPrimary = ppinfo, 865 knownComponentsAll = cinfo, 866 knownComponentsPrimary = pcinfo, 867 knownComponentsOther = ocinfo 868 } = 869 -- The various forms of syntax here are ambiguous in many cases. 870 -- Our policy is by default we expose that ambiguity and report 871 -- ambiguous matches. In certain cases we override the ambiguity 872 -- by having some forms shadow others. 873 -- 874 -- We make modules shadow files because module name "Q" clashes 875 -- with file "Q" with no extension but these refer to the same 876 -- thing anyway so it's not a useful ambiguity. Other cases are 877 -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q". 878 879 ambiguousAlternatives 880 -- convenient single-component forms 881 [ shadowingAlternatives 882 [ ambiguousAlternatives 883 [ syntaxForm1All 884 , syntaxForm1Filter ppinfo 885 , shadowingAlternatives 886 [ syntaxForm1Component pcinfo 887 , syntaxForm1Package pinfo 888 ] 889 ] 890 , syntaxForm1Component ocinfo 891 , syntaxForm1Module cinfo 892 , syntaxForm1File pinfo 893 ] 894 895 -- two-component partially qualified forms 896 -- fully qualified form for 'all' 897 , syntaxForm2MetaAll 898 , syntaxForm2AllFilter 899 , syntaxForm2NamespacePackage pinfo 900 , syntaxForm2PackageComponent pinfo 901 , syntaxForm2PackageFilter pinfo 902 , syntaxForm2KindComponent cinfo 903 , shadowingAlternatives 904 [ syntaxForm2PackageModule pinfo 905 , syntaxForm2PackageFile pinfo 906 ] 907 , shadowingAlternatives 908 [ syntaxForm2ComponentModule cinfo 909 , syntaxForm2ComponentFile cinfo 910 ] 911 912 -- rarely used partially qualified forms 913 , syntaxForm3PackageKindComponent pinfo 914 , shadowingAlternatives 915 [ syntaxForm3PackageComponentModule pinfo 916 , syntaxForm3PackageComponentFile pinfo 917 ] 918 , shadowingAlternatives 919 [ syntaxForm3KindComponentModule cinfo 920 , syntaxForm3KindComponentFile cinfo 921 ] 922 , syntaxForm3NamespacePackageFilter pinfo 923 924 -- fully-qualified forms for all and cwd with filter 925 , syntaxForm3MetaAllFilter 926 , syntaxForm3MetaCwdFilter ppinfo 927 928 -- fully-qualified form for package and package with filter 929 , syntaxForm3MetaNamespacePackage pinfo 930 , syntaxForm4MetaNamespacePackageFilter pinfo 931 932 -- fully-qualified forms for component, module and file 933 , syntaxForm5MetaNamespacePackageKindComponent pinfo 934 , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo 935 , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo 936 ] 937 where 938 ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives 939 shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives 940 941 942-- | Syntax: "all" to select all packages in the project 943-- 944-- > cabal build all 945-- 946syntaxForm1All :: Syntax 947syntaxForm1All = 948 syntaxForm1 render $ \str1 _fstatus1 -> do 949 guardMetaAll str1 950 return (TargetAllPackages Nothing) 951 where 952 render (TargetAllPackages Nothing) = 953 [TargetStringFileStatus1 "all" noFileStatus] 954 render _ = [] 955 956-- | Syntax: filter 957-- 958-- > cabal build tests 959-- 960syntaxForm1Filter :: [KnownPackage] -> Syntax 961syntaxForm1Filter ps = 962 syntaxForm1 render $ \str1 _fstatus1 -> do 963 kfilter <- matchComponentKindFilter str1 964 return (TargetPackage TargetImplicitCwd pids (Just kfilter)) 965 where 966 pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] 967 render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = 968 [TargetStringFileStatus1 (dispF kfilter) noFileStatus] 969 render _ = [] 970 971 972-- | Syntax: package (name, dir or file) 973-- 974-- > cabal build foo 975-- > cabal build ../bar ../bar/bar.cabal 976-- 977syntaxForm1Package :: [KnownPackage] -> Syntax 978syntaxForm1Package pinfo = 979 syntaxForm1 render $ \str1 fstatus1 -> do 980 guardPackage str1 fstatus1 981 p <- matchPackage pinfo str1 fstatus1 982 case p of 983 KnownPackage{pinfoId} -> 984 return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) 985 KnownPackageName pn -> 986 return (TargetPackageNamed pn Nothing) 987 where 988 render (TargetPackage TargetExplicitNamed [p] Nothing) = 989 [TargetStringFileStatus1 (dispP p) noFileStatus] 990 render (TargetPackageNamed pn Nothing) = 991 [TargetStringFileStatus1 (dispPN pn) noFileStatus] 992 render _ = [] 993 994-- | Syntax: component 995-- 996-- > cabal build foo 997-- 998syntaxForm1Component :: [KnownComponent] -> Syntax 999syntaxForm1Component cs = 1000 syntaxForm1 render $ \str1 _fstatus1 -> do 1001 guardComponentName str1 1002 c <- matchComponentName cs str1 1003 return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) 1004 where 1005 render (TargetComponent p c WholeComponent) = 1006 [TargetStringFileStatus1 (dispC p c) noFileStatus] 1007 render _ = [] 1008 1009-- | Syntax: module 1010-- 1011-- > cabal build Data.Foo 1012-- 1013syntaxForm1Module :: [KnownComponent] -> Syntax 1014syntaxForm1Module cs = 1015 syntaxForm1 render $ \str1 _fstatus1 -> do 1016 guardModuleName str1 1017 let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] 1018 (m,c) <- matchModuleNameAnd ms str1 1019 return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m)) 1020 where 1021 render (TargetComponent _p _c (ModuleTarget m)) = 1022 [TargetStringFileStatus1 (dispM m) noFileStatus] 1023 render _ = [] 1024 1025-- | Syntax: file name 1026-- 1027-- > cabal build Data/Foo.hs bar/Main.hsc 1028-- 1029syntaxForm1File :: [KnownPackage] -> Syntax 1030syntaxForm1File ps = 1031 -- Note there's a bit of an inconsistency here vs the other syntax forms 1032 -- for files. For the single-part syntax the target has to point to a file 1033 -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for 1034 -- all the other forms we don't require that. 1035 syntaxForm1 render $ \str1 fstatus1 -> 1036 expecting "file" str1 $ do 1037 (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) 1038 -- always returns the KnownPackage case 1039 <- matchPackageDirectoryPrefix ps fstatus1 1040 orNoThingIn "package" (display (packageName pinfoId)) $ do 1041 (filepath, c) <- matchComponentFile pinfoComponents pkgfile 1042 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) 1043 where 1044 render (TargetComponent _p _c (FileTarget f)) = 1045 [TargetStringFileStatus1 f noFileStatus] 1046 render _ = [] 1047 1048--- 1049 1050-- | Syntax: :all 1051-- 1052-- > cabal build :all 1053-- 1054syntaxForm2MetaAll :: Syntax 1055syntaxForm2MetaAll = 1056 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1057 guardNamespaceMeta str1 1058 guardMetaAll str2 1059 return (TargetAllPackages Nothing) 1060 where 1061 render (TargetAllPackages Nothing) = 1062 [TargetStringFileStatus2 "" noFileStatus "all"] 1063 render _ = [] 1064 1065-- | Syntax: all : filer 1066-- 1067-- > cabal build all:tests 1068-- 1069syntaxForm2AllFilter :: Syntax 1070syntaxForm2AllFilter = 1071 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1072 guardMetaAll str1 1073 kfilter <- matchComponentKindFilter str2 1074 return (TargetAllPackages (Just kfilter)) 1075 where 1076 render (TargetAllPackages (Just kfilter)) = 1077 [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)] 1078 render _ = [] 1079 1080-- | Syntax: package : filer 1081-- 1082-- > cabal build foo:tests 1083-- 1084syntaxForm2PackageFilter :: [KnownPackage] -> Syntax 1085syntaxForm2PackageFilter ps = 1086 syntaxForm2 render $ \str1 fstatus1 str2 -> do 1087 guardPackage str1 fstatus1 1088 p <- matchPackage ps str1 fstatus1 1089 kfilter <- matchComponentKindFilter str2 1090 case p of 1091 KnownPackage{pinfoId} -> 1092 return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) 1093 KnownPackageName pn -> 1094 return (TargetPackageNamed pn (Just kfilter)) 1095 where 1096 render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = 1097 [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)] 1098 render (TargetPackageNamed pn (Just kfilter)) = 1099 [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)] 1100 render _ = [] 1101 1102-- | Syntax: pkg : package name 1103-- 1104-- > cabal build pkg:foo 1105-- 1106syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax 1107syntaxForm2NamespacePackage pinfo = 1108 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1109 guardNamespacePackage str1 1110 guardPackageName str2 1111 p <- matchPackage pinfo str2 noFileStatus 1112 case p of 1113 KnownPackage{pinfoId} -> 1114 return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) 1115 KnownPackageName pn -> 1116 return (TargetPackageNamed pn Nothing) 1117 where 1118 render (TargetPackage TargetExplicitNamed [p] Nothing) = 1119 [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)] 1120 render (TargetPackageNamed pn Nothing) = 1121 [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)] 1122 render _ = [] 1123 1124-- | Syntax: package : component 1125-- 1126-- > cabal build foo:foo 1127-- > cabal build ./foo:foo 1128-- > cabal build ./foo.cabal:foo 1129-- 1130syntaxForm2PackageComponent :: [KnownPackage] -> Syntax 1131syntaxForm2PackageComponent ps = 1132 syntaxForm2 render $ \str1 fstatus1 str2 -> do 1133 guardPackage str1 fstatus1 1134 guardComponentName str2 1135 p <- matchPackage ps str1 fstatus1 1136 case p of 1137 KnownPackage{pinfoId, pinfoComponents} -> 1138 orNoThingIn "package" (display (packageName pinfoId)) $ do 1139 c <- matchComponentName pinfoComponents str2 1140 return (TargetComponent pinfoId (cinfoName c) WholeComponent) 1141 --TODO: the error here ought to say there's no component by that name in 1142 -- this package, and name the package 1143 KnownPackageName pn -> 1144 let cn = mkUnqualComponentName str2 in 1145 return (TargetComponentUnknown pn (Left cn) WholeComponent) 1146 where 1147 render (TargetComponent p c WholeComponent) = 1148 [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)] 1149 render (TargetComponentUnknown pn (Left cn) WholeComponent) = 1150 [TargetStringFileStatus2 (dispPN pn) noFileStatus (display cn)] 1151 render _ = [] 1152 1153-- | Syntax: namespace : component 1154-- 1155-- > cabal build lib:foo exe:foo 1156-- 1157syntaxForm2KindComponent :: [KnownComponent] -> Syntax 1158syntaxForm2KindComponent cs = 1159 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1160 ckind <- matchComponentKind str1 1161 guardComponentName str2 1162 c <- matchComponentKindAndName cs ckind str2 1163 return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent) 1164 where 1165 render (TargetComponent p c WholeComponent) = 1166 [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)] 1167 render _ = [] 1168 1169-- | Syntax: package : module 1170-- 1171-- > cabal build foo:Data.Foo 1172-- > cabal build ./foo:Data.Foo 1173-- > cabal build ./foo.cabal:Data.Foo 1174-- 1175syntaxForm2PackageModule :: [KnownPackage] -> Syntax 1176syntaxForm2PackageModule ps = 1177 syntaxForm2 render $ \str1 fstatus1 str2 -> do 1178 guardPackage str1 fstatus1 1179 guardModuleName str2 1180 p <- matchPackage ps str1 fstatus1 1181 case p of 1182 KnownPackage{pinfoId, pinfoComponents} -> 1183 orNoThingIn "package" (display (packageName pinfoId)) $ do 1184 let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ] 1185 (m,c) <- matchModuleNameAnd ms str2 1186 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) 1187 KnownPackageName pn -> do 1188 m <- matchModuleNameUnknown str2 1189 -- We assume the primary library component of the package: 1190 return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m)) 1191 where 1192 render (TargetComponent p _c (ModuleTarget m)) = 1193 [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)] 1194 render _ = [] 1195 1196-- | Syntax: component : module 1197-- 1198-- > cabal build foo:Data.Foo 1199-- 1200syntaxForm2ComponentModule :: [KnownComponent] -> Syntax 1201syntaxForm2ComponentModule cs = 1202 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1203 guardComponentName str1 1204 guardModuleName str2 1205 c <- matchComponentName cs str1 1206 orNoThingIn "component" (cinfoStrName c) $ do 1207 let ms = cinfoModules c 1208 m <- matchModuleName ms str2 1209 return (TargetComponent (cinfoPackageId c) (cinfoName c) 1210 (ModuleTarget m)) 1211 where 1212 render (TargetComponent p c (ModuleTarget m)) = 1213 [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)] 1214 render _ = [] 1215 1216-- | Syntax: package : filename 1217-- 1218-- > cabal build foo:Data/Foo.hs 1219-- > cabal build ./foo:Data/Foo.hs 1220-- > cabal build ./foo.cabal:Data/Foo.hs 1221-- 1222syntaxForm2PackageFile :: [KnownPackage] -> Syntax 1223syntaxForm2PackageFile ps = 1224 syntaxForm2 render $ \str1 fstatus1 str2 -> do 1225 guardPackage str1 fstatus1 1226 p <- matchPackage ps str1 fstatus1 1227 case p of 1228 KnownPackage{pinfoId, pinfoComponents} -> 1229 orNoThingIn "package" (display (packageName pinfoId)) $ do 1230 (filepath, c) <- matchComponentFile pinfoComponents str2 1231 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) 1232 KnownPackageName pn -> 1233 let filepath = str2 in 1234 -- We assume the primary library component of the package: 1235 return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath)) 1236 where 1237 render (TargetComponent p _c (FileTarget f)) = 1238 [TargetStringFileStatus2 (dispP p) noFileStatus f] 1239 render _ = [] 1240 1241-- | Syntax: component : filename 1242-- 1243-- > cabal build foo:Data/Foo.hs 1244-- 1245syntaxForm2ComponentFile :: [KnownComponent] -> Syntax 1246syntaxForm2ComponentFile cs = 1247 syntaxForm2 render $ \str1 _fstatus1 str2 -> do 1248 guardComponentName str1 1249 c <- matchComponentName cs str1 1250 orNoThingIn "component" (cinfoStrName c) $ do 1251 (filepath, _) <- matchComponentFile [c] str2 1252 return (TargetComponent (cinfoPackageId c) (cinfoName c) 1253 (FileTarget filepath)) 1254 where 1255 render (TargetComponent p c (FileTarget f)) = 1256 [TargetStringFileStatus2 (dispC p c) noFileStatus f] 1257 render _ = [] 1258 1259--- 1260 1261-- | Syntax: :all : filter 1262-- 1263-- > cabal build :all:tests 1264-- 1265syntaxForm3MetaAllFilter :: Syntax 1266syntaxForm3MetaAllFilter = 1267 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1268 guardNamespaceMeta str1 1269 guardMetaAll str2 1270 kfilter <- matchComponentKindFilter str3 1271 return (TargetAllPackages (Just kfilter)) 1272 where 1273 render (TargetAllPackages (Just kfilter)) = 1274 [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)] 1275 render _ = [] 1276 1277syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax 1278syntaxForm3MetaCwdFilter ps = 1279 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1280 guardNamespaceMeta str1 1281 guardNamespaceCwd str2 1282 kfilter <- matchComponentKindFilter str3 1283 return (TargetPackage TargetImplicitCwd pids (Just kfilter)) 1284 where 1285 pids = [ pinfoId | KnownPackage{pinfoId} <- ps ] 1286 render (TargetPackage TargetImplicitCwd _ (Just kfilter)) = 1287 [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)] 1288 render _ = [] 1289 1290-- | Syntax: :pkg : package name 1291-- 1292-- > cabal build :pkg:foo 1293-- 1294syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax 1295syntaxForm3MetaNamespacePackage pinfo = 1296 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1297 guardNamespaceMeta str1 1298 guardNamespacePackage str2 1299 guardPackageName str3 1300 p <- matchPackage pinfo str3 noFileStatus 1301 case p of 1302 KnownPackage{pinfoId} -> 1303 return (TargetPackage TargetExplicitNamed [pinfoId] Nothing) 1304 KnownPackageName pn -> 1305 return (TargetPackageNamed pn Nothing) 1306 where 1307 render (TargetPackage TargetExplicitNamed [p] Nothing) = 1308 [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)] 1309 render (TargetPackageNamed pn Nothing) = 1310 [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)] 1311 render _ = [] 1312 1313-- | Syntax: package : namespace : component 1314-- 1315-- > cabal build foo:lib:foo 1316-- > cabal build foo/:lib:foo 1317-- > cabal build foo.cabal:lib:foo 1318-- 1319syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax 1320syntaxForm3PackageKindComponent ps = 1321 syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do 1322 guardPackage str1 fstatus1 1323 ckind <- matchComponentKind str2 1324 guardComponentName str3 1325 p <- matchPackage ps str1 fstatus1 1326 case p of 1327 KnownPackage{pinfoId, pinfoComponents} -> 1328 orNoThingIn "package" (display (packageName pinfoId)) $ do 1329 c <- matchComponentKindAndName pinfoComponents ckind str3 1330 return (TargetComponent pinfoId (cinfoName c) WholeComponent) 1331 KnownPackageName pn -> 1332 let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in 1333 return (TargetComponentUnknown pn (Right cn) WholeComponent) 1334 where 1335 render (TargetComponent p c WholeComponent) = 1336 [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)] 1337 render (TargetComponentUnknown pn (Right c) WholeComponent) = 1338 [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)] 1339 render _ = [] 1340 1341-- | Syntax: package : component : module 1342-- 1343-- > cabal build foo:foo:Data.Foo 1344-- > cabal build foo/:foo:Data.Foo 1345-- > cabal build foo.cabal:foo:Data.Foo 1346-- 1347syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax 1348syntaxForm3PackageComponentModule ps = 1349 syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do 1350 guardPackage str1 fstatus1 1351 guardComponentName str2 1352 guardModuleName str3 1353 p <- matchPackage ps str1 fstatus1 1354 case p of 1355 KnownPackage{pinfoId, pinfoComponents} -> 1356 orNoThingIn "package" (display (packageName pinfoId)) $ do 1357 c <- matchComponentName pinfoComponents str2 1358 orNoThingIn "component" (cinfoStrName c) $ do 1359 let ms = cinfoModules c 1360 m <- matchModuleName ms str3 1361 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) 1362 KnownPackageName pn -> do 1363 let cn = mkUnqualComponentName str2 1364 m <- matchModuleNameUnknown str3 1365 return (TargetComponentUnknown pn (Left cn) (ModuleTarget m)) 1366 where 1367 render (TargetComponent p c (ModuleTarget m)) = 1368 [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)] 1369 render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) = 1370 [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)] 1371 render _ = [] 1372 1373-- | Syntax: namespace : component : module 1374-- 1375-- > cabal build lib:foo:Data.Foo 1376-- 1377syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax 1378syntaxForm3KindComponentModule cs = 1379 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1380 ckind <- matchComponentKind str1 1381 guardComponentName str2 1382 guardModuleName str3 1383 c <- matchComponentKindAndName cs ckind str2 1384 orNoThingIn "component" (cinfoStrName c) $ do 1385 let ms = cinfoModules c 1386 m <- matchModuleName ms str3 1387 return (TargetComponent (cinfoPackageId c) (cinfoName c) 1388 (ModuleTarget m)) 1389 where 1390 render (TargetComponent p c (ModuleTarget m)) = 1391 [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)] 1392 render _ = [] 1393 1394-- | Syntax: package : component : filename 1395-- 1396-- > cabal build foo:foo:Data/Foo.hs 1397-- > cabal build foo/:foo:Data/Foo.hs 1398-- > cabal build foo.cabal:foo:Data/Foo.hs 1399-- 1400syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax 1401syntaxForm3PackageComponentFile ps = 1402 syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do 1403 guardPackage str1 fstatus1 1404 guardComponentName str2 1405 p <- matchPackage ps str1 fstatus1 1406 case p of 1407 KnownPackage{pinfoId, pinfoComponents} -> 1408 orNoThingIn "package" (display (packageName pinfoId)) $ do 1409 c <- matchComponentName pinfoComponents str2 1410 orNoThingIn "component" (cinfoStrName c) $ do 1411 (filepath, _) <- matchComponentFile [c] str3 1412 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) 1413 KnownPackageName pn -> 1414 let cn = mkUnqualComponentName str2 1415 filepath = str3 in 1416 return (TargetComponentUnknown pn (Left cn) (FileTarget filepath)) 1417 where 1418 render (TargetComponent p c (FileTarget f)) = 1419 [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f] 1420 render (TargetComponentUnknown pn (Left c) (FileTarget f)) = 1421 [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f] 1422 render _ = [] 1423 1424-- | Syntax: namespace : component : filename 1425-- 1426-- > cabal build lib:foo:Data/Foo.hs 1427-- 1428syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax 1429syntaxForm3KindComponentFile cs = 1430 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1431 ckind <- matchComponentKind str1 1432 guardComponentName str2 1433 c <- matchComponentKindAndName cs ckind str2 1434 orNoThingIn "component" (cinfoStrName c) $ do 1435 (filepath, _) <- matchComponentFile [c] str3 1436 return (TargetComponent (cinfoPackageId c) (cinfoName c) 1437 (FileTarget filepath)) 1438 where 1439 render (TargetComponent p c (FileTarget f)) = 1440 [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f] 1441 render _ = [] 1442 1443syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax 1444syntaxForm3NamespacePackageFilter ps = 1445 syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do 1446 guardNamespacePackage str1 1447 guardPackageName str2 1448 p <- matchPackage ps str2 noFileStatus 1449 kfilter <- matchComponentKindFilter str3 1450 case p of 1451 KnownPackage{pinfoId} -> 1452 return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) 1453 KnownPackageName pn -> 1454 return (TargetPackageNamed pn (Just kfilter)) 1455 where 1456 render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = 1457 [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)] 1458 render (TargetPackageNamed pn (Just kfilter)) = 1459 [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)] 1460 render _ = [] 1461 1462-- 1463 1464syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax 1465syntaxForm4MetaNamespacePackageFilter ps = 1466 syntaxForm4 render $ \str1 str2 str3 str4 -> do 1467 guardNamespaceMeta str1 1468 guardNamespacePackage str2 1469 guardPackageName str3 1470 p <- matchPackage ps str3 noFileStatus 1471 kfilter <- matchComponentKindFilter str4 1472 case p of 1473 KnownPackage{pinfoId} -> 1474 return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter)) 1475 KnownPackageName pn -> 1476 return (TargetPackageNamed pn (Just kfilter)) 1477 where 1478 render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) = 1479 [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)] 1480 render (TargetPackageNamed pn (Just kfilter)) = 1481 [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)] 1482 render _ = [] 1483 1484-- | Syntax: :pkg : package : namespace : component 1485-- 1486-- > cabal build :pkg:foo:lib:foo 1487-- 1488syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax 1489syntaxForm5MetaNamespacePackageKindComponent ps = 1490 syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do 1491 guardNamespaceMeta str1 1492 guardNamespacePackage str2 1493 guardPackageName str3 1494 ckind <- matchComponentKind str4 1495 guardComponentName str5 1496 p <- matchPackage ps str3 noFileStatus 1497 case p of 1498 KnownPackage{pinfoId, pinfoComponents} -> 1499 orNoThingIn "package" (display (packageName pinfoId)) $ do 1500 c <- matchComponentKindAndName pinfoComponents ckind str5 1501 return (TargetComponent pinfoId (cinfoName c) WholeComponent) 1502 KnownPackageName pn -> 1503 let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in 1504 return (TargetComponentUnknown pn (Right cn) WholeComponent) 1505 where 1506 render (TargetComponent p c WholeComponent) = 1507 [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)] 1508 render (TargetComponentUnknown pn (Right c) WholeComponent) = 1509 [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)] 1510 render _ = [] 1511 1512-- | Syntax: :pkg : package : namespace : component : module : module 1513-- 1514-- > cabal build :pkg:foo:lib:foo:module:Data.Foo 1515-- 1516syntaxForm7MetaNamespacePackageKindComponentNamespaceModule 1517 :: [KnownPackage] -> Syntax 1518syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps = 1519 syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do 1520 guardNamespaceMeta str1 1521 guardNamespacePackage str2 1522 guardPackageName str3 1523 ckind <- matchComponentKind str4 1524 guardComponentName str5 1525 guardNamespaceModule str6 1526 p <- matchPackage ps str3 noFileStatus 1527 case p of 1528 KnownPackage{pinfoId, pinfoComponents} -> 1529 orNoThingIn "package" (display (packageName pinfoId)) $ do 1530 c <- matchComponentKindAndName pinfoComponents ckind str5 1531 orNoThingIn "component" (cinfoStrName c) $ do 1532 let ms = cinfoModules c 1533 m <- matchModuleName ms str7 1534 return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m)) 1535 KnownPackageName pn -> do 1536 let cn = mkComponentName pn ckind (mkUnqualComponentName str2) 1537 m <- matchModuleNameUnknown str7 1538 return (TargetComponentUnknown pn (Right cn) (ModuleTarget m)) 1539 where 1540 render (TargetComponent p c (ModuleTarget m)) = 1541 [TargetStringFileStatus7 "" "pkg" (dispP p) 1542 (dispCK c) (dispC p c) 1543 "module" (dispM m)] 1544 render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) = 1545 [TargetStringFileStatus7 "" "pkg" (dispPN pn) 1546 (dispCK c) (dispC' pn c) 1547 "module" (dispM m)] 1548 render _ = [] 1549 1550-- | Syntax: :pkg : package : namespace : component : file : filename 1551-- 1552-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs 1553-- 1554syntaxForm7MetaNamespacePackageKindComponentNamespaceFile 1555 :: [KnownPackage] -> Syntax 1556syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps = 1557 syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do 1558 guardNamespaceMeta str1 1559 guardNamespacePackage str2 1560 guardPackageName str3 1561 ckind <- matchComponentKind str4 1562 guardComponentName str5 1563 guardNamespaceFile str6 1564 p <- matchPackage ps str3 noFileStatus 1565 case p of 1566 KnownPackage{pinfoId, pinfoComponents} -> 1567 orNoThingIn "package" (display (packageName pinfoId)) $ do 1568 c <- matchComponentKindAndName pinfoComponents ckind str5 1569 orNoThingIn "component" (cinfoStrName c) $ do 1570 (filepath,_) <- matchComponentFile [c] str7 1571 return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath)) 1572 KnownPackageName pn -> 1573 let cn = mkComponentName pn ckind (mkUnqualComponentName str5) 1574 filepath = str7 in 1575 return (TargetComponentUnknown pn (Right cn) (FileTarget filepath)) 1576 where 1577 render (TargetComponent p c (FileTarget f)) = 1578 [TargetStringFileStatus7 "" "pkg" (dispP p) 1579 (dispCK c) (dispC p c) 1580 "file" f] 1581 render (TargetComponentUnknown pn (Right c) (FileTarget f)) = 1582 [TargetStringFileStatus7 "" "pkg" (dispPN pn) 1583 (dispCK c) (dispC' pn c) 1584 "file" f] 1585 render _ = [] 1586 1587 1588--------------------------------------- 1589-- Syntax utils 1590-- 1591 1592type Match1 = String -> FileStatus -> Match TargetSelector 1593type Match2 = String -> FileStatus -> String 1594 -> Match TargetSelector 1595type Match3 = String -> FileStatus -> String -> String 1596 -> Match TargetSelector 1597type Match4 = String -> String -> String -> String 1598 -> Match TargetSelector 1599type Match5 = String -> String -> String -> String -> String 1600 -> Match TargetSelector 1601type Match7 = String -> String -> String -> String -> String -> String -> String 1602 -> Match TargetSelector 1603 1604syntaxForm1 :: Renderer -> Match1 -> Syntax 1605syntaxForm2 :: Renderer -> Match2 -> Syntax 1606syntaxForm3 :: Renderer -> Match3 -> Syntax 1607syntaxForm4 :: Renderer -> Match4 -> Syntax 1608syntaxForm5 :: Renderer -> Match5 -> Syntax 1609syntaxForm7 :: Renderer -> Match7 -> Syntax 1610 1611syntaxForm1 render f = 1612 Syntax QL1 match render 1613 where 1614 match = \(TargetStringFileStatus1 str1 fstatus1) -> 1615 f str1 fstatus1 1616 1617syntaxForm2 render f = 1618 Syntax QL2 match render 1619 where 1620 match = \(TargetStringFileStatus2 str1 fstatus1 str2) -> 1621 f str1 fstatus1 str2 1622 1623syntaxForm3 render f = 1624 Syntax QL3 match render 1625 where 1626 match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) -> 1627 f str1 fstatus1 str2 str3 1628 1629syntaxForm4 render f = 1630 Syntax QLFull match render 1631 where 1632 match (TargetStringFileStatus4 str1 str2 str3 str4) 1633 = f str1 str2 str3 str4 1634 match _ = mzero 1635 1636syntaxForm5 render f = 1637 Syntax QLFull match render 1638 where 1639 match (TargetStringFileStatus5 str1 str2 str3 str4 str5) 1640 = f str1 str2 str3 str4 str5 1641 match _ = mzero 1642 1643syntaxForm7 render f = 1644 Syntax QLFull match render 1645 where 1646 match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) 1647 = f str1 str2 str3 str4 str5 str6 str7 1648 match _ = mzero 1649 1650dispP :: Package p => p -> String 1651dispP = display . packageName 1652 1653dispPN :: PackageName -> String 1654dispPN = display 1655 1656dispC :: PackageId -> ComponentName -> String 1657dispC = componentStringName . packageName 1658 1659dispC' :: PackageName -> ComponentName -> String 1660dispC' = componentStringName 1661 1662dispCN :: UnqualComponentName -> String 1663dispCN = display 1664 1665dispK :: ComponentKind -> String 1666dispK = showComponentKindShort 1667 1668dispCK :: ComponentName -> String 1669dispCK = dispK . componentKind 1670 1671dispF :: ComponentKind -> String 1672dispF = showComponentKindFilterShort 1673 1674dispM :: ModuleName -> String 1675dispM = display 1676 1677 1678------------------------------- 1679-- Package and component info 1680-- 1681 1682data KnownTargets = KnownTargets { 1683 knownPackagesAll :: [KnownPackage], 1684 knownPackagesPrimary :: [KnownPackage], 1685 knownPackagesOther :: [KnownPackage], 1686 knownComponentsAll :: [KnownComponent], 1687 knownComponentsPrimary :: [KnownComponent], 1688 knownComponentsOther :: [KnownComponent] 1689 } 1690 deriving Show 1691 1692data KnownPackage = 1693 KnownPackage { 1694 pinfoId :: PackageId, 1695 pinfoDirectory :: Maybe (FilePath, FilePath), 1696 pinfoPackageFile :: Maybe (FilePath, FilePath), 1697 pinfoComponents :: [KnownComponent] 1698 } 1699 | KnownPackageName { 1700 pinfoName :: PackageName 1701 } 1702 deriving Show 1703 1704data KnownComponent = KnownComponent { 1705 cinfoName :: ComponentName, 1706 cinfoStrName :: ComponentStringName, 1707 cinfoPackageId :: PackageId, 1708 cinfoSrcDirs :: [FilePath], 1709 cinfoModules :: [ModuleName], 1710 cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) 1711 cinfoCFiles :: [FilePath], 1712 cinfoJsFiles :: [FilePath] 1713 } 1714 deriving Show 1715 1716type ComponentStringName = String 1717 1718knownPackageName :: KnownPackage -> PackageName 1719knownPackageName KnownPackage{pinfoId} = packageName pinfoId 1720knownPackageName KnownPackageName{pinfoName} = pinfoName 1721 1722emptyKnownTargets :: KnownTargets 1723emptyKnownTargets = KnownTargets [] [] [] [] [] [] 1724 1725getKnownTargets :: (Applicative m, Monad m) 1726 => DirActions m 1727 -> [PackageSpecifier (SourcePackage (PackageLocation a))] 1728 -> m KnownTargets 1729getKnownTargets dirActions@DirActions{..} pkgs = do 1730 pinfo <- mapM (collectKnownPackageInfo dirActions) pkgs 1731 cwd <- getCurrentDirectory 1732 let (ppinfo, opinfo) = selectPrimaryPackage cwd pinfo 1733 return KnownTargets { 1734 knownPackagesAll = pinfo, 1735 knownPackagesPrimary = ppinfo, 1736 knownPackagesOther = opinfo, 1737 knownComponentsAll = allComponentsIn pinfo, 1738 knownComponentsPrimary = allComponentsIn ppinfo, 1739 knownComponentsOther = allComponentsIn opinfo 1740 } 1741 where 1742 selectPrimaryPackage :: FilePath 1743 -> [KnownPackage] 1744 -> ([KnownPackage], [KnownPackage]) 1745 selectPrimaryPackage cwd = partition isPkgDirCwd 1746 where 1747 isPkgDirCwd KnownPackage { pinfoDirectory = Just (dir,_) } 1748 | dir == cwd = True 1749 isPkgDirCwd _ = False 1750 allComponentsIn ps = 1751 [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ] 1752 1753 1754collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m 1755 -> PackageSpecifier (SourcePackage (PackageLocation a)) 1756 -> m KnownPackage 1757collectKnownPackageInfo _ (NamedPackage pkgname _props) = 1758 return (KnownPackageName pkgname) 1759collectKnownPackageInfo dirActions@DirActions{..} 1760 (SpecificSourcePackage SourcePackage { 1761 packageDescription = pkg, 1762 packageSource = loc 1763 }) = do 1764 (pkgdir, pkgfile) <- 1765 case loc of 1766 --TODO: local tarballs, remote tarballs etc 1767 LocalUnpackedPackage dir -> do 1768 dirabs <- canonicalizePath dir 1769 dirrel <- makeRelativeToCwd dirActions dirabs 1770 --TODO: ought to get this earlier in project reading 1771 let fileabs = dirabs </> display (packageName pkg) <.> "cabal" 1772 filerel = dirrel </> display (packageName pkg) <.> "cabal" 1773 exists <- doesFileExist fileabs 1774 return ( Just (dirabs, dirrel) 1775 , if exists then Just (fileabs, filerel) else Nothing 1776 ) 1777 _ -> return (Nothing, Nothing) 1778 let pinfo = 1779 KnownPackage { 1780 pinfoId = packageId pkg, 1781 pinfoDirectory = pkgdir, 1782 pinfoPackageFile = pkgfile, 1783 pinfoComponents = collectKnownComponentInfo 1784 (flattenPackageDescription pkg) 1785 } 1786 return pinfo 1787 1788 1789collectKnownComponentInfo :: PackageDescription -> [KnownComponent] 1790collectKnownComponentInfo pkg = 1791 [ KnownComponent { 1792 cinfoName = componentName c, 1793 cinfoStrName = componentStringName (packageName pkg) (componentName c), 1794 cinfoPackageId = packageId pkg, 1795 cinfoSrcDirs = ordNub (hsSourceDirs bi), 1796 cinfoModules = ordNub (componentModules c), 1797 cinfoHsFiles = ordNub (componentHsFiles c), 1798 cinfoCFiles = ordNub (cSources bi), 1799 cinfoJsFiles = ordNub (jsSources bi) 1800 } 1801 | c <- pkgComponents pkg 1802 , let bi = componentBuildInfo c ] 1803 1804 1805componentStringName :: PackageName -> ComponentName -> ComponentStringName 1806componentStringName pkgname (CLibName LMainLibName) = display pkgname 1807componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name 1808componentStringName _ (CFLibName name) = unUnqualComponentName name 1809componentStringName _ (CExeName name) = unUnqualComponentName name 1810componentStringName _ (CTestName name) = unUnqualComponentName name 1811componentStringName _ (CBenchName name) = unUnqualComponentName name 1812 1813componentModules :: Component -> [ModuleName] 1814-- I think it's unlikely users will ask to build a requirement 1815-- which is not mentioned locally. 1816componentModules (CLib lib) = explicitLibModules lib 1817componentModules (CFLib flib) = foreignLibModules flib 1818componentModules (CExe exe) = exeModules exe 1819componentModules (CTest test) = testModules test 1820componentModules (CBench bench) = benchmarkModules bench 1821 1822componentHsFiles :: Component -> [FilePath] 1823componentHsFiles (CExe exe) = [modulePath exe] 1824componentHsFiles (CTest TestSuite { 1825 testInterface = TestSuiteExeV10 _ mainfile 1826 }) = [mainfile] 1827componentHsFiles (CBench Benchmark { 1828 benchmarkInterface = BenchmarkExeV10 _ mainfile 1829 }) = [mainfile] 1830componentHsFiles _ = [] 1831 1832 1833------------------------------ 1834-- Matching meta targets 1835-- 1836 1837guardNamespaceMeta :: String -> Match () 1838guardNamespaceMeta = guardToken [""] "meta namespace" 1839 1840guardMetaAll :: String -> Match () 1841guardMetaAll = guardToken ["all"] "meta-target 'all'" 1842 1843guardNamespacePackage :: String -> Match () 1844guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace" 1845 1846guardNamespaceCwd :: String -> Match () 1847guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace" 1848 1849guardNamespaceModule :: String -> Match () 1850guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace" 1851 1852guardNamespaceFile :: String -> Match () 1853guardNamespaceFile = guardToken ["file"] "'file' namespace" 1854 1855guardToken :: [String] -> String -> String -> Match () 1856guardToken tokens msg s 1857 | caseFold s `elem` tokens = increaseConfidence 1858 | otherwise = matchErrorExpected msg s 1859 1860 1861------------------------------ 1862-- Matching component kinds 1863-- 1864 1865componentKind :: ComponentName -> ComponentKind 1866componentKind (CLibName _) = LibKind 1867componentKind (CFLibName _) = FLibKind 1868componentKind (CExeName _) = ExeKind 1869componentKind (CTestName _) = TestKind 1870componentKind (CBenchName _) = BenchKind 1871 1872cinfoKind :: KnownComponent -> ComponentKind 1873cinfoKind = componentKind . cinfoName 1874 1875matchComponentKind :: String -> Match ComponentKind 1876matchComponentKind s 1877 | s' `elem` liblabels = increaseConfidence >> return LibKind 1878 | s' `elem` fliblabels = increaseConfidence >> return FLibKind 1879 | s' `elem` exelabels = increaseConfidence >> return ExeKind 1880 | s' `elem` testlabels = increaseConfidence >> return TestKind 1881 | s' `elem` benchlabels = increaseConfidence >> return BenchKind 1882 | otherwise = matchErrorExpected "component kind" s 1883 where 1884 s' = caseFold s 1885 liblabels = ["lib", "library"] 1886 fliblabels = ["flib", "foreign-library"] 1887 exelabels = ["exe", "executable"] 1888 testlabels = ["tst", "test", "test-suite"] 1889 benchlabels = ["bench", "benchmark"] 1890 1891matchComponentKindFilter :: String -> Match ComponentKind 1892matchComponentKindFilter s 1893 | s' `elem` liblabels = increaseConfidence >> return LibKind 1894 | s' `elem` fliblabels = increaseConfidence >> return FLibKind 1895 | s' `elem` exelabels = increaseConfidence >> return ExeKind 1896 | s' `elem` testlabels = increaseConfidence >> return TestKind 1897 | s' `elem` benchlabels = increaseConfidence >> return BenchKind 1898 | otherwise = matchErrorExpected "component kind filter" s 1899 where 1900 s' = caseFold s 1901 liblabels = ["libs", "libraries"] 1902 fliblabels = ["flibs", "foreign-libraries"] 1903 exelabels = ["exes", "executables"] 1904 testlabels = ["tests", "test-suites"] 1905 benchlabels = ["benches", "benchmarks"] 1906 1907showComponentKind :: ComponentKind -> String 1908showComponentKind LibKind = "library" 1909showComponentKind FLibKind = "foreign library" 1910showComponentKind ExeKind = "executable" 1911showComponentKind TestKind = "test-suite" 1912showComponentKind BenchKind = "benchmark" 1913 1914showComponentKindShort :: ComponentKind -> String 1915showComponentKindShort LibKind = "lib" 1916showComponentKindShort FLibKind = "flib" 1917showComponentKindShort ExeKind = "exe" 1918showComponentKindShort TestKind = "test" 1919showComponentKindShort BenchKind = "bench" 1920 1921showComponentKindFilterShort :: ComponentKind -> String 1922showComponentKindFilterShort LibKind = "libs" 1923showComponentKindFilterShort FLibKind = "flibs" 1924showComponentKindFilterShort ExeKind = "exes" 1925showComponentKindFilterShort TestKind = "tests" 1926showComponentKindFilterShort BenchKind = "benchmarks" 1927 1928 1929------------------------------ 1930-- Matching package targets 1931-- 1932 1933guardPackage :: String -> FileStatus -> Match () 1934guardPackage str fstatus = 1935 guardPackageName str 1936 <|> guardPackageDir str fstatus 1937 <|> guardPackageFile str fstatus 1938 1939 1940guardPackageName :: String -> Match () 1941guardPackageName s 1942 | validPackageName s = increaseConfidence 1943 | otherwise = matchErrorExpected "package name" s 1944 1945validPackageName :: String -> Bool 1946validPackageName s = 1947 all validPackageNameChar s 1948 && not (null s) 1949 where 1950 validPackageNameChar c = isAlphaNum c || c == '-' 1951 1952 1953guardPackageDir :: String -> FileStatus -> Match () 1954guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence 1955guardPackageDir str _ = matchErrorExpected "package directory" str 1956 1957 1958guardPackageFile :: String -> FileStatus -> Match () 1959guardPackageFile _ (FileStatusExistsFile file) 1960 | takeExtension file == ".cabal" 1961 = increaseConfidence 1962guardPackageFile str _ = matchErrorExpected "package .cabal file" str 1963 1964 1965matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage 1966matchPackage pinfo = \str fstatus -> 1967 orNoThingIn "project" "" $ 1968 matchPackageName pinfo str 1969 <//> (matchPackageNameUnknown str 1970 <|> matchPackageDir pinfo str fstatus 1971 <|> matchPackageFile pinfo str fstatus) 1972 1973 1974matchPackageName :: [KnownPackage] -> String -> Match KnownPackage 1975matchPackageName ps = \str -> do 1976 guard (validPackageName str) 1977 orNoSuchThing "package" str 1978 (map (display . knownPackageName) ps) $ 1979 increaseConfidenceFor $ 1980 matchInexactly caseFold (display . knownPackageName) ps str 1981 1982 1983matchPackageNameUnknown :: String -> Match KnownPackage 1984matchPackageNameUnknown str = do 1985 pn <- matchParse str 1986 unknownMatch (KnownPackageName pn) 1987 1988 1989matchPackageDir :: [KnownPackage] 1990 -> String -> FileStatus -> Match KnownPackage 1991matchPackageDir ps = \str fstatus -> 1992 case fstatus of 1993 FileStatusExistsDir canondir -> 1994 orNoSuchThing "package directory" str (map (snd . fst) dirs) $ 1995 increaseConfidenceFor $ 1996 fmap snd $ matchExactly (fst . fst) dirs canondir 1997 _ -> mzero 1998 where 1999 dirs = [ ((dabs,drel),p) 2000 | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ] 2001 2002 2003matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage 2004matchPackageFile ps = \str fstatus -> do 2005 case fstatus of 2006 FileStatusExistsFile canonfile -> 2007 orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ 2008 increaseConfidenceFor $ 2009 fmap snd $ matchExactly (fst . fst) files canonfile 2010 _ -> mzero 2011 where 2012 files = [ ((fabs,frel),p) 2013 | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ] 2014 2015--TODO: test outcome when dir exists but doesn't match any known one 2016 2017--TODO: perhaps need another distinction, vs no such thing, point is the 2018-- thing is not known, within the project, but could be outside project 2019 2020 2021------------------------------ 2022-- Matching component targets 2023-- 2024 2025 2026guardComponentName :: String -> Match () 2027guardComponentName s 2028 | all validComponentChar s 2029 && not (null s) = increaseConfidence 2030 | otherwise = matchErrorExpected "component name" s 2031 where 2032 validComponentChar c = isAlphaNum c || c == '.' 2033 || c == '_' || c == '-' || c == '\'' 2034 2035 2036matchComponentName :: [KnownComponent] -> String -> Match KnownComponent 2037matchComponentName cs str = 2038 orNoSuchThing "component" str (map cinfoStrName cs) 2039 $ increaseConfidenceFor 2040 $ matchInexactly caseFold cinfoStrName cs str 2041 2042 2043matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String 2044 -> Match KnownComponent 2045matchComponentKindAndName cs ckind str = 2046 orNoSuchThing (showComponentKind ckind ++ " component") str 2047 (map render cs) 2048 $ increaseConfidenceFor 2049 $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) 2050 (\c -> (cinfoKind c, cinfoStrName c)) 2051 cs 2052 (ckind, str) 2053 where 2054 render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c 2055 2056 2057------------------------------ 2058-- Matching module targets 2059-- 2060 2061guardModuleName :: String -> Match () 2062guardModuleName s = 2063 case simpleParse s :: Maybe ModuleName of 2064 Just _ -> increaseConfidence 2065 _ | all validModuleChar s 2066 && not (null s) -> return () 2067 | otherwise -> matchErrorExpected "module name" s 2068 where 2069 validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' 2070 2071 2072matchModuleName :: [ModuleName] -> String -> Match ModuleName 2073matchModuleName ms str = 2074 orNoSuchThing "module" str (map display ms) 2075 $ increaseConfidenceFor 2076 $ matchInexactly caseFold display ms str 2077 2078 2079matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) 2080matchModuleNameAnd ms str = 2081 orNoSuchThing "module" str (map (display . fst) ms) 2082 $ increaseConfidenceFor 2083 $ matchInexactly caseFold (display . fst) ms str 2084 2085 2086matchModuleNameUnknown :: String -> Match ModuleName 2087matchModuleNameUnknown str = 2088 expecting "module" str 2089 $ increaseConfidenceFor 2090 $ matchParse str 2091 2092 2093------------------------------ 2094-- Matching file targets 2095-- 2096 2097matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus 2098 -> Match (FilePath, KnownPackage) 2099matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = 2100 increaseConfidenceFor $ 2101 matchDirectoryPrefix pkgdirs filepath 2102 where 2103 pkgdirs = [ (dir, p) 2104 | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ] 2105matchPackageDirectoryPrefix _ _ = mzero 2106 2107 2108matchComponentFile :: [KnownComponent] -> String 2109 -> Match (FilePath, KnownComponent) 2110matchComponentFile cs str = 2111 orNoSuchThing "file" str [] $ 2112 matchComponentModuleFile cs str 2113 <|> matchComponentOtherFile cs str 2114 2115 2116matchComponentOtherFile :: [KnownComponent] -> String 2117 -> Match (FilePath, KnownComponent) 2118matchComponentOtherFile cs = 2119 matchFile 2120 [ (normalise (srcdir </> file), c) 2121 | c <- cs 2122 , srcdir <- cinfoSrcDirs c 2123 , file <- cinfoHsFiles c 2124 ++ cinfoCFiles c 2125 ++ cinfoJsFiles c 2126 ] 2127 . normalise 2128 2129 2130matchComponentModuleFile :: [KnownComponent] -> String 2131 -> Match (FilePath, KnownComponent) 2132matchComponentModuleFile cs str = do 2133 matchFile 2134 [ (normalise (d </> toFilePath m), c) 2135 | c <- cs 2136 , d <- cinfoSrcDirs c 2137 , m <- cinfoModules c 2138 ] 2139 (dropExtension (normalise str)) 2140 2141-- utils 2142 2143matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) 2144matchFile fs = 2145 increaseConfidenceFor 2146 . matchInexactly caseFold fst fs 2147 2148matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) 2149matchDirectoryPrefix dirs filepath = 2150 tryEach $ 2151 [ (file, x) 2152 | (dir,x) <- dirs 2153 , file <- maybeToList (stripDirectory dir) ] 2154 where 2155 stripDirectory :: FilePath -> Maybe FilePath 2156 stripDirectory dir = 2157 joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit 2158 2159 filepathsplit = splitDirectories filepath 2160 2161 2162------------------------------ 2163-- Matching monad 2164-- 2165 2166-- | A matcher embodies a way to match some input as being some recognised 2167-- value. In particular it deals with multiple and ambiguous matches. 2168-- 2169-- There are various matcher primitives ('matchExactly', 'matchInexactly'), 2170-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we 2171-- can run a matcher against an input using 'findMatch'. 2172-- 2173data Match a = NoMatch !Confidence [MatchError] 2174 | Match !MatchClass !Confidence [a] 2175 deriving Show 2176 2177-- | The kind of match, inexact or exact. We keep track of this so we can 2178-- prefer exact over inexact matches. The 'Ord' here is important: we try 2179-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom. 2180-- 2181data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package 2182 -- name without it being a specific known package 2183 | Inexact -- ^ Matches a known thing inexactly 2184 -- e.g. matches a known package case insensitively 2185 | Exact -- ^ Exactly matches a known thing, 2186 -- e.g. matches a known package case sensitively 2187 deriving (Show, Eq, Ord) 2188 2189type Confidence = Int 2190 2191data MatchError = MatchErrorExpected String String -- thing got 2192 | MatchErrorNoSuch String String [String] -- thing got alts 2193 | MatchErrorIn String String MatchError -- kind thing 2194 deriving (Show, Eq) 2195 2196 2197instance Functor Match where 2198 fmap _ (NoMatch d ms) = NoMatch d ms 2199 fmap f (Match m d xs) = Match m d (fmap f xs) 2200 2201instance Applicative Match where 2202 pure a = Match Exact 0 [a] 2203 (<*>) = ap 2204 2205instance Alternative Match where 2206 empty = NoMatch 0 [] 2207 (<|>) = matchPlus 2208 2209instance Monad Match where 2210 return = pure 2211 NoMatch d ms >>= _ = NoMatch d ms 2212 Match m d xs >>= f = 2213 -- To understand this, it needs to be read in context with the 2214 -- implementation of 'matchPlus' below 2215 case msum (map f xs) of 2216 Match m' d' xs' -> Match (min m m') (d + d') xs' 2217 -- The minimum match class is the one we keep. The match depth is 2218 -- tracked but not used in the Match case. 2219 2220 NoMatch d' ms -> NoMatch (d + d') ms 2221 -- Here is where we transfer the depth we were keeping track of in 2222 -- the Match case over to the NoMatch case where it finally gets used. 2223 2224instance MonadPlus Match where 2225 mzero = empty 2226 mplus = matchPlus 2227 2228(<//>) :: Match a -> Match a -> Match a 2229(<//>) = matchPlusShadowing 2230 2231infixl 3 <//> 2232 2233-- | Combine two matchers. Exact matches are used over inexact matches 2234-- but if we have multiple exact, or inexact then the we collect all the 2235-- ambiguous matches. 2236-- 2237-- This operator is associative, has unit 'mzero' and is also commutative. 2238-- 2239matchPlus :: Match a -> Match a -> Match a 2240matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a 2241matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b 2242matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b) 2243 | d_a > d_b = a -- We only really make use of the depth in the NoMatch case. 2244 | d_a < d_b = b 2245 | otherwise = NoMatch d_a (ms_a ++ ms_b) 2246matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b) 2247 | m_a > m_b = a -- exact over inexact 2248 | m_a < m_b = b -- exact over inexact 2249 | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b) 2250 2251-- | Combine two matchers. This is similar to 'matchPlus' with the 2252-- difference that an exact match from the left matcher shadows any exact 2253-- match on the right. Inexact matches are still collected however. 2254-- 2255-- This operator is associative, has unit 'mzero' and is not commutative. 2256-- 2257matchPlusShadowing :: Match a -> Match a -> Match a 2258matchPlusShadowing a@(Match Exact _ _) _ = a 2259matchPlusShadowing a b = matchPlus a b 2260 2261 2262------------------------------ 2263-- Various match primitives 2264-- 2265 2266matchErrorExpected :: String -> String -> Match a 2267matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] 2268 2269matchErrorNoSuch :: String -> String -> [String] -> Match a 2270matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] 2271 2272expecting :: String -> String -> Match a -> Match a 2273expecting thing got (NoMatch 0 _) = matchErrorExpected thing got 2274expecting _ _ m = m 2275 2276orNoSuchThing :: String -> String -> [String] -> Match a -> Match a 2277orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts 2278orNoSuchThing _ _ _ m = m 2279 2280orNoThingIn :: String -> String -> Match a -> Match a 2281orNoThingIn kind name (NoMatch n ms) = 2282 NoMatch n [ MatchErrorIn kind name m | m <- ms ] 2283orNoThingIn _ _ m = m 2284 2285increaseConfidence :: Match () 2286increaseConfidence = Match Exact 1 [()] 2287 2288increaseConfidenceFor :: Match a -> Match a 2289increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r 2290 2291nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a 2292nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs 2293nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs) 2294 2295-- | Lift a list of matches to an exact match. 2296-- 2297exactMatches, inexactMatches :: [a] -> Match a 2298 2299exactMatches [] = mzero 2300exactMatches xs = Match Exact 0 xs 2301 2302inexactMatches [] = mzero 2303inexactMatches xs = Match Inexact 0 xs 2304 2305unknownMatch :: a -> Match a 2306unknownMatch x = Match Unknown 0 [x] 2307 2308tryEach :: [a] -> Match a 2309tryEach = exactMatches 2310 2311 2312------------------------------ 2313-- Top level match runner 2314-- 2315 2316-- | Given a matcher and a key to look up, use the matcher to find all the 2317-- possible matches. There may be 'None', a single 'Unambiguous' match or 2318-- you may have an 'Ambiguous' match with several possibilities. 2319-- 2320findMatch :: Match a -> MaybeAmbiguous a 2321findMatch match = case match of 2322 NoMatch _ msgs -> None msgs 2323 Match _ _ [x] -> Unambiguous x 2324 Match m d [] -> error $ "findMatch: impossible: " ++ show match' 2325 where match' = Match m d [] :: Match () 2326 -- TODO: Maybe use Data.List.NonEmpty inside 2327 -- Match so that this case would be correct 2328 -- by construction? 2329 Match m _ xs -> Ambiguous m xs 2330 2331data MaybeAmbiguous a = None [MatchError] 2332 | Unambiguous a 2333 | Ambiguous MatchClass [a] 2334 deriving Show 2335 2336 2337------------------------------ 2338-- Basic matchers 2339-- 2340 2341-- | A primitive matcher that looks up a value in a finite 'Map'. The 2342-- value must match exactly. 2343-- 2344matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) 2345matchExactly key xs = 2346 \k -> case Map.lookup k m of 2347 Nothing -> mzero 2348 Just ys -> exactMatches ys 2349 where 2350 m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] 2351 2352-- | A primitive matcher that looks up a value in a finite 'Map'. It checks 2353-- for an exact or inexact match. We get an inexact match if the match 2354-- is not exact, but the canonical forms match. It takes a canonicalisation 2355-- function for this purpose. 2356-- 2357-- So for example if we used string case fold as the canonicalisation 2358-- function, then we would get case insensitive matching (but it will still 2359-- report an exact match when the case matches too). 2360-- 2361matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k) 2362 -> [a] -> (k -> Match a) 2363matchInexactly cannonicalise key xs = 2364 \k -> case Map.lookup k m of 2365 Just ys -> exactMatches ys 2366 Nothing -> case Map.lookup (cannonicalise k) m' of 2367 Just ys -> inexactMatches ys 2368 Nothing -> mzero 2369 where 2370 m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] 2371 2372 -- the map of canonicalised keys to groups of inexact matches 2373 m' = Map.mapKeysWith (++) cannonicalise m 2374 2375matchParse :: Text a => String -> Match a 2376matchParse = maybe mzero return . simpleParse 2377 2378 2379------------------------------ 2380-- Utils 2381-- 2382 2383caseFold :: String -> String 2384caseFold = lowercase 2385 2386-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the 2387-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's 2388-- primary library from named private libraries. 2389-- 2390mkComponentName :: PackageName 2391 -> ComponentKind 2392 -> UnqualComponentName 2393 -> ComponentName 2394mkComponentName pkgname ckind ucname = 2395 case ckind of 2396 LibKind 2397 | packageNameToUnqualComponentName pkgname == ucname 2398 -> CLibName LMainLibName 2399 | otherwise -> CLibName $ LSubLibName ucname 2400 FLibKind -> CFLibName ucname 2401 ExeKind -> CExeName ucname 2402 TestKind -> CTestName ucname 2403 BenchKind -> CBenchName ucname 2404 2405 2406------------------------------ 2407-- Example inputs 2408-- 2409 2410{- 2411ex1pinfo :: [KnownPackage] 2412ex1pinfo = 2413 [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $ 2414 KnownPackage { 2415 pinfoId = PackageIdentifier (mkPackageName "foo") (mkVersion [1]), 2416 pinfoDirectory = Just ("/the/foo", "foo"), 2417 pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"), 2418 pinfoComponents = [] 2419 } 2420 , KnownPackage { 2421 pinfoId = PackageIdentifier (mkPackageName "bar") (mkVersion [1]), 2422 pinfoDirectory = Just ("/the/bar", "bar"), 2423 pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"), 2424 pinfoComponents = [] 2425 } 2426 ] 2427 where 2428 addComponent n ds ms p = 2429 p { 2430 pinfoComponents = 2431 KnownComponent n (componentStringName (pinfoId p) n) 2432 p ds (map mkMn ms) 2433 [] [] [] 2434 : pinfoComponents p 2435 } 2436 2437 mkMn :: String -> ModuleName 2438 mkMn = ModuleName.fromString 2439-} 2440{- 2441stargets = 2442 [ TargetComponent (CExeName "foo") WholeComponent 2443 , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo")) 2444 , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo")) 2445 ] 2446 where 2447 mkMn :: String -> ModuleName 2448 mkMn = fromJust . simpleParse 2449 2450ex_pkgid :: PackageIdentifier 2451Just ex_pkgid = simpleParse "thelib" 2452-} 2453 2454{- 2455ex_cs :: [KnownComponent] 2456ex_cs = 2457 [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"]) 2458 , (mkC (CExeName "tst") ["src1", "test"] ["Foo"]) 2459 ] 2460 where 2461 mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms) 2462 mkMn :: String -> ModuleName 2463 mkMn = fromJust . simpleParse 2464 pkgid :: PackageIdentifier 2465 Just pkgid = simpleParse "thelib" 2466-} 2467