Cabal/src/Distribution/Simple/BuildTarget.hs

   1 {-# LANGUAGE DeriveGeneric #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -----------------------------------------------------------------------------
   8
   9 -- |
  10 -- Module      :  Distribution.Client.BuildTargets
  11 -- Copyright   :  (c) Duncan Coutts 2012
  12 -- License     :  BSD-like
  13 --
  14 -- Maintainer  :  duncan@community.haskell.org
  15 --
  16 -- Handling for user-specified build targets
  17 module Distribution.Simple.BuildTarget
  18   ( -- * Main interface
  19     readTargetInfos
  20   , readBuildTargets -- in case you don't have LocalBuildInfo
  21
  22     -- * Build targets
  23   , BuildTarget (..)
  24   , showBuildTarget
  25   , QualLevel (..)
  26   , buildTargetComponentName
  27
  28     -- * Parsing user build targets
  29   , UserBuildTarget
  30   , readUserBuildTargets
  31   , showUserBuildTarget
  32   , UserBuildTargetProblem (..)
  33   , reportUserBuildTargetProblems
  34
  35     -- * Resolving build targets
  36   , resolveBuildTargets
  37   , BuildTargetProblem (..)
  38   , reportBuildTargetProblems
  39   ) where
  40
  41 import Distribution.Compat.Prelude
  42 import Prelude ()
  43
  44 import Distribution.Types.ComponentRequestedSpec
  45 import Distribution.Types.ForeignLib
  46 import Distribution.Types.LocalBuildInfo
  47 import Distribution.Types.TargetInfo
  48 import Distribution.Types.UnqualComponentName
  49
  50 import qualified Distribution.Compat.CharParsing as P
  51 import Distribution.ModuleName
  52 import Distribution.Package
  53 import Distribution.PackageDescription
  54 import Distribution.Parsec
  55 import Distribution.Pretty
  56 import Distribution.Simple.Errors
  57 import Distribution.Simple.LocalBuildInfo
  58 import Distribution.Simple.Utils
  59 import Distribution.Utils.Path
  60 import Distribution.Verbosity
  61
  62 import Control.Arrow ((&&&))
  63 import Control.Monad (msum)
  64 import Data.List (groupBy, stripPrefix)
  65 import qualified Data.List.NonEmpty as NE
  66 import qualified Data.Map as Map
  67 import System.Directory (doesDirectoryExist, doesFileExist)
  68 import System.FilePath as FilePath
  69   ( dropExtension
  70   , hasTrailingPathSeparator
  71   , joinPath
  72   , normalise
  73   , splitDirectories
  74   , splitPath
  75   )
  76
  77 -- | Take a list of 'String' build targets, and parse and validate them
  78 -- into actual 'TargetInfo's to be built/registered/whatever.
  79 readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
  80 readTargetInfos verbosity pkg_descr lbi args = do
  81   build_targets <- readBuildTargets verbosity pkg_descr args
  82   checkBuildTargets verbosity pkg_descr lbi build_targets
  83
  84 -- ------------------------------------------------------------
  85
  86 -- * User build targets
  87
  88 -- ------------------------------------------------------------
  89
  90 -- | Various ways that a user may specify a build target.
  91 data UserBuildTarget
  92   = -- | A target specified by a single name. This could be a component
  93     -- module or file.
  94     --
  95     -- > cabal build foo
  96     -- > cabal build Data.Foo
  97     -- > cabal build Data/Foo.hs  Data/Foo.hsc
  98     UserBuildTargetSingle String
  99   | -- | A target specified by a qualifier and name. This could be a component
 100     -- name qualified by the component namespace kind, or a module or file
 101     -- qualified by the component name.
 102     --
 103     -- > cabal build lib:foo exe:foo
 104     -- > cabal build foo:Data.Foo
 105     -- > cabal build foo:Data/Foo.hs
 106     UserBuildTargetDouble String String
 107   | -- | A fully qualified target, either a module or file qualified by a
 108     -- component name with the component namespace kind.
 109     --
 110     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
 111     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
 112     UserBuildTargetTriple String String String
 113   deriving (Show, Eq, Ord)
 114
 115 -- ------------------------------------------------------------
 116
 117 -- * Resolved build targets
 118
 119 -- ------------------------------------------------------------
 120
 121 -- | A fully resolved build target.
 122 data BuildTarget
 123   = -- | A specific component
 124     BuildTargetComponent ComponentName
 125   | -- | A specific module within a specific component.
 126     BuildTargetModule ComponentName ModuleName
 127   | -- | A specific file within a specific component.
 128     BuildTargetFile ComponentName FilePath
 129   deriving (Eq, Show, Generic)
 130
 131 instance Binary BuildTarget
 132
 133 buildTargetComponentName :: BuildTarget -> ComponentName
 134 buildTargetComponentName (BuildTargetComponent cn) = cn
 135 buildTargetComponentName (BuildTargetModule cn _) = cn
 136 buildTargetComponentName (BuildTargetFile cn _) = cn
 137
 138 -- | Read a list of user-supplied build target strings and resolve them to
 139 -- 'BuildTarget's according to a 'PackageDescription'. If there are problems
 140 -- with any of the targets e.g. they don't exist or are misformatted, throw an
 141 -- 'IOException'.
 142 readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
 143 readBuildTargets verbosity pkg targetStrs = do
 144   let (uproblems, utargets) = readUserBuildTargets targetStrs
 145   reportUserBuildTargetProblems verbosity uproblems
 146
 147   utargets' <- traverse checkTargetExistsAsFile utargets
 148
 149   let (bproblems, btargets) = resolveBuildTargets pkg utargets'
 150   reportBuildTargetProblems verbosity bproblems
 151
 152   return btargets
 153
 154 checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
 155 checkTargetExistsAsFile t = do
 156   fexists <- existsAsFile (fileComponentOfTarget t)
 157   return (t, fexists)
 158   where
 159     existsAsFile f = do
 160       exists <- doesFileExist f
 161       case splitPath f of
 162         (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d
 163         (d : _ : _) | not exists -> doesDirectoryExist d
 164         _ -> return exists
 165
 166     fileComponentOfTarget (UserBuildTargetSingle s1) = s1
 167     fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
 168     fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3
 169
 170 -- ------------------------------------------------------------
 171
 172 -- * Parsing user targets
 173
 174 -- ------------------------------------------------------------
 175
 176 readUserBuildTargets
 177   :: [String]
 178   -> ( [UserBuildTargetProblem]
 179      , [UserBuildTarget]
 180      )
 181 readUserBuildTargets = partitionEithers . map readUserBuildTarget
 182
 183 -- |
 184 --
 185 -- >>> readUserBuildTarget "comp"
 186 -- Right (UserBuildTargetSingle "comp")
 187 --
 188 -- >>> readUserBuildTarget "lib:comp"
 189 -- Right (UserBuildTargetDouble "lib" "comp")
 190 --
 191 -- >>> readUserBuildTarget "pkg:lib:comp"
 192 -- Right (UserBuildTargetTriple "pkg" "lib" "comp")
 193 --
 194 -- >>> readUserBuildTarget "\"comp\""
 195 -- Right (UserBuildTargetSingle "comp")
 196 --
 197 -- >>> readUserBuildTarget "lib:\"comp\""
 198 -- Right (UserBuildTargetDouble "lib" "comp")
 199 --
 200 -- >>> readUserBuildTarget "pkg:lib:\"comp\""
 201 -- Right (UserBuildTargetTriple "pkg" "lib" "comp")
 202 --
 203 -- >>> readUserBuildTarget "pkg:lib:comp:more"
 204 -- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")
 205 --
 206 -- >>> readUserBuildTarget "pkg:\"lib\":comp"
 207 -- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")
 208 readUserBuildTarget
 209   :: String
 210   -> Either
 211       UserBuildTargetProblem
 212       UserBuildTarget
 213 readUserBuildTarget targetstr =
 214   case explicitEitherParsec parseTargetApprox targetstr of
 215     Left _ -> Left (UserBuildTargetUnrecognised targetstr)
 216     Right tgt -> Right tgt
 217   where
 218     parseTargetApprox :: CabalParsing m => m UserBuildTarget
 219     parseTargetApprox = do
 220       -- read one, two, or three tokens, where last could be "hs-string"
 221       ts <- tokens
 222       return $ case ts of
 223         (a, Nothing) -> UserBuildTargetSingle a
 224         (a, Just (b, Nothing)) -> UserBuildTargetDouble a b
 225         (a, Just (b, Just c)) -> UserBuildTargetTriple a b c
 226
 227     tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
 228     tokens =
 229       (\s -> (s, Nothing)) <$> parsecHaskellString
 230         <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)
 231
 232     tokens2 :: CabalParsing m => m (String, Maybe String)
 233     tokens2 =
 234       (\s -> (s, Nothing)) <$> parsecHaskellString
 235         <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))
 236
 237     token :: CabalParsing m => m String
 238     token = P.munch1 (\x -> not (isSpace x) && x /= ':')
 239
 240 data UserBuildTargetProblem
 241   = UserBuildTargetUnrecognised String
 242   deriving (Show)
 243
 244 reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
 245 reportUserBuildTargetProblems verbosity problems = do
 246   case [target | UserBuildTargetUnrecognised target <- problems] of
 247     [] -> return ()
 248     target ->
 249       dieWithException verbosity $
 250         UnrecognisedBuildTarget target
 251
 252 showUserBuildTarget :: UserBuildTarget -> String
 253 showUserBuildTarget = intercalate ":" . getComponents
 254   where
 255     getComponents (UserBuildTargetSingle s1) = [s1]
 256     getComponents (UserBuildTargetDouble s1 s2) = [s1, s2]
 257     getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3]
 258
 259 -- | Unless you use 'QL1', this function is PARTIAL;
 260 -- use 'showBuildTarget' instead.
 261 showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
 262 showBuildTarget' ql pkgid bt =
 263   showUserBuildTarget (renderBuildTarget ql bt pkgid)
 264
 265 -- | Unambiguously render a 'BuildTarget', so that it can
 266 -- be parsed in all situations.
 267 showBuildTarget :: PackageId -> BuildTarget -> String
 268 showBuildTarget pkgid t =
 269   showBuildTarget' (qlBuildTarget t) pkgid t
 270   where
 271     qlBuildTarget BuildTargetComponent{} = QL2
 272     qlBuildTarget _ = QL3
 273
 274 -- ------------------------------------------------------------
 275
 276 -- * Resolving user targets to build targets
 277
 278 -- ------------------------------------------------------------
 279
 280 {-
 281 stargets =
 282   [ BuildTargetComponent (CExeName "foo")
 283   , BuildTargetModule    (CExeName "foo") (mkMn "Foo")
 284   , BuildTargetModule    (CExeName "tst") (mkMn "Foo")
 285   ]
 286     where
 287     mkMn :: String -> ModuleName
 288     mkMn  = fromJust . simpleParse
 289
 290 ex_pkgid :: PackageIdentifier
 291 Just ex_pkgid = simpleParse "thelib"
 292 -}
 293
 294 -- | Given a bunch of user-specified targets, try to resolve what it is they
 295 -- refer to.
 296 resolveBuildTargets
 297   :: PackageDescription
 298   -> [(UserBuildTarget, Bool)]
 299   -> ([BuildTargetProblem], [BuildTarget])
 300 resolveBuildTargets pkg =
 301   partitionEithers
 302     . map (uncurry (resolveBuildTarget pkg))
 303
 304 resolveBuildTarget
 305   :: PackageDescription
 306   -> UserBuildTarget
 307   -> Bool
 308   -> Either BuildTargetProblem BuildTarget
 309 resolveBuildTarget pkg userTarget fexists =
 310   case findMatch (matchBuildTarget pkg userTarget fexists) of
 311     Unambiguous target -> Right target
 312     Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')
 313       where
 314         targets' =
 315           disambiguateBuildTargets
 316             (packageId pkg)
 317             userTarget
 318             targets
 319     None errs -> Left (classifyMatchErrors errs)
 320   where
 321     classifyMatchErrors errs
 322       | Just expected' <- NE.nonEmpty expected =
 323           let unzip' = fmap fst &&& fmap snd
 324               (things, got :| _) = unzip' expected'
 325            in BuildTargetExpected userTarget (NE.toList things) got
 326       | not (null nosuch) = BuildTargetNoSuch userTarget nosuch
 327       | otherwise = error $ "resolveBuildTarget: internal error in matching"
 328       where
 329         expected = [(thing, got) | MatchErrorExpected thing got <- errs]
 330         nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs]
 331
 332 data BuildTargetProblem
 333   = -- |  [expected thing] (actually got)
 334     BuildTargetExpected UserBuildTarget [String] String
 335   | -- | [(no such thing,  actually got)]
 336     BuildTargetNoSuch UserBuildTarget [(String, String)]
 337   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
 338   deriving (Show)
 339
 340 disambiguateBuildTargets
 341   :: PackageId
 342   -> UserBuildTarget
 343   -> [BuildTarget]
 344   -> [(UserBuildTarget, BuildTarget)]
 345 disambiguateBuildTargets pkgid original =
 346   disambiguate (userTargetQualLevel original)
 347   where
 348     disambiguate ql ts
 349       | null amb = unamb
 350       | otherwise = unamb ++ disambiguate (succ ql) amb
 351       where
 352         (amb, unamb) = step ql ts
 353
 354     userTargetQualLevel (UserBuildTargetSingle _) = QL1
 355     userTargetQualLevel (UserBuildTargetDouble _ _) = QL2
 356     userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3
 357
 358     step
 359       :: QualLevel
 360       -> [BuildTarget]
 361       -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
 362     step ql =
 363       (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
 364         . partition (\g -> length g > 1)
 365         . groupBy (equating fst)
 366         . sortBy (comparing fst)
 367         . map (\t -> (renderBuildTarget ql t pkgid, t))
 368
 369 data QualLevel = QL1 | QL2 | QL3
 370   deriving (Enum, Show)
 371
 372 renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
 373 renderBuildTarget ql target pkgid =
 374   case ql of
 375     QL1 -> UserBuildTargetSingle s1 where s1 = single target
 376     QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target
 377     QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target
 378   where
 379     single (BuildTargetComponent cn) = dispCName cn
 380     single (BuildTargetModule _ m) = prettyShow m
 381     single (BuildTargetFile _ f) = f
 382
 383     double (BuildTargetComponent cn) = (dispKind cn, dispCName cn)
 384     double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)
 385     double (BuildTargetFile cn f) = (dispCName cn, f)
 386
 387     triple (BuildTargetComponent _) = error "triple BuildTargetComponent"
 388     triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m)
 389     triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)
 390
 391     dispCName = componentStringName pkgid
 392     dispKind = showComponentKindShort . componentKind
 393
 394 reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
 395 reportBuildTargetProblems verbosity problems = do
 396   case [(t, e, g) | BuildTargetExpected t e g <- problems] of
 397     [] -> return ()
 398     targets ->
 399       dieWithException verbosity $
 400         ReportBuildTargetProblems $
 401           map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets
 402
 403   case [(t, e) | BuildTargetNoSuch t e <- problems] of
 404     [] -> return ()
 405     targets ->
 406       dieWithException verbosity $
 407         UnknownBuildTarget $
 408           map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets
 409
 410   case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of
 411     [] -> return ()
 412     targets ->
 413       dieWithException verbosity $
 414         AmbiguousBuildTarget $
 415           map
 416             ( \(target, amb) ->
 417                 ( showUserBuildTarget target
 418                 , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) amb)
 419                 )
 420             )
 421             targets
 422   where
 423     showBuildTargetKind (BuildTargetComponent _) = "component"
 424     showBuildTargetKind (BuildTargetModule _ _) = "module"
 425     showBuildTargetKind (BuildTargetFile _ _) = "file"
 426
 427 ----------------------------------
 428 -- Top level BuildTarget matcher
 429 --
 430
 431 matchBuildTarget
 432   :: PackageDescription
 433   -> UserBuildTarget
 434   -> Bool
 435   -> Match BuildTarget
 436 matchBuildTarget pkg = \utarget fexists ->
 437   case utarget of
 438     UserBuildTargetSingle str1 ->
 439       matchBuildTarget1 cinfo str1 fexists
 440     UserBuildTargetDouble str1 str2 ->
 441       matchBuildTarget2 cinfo str1 str2 fexists
 442     UserBuildTargetTriple str1 str2 str3 ->
 443       matchBuildTarget3 cinfo str1 str2 str3 fexists
 444   where
 445     cinfo = pkgComponentInfo pkg
 446
 447 matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
 448 matchBuildTarget1 cinfo str1 fexists =
 449   matchComponent1 cinfo str1
 450     `matchPlusShadowing` matchModule1 cinfo str1
 451     `matchPlusShadowing` matchFile1 cinfo str1 fexists
 452
 453 matchBuildTarget2
 454   :: [ComponentInfo]
 455   -> String
 456   -> String
 457   -> Bool
 458   -> Match BuildTarget
 459 matchBuildTarget2 cinfo str1 str2 fexists =
 460   matchComponent2 cinfo str1 str2
 461     `matchPlusShadowing` matchModule2 cinfo str1 str2
 462     `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists
 463
 464 matchBuildTarget3
 465   :: [ComponentInfo]
 466   -> String
 467   -> String
 468   -> String
 469   -> Bool
 470   -> Match BuildTarget
 471 matchBuildTarget3 cinfo str1 str2 str3 fexists =
 472   matchModule3 cinfo str1 str2 str3
 473     `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists
 474
 475 data ComponentInfo = ComponentInfo
 476   { cinfoName :: ComponentName
 477   , cinfoStrName :: ComponentStringName
 478   , cinfoSrcDirs :: [FilePath]
 479   , cinfoModules :: [ModuleName]
 480   , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
 481   , cinfoAsmFiles :: [FilePath]
 482   , cinfoCmmFiles :: [FilePath]
 483   , cinfoCFiles :: [FilePath]
 484   , cinfoCxxFiles :: [FilePath]
 485   , cinfoJsFiles :: [FilePath]
 486   }
 487
 488 type ComponentStringName = String
 489
 490 pkgComponentInfo :: PackageDescription -> [ComponentInfo]
 491 pkgComponentInfo pkg =
 492   [ ComponentInfo
 493     { cinfoName = componentName c
 494     , cinfoStrName = componentStringName pkg (componentName c)
 495     , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi
 496     , cinfoModules = componentModules c
 497     , cinfoHsFiles = componentHsFiles c
 498     , cinfoAsmFiles = asmSources bi
 499     , cinfoCmmFiles = cmmSources bi
 500     , cinfoCFiles = cSources bi
 501     , cinfoCxxFiles = cxxSources bi
 502     , cinfoJsFiles = jsSources bi
 503     }
 504   | c <- pkgComponents pkg
 505   , let bi = componentBuildInfo c
 506   ]
 507
 508 componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
 509 componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg)
 510 componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name
 511 componentStringName _ (CFLibName name) = unUnqualComponentName name
 512 componentStringName _ (CExeName name) = unUnqualComponentName name
 513 componentStringName _ (CTestName name) = unUnqualComponentName name
 514 componentStringName _ (CBenchName name) = unUnqualComponentName name
 515
 516 componentModules :: Component -> [ModuleName]
 517 -- TODO: Use of 'explicitLibModules' here is a bit wrong:
 518 -- a user could very well ask to build a specific signature
 519 -- that was inherited from other packages.  To fix this
 520 -- we have to plumb 'LocalBuildInfo' through this code.
 521 -- Fortunately, this is only used by 'pkgComponentInfo'
 522 -- Please don't export this function unless you plan on fixing
 523 -- this.
 524 componentModules (CLib lib) = explicitLibModules lib
 525 componentModules (CFLib flib) = foreignLibModules flib
 526 componentModules (CExe exe) = exeModules exe
 527 componentModules (CTest test) = testModules test
 528 componentModules (CBench bench) = benchmarkModules bench
 529
 530 componentHsFiles :: Component -> [FilePath]
 531 componentHsFiles (CExe exe) = [modulePath exe]
 532 componentHsFiles
 533   ( CTest
 534       TestSuite
 535         { testInterface = TestSuiteExeV10 _ mainfile
 536         }
 537     ) = [mainfile]
 538 componentHsFiles
 539   ( CBench
 540       Benchmark
 541         { benchmarkInterface = BenchmarkExeV10 _ mainfile
 542         }
 543     ) = [mainfile]
 544 componentHsFiles _ = []
 545
 546 {-
 547 ex_cs :: [ComponentInfo]
 548 ex_cs =
 549   [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
 550   , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])
 551   ]
 552     where
 553     mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)
 554     mkMn :: String -> ModuleName
 555     mkMn  = fromJust . simpleParse
 556     pkgid :: PackageIdentifier
 557     Just pkgid = simpleParse "thelib"
 558 -}
 559
 560 ------------------------------
 561 -- Matching component kinds
 562 --
 563
 564 data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
 565   deriving (Eq, Ord, Show, Enum, Bounded)
 566
 567 componentKind :: ComponentName -> ComponentKind
 568 componentKind (CLibName _) = LibKind
 569 componentKind (CFLibName _) = FLibKind
 570 componentKind (CExeName _) = ExeKind
 571 componentKind (CTestName _) = TestKind
 572 componentKind (CBenchName _) = BenchKind
 573
 574 cinfoKind :: ComponentInfo -> ComponentKind
 575 cinfoKind = componentKind . cinfoName
 576
 577 matchComponentKind :: String -> Match ComponentKind
 578 matchComponentKind s
 579   | s `elem` ["lib", "library"] = return' LibKind
 580   | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind
 581   | s `elem` ["exe", "executable"] = return' ExeKind
 582   | s `elem` ["tst", "test", "test-suite"] = return' TestKind
 583   | s `elem` ["bench", "benchmark"] = return' BenchKind
 584   | otherwise = matchErrorExpected "component kind" s
 585   where
 586     return' ck = increaseConfidence >> return ck
 587
 588 showComponentKind :: ComponentKind -> String
 589 showComponentKind LibKind = "library"
 590 showComponentKind FLibKind = "foreign-library"
 591 showComponentKind ExeKind = "executable"
 592 showComponentKind TestKind = "test-suite"
 593 showComponentKind BenchKind = "benchmark"
 594
 595 showComponentKindShort :: ComponentKind -> String
 596 showComponentKindShort LibKind = "lib"
 597 showComponentKindShort FLibKind = "flib"
 598 showComponentKindShort ExeKind = "exe"
 599 showComponentKindShort TestKind = "test"
 600 showComponentKindShort BenchKind = "bench"
 601
 602 ------------------------------
 603 -- Matching component targets
 604 --
 605
 606 matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
 607 matchComponent1 cs = \str1 -> do
 608   guardComponentName str1
 609   c <- matchComponentName cs str1
 610   return (BuildTargetComponent (cinfoName c))
 611
 612 matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
 613 matchComponent2 cs = \str1 str2 -> do
 614   ckind <- matchComponentKind str1
 615   guardComponentName str2
 616   c <- matchComponentKindAndName cs ckind str2
 617   return (BuildTargetComponent (cinfoName c))
 618
 619 -- utils:
 620
 621 guardComponentName :: String -> Match ()
 622 guardComponentName s
 623   | all validComponentChar s
 624       && not (null s) =
 625       increaseConfidence
 626   | otherwise = matchErrorExpected "component name" s
 627   where
 628     validComponentChar c =
 629       isAlphaNum c
 630         || c == '.'
 631         || c == '_'
 632         || c == '-'
 633         || c == '\''
 634
 635 matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
 636 matchComponentName cs str =
 637   orNoSuchThing "component" str $
 638     increaseConfidenceFor $
 639       matchInexactly
 640         caseFold
 641         [(cinfoStrName c, c) | c <- cs]
 642         str
 643
 644 matchComponentKindAndName
 645   :: [ComponentInfo]
 646   -> ComponentKind
 647   -> String
 648   -> Match ComponentInfo
 649 matchComponentKindAndName cs ckind str =
 650   orNoSuchThing (showComponentKind ckind ++ " component") str $
 651     increaseConfidenceFor $
 652       matchInexactly
 653         (\(ck, cn) -> (ck, caseFold cn))
 654         [((cinfoKind c, cinfoStrName c), c) | c <- cs]
 655         (ckind, str)
 656
 657 ------------------------------
 658 -- Matching module targets
 659 --
 660
 661 matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
 662 matchModule1 cs = \str1 -> do
 663   guardModuleName str1
 664   nubMatchErrors $ do
 665     c <- tryEach cs
 666     let ms = cinfoModules c
 667     m <- matchModuleName ms str1
 668     return (BuildTargetModule (cinfoName c) m)
 669
 670 matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
 671 matchModule2 cs = \str1 str2 -> do
 672   guardComponentName str1
 673   guardModuleName str2
 674   c <- matchComponentName cs str1
 675   let ms = cinfoModules c
 676   m <- matchModuleName ms str2
 677   return (BuildTargetModule (cinfoName c) m)
 678
 679 matchModule3
 680   :: [ComponentInfo]
 681   -> String
 682   -> String
 683   -> String
 684   -> Match BuildTarget
 685 matchModule3 cs str1 str2 str3 = do
 686   ckind <- matchComponentKind str1
 687   guardComponentName str2
 688   c <- matchComponentKindAndName cs ckind str2
 689   guardModuleName str3
 690   let ms = cinfoModules c
 691   m <- matchModuleName ms str3
 692   return (BuildTargetModule (cinfoName c) m)
 693
 694 -- utils:
 695
 696 guardModuleName :: String -> Match ()
 697 guardModuleName s
 698   | all validModuleChar s
 699       && not (null s) =
 700       increaseConfidence
 701   | otherwise = matchErrorExpected "module name" s
 702   where
 703     validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
 704
 705 matchModuleName :: [ModuleName] -> String -> Match ModuleName
 706 matchModuleName ms str =
 707   orNoSuchThing "module" str $
 708     increaseConfidenceFor $
 709       matchInexactly
 710         caseFold
 711         [ (prettyShow m, m)
 712         | m <- ms
 713         ]
 714         str
 715
 716 ------------------------------
 717 -- Matching file targets
 718 --
 719
 720 matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
 721 matchFile1 cs str1 exists =
 722   nubMatchErrors $ do
 723     c <- tryEach cs
 724     filepath <- matchComponentFile c str1 exists
 725     return (BuildTargetFile (cinfoName c) filepath)
 726
 727 matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
 728 matchFile2 cs str1 str2 exists = do
 729   guardComponentName str1
 730   c <- matchComponentName cs str1
 731   filepath <- matchComponentFile c str2 exists
 732   return (BuildTargetFile (cinfoName c) filepath)
 733
 734 matchFile3
 735   :: [ComponentInfo]
 736   -> String
 737   -> String
 738   -> String
 739   -> Bool
 740   -> Match BuildTarget
 741 matchFile3 cs str1 str2 str3 exists = do
 742   ckind <- matchComponentKind str1
 743   guardComponentName str2
 744   c <- matchComponentKindAndName cs ckind str2
 745   filepath <- matchComponentFile c str3 exists
 746   return (BuildTargetFile (cinfoName c) filepath)
 747
 748 matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
 749 matchComponentFile c str fexists =
 750   expecting "file" str $
 751     matchPlus
 752       (matchFileExists str fexists)
 753       ( matchPlusShadowing
 754           ( msum
 755               [ matchModuleFileRooted dirs ms str
 756               , matchOtherFileRooted dirs hsFiles str
 757               ]
 758           )
 759           ( msum
 760               [ matchModuleFileUnrooted ms str
 761               , matchOtherFileUnrooted hsFiles str
 762               , matchOtherFileUnrooted cFiles str
 763               , matchOtherFileUnrooted jsFiles str
 764               ]
 765           )
 766       )
 767   where
 768     dirs = cinfoSrcDirs c
 769     ms = cinfoModules c
 770     hsFiles = cinfoHsFiles c
 771     cFiles = cinfoCFiles c
 772     jsFiles = cinfoJsFiles c
 773
 774 -- utils
 775
 776 matchFileExists :: FilePath -> Bool -> Match a
 777 matchFileExists _ False = mzero
 778 matchFileExists fname True = do
 779   increaseConfidence
 780   matchErrorNoSuch "file" fname
 781
 782 matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
 783 matchModuleFileUnrooted ms str = do
 784   let filepath = normalise str
 785   _ <- matchModuleFileStem ms filepath
 786   return filepath
 787
 788 matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
 789 matchModuleFileRooted dirs ms str = nubMatches $ do
 790   let filepath = normalise str
 791   filepath' <- matchDirectoryPrefix dirs filepath
 792   _ <- matchModuleFileStem ms filepath'
 793   return filepath
 794
 795 matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
 796 matchModuleFileStem ms =
 797   increaseConfidenceFor
 798     . matchInexactly
 799       caseFold
 800       [(toFilePath m, m) | m <- ms]
 801     . dropExtension
 802
 803 matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
 804 matchOtherFileRooted dirs fs str = do
 805   let filepath = normalise str
 806   filepath' <- matchDirectoryPrefix dirs filepath
 807   _ <- matchFile fs filepath'
 808   return filepath
 809
 810 matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
 811 matchOtherFileUnrooted fs str = do
 812   let filepath = normalise str
 813   _ <- matchFile fs filepath
 814   return filepath
 815
 816 matchFile :: [FilePath] -> FilePath -> Match FilePath
 817 matchFile fs =
 818   increaseConfidenceFor
 819     . matchInexactly caseFold [(f, f) | f <- fs]
 820
 821 matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
 822 matchDirectoryPrefix dirs filepath =
 823   exactMatches $
 824     catMaybes
 825       [stripDirectory (normalise dir) filepath | dir <- dirs]
 826   where
 827     stripDirectory :: FilePath -> FilePath -> Maybe FilePath
 828     stripDirectory dir fp =
 829       joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)
 830
 831 ------------------------------
 832 -- Matching monad
 833 --
 834
 835 -- | A matcher embodies a way to match some input as being some recognised
 836 -- value. In particular it deals with multiple and ambiguous matches.
 837 --
 838 -- There are various matcher primitives ('matchExactly', 'matchInexactly'),
 839 -- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
 840 -- run a matcher against an input using 'findMatch'.
 841 data Match a
 842   = NoMatch Confidence [MatchError]
 843   | ExactMatch Confidence [a]
 844   | InexactMatch Confidence [a]
 845   deriving (Show)
 846
 847 type Confidence = Int
 848
 849 data MatchError
 850   = MatchErrorExpected String String
 851   | MatchErrorNoSuch String String
 852   deriving (Show, Eq)
 853
 854 instance Alternative Match where
 855   empty = mzero
 856   (<|>) = mplus
 857
 858 instance MonadPlus Match where
 859   mzero = matchZero
 860   mplus = matchPlus
 861
 862 matchZero :: Match a
 863 matchZero = NoMatch 0 []
 864
 865 -- | Combine two matchers. Exact matches are used over inexact matches
 866 -- but if we have multiple exact, or inexact then the we collect all the
 867 -- ambiguous matches.
 868 matchPlus :: Match a -> Match a -> Match a
 869 matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
 870   ExactMatch (max d1 d2) (xs ++ xs')
 871 matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a
 872 matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a
 873 matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b
 874 matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =
 875   InexactMatch (max d1 d2) (xs ++ xs')
 876 matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a
 877 matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b
 878 matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b
 879 matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
 880   | d1 > d2 = a
 881   | d1 < d2 = b
 882   | otherwise = NoMatch d1 (ms ++ ms')
 883
 884 -- | Combine two matchers. This is similar to 'ambiguousWith' with the
 885 -- difference that an exact match from the left matcher shadows any exact
 886 -- match on the right. Inexact matches are still collected however.
 887 matchPlusShadowing :: Match a -> Match a -> Match a
 888 matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
 889 matchPlusShadowing a b = matchPlus a b
 890
 891 instance Functor Match where
 892   fmap _ (NoMatch d ms) = NoMatch d ms
 893   fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)
 894   fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)
 895
 896 instance Applicative Match where
 897   pure a = ExactMatch 0 [a]
 898   (<*>) = ap
 899
 900 instance Monad Match where
 901   return = pure
 902
 903   NoMatch d ms >>= _ = NoMatch d ms
 904   ExactMatch d xs >>= f =
 905     addDepth d $
 906       foldr matchPlus matchZero (map f xs)
 907   InexactMatch d xs >>= f =
 908     addDepth d . forceInexact $
 909       foldr matchPlus matchZero (map f xs)
 910
 911 addDepth :: Confidence -> Match a -> Match a
 912 addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs
 913 addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs
 914 addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs
 915
 916 forceInexact :: Match a -> Match a
 917 forceInexact (ExactMatch d ys) = InexactMatch d ys
 918 forceInexact m = m
 919
 920 ------------------------------
 921 -- Various match primitives
 922 --
 923
 924 matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
 925 matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
 926 matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]
 927
 928 expecting :: String -> String -> Match a -> Match a
 929 expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
 930 expecting _ _ m = m
 931
 932 orNoSuchThing :: String -> String -> Match a -> Match a
 933 orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
 934 orNoSuchThing _ _ m = m
 935
 936 increaseConfidence :: Match ()
 937 increaseConfidence = ExactMatch 1 [()]
 938
 939 increaseConfidenceFor :: Match a -> Match a
 940 increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r
 941
 942 nubMatches :: Eq a => Match a -> Match a
 943 nubMatches (NoMatch d msgs) = NoMatch d msgs
 944 nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)
 945 nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)
 946
 947 nubMatchErrors :: Match a -> Match a
 948 nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
 949 nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
 950 nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
 951
 952 -- | Lift a list of matches to an exact match.
 953 exactMatches, inexactMatches :: [a] -> Match a
 954 exactMatches [] = matchZero
 955 exactMatches xs = ExactMatch 0 xs
 956 inexactMatches [] = matchZero
 957 inexactMatches xs = InexactMatch 0 xs
 958
 959 tryEach :: [a] -> Match a
 960 tryEach = exactMatches
 961
 962 ------------------------------
 963 -- Top level match runner
 964 --
 965
 966 -- | Given a matcher and a key to look up, use the matcher to find all the
 967 -- possible matches. There may be 'None', a single 'Unambiguous' match or
 968 -- you may have an 'Ambiguous' match with several possibilities.
 969 findMatch :: Eq b => Match b -> MaybeAmbiguous b
 970 findMatch match =
 971   case match of
 972     NoMatch _ msgs -> None (nub msgs)
 973     ExactMatch _ xs -> checkAmbiguous xs
 974     InexactMatch _ xs -> checkAmbiguous xs
 975   where
 976     checkAmbiguous xs = case nub xs of
 977       [x] -> Unambiguous x
 978       xs' -> Ambiguous xs'
 979
 980 data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
 981   deriving (Show)
 982
 983 ------------------------------
 984 -- Basic matchers
 985 --
 986
 987 {-
 988 -- | A primitive matcher that looks up a value in a finite 'Map'. The
 989 -- value must match exactly.
 990 --
 991 matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
 992 matchExactly xs =
 993     \x -> case Map.lookup x m of
 994             Nothing -> matchZero
 995             Just ys -> ExactMatch 0 ys
 996   where
 997     m :: Ord a => Map a [b]
 998     m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
 999 -}
