cabal-install/src/Distribution/Client/TargetSelector.hs

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