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

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