1000
1001 -- | A primitive matcher that looks up a value in a finite 'Map'. It checks
1002 -- for an exact or inexact match. We get an inexact match if the match
1003 -- is not exact, but the canonical forms match. It takes a canonicalisation
1004 -- function for this purpose.
1005 --
1006 -- So for example if we used string case fold as the canonicalisation
1007 -- function, then we would get case insensitive matching (but it will still
1008 -- report an exact match when the case matches too).
1009 matchInexactly
1010   :: (Ord a, Ord a')
1011   => (a -> a')
1012   -> [(a, b)]
1013   -> (a -> Match b)
1014 matchInexactly cannonicalise xs =
1015   \x -> case Map.lookup x m of
1016     Just ys -> exactMatches ys
1017     Nothing -> case Map.lookup (cannonicalise x) m' of
1018       Just ys -> inexactMatches ys
1019       Nothing -> matchZero
1020   where
1021     m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs]
1022
1023     -- the map of canonicalised keys to groups of inexact matches
1024     m' = Map.mapKeysWith (++) cannonicalise m
1025
1026 ------------------------------
1027 -- Utils
1028 --
1029
1030 caseFold :: String -> String
1031 caseFold = lowercase
1032
1033 -- | Check that the given build targets are valid in the current context.
1034 --
1035 -- Also swizzle into a more convenient form.
1036 checkBuildTargets
1037   :: Verbosity
1038   -> PackageDescription
1039   -> LocalBuildInfo
1040   -> [BuildTarget]
1041   -> IO [TargetInfo]
1042 checkBuildTargets _ pkg_descr lbi [] =
1043   return (allTargetsInBuildOrder' pkg_descr lbi)
1044 checkBuildTargets verbosity pkg_descr lbi targets = do
1045   let (enabled, disabled) =
1046         partitionEithers
1047           [ case componentDisabledReason (componentEnabledSpec lbi) comp of
1048             Nothing -> Left target'
1049             Just reason -> Right (cname, reason)
1050           | target <- targets
1051           , let target'@(cname, _) = swizzleTarget target
1052           , let comp = getComponent pkg_descr cname
1053           ]
1054
1055   case disabled of
1056     [] -> return ()
1057     ((cname, reason) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason
1058
1059   for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->
1060     warn verbosity $
1061       "Ignoring '"
1062         ++ either prettyShow id t
1063         ++ ". The whole "
1064         ++ showComponentName c
1065         ++ " will be processed. (Support for "
1066         ++ "module and file targets has not been implemented yet.)"
1067
1068   -- Pick out the actual CLBIs for each of these cnames
1069   enabled' <- for enabled $ \(cname, _) -> do
1070     case componentNameTargets' pkg_descr lbi cname of
1071       [] -> error "checkBuildTargets: nothing enabled"
1072       [target] -> return target
1073       _targets -> error "checkBuildTargets: multiple copies enabled"
1074
1075   return enabled'
1076   where
1077     swizzleTarget (BuildTargetComponent c) = (c, Nothing)
1078     swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))
1079     swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))
1080
1081     formatReason cn DisabledComponent =
1082       "Cannot process the "
1083         ++ cn
1084         ++ " because the component is marked "
1085         ++ "as disabled in the .cabal file."
1086     formatReason cn DisabledAllTests =
1087       "Cannot process the "
1088         ++ cn
1089         ++ " because test suites are not "
1090         ++ "enabled. Run configure with the flag --enable-tests"
1091     formatReason cn DisabledAllBenchmarks =
1092       "Cannot process the "
1093         ++ cn
1094         ++ " because benchmarks are not "
1095         ++ "enabled. Re-run configure with the flag --enable-benchmarks"
1096     formatReason cn (DisabledAllButOne cn') =
1097       "Cannot process the "
1098         ++ cn
1099         ++ " because this package was "
1100         ++ "configured only to build "
1101         ++ cn'
1102         ++ ". Re-run configure "
1103         ++ "with the argument "
1104         ++ cn