Cabal/Distribution/Simple/BuildTarget.hs

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