BuildTarget.hs 36.4 KB
Newer Older
1
{-# LANGUAGE DeriveGeneric #-}
2 3 4
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

5 6 7 8 9 10 11 12 13 14 15
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.BuildTargets
-- Copyright   :  (c) Duncan Coutts 2012
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
--
-- Handling for user-specified build targets
-----------------------------------------------------------------------------
module Distribution.Simple.BuildTarget (
16 17
    -- * Main interface
    readTargetInfos,
18
    readBuildTargets, -- in case you don't have LocalBuildInfo
19

20 21
    -- * Build targets
    BuildTarget(..),
22 23 24
    showBuildTarget,
    QualLevel(..),
    buildTargetComponentName,
25 26 27 28

    -- * Parsing user build targets
    UserBuildTarget,
    readUserBuildTargets,
29
    showUserBuildTarget,
30 31 32 33 34 35 36 37 38
    UserBuildTargetProblem(..),
    reportUserBuildTargetProblems,

    -- * Resolving build targets
    resolveBuildTargets,
    BuildTargetProblem(..),
    reportBuildTargetProblems,
  ) where

39 40 41
import Prelude ()
import Distribution.Compat.Prelude

42 43
import Distribution.Types.TargetInfo
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 50 51 52 53
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Text
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 61 62

import Control.Monad ( msum )
import Data.List ( stripPrefix, groupBy, partition )
import Data.Either ( partitionEithers )
63 64 65
import System.FilePath as FilePath
         ( dropExtension, normalise, splitDirectories, joinPath, splitPath
         , hasTrailingPathSeparator )
66 67
import System.Directory ( doesFileExist, doesDirectoryExist )
import qualified Data.Map as Map
68

69 70
-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
71 72
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
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 78 79 80 81 82
-- ------------------------------------------------------------
-- * User build targets
-- ------------------------------------------------------------

-- | Various ways that a user may specify a build target.
--
data UserBuildTarget =
83

84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
     -- | A target specified by a single name. This could be a component
     -- module or file.
     --
     -- > cabal build foo
     -- > cabal build Data.Foo
     -- > cabal build Data/Foo.hs  Data/Foo.hsc
     --
     UserBuildTargetSingle String

     -- | A target specified by a qualifier and name. This could be a component
     -- name qualified by the component namespace kind, or a module or file
     -- qualified by the component name.
     --
     -- > cabal build lib:foo exe:foo
     -- > cabal build foo:Data.Foo
     -- > cabal build foo:Data/Foo.hs
     --
   | UserBuildTargetDouble String String

Alan Zimmerman's avatar
Alan Zimmerman committed
103
     -- | A fully qualified target, either a module or file qualified by a
104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
     -- component name with the component namespace kind.
     --
     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
     --
   | UserBuildTargetTriple String String String
  deriving (Show, Eq, Ord)


-- ------------------------------------------------------------
-- * Resolved build targets
-- ------------------------------------------------------------

-- | A fully resolved build target.
--
data BuildTarget =

     -- | A specific component
     --
     BuildTargetComponent ComponentName

     -- | A specific module within a specific component.
     --
   | BuildTargetModule ComponentName ModuleName

     -- | A specific file within a specific component.
     --
   | BuildTargetFile ComponentName FilePath
132
  deriving (Eq, Show, Generic)
133

134
instance Binary BuildTarget
135

136 137 138 139 140
buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent cn)   = cn
buildTargetComponentName (BuildTargetModule    cn _) = cn
buildTargetComponentName (BuildTargetFile      cn _) = cn

enolan's avatar
enolan committed
141 142 143 144
-- | Read a list of user-supplied build target strings and resolve them to
-- 'BuildTarget's according to a 'PackageDescription'. If there are problems
-- with any of the targets e.g. they don't exist or are misformatted, throw an
-- 'IOException'.
145 146
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
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 156

    return btargets

157
checkTargetExistsAsFile :: UserBuildTarget -> NoCallStackIO (UserBuildTarget, Bool)
158 159 160
checkTargetExistsAsFile t = do
    fexists <- existsAsFile (fileComponentOfTarget t)
    return (t, fexists)
161

162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
  where
    existsAsFile f = do
      exists <- doesFileExist f
      case splitPath f of
        (d:_)   | hasTrailingPathSeparator d -> doesDirectoryExist d
        (d:_:_) | not exists                 -> doesDirectoryExist d
        _                                    -> return exists

    fileComponentOfTarget (UserBuildTargetSingle     s1) = s1
    fileComponentOfTarget (UserBuildTargetDouble _   s2) = s2
    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3


-- ------------------------------------------------------------
-- * Parsing user targets
-- ------------------------------------------------------------

readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
                                    ,[UserBuildTarget])
readUserBuildTargets = partitionEithers . map readUserBuildTarget

readUserBuildTarget :: String -> Either UserBuildTargetProblem
                                        UserBuildTarget
readUserBuildTarget targetstr =
    case readPToMaybe parseTargetApprox targetstr of
      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)
      Just tgt -> Right tgt

  where
    parseTargetApprox :: Parse.ReadP r UserBuildTarget
    parseTargetApprox =
          (do a <- tokenQ
              return (UserBuildTargetSingle a))
      +++ (do a <- token
              _ <- Parse.char ':'
              b <- tokenQ
              return (UserBuildTargetDouble a b))
      +++ (do a <- token
              _ <- Parse.char ':'
              b <- token
              _ <- Parse.char ':'
              c <- tokenQ
              return (UserBuildTargetTriple a b c))

    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
    tokenQ = parseHaskellString <++ token
    parseHaskellString :: Parse.ReadP r String
    parseHaskellString = Parse.readS_to_P reads

data UserBuildTargetProblem
   = UserBuildTargetUnrecognised String
  deriving Show

215 216
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
217 218 219
    case [ target | UserBuildTargetUnrecognised target <- problems ] of
      []     -> return ()
      target ->
220
        die' verbosity $ unlines
221 222 223
                [ "Unrecognised build target '" ++ name ++ "'."
                | name <- target ]
           ++ "Examples:\n"
224 225
           ++ " - build foo          -- component name "
           ++ "(library, executable, test-suite or benchmark)\n"
226 227 228 229 230 231 232
           ++ " - build Data.Foo     -- module name\n"
           ++ " - build Data/Foo.hsc -- file name\n"
           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"
           ++ " - build foo:Data.Foo      -- module qualified by component\n"
           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"

showUserBuildTarget :: UserBuildTarget -> String
233
showUserBuildTarget = intercalate ":" . getComponents
234
  where
235 236 237
    getComponents (UserBuildTargetSingle s1)       = [s1]
    getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]
    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]
238

239 240 241 242
-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' ql pkgid bt =
243
    showUserBuildTarget (renderBuildTarget ql bt pkgid)
244

245 246 247 248 249 250 251 252 253
-- | Unambiguously render a 'BuildTarget', so that it can
-- be parsed in all situations.
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget pkgid t =
    showBuildTarget' (qlBuildTarget t) pkgid t
  where
    qlBuildTarget BuildTargetComponent{} = QL2
    qlBuildTarget _                      = QL3

254 255 256 257 258 259 260 261 262 263 264 265

-- ------------------------------------------------------------
-- * Resolving user targets to build targets
-- ------------------------------------------------------------

{-
stargets =
  [ BuildTargetComponent (CExeName "foo")
  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")
  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")
  ]
    where
266
    mkMn :: String -> ModuleName
267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
    mkMn  = fromJust . simpleParse

ex_pkgid :: PackageIdentifier
Just ex_pkgid = simpleParse "thelib"
-}

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
--
resolveBuildTargets :: PackageDescription
                    -> [(UserBuildTarget, Bool)]
                    -> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets pkg = partitionEithers
                        . map (uncurry (resolveBuildTarget pkg))

resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
                   -> Either BuildTargetProblem BuildTarget
resolveBuildTarget pkg userTarget fexists =
    case findMatch (matchBuildTarget pkg userTarget fexists) of
      Unambiguous target  -> Right target
RyanGlScott's avatar
RyanGlScott committed
287
      Ambiguous   targets -> Left (BuildTargetAmbiguous userTarget targets')
288
                               where targets' = disambiguateBuildTargets
289
                                                    (packageId pkg)
290
                                                    userTarget
291
                                                    targets
292 293 294 295 296 297 298 299 300 301 302 303 304 305
      None        errs    -> Left (classifyMatchErrors errs)

  where
    classifyMatchErrors errs
      | not (null expected) = let (things, got:_) = unzip expected in
                              BuildTargetExpected userTarget things got
      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch
      | otherwise = error $ "resolveBuildTarget: internal error in matching"
      where
        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]
        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]


data BuildTargetProblem
306 307 308 309
   = BuildTargetExpected  UserBuildTarget [String]  String
     -- ^  [expected thing] (actually got)
   | BuildTargetNoSuch    UserBuildTarget [(String, String)]
     -- ^ [(no such thing,  actually got)]
RyanGlScott's avatar
RyanGlScott committed
310
   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
311 312 313
  deriving Show


314
disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
315
                         -> [(UserBuildTarget, BuildTarget)]
316
disambiguateBuildTargets pkgid original =
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334
    disambiguate (userTargetQualLevel original)
  where
    disambiguate ql ts
        | null amb  = unamb
        | otherwise = unamb ++ disambiguate (succ ql) amb
      where
        (amb, unamb) = step ql ts

    userTargetQualLevel (UserBuildTargetSingle _    ) = QL1
    userTargetQualLevel (UserBuildTargetDouble _ _  ) = QL2
    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3

    step  :: QualLevel -> [BuildTarget]
          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
    step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
            . partition (\g -> length g > 1)
            . groupBy (equating fst)
            . sortBy (comparing fst)
335
            . map (\t -> (renderBuildTarget ql t pkgid, t))
336 337 338 339

data QualLevel = QL1 | QL2 | QL3
  deriving (Enum, Show)

340 341
renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget ql target pkgid =
342 343 344 345 346 347 348 349 350
    case ql of
      QL1 -> UserBuildTargetSingle s1        where  s1          = single target
      QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target
      QL3 -> UserBuildTargetTriple s1 s2 s3  where (s1, s2, s3) = triple target

  where
    single (BuildTargetComponent cn  ) = dispCName cn
    single (BuildTargetModule    _  m) = display m
    single (BuildTargetFile      _  f) = f
351

352 353 354 355 356 357 358 359
    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)
    double (BuildTargetModule    cn m) = (dispCName cn, display m)
    double (BuildTargetFile      cn f) = (dispCName cn, f)

    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"
    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)
    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)

360
    dispCName = componentStringName pkgid
361 362
    dispKind  = showComponentKindShort . componentKind

363 364
reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems verbosity problems = do
365 366 367 368

    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
      []      -> return ()
      targets ->
369
        die' verbosity $ unlines
370 371 372 373 374 375 376 377 378
          [    "Unrecognised build target '" ++ showUserBuildTarget target
            ++ "'.\n"
            ++ "Expected a " ++ intercalate " or " expected
            ++ ", rather than '" ++ got ++ "'."
          | (target, expected, got) <- targets ]

    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of
      []      -> return ()
      targets ->
379
        die' verbosity $ unlines
380 381 382 383 384 385 386 387 388
          [    "Unknown build target '" ++ showUserBuildTarget target
            ++ "'.\nThere is no "
            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
                                  | (thing, got) <- nosuch ] ++ "."
          | (target, nosuch) <- targets ]
        where
          mungeThing "file" = "file target"
          mungeThing thing  = thing

RyanGlScott's avatar
RyanGlScott committed
389
    case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of
390 391
      []      -> return ()
      targets ->
392
        die' verbosity $ unlines
393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431
          [    "Ambiguous build target '" ++ showUserBuildTarget target
            ++ "'. It could be:\n "
            ++ unlines [ "   "++ showUserBuildTarget ut ++
                         " (" ++ showBuildTargetKind bt ++ ")"
                       | (ut, bt) <- amb ]
          | (target, amb) <- targets ]

  where
    showBuildTargetKind (BuildTargetComponent _  ) = "component"
    showBuildTargetKind (BuildTargetModule    _ _) = "module"
    showBuildTargetKind (BuildTargetFile      _ _) = "file"


----------------------------------
-- Top level BuildTarget matcher
--

matchBuildTarget :: PackageDescription
                 -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget pkg = \utarget fexists ->
    case utarget of
      UserBuildTargetSingle str1 ->
        matchBuildTarget1 cinfo str1 fexists

      UserBuildTargetDouble str1 str2 ->
        matchBuildTarget2 cinfo str1 str2 fexists

      UserBuildTargetTriple str1 str2 str3 ->
        matchBuildTarget3 cinfo str1 str2 str3 fexists
  where
    cinfo = pkgComponentInfo pkg

matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 cinfo str1 fexists =
                        matchComponent1 cinfo str1
   `matchPlusShadowing` matchModule1    cinfo str1
   `matchPlusShadowing` matchFile1      cinfo str1 fexists


432 433
matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
                  -> Match BuildTarget
434 435 436 437 438 439
matchBuildTarget2 cinfo str1 str2 fexists =
                        matchComponent2 cinfo str1 str2
   `matchPlusShadowing` matchModule2    cinfo str1 str2
   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists


440 441
matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
                  -> Match BuildTarget
442 443 444 445 446 447 448 449 450 451 452
matchBuildTarget3 cinfo str1 str2 str3 fexists =
                        matchModule3    cinfo str1 str2 str3
   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists


data ComponentInfo = ComponentInfo {
       cinfoName    :: ComponentName,
       cinfoStrName :: ComponentStringName,
       cinfoSrcDirs :: [FilePath],
       cinfoModules :: [ModuleName],
       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)
453
       cinfoAsmFiles:: [FilePath],
454
       cinfoCmmFiles:: [FilePath],
455 456
       cinfoCFiles  :: [FilePath],
       cinfoJsFiles :: [FilePath]
457 458 459 460 461 462 463 464
     }

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
    [ ComponentInfo {
        cinfoName    = componentName c,
465
        cinfoStrName = componentStringName pkg (componentName c),
466 467 468
        cinfoSrcDirs = hsSourceDirs bi,
        cinfoModules = componentModules c,
        cinfoHsFiles = componentHsFiles c,
469
        cinfoAsmFiles= asmSources bi,
470
        cinfoCmmFiles= cmmSources bi,
471 472
        cinfoCFiles  = cSources bi,
        cinfoJsFiles = jsSources bi
473 474 475 476
      }
    | c <- pkgComponents pkg
    , let bi = componentBuildInfo c ]

477 478
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg CLibName          = display (packageName pkg)
479 480 481 482 483
componentStringName _   (CSubLibName name) = unUnqualComponentName name
componentStringName _   (CFLibName  name) = unUnqualComponentName name
componentStringName _   (CExeName   name) = unUnqualComponentName name
componentStringName _   (CTestName  name) = unUnqualComponentName name
componentStringName _   (CBenchName name) = unUnqualComponentName name
484 485

componentModules :: Component -> [ModuleName]
486 487 488 489 490 491 492 493
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
-- a user could very well ask to build a specific signature
-- that was inherited from other packages.  To fix this
-- we have to plumb 'LocalBuildInfo' through this code.
-- Fortunately, this is only used by 'pkgComponentInfo' 
-- Please don't export this function unless you plan on fixing
-- this.
componentModules (CLib   lib)   = explicitLibModules lib
494
componentModules (CFLib  flib)  = foreignLibModules flib
495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516
componentModules (CExe   exe)   = exeModules exe
componentModules (CTest  test)  = testModules test
componentModules (CBench bench) = benchmarkModules bench

componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
componentHsFiles (CTest  TestSuite {
                           testInterface = TestSuiteExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles (CBench Benchmark {
                           benchmarkInterface = BenchmarkExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles _          = []

{-
ex_cs :: [ComponentInfo]
ex_cs =
  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])
  ]
    where
    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)
517
    mkMn :: String -> ModuleName
518 519 520 521 522 523 524 525 526
    mkMn  = fromJust . simpleParse
    pkgid :: PackageIdentifier
    Just pkgid = simpleParse "thelib"
-}

------------------------------
-- Matching component kinds
--

527
data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
528 529 530
  deriving (Eq, Ord, Show)

componentKind :: ComponentName -> ComponentKind
531 532
componentKind CLibName = LibKind
componentKind (CSubLibName _) = LibKind
533
componentKind (CFLibName  _) = FLibKind
534
componentKind (CExeName   _) = ExeKind
535 536 537 538 539 540 541 542
componentKind (CTestName  _) = TestKind
componentKind (CBenchName _) = BenchKind

cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = componentKind . cinfoName

matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
543
  | s `elem` ["lib", "library"]                 = return' LibKind
544
  | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind
545 546 547 548 549 550
  | s `elem` ["exe", "executable"]              = return' ExeKind
  | s `elem` ["tst", "test", "test-suite"]      = return' TestKind
  | s `elem` ["bench", "benchmark"]             = return' BenchKind
  | otherwise = matchErrorExpected "component kind" s
  where
    return' ck = increaseConfidence >> return ck
551 552 553

showComponentKind :: ComponentKind -> String
showComponentKind LibKind   = "library"
554
showComponentKind FLibKind  = "foreign-library"
555 556 557 558 559 560
showComponentKind ExeKind   = "executable"
showComponentKind TestKind  = "test-suite"
showComponentKind BenchKind = "benchmark"

showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind   = "lib"
561
showComponentKindShort FLibKind  = "flib"
562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591
showComponentKindShort ExeKind   = "exe"
showComponentKindShort TestKind  = "test"
showComponentKindShort BenchKind = "bench"

------------------------------
-- Matching component targets
--

matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 cs = \str1 -> do
    guardComponentName str1
    c <- matchComponentName cs str1
    return (BuildTargetComponent (cinfoName c))

matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 cs = \str1 str2 -> do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    return (BuildTargetComponent (cinfoName c))

-- utils:

guardComponentName :: String -> Match ()
guardComponentName s
  | all validComponentChar s
    && not (null s)  = increaseConfidence
  | otherwise        = matchErrorExpected "component name" s
  where
    validComponentChar c = isAlphaNum c || c == '.'
592
                        || c == '_' || c == '-' || c == '\''
593 594 595 596 597 598 599 600 601

matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName cs str =
    orNoSuchThing "component" str
  $ increaseConfidenceFor
  $ matchInexactly caseFold
      [ (cinfoStrName c, c) | c <- cs ]
      str

602 603
matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
                          -> Match ComponentInfo
604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633
matchComponentKindAndName cs ckind str =
    orNoSuchThing (showComponentKind ckind ++ " component") str
  $ increaseConfidenceFor
  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
      [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]
      (ckind, str)


------------------------------
-- Matching module targets
--

matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 cs = \str1 -> do
    guardModuleName str1
    nubMatchErrors $ do
      c <- tryEach cs
      let ms = cinfoModules c
      m <- matchModuleName ms str1
      return (BuildTargetModule (cinfoName c) m)

matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchModule2 cs = \str1 str2 -> do
    guardComponentName str1
    guardModuleName    str2
    c <- matchComponentName cs str1
    let ms = cinfoModules c
    m <- matchModuleName ms str2
    return (BuildTargetModule (cinfoName c) m)

634 635
matchModule3 :: [ComponentInfo] -> String -> String -> String
             -> Match BuildTarget
636 637 638 639 640 641 642 643 644 645 646 647 648
matchModule3 cs str1 str2 str3 = do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    guardModuleName    str3
    let ms = cinfoModules c
    m <- matchModuleName ms str3
    return (BuildTargetModule (cinfoName c) m)

-- utils:

guardModuleName :: String -> Match ()
guardModuleName s
649
  | all validModuleChar s
650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684
    && not (null s)       = increaseConfidence
  | otherwise             = matchErrorExpected "module name" s
  where
    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
    orNoSuchThing "module" str
  $ increaseConfidenceFor
  $ matchInexactly caseFold
      [ (display m, m)
      | m <- ms ]
      str


------------------------------
-- Matching file targets
--

matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 cs str1 exists =
    nubMatchErrors $ do
      c <- tryEach cs
      filepath <- matchComponentFile c str1 exists
      return (BuildTargetFile (cinfoName c) filepath)


matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 cs str1 str2 exists = do
    guardComponentName str1
    c <- matchComponentName cs str1
    filepath <- matchComponentFile c str2 exists
    return (BuildTargetFile (cinfoName c) filepath)


685 686
matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
           -> Match BuildTarget
687 688 689 690 691 692 693 694 695 696 697 698 699 700
matchFile3 cs str1 str2 str3 exists = do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    filepath <- matchComponentFile c str3 exists
    return (BuildTargetFile (cinfoName c) filepath)


matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile c str fexists =
    expecting "file" str $
      matchPlus
        (matchFileExists str fexists)
        (matchPlusShadowing
701
          (msum [ matchModuleFileRooted   dirs ms      str
702 703 704
                , matchOtherFileRooted    dirs hsFiles str ])
          (msum [ matchModuleFileUnrooted      ms      str
                , matchOtherFileUnrooted       hsFiles str
705 706
                , matchOtherFileUnrooted       cFiles  str
                , matchOtherFileUnrooted       jsFiles str ]))
707 708 709 710 711
  where
    dirs = cinfoSrcDirs c
    ms   = cinfoModules c
    hsFiles = cinfoHsFiles c
    cFiles  = cinfoCFiles c
712
    jsFiles = cinfoJsFiles c
713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774


-- utils

matchFileExists :: FilePath -> Bool -> Match a
matchFileExists _     False = mzero
matchFileExists fname True  = do increaseConfidence
                                 matchErrorNoSuch "file" fname

matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted ms str = do
    let filepath = normalise str
    _ <- matchModuleFileStem ms filepath
    return filepath

matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted dirs ms str = nubMatches $ do
    let filepath = normalise str
    filepath' <- matchDirectoryPrefix dirs filepath
    _ <- matchModuleFileStem ms filepath'
    return filepath

matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem ms =
      increaseConfidenceFor
    . matchInexactly caseFold
        [ (toFilePath m, m) | m <- ms ]
    . dropExtension

matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted dirs fs str = do
    let filepath = normalise str
    filepath' <- matchDirectoryPrefix dirs filepath
    _ <- matchFile fs filepath'
    return filepath

matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted fs str = do
    let filepath = normalise str
    _ <- matchFile fs filepath
    return filepath

matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile fs = increaseConfidenceFor
             . matchInexactly caseFold [ (f, f) | f <- fs ]

matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix dirs filepath =
    exactMatches $
      catMaybes
       [ stripDirectory (normalise dir) filepath | dir <- dirs ]
  where
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
    stripDirectory dir fp =
      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)


------------------------------
-- Matching monad
--

-- | A matcher embodies a way to match some input as being some recognised
RyanGlScott's avatar
RyanGlScott committed
775
-- value. In particular it deals with multiple and ambiguous matches.
776 777
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
RyanGlScott's avatar
RyanGlScott committed
778
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
779 780 781 782 783 784 785 786 787 788 789 790 791 792 793
-- run a matcher against an input using 'findMatch'.
--

data Match a = NoMatch      Confidence [MatchError]
             | ExactMatch   Confidence [a]
             | InexactMatch Confidence [a]
  deriving Show

type Confidence = Int

data MatchError = MatchErrorExpected String String
                | MatchErrorNoSuch   String String
  deriving (Show, Eq)


quchen's avatar
quchen committed
794 795 796 797
instance Alternative Match where
      empty = mzero
      (<|>) = mplus

798 799 800 801 802 803 804 805 806
instance MonadPlus Match where
  mzero = matchZero
  mplus = matchPlus

matchZero :: Match a
matchZero = NoMatch 0 []

-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
RyanGlScott's avatar
RyanGlScott committed
807
-- ambiguous matches.
808 809
--
matchPlus :: Match a -> Match a -> Match a
810 811
matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =
  ExactMatch (max d1 d2) (xs ++ xs')
812 813 814
matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a
matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a
matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b
815 816
matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =
  InexactMatch (max d1 d2) (xs ++ xs')
817 818 819 820 821 822 823 824
matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a
matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b
matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b
matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')
                                             | d1 >  d2  = a
                                             | d1 <  d2  = b
                                             | otherwise = NoMatch d1 (ms ++ ms')

RyanGlScott's avatar
RyanGlScott committed
825
-- | Combine two matchers. This is similar to 'ambiguousWith' with the
826 827 828 829 830
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
--
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
831
matchPlusShadowing a                   b               = matchPlus a b
832 833 834 835 836 837

instance Functor Match where
  fmap _ (NoMatch      d ms) = NoMatch      d ms
  fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)
  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)

838
instance Applicative Match where
839
  pure a = ExactMatch 0 [a]
840 841
  (<*>) = ap

842
instance Monad Match where
843
  return = pure
844

845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913
  NoMatch      d ms >>= _ = NoMatch d ms
  ExactMatch   d xs >>= f = addDepth d
                          $ foldr matchPlus matchZero (map f xs)
  InexactMatch d xs >>= f = addDepth d .  forceInexact
                          $ foldr matchPlus matchZero (map f xs)

addDepth :: Confidence -> Match a -> Match a
addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs
addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs
addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs

forceInexact :: Match a -> Match a
forceInexact (ExactMatch d ys) = InexactMatch d ys
forceInexact m                 = m

------------------------------
-- Various match primitives
--

matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
matchErrorNoSuch   thing got = NoMatch 0 [MatchErrorNoSuch   thing got]

expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
expecting _     _   m             = m

orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
orNoSuchThing _     _   m             = m

increaseConfidence :: Match ()
increaseConfidence = ExactMatch 1 [()]

increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r

nubMatches :: Eq a => Match a -> Match a
nubMatches (NoMatch      d msgs) = NoMatch      d msgs
nubMatches (ExactMatch   d xs)   = ExactMatch   d (nub xs)
nubMatches (InexactMatch d xs)   = InexactMatch d (nub xs)

nubMatchErrors :: Match a -> Match a
nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)
nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs
nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs

-- | Lift a list of matches to an exact match.
--
exactMatches, inexactMatches :: [a] -> Match a

exactMatches [] = matchZero
exactMatches xs = ExactMatch 0 xs

inexactMatches [] = matchZero
inexactMatches xs = InexactMatch 0 xs

tryEach :: [a] -> Match a
tryEach = exactMatches


------------------------------
-- Top level match runner
--

-- | Given a matcher and a key to look up, use the matcher to find all the
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
--
RyanGlScott's avatar
RyanGlScott committed
914
findMatch :: Eq b => Match b -> MaybeAmbiguous b
915 916 917
findMatch match =
    case match of
      NoMatch    _ msgs -> None (nub msgs)
RyanGlScott's avatar
RyanGlScott committed
918 919
      ExactMatch   _ xs -> checkAmbiguous xs
      InexactMatch _ xs -> checkAmbiguous xs
920
  where
RyanGlScott's avatar
RyanGlScott committed
921
    checkAmbiguous xs = case nub xs of
922 923 924
                          [x] -> Unambiguous x
                          xs' -> Ambiguous   xs'

RyanGlScott's avatar
RyanGlScott committed
925
data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955
  deriving Show


------------------------------
-- Basic matchers
--

{-
-- | A primitive matcher that looks up a value in a finite 'Map'. The
-- value must match exactly.
--
matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
matchExactly xs =
    \x -> case Map.lookup x m of
            Nothing -> matchZero
            Just ys -> ExactMatch 0 ys
  where
    m :: Ord a => Map a [b]
    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
-}

-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
-- is not exact, but the canonical forms match. It takes a canonicalisation
-- function for this purpose.
--
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
--
Ben Millwood's avatar
Ben Millwood committed
956
matchInexactly :: (Ord a, Ord a') =>
957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978
                        (a -> a') ->
                        [(a, b)] -> (a -> Match b)
matchInexactly cannonicalise xs =
    \x -> case Map.lookup x m of
            Just ys -> exactMatches ys
            Nothing -> case Map.lookup (cannonicalise x) m' of
                         Just ys -> inexactMatches ys
                         Nothing -> matchZero
  where
    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]

    -- the map of canonicalised keys to groups of inexact matches
    m' = Map.mapKeysWith (++) cannonicalise m



------------------------------
-- Utils
--

caseFold :: String -> String
caseFold = lowercase
979 980 981 982 983 984


-- | Check that the given build targets are valid in the current context.
--
-- Also swizzle into a more convenient form.
--
985
checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
986
                  -> IO [TargetInfo]
987 988
checkBuildTargets _ pkg_descr lbi []      =
    return (allTargetsInBuildOrder' pkg_descr lbi)
989

990
checkBuildTargets verbosity pkg_descr lbi targets = do
991 992 993

    let (enabled, disabled) =
          partitionEithers
994
            [ case componentDisabledReason (componentEnabledSpec lbi) comp of
995 996 997
                Nothing     -> Left  target'
                Just reason -> Right (cname, reason)
            | target <- targets
998 999
            , let target'@(cname,_) = swizzleTarget target
            , let comp = getComponent pkg_descr cname ]
1000 1001 1002

    case disabled of
      []                 -> return ()
1003
      ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason
1004

1005
    for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->
1006 1007 1008 1009
      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "
                    ++ showComponentName c ++ " will be processed. (Support for "
                    ++ "module and file targets has not been implemented yet.)"

1010
    -- Pick out the actual CLBIs for each of these cnames
1011
    enabled' <- for enabled $ \(cname, _) -> do
1012 1013 1014 1015
        case componentNameTargets' pkg_descr lbi cname of
            [] -> error "checkBuildTargets: nothing enabled"
            [target] -> return target
            _targets -> error "checkBuildTargets: multiple copies enabled"
1016 1017

    return enabled'
1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032

  where
    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)
    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))
    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))

    formatReason cn DisabledComponent =
        "Cannot process the " ++ cn ++ " because the component is marked "
     ++ "as disabled in the .cabal file."
    formatReason cn DisabledAllTests =
        "Cannot process the " ++ cn ++ " because test suites are not "
     ++ "enabled. Run configure with the flag --enable-tests"
    formatReason cn DisabledAllBenchmarks =
        "Cannot process the " ++ cn ++ " because benchmarks are not "
     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
1033 1034 1035 1036
    formatReason cn (DisabledAllButOne cn') =
        "Cannot process the " ++ cn ++ " because this package was "
     ++ "configured only to build " ++ cn' ++ ". Re-run configure "
     ++ "with the argument " ++ cn