Cabal/src/Distribution/Simple/BuildTarget.hs

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