{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- 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 (
    -- * Main interface
    readTargetInfos,
    readBuildTargets, -- in case you don't have LocalBuildInfo

    -- * Build targets
    BuildTarget(..),
    showBuildTarget,
    QualLevel(..),
    buildTargetComponentName,

    -- * Parsing user build targets
    UserBuildTarget,
    readUserBuildTargets,
    showUserBuildTarget,
    UserBuildTargetProblem(..),
    reportUserBuildTargetProblems,

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

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.TargetInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName

import Distribution.Package
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Utils.Path

import qualified Distribution.Compat.CharParsing as P

import Control.Monad ( msum )
import Data.List ( stripPrefix, groupBy )
import qualified Data.List.NonEmpty as NE
import System.FilePath as FilePath
         ( dropExtension, normalise, splitDirectories, joinPath, splitPath
         , hasTrailingPathSeparator )
import System.Directory ( doesFileExist, doesDirectoryExist )
import qualified Data.Map as Map

-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [FilePath]
-> IO [TargetInfo]
readTargetInfos Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi [FilePath]
args = do
    [BuildTarget]
build_targets <- Verbosity -> PackageDescription -> [FilePath] -> IO [BuildTarget]
readBuildTargets Verbosity
verbosity PackageDescription
pkg_descr [FilePath]
args
    Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [BuildTarget]
-> IO [TargetInfo]
checkBuildTargets Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi [BuildTarget]
build_targets

-- ------------------------------------------------------------
-- * User build targets
-- ------------------------------------------------------------

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

     -- | 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

     -- | A fully qualified target, either a module or file qualified by a
     -- 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 (Int -> UserBuildTarget -> ShowS
[UserBuildTarget] -> ShowS
UserBuildTarget -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UserBuildTarget] -> ShowS
$cshowList :: [UserBuildTarget] -> ShowS
show :: UserBuildTarget -> FilePath
$cshow :: UserBuildTarget -> FilePath
showsPrec :: Int -> UserBuildTarget -> ShowS
$cshowsPrec :: Int -> UserBuildTarget -> ShowS
Show, UserBuildTarget -> UserBuildTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserBuildTarget -> UserBuildTarget -> Bool
$c/= :: UserBuildTarget -> UserBuildTarget -> Bool
== :: UserBuildTarget -> UserBuildTarget -> Bool
$c== :: UserBuildTarget -> UserBuildTarget -> Bool
Eq, Eq UserBuildTarget
UserBuildTarget -> UserBuildTarget -> Bool
UserBuildTarget -> UserBuildTarget -> Ordering
UserBuildTarget -> UserBuildTarget -> UserBuildTarget
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmin :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
max :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmax :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
>= :: UserBuildTarget -> UserBuildTarget -> Bool
$c>= :: UserBuildTarget -> UserBuildTarget -> Bool
> :: UserBuildTarget -> UserBuildTarget -> Bool
$c> :: UserBuildTarget -> UserBuildTarget -> Bool
<= :: UserBuildTarget -> UserBuildTarget -> Bool
$c<= :: UserBuildTarget -> UserBuildTarget -> Bool
< :: UserBuildTarget -> UserBuildTarget -> Bool
$c< :: UserBuildTarget -> UserBuildTarget -> Bool
compare :: UserBuildTarget -> UserBuildTarget -> Ordering
$ccompare :: UserBuildTarget -> UserBuildTarget -> Ordering
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
  deriving (BuildTarget -> BuildTarget -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildTarget -> BuildTarget -> Bool
$c/= :: BuildTarget -> BuildTarget -> Bool
== :: BuildTarget -> BuildTarget -> Bool
$c== :: BuildTarget -> BuildTarget -> Bool
Eq, Int -> BuildTarget -> ShowS
[BuildTarget] -> ShowS
BuildTarget -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BuildTarget] -> ShowS
$cshowList :: [BuildTarget] -> ShowS
show :: BuildTarget -> FilePath
$cshow :: BuildTarget -> FilePath
showsPrec :: Int -> BuildTarget -> ShowS
$cshowsPrec :: Int -> BuildTarget -> ShowS
Show, forall x. Rep BuildTarget x -> BuildTarget
forall x. BuildTarget -> Rep BuildTarget x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BuildTarget x -> BuildTarget
$cfrom :: forall x. BuildTarget -> Rep BuildTarget x
Generic)

instance Binary BuildTarget

buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent ComponentName
cn)   = ComponentName
cn
buildTargetComponentName (BuildTargetModule    ComponentName
cn ModuleName
_) = ComponentName
cn
buildTargetComponentName (BuildTargetFile      ComponentName
cn FilePath
_) = ComponentName
cn

-- | 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'.
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets :: Verbosity -> PackageDescription -> [FilePath] -> IO [BuildTarget]
readBuildTargets Verbosity
verbosity PackageDescription
pkg [FilePath]
targetStrs = do
    let ([UserBuildTargetProblem]
uproblems, [UserBuildTarget]
utargets) = [FilePath] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets [FilePath]
targetStrs
    Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems Verbosity
verbosity [UserBuildTargetProblem]
uproblems

    [(UserBuildTarget, Bool)]
utargets' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile [UserBuildTarget]
utargets

    let ([BuildTargetProblem]
bproblems, [BuildTarget]
btargets) = PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets PackageDescription
pkg [(UserBuildTarget, Bool)]
utargets'
    Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems Verbosity
verbosity [BuildTargetProblem]
bproblems

    forall (m :: * -> *) a. Monad m => a -> m a
return [BuildTarget]
btargets

checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile UserBuildTarget
t = do
    Bool
fexists <- FilePath -> IO Bool
existsAsFile (UserBuildTarget -> FilePath
fileComponentOfTarget UserBuildTarget
t)
    forall (m :: * -> *) a. Monad m => a -> m a
return (UserBuildTarget
t, Bool
fexists)

  where
    existsAsFile :: FilePath -> IO Bool
existsAsFile FilePath
f = do
      Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
f
      case FilePath -> [FilePath]
splitPath FilePath
f of
        (FilePath
d:[FilePath]
_)   | FilePath -> Bool
hasTrailingPathSeparator FilePath
d -> FilePath -> IO Bool
doesDirectoryExist FilePath
d
        (FilePath
d:FilePath
_:[FilePath]
_) | Bool -> Bool
not Bool
exists                 -> FilePath -> IO Bool
doesDirectoryExist FilePath
d
        [FilePath]
_                                    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
exists

    fileComponentOfTarget :: UserBuildTarget -> FilePath
fileComponentOfTarget (UserBuildTargetSingle     FilePath
s1) = FilePath
s1
    fileComponentOfTarget (UserBuildTargetDouble FilePath
_   FilePath
s2) = FilePath
s2
    fileComponentOfTarget (UserBuildTargetTriple FilePath
_ FilePath
_ FilePath
s3) = FilePath
s3


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

readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
                                    ,[UserBuildTarget])
readUserBuildTargets :: [FilePath] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Either UserBuildTargetProblem UserBuildTarget
readUserBuildTarget

-- |
--
-- >>> readUserBuildTarget "comp"
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:comp"
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp"
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "\"comp\""
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:\"comp\""
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:\"comp\""
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp:more"
-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")
--
-- >>> readUserBuildTarget "pkg:\"lib\":comp"
-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")
--
readUserBuildTarget :: String -> Either UserBuildTargetProblem
                                        UserBuildTarget
readUserBuildTarget :: FilePath -> Either UserBuildTargetProblem UserBuildTarget
readUserBuildTarget FilePath
targetstr =
    case forall a. ParsecParser a -> FilePath -> Either FilePath a
explicitEitherParsec forall (m :: * -> *). CabalParsing m => m UserBuildTarget
parseTargetApprox FilePath
targetstr of
      Left FilePath
_    -> forall a b. a -> Either a b
Left  (FilePath -> UserBuildTargetProblem
UserBuildTargetUnrecognised FilePath
targetstr)
      Right UserBuildTarget
tgt -> forall a b. b -> Either a b
Right UserBuildTarget
tgt

  where
    parseTargetApprox :: CabalParsing m => m UserBuildTarget
    parseTargetApprox :: forall (m :: * -> *). CabalParsing m => m UserBuildTarget
parseTargetApprox = do
        -- read one, two, or three tokens, where last could be "hs-string"
        (FilePath, Maybe (FilePath, Maybe FilePath))
ts <- forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe (FilePath, Maybe FilePath))
tokens
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case (FilePath, Maybe (FilePath, Maybe FilePath))
ts of
            (FilePath
a, Maybe (FilePath, Maybe FilePath)
Nothing)           -> FilePath -> UserBuildTarget
UserBuildTargetSingle FilePath
a
            (FilePath
a, Just (FilePath
b, Maybe FilePath
Nothing)) -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetDouble FilePath
a FilePath
b
            (FilePath
a, Just (FilePath
b, Just FilePath
c))  -> FilePath -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetTriple FilePath
a FilePath
b FilePath
c

    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
    tokens :: forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe (FilePath, Maybe FilePath))
tokens = (\FilePath
s -> (FilePath
s, forall a. Maybe a
Nothing)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FilePath
token forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe FilePath)
tokens2)

    tokens2 :: CabalParsing m => m (String, Maybe String)
    tokens2 :: forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe FilePath)
tokens2 = (\FilePath
s -> (FilePath
s, forall a. Maybe a
Nothing)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). CabalParsing m => m FilePath
token forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). CabalParsing m => m FilePath
token))

    token :: CabalParsing m => m String
    token :: forall (m :: * -> *). CabalParsing m => m FilePath
token  = forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m FilePath
P.munch1 (\Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x forall a. Eq a => a -> a -> Bool
/= Char
':')

data UserBuildTargetProblem
   = UserBuildTargetUnrecognised String
  deriving Int -> UserBuildTargetProblem -> ShowS
[UserBuildTargetProblem] -> ShowS
UserBuildTargetProblem -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [UserBuildTargetProblem] -> ShowS
$cshowList :: [UserBuildTargetProblem] -> ShowS
show :: UserBuildTargetProblem -> FilePath
$cshow :: UserBuildTargetProblem -> FilePath
showsPrec :: Int -> UserBuildTargetProblem -> ShowS
$cshowsPrec :: Int -> UserBuildTargetProblem -> ShowS
Show

reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems Verbosity
verbosity [UserBuildTargetProblem]
problems = do
    case [ FilePath
target | UserBuildTargetUnrecognised FilePath
target <- [UserBuildTargetProblem]
problems ] of
      []     -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [FilePath]
target ->
        forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
                [ FilePath
"Unrecognised build target '" forall a. [a] -> [a] -> [a]
++ FilePath
name forall a. [a] -> [a] -> [a]
++ FilePath
"'."
                | FilePath
name <- [FilePath]
target ]
           forall a. [a] -> [a] -> [a]
++ FilePath
"Examples:\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo          -- component name "
           forall a. [a] -> [a] -> [a]
++ FilePath
"(library, executable, test-suite or benchmark)\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build Data.Foo     -- module name\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build Data/Foo.hsc -- file name\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build lib:foo exe:foo   -- component qualified by kind\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo:Data.Foo      -- module qualified by component\n"
           forall a. [a] -> [a] -> [a]
++ FilePath
" - build foo:Data/Foo.hsc  -- file qualified by component"

showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget :: UserBuildTarget -> FilePath
showUserBuildTarget = forall a. [a] -> [[a]] -> [a]
intercalate FilePath
":" forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserBuildTarget -> [FilePath]
getComponents
  where
    getComponents :: UserBuildTarget -> [FilePath]
getComponents (UserBuildTargetSingle FilePath
s1)       = [FilePath
s1]
    getComponents (UserBuildTargetDouble FilePath
s1 FilePath
s2)    = [FilePath
s1,FilePath
s2]
    getComponents (UserBuildTargetTriple FilePath
s1 FilePath
s2 FilePath
s3) = [FilePath
s1,FilePath
s2,FilePath
s3]

-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> FilePath
showBuildTarget' QualLevel
ql PackageId
pkgid BuildTarget
bt =
    UserBuildTarget -> FilePath
showUserBuildTarget (QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
bt PackageId
pkgid)

-- | Unambiguously render a 'BuildTarget', so that it can
-- be parsed in all situations.
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget :: PackageId -> BuildTarget -> FilePath
showBuildTarget PackageId
pkgid BuildTarget
t =
    QualLevel -> PackageId -> BuildTarget -> FilePath
showBuildTarget' (BuildTarget -> QualLevel
qlBuildTarget BuildTarget
t) PackageId
pkgid BuildTarget
t
  where
    qlBuildTarget :: BuildTarget -> QualLevel
qlBuildTarget BuildTargetComponent{} = QualLevel
QL2
    qlBuildTarget BuildTarget
_                      = QualLevel
QL3


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

{-
stargets =
  [ BuildTargetComponent (CExeName "foo")
  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")
  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")
  ]
    where
    mkMn :: String -> ModuleName
    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 :: PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets PackageDescription
pkg = forall a b. [Either a b] -> ([a], [b])
partitionEithers
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (PackageDescription
-> UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget
resolveBuildTarget PackageDescription
pkg))

resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
                   -> Either BuildTargetProblem BuildTarget
resolveBuildTarget :: PackageDescription
-> UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget
resolveBuildTarget PackageDescription
pkg UserBuildTarget
userTarget Bool
fexists =
    case forall b. Eq b => Match b -> MaybeAmbiguous b
findMatch (PackageDescription -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget PackageDescription
pkg UserBuildTarget
userTarget Bool
fexists) of
      Unambiguous BuildTarget
target  -> forall a b. b -> Either a b
Right BuildTarget
target
      Ambiguous   [BuildTarget]
targets -> forall a b. a -> Either a b
Left (UserBuildTarget
-> [(UserBuildTarget, BuildTarget)] -> BuildTargetProblem
BuildTargetAmbiguous UserBuildTarget
userTarget [(UserBuildTarget, BuildTarget)]
targets')
                               where targets' :: [(UserBuildTarget, BuildTarget)]
targets' = PackageId
-> UserBuildTarget
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets
                                                    (forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg)
                                                    UserBuildTarget
userTarget
                                                    [BuildTarget]
targets
      None        [MatchError]
errs    -> forall a b. a -> Either a b
Left ([MatchError] -> BuildTargetProblem
classifyMatchErrors [MatchError]
errs)

  where
    classifyMatchErrors :: [MatchError] -> BuildTargetProblem
classifyMatchErrors [MatchError]
errs
      | Just NonEmpty (FilePath, FilePath)
expected' <- forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(FilePath, FilePath)]
expected
                            = let (NonEmpty FilePath
things, FilePath
got:|[FilePath]
_) = forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip NonEmpty (FilePath, FilePath)
expected' in
                              UserBuildTarget -> [FilePath] -> FilePath -> BuildTargetProblem
BuildTargetExpected UserBuildTarget
userTarget (forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
things) FilePath
got
      | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, FilePath)]
nosuch)   = UserBuildTarget -> [(FilePath, FilePath)] -> BuildTargetProblem
BuildTargetNoSuch   UserBuildTarget
userTarget [(FilePath, FilePath)]
nosuch
      | Bool
otherwise = forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"resolveBuildTarget: internal error in matching"
      where
        expected :: [(FilePath, FilePath)]
expected = [ (FilePath
thing, FilePath
got) | MatchErrorExpected FilePath
thing FilePath
got <- [MatchError]
errs ]
        nosuch :: [(FilePath, FilePath)]
nosuch   = [ (FilePath
thing, FilePath
got) | MatchErrorNoSuch   FilePath
thing FilePath
got <- [MatchError]
errs ]


data BuildTargetProblem
   = BuildTargetExpected  UserBuildTarget [String]  String
     -- ^  [expected thing] (actually got)
   | BuildTargetNoSuch    UserBuildTarget [(String, String)]
     -- ^ [(no such thing,  actually got)]
   | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
  deriving Int -> BuildTargetProblem -> ShowS
[BuildTargetProblem] -> ShowS
BuildTargetProblem -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [BuildTargetProblem] -> ShowS
$cshowList :: [BuildTargetProblem] -> ShowS
show :: BuildTargetProblem -> FilePath
$cshow :: BuildTargetProblem -> FilePath
showsPrec :: Int -> BuildTargetProblem -> ShowS
$cshowsPrec :: Int -> BuildTargetProblem -> ShowS
Show


disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
                         -> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets :: PackageId
-> UserBuildTarget
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets PackageId
pkgid UserBuildTarget
original =
    QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (UserBuildTarget -> QualLevel
userTargetQualLevel UserBuildTarget
original)
  where
    disambiguate :: QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate QualLevel
ql [BuildTarget]
ts
        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BuildTarget]
amb  = [(UserBuildTarget, BuildTarget)]
unamb
        | Bool
otherwise = [(UserBuildTarget, BuildTarget)]
unamb forall a. [a] -> [a] -> [a]
++ QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (forall a. Enum a => a -> a
succ QualLevel
ql) [BuildTarget]
amb
      where
        ([BuildTarget]
amb, [(UserBuildTarget, BuildTarget)]
unamb) = QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step QualLevel
ql [BuildTarget]
ts

    userTargetQualLevel :: UserBuildTarget -> QualLevel
userTargetQualLevel (UserBuildTargetSingle FilePath
_    ) = QualLevel
QL1
    userTargetQualLevel (UserBuildTargetDouble FilePath
_ FilePath
_  ) = QualLevel
QL2
    userTargetQualLevel (UserBuildTargetTriple FilePath
_ FilePath
_ FilePath
_) = QualLevel
QL3

    step  :: QualLevel -> [BuildTarget]
          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
    step :: QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step QualLevel
ql = (\([[(UserBuildTarget, BuildTarget)]]
amb, [[(UserBuildTarget, BuildTarget)]]
unamb) -> (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
amb, forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
unamb))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(UserBuildTarget, BuildTarget)]
g -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UserBuildTarget, BuildTarget)]
g forall a. Ord a => a -> a -> Bool
> Int
1)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating forall a b. (a, b) -> a
fst)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\BuildTarget
t -> (QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
t PackageId
pkgid, BuildTarget
t))

data QualLevel = QL1 | QL2 | QL3
  deriving (Int -> QualLevel
QualLevel -> Int
QualLevel -> [QualLevel]
QualLevel -> QualLevel
QualLevel -> QualLevel -> [QualLevel]
QualLevel -> QualLevel -> QualLevel -> [QualLevel]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
$cenumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
enumFromTo :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromTo :: QualLevel -> QualLevel -> [QualLevel]
enumFromThen :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromThen :: QualLevel -> QualLevel -> [QualLevel]
enumFrom :: QualLevel -> [QualLevel]
$cenumFrom :: QualLevel -> [QualLevel]
fromEnum :: QualLevel -> Int
$cfromEnum :: QualLevel -> Int
toEnum :: Int -> QualLevel
$ctoEnum :: Int -> QualLevel
pred :: QualLevel -> QualLevel
$cpred :: QualLevel -> QualLevel
succ :: QualLevel -> QualLevel
$csucc :: QualLevel -> QualLevel
Enum, Int -> QualLevel -> ShowS
[QualLevel] -> ShowS
QualLevel -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [QualLevel] -> ShowS
$cshowList :: [QualLevel] -> ShowS
show :: QualLevel -> FilePath
$cshow :: QualLevel -> FilePath
showsPrec :: Int -> QualLevel -> ShowS
$cshowsPrec :: Int -> QualLevel -> ShowS
Show)

renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
target PackageId
pkgid =
    case QualLevel
ql of
      QualLevel
QL1 -> FilePath -> UserBuildTarget
UserBuildTargetSingle FilePath
s1        where  s1 :: FilePath
s1          = BuildTarget -> FilePath
single BuildTarget
target
      QualLevel
QL2 -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetDouble FilePath
s1 FilePath
s2     where (FilePath
s1, FilePath
s2)     = BuildTarget -> (FilePath, FilePath)
double BuildTarget
target
      QualLevel
QL3 -> FilePath -> FilePath -> FilePath -> UserBuildTarget
UserBuildTargetTriple FilePath
s1 FilePath
s2 FilePath
s3  where (FilePath
s1, FilePath
s2, FilePath
s3) = BuildTarget -> (FilePath, FilePath, FilePath)
triple BuildTarget
target

  where
    single :: BuildTarget -> FilePath
single (BuildTargetComponent ComponentName
cn  ) = ComponentName -> FilePath
dispCName ComponentName
cn
    single (BuildTargetModule    ComponentName
_  ModuleName
m) = forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m
    single (BuildTargetFile      ComponentName
_  FilePath
f) = FilePath
f

    double :: BuildTarget -> (FilePath, FilePath)
double (BuildTargetComponent ComponentName
cn  ) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn)
    double (BuildTargetModule    ComponentName
cn ModuleName
m) = (ComponentName -> FilePath
dispCName ComponentName
cn, forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m)
    double (BuildTargetFile      ComponentName
cn FilePath
f) = (ComponentName -> FilePath
dispCName ComponentName
cn, FilePath
f)

    triple :: BuildTarget -> (FilePath, FilePath, FilePath)
triple (BuildTargetComponent ComponentName
_   ) = forall a. HasCallStack => FilePath -> a
error FilePath
"triple BuildTargetComponent"
    triple (BuildTargetModule    ComponentName
cn ModuleName
m) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn, forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m)
    triple (BuildTargetFile      ComponentName
cn FilePath
f) = (ComponentName -> FilePath
dispKind ComponentName
cn, ComponentName -> FilePath
dispCName ComponentName
cn, FilePath
f)

    dispCName :: ComponentName -> FilePath
dispCName = forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageId
pkgid
    dispKind :: ComponentName -> FilePath
dispKind  = ComponentKind -> FilePath
showComponentKindShort forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> ComponentKind
componentKind

reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems Verbosity
verbosity [BuildTargetProblem]
problems = do

    case [ (UserBuildTarget
t, [FilePath]
e, FilePath
g) | BuildTargetExpected UserBuildTarget
t [FilePath]
e FilePath
g <- [BuildTargetProblem]
problems ] of
      []      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(UserBuildTarget, [FilePath], FilePath)]
targets ->
        forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
          [    FilePath
"Unrecognised build target '" forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            forall a. [a] -> [a] -> [a]
++ FilePath
"'.\n"
            forall a. [a] -> [a] -> [a]
++ FilePath
"Expected a " forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" or " [FilePath]
expected
            forall a. [a] -> [a] -> [a]
++ FilePath
", rather than '" forall a. [a] -> [a] -> [a]
++ FilePath
got forall a. [a] -> [a] -> [a]
++ FilePath
"'."
          | (UserBuildTarget
target, [FilePath]
expected, FilePath
got) <- [(UserBuildTarget, [FilePath], FilePath)]
targets ]

    case [ (UserBuildTarget
t, [(FilePath, FilePath)]
e) | BuildTargetNoSuch UserBuildTarget
t [(FilePath, FilePath)]
e <- [BuildTargetProblem]
problems ] of
      []      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(UserBuildTarget, [(FilePath, FilePath)])]
targets ->
        forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
          [    FilePath
"Unknown build target '" forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            forall a. [a] -> [a] -> [a]
++ FilePath
"'.\nThere is no "
            forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
" or " [ ShowS
mungeThing FilePath
thing forall a. [a] -> [a] -> [a]
++ FilePath
" '" forall a. [a] -> [a] -> [a]
++ FilePath
got forall a. [a] -> [a] -> [a]
++ FilePath
"'"
                                  | (FilePath
thing, FilePath
got) <- [(FilePath, FilePath)]
nosuch ] forall a. [a] -> [a] -> [a]
++ FilePath
"."
          | (UserBuildTarget
target, [(FilePath, FilePath)]
nosuch) <- [(UserBuildTarget, [(FilePath, FilePath)])]
targets ]
        where
          mungeThing :: ShowS
mungeThing FilePath
"file" = FilePath
"file target"
          mungeThing FilePath
thing  = FilePath
thing

    case [ (UserBuildTarget
t, [(UserBuildTarget, BuildTarget)]
ts) | BuildTargetAmbiguous UserBuildTarget
t [(UserBuildTarget, BuildTarget)]
ts <- [BuildTargetProblem]
problems ] of
      []      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets ->
        forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
          [    FilePath
"Ambiguous build target '" forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
            forall a. [a] -> [a] -> [a]
++ FilePath
"'. It could be:\n "
            forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unlines [ FilePath
"   "forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
ut forall a. [a] -> [a] -> [a]
++
                         FilePath
" (" forall a. [a] -> [a] -> [a]
++ BuildTarget -> FilePath
showBuildTargetKind BuildTarget
bt forall a. [a] -> [a] -> [a]
++ FilePath
")"
                       | (UserBuildTarget
ut, BuildTarget
bt) <- [(UserBuildTarget, BuildTarget)]
amb ]
          | (UserBuildTarget
target, [(UserBuildTarget, BuildTarget)]
amb) <- [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets ]

  where
    showBuildTargetKind :: BuildTarget -> FilePath
showBuildTargetKind (BuildTargetComponent ComponentName
_  ) = FilePath
"component"
    showBuildTargetKind (BuildTargetModule    ComponentName
_ ModuleName
_) = FilePath
"module"
    showBuildTargetKind (BuildTargetFile      ComponentName
_ FilePath
_) = FilePath
"file"


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

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

      UserBuildTargetDouble FilePath
str1 FilePath
str2 ->
        [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists

      UserBuildTargetTriple FilePath
str1 FilePath
str2 FilePath
str3 ->
        [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists
  where
    cinfo :: [ComponentInfo]
cinfo = PackageDescription -> [ComponentInfo]
pkgComponentInfo PackageDescription
pkg

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


matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
                  -> Match BuildTarget
matchBuildTarget2 :: [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists =
                        [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchComponent2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2
   forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchModule2    [ComponentInfo]
cinfo FilePath
str1 FilePath
str2
   forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile2      [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 Bool
fexists


matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
                  -> Match BuildTarget
matchBuildTarget3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchBuildTarget3 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists =
                        [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Match BuildTarget
matchModule3    [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3
   forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile3      [ComponentInfo]
cinfo FilePath
str1 FilePath
str2 FilePath
str3 Bool
fexists


data ComponentInfo = ComponentInfo {
       ComponentInfo -> ComponentName
cinfoName    :: ComponentName,
       ComponentInfo -> FilePath
cinfoStrName :: ComponentStringName,
       ComponentInfo -> [FilePath]
cinfoSrcDirs :: [FilePath],
       ComponentInfo -> [ModuleName]
cinfoModules :: [ModuleName],
       ComponentInfo -> [FilePath]
cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)
       ComponentInfo -> [FilePath]
cinfoAsmFiles:: [FilePath],
       ComponentInfo -> [FilePath]
cinfoCmmFiles:: [FilePath],
       ComponentInfo -> [FilePath]
cinfoCFiles  :: [FilePath],
       ComponentInfo -> [FilePath]
cinfoCxxFiles:: [FilePath],
       ComponentInfo -> [FilePath]
cinfoJsFiles :: [FilePath]
     }

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo PackageDescription
pkg =
    [ ComponentInfo {
        cinfoName :: ComponentName
cinfoName    = Component -> ComponentName
componentName Component
c,
        cinfoStrName :: FilePath
cinfoStrName = forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageDescription
pkg (Component -> ComponentName
componentName Component
c),
        cinfoSrcDirs :: [FilePath]
cinfoSrcDirs = forall a b. (a -> b) -> [a] -> [b]
map forall from to. SymbolicPath from to -> FilePath
getSymbolicPath forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi,
        cinfoModules :: [ModuleName]
cinfoModules = Component -> [ModuleName]
componentModules Component
c,
        cinfoHsFiles :: [FilePath]
cinfoHsFiles = Component -> [FilePath]
componentHsFiles Component
c,
        cinfoAsmFiles :: [FilePath]
cinfoAsmFiles= BuildInfo -> [FilePath]
asmSources BuildInfo
bi,
        cinfoCmmFiles :: [FilePath]
cinfoCmmFiles= BuildInfo -> [FilePath]
cmmSources BuildInfo
bi,
        cinfoCFiles :: [FilePath]
cinfoCFiles  = BuildInfo -> [FilePath]
cSources BuildInfo
bi,
        cinfoCxxFiles :: [FilePath]
cinfoCxxFiles= BuildInfo -> [FilePath]
cxxSources BuildInfo
bi,
        cinfoJsFiles :: [FilePath]
cinfoJsFiles = BuildInfo -> [FilePath]
jsSources BuildInfo
bi
      }
    | Component
c <- PackageDescription -> [Component]
pkgComponents PackageDescription
pkg
    , let bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
c ]

componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName :: forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName pkg
pkg (CLibName LibraryName
LMainLibName      ) = forall a. Pretty a => a -> FilePath
prettyShow (forall pkg. Package pkg => pkg -> PackageName
packageName pkg
pkg)
componentStringName pkg
_   (CLibName (LSubLibName UnqualComponentName
name)) = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CFLibName  UnqualComponentName
name) = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CExeName   UnqualComponentName
name) = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CTestName  UnqualComponentName
name) = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CBenchName UnqualComponentName
name) = UnqualComponentName -> FilePath
unUnqualComponentName UnqualComponentName
name

componentModules :: Component -> [ModuleName]
-- 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 :: Component -> [ModuleName]
componentModules (CLib   Library
lib)   = Library -> [ModuleName]
explicitLibModules Library
lib
componentModules (CFLib  ForeignLib
flib)  = ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
componentModules (CExe   Executable
exe)   = Executable -> [ModuleName]
exeModules Executable
exe
componentModules (CTest  TestSuite
test)  = TestSuite -> [ModuleName]
testModules TestSuite
test
componentModules (CBench Benchmark
bench) = Benchmark -> [ModuleName]
benchmarkModules Benchmark
bench

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

{-
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)
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse
    pkgid :: PackageIdentifier
    Just pkgid = simpleParse "thelib"
-}

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

data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
  deriving (ComponentKind -> ComponentKind -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ComponentKind -> ComponentKind -> Bool
$c/= :: ComponentKind -> ComponentKind -> Bool
== :: ComponentKind -> ComponentKind -> Bool
$c== :: ComponentKind -> ComponentKind -> Bool
Eq, Eq ComponentKind
ComponentKind -> ComponentKind -> Bool
ComponentKind -> ComponentKind -> Ordering
ComponentKind -> ComponentKind -> ComponentKind
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ComponentKind -> ComponentKind -> ComponentKind
$cmin :: ComponentKind -> ComponentKind -> ComponentKind
max :: ComponentKind -> ComponentKind -> ComponentKind
$cmax :: ComponentKind -> ComponentKind -> ComponentKind
>= :: ComponentKind -> ComponentKind -> Bool
$c>= :: ComponentKind -> ComponentKind -> Bool
> :: ComponentKind -> ComponentKind -> Bool
$c> :: ComponentKind -> ComponentKind -> Bool
<= :: ComponentKind -> ComponentKind -> Bool
$c<= :: ComponentKind -> ComponentKind -> Bool
< :: ComponentKind -> ComponentKind -> Bool
$c< :: ComponentKind -> ComponentKind -> Bool
compare :: ComponentKind -> ComponentKind -> Ordering
$ccompare :: ComponentKind -> ComponentKind -> Ordering
Ord, Int -> ComponentKind -> ShowS
[ComponentKind] -> ShowS
ComponentKind -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [ComponentKind] -> ShowS
$cshowList :: [ComponentKind] -> ShowS
show :: ComponentKind -> FilePath
$cshow :: ComponentKind -> FilePath
showsPrec :: Int -> ComponentKind -> ShowS
$cshowsPrec :: Int -> ComponentKind -> ShowS
Show, Int -> ComponentKind
ComponentKind -> Int
ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind
ComponentKind -> ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
enumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFrom :: ComponentKind -> [ComponentKind]
$cenumFrom :: ComponentKind -> [ComponentKind]
fromEnum :: ComponentKind -> Int
$cfromEnum :: ComponentKind -> Int
toEnum :: Int -> ComponentKind
$ctoEnum :: Int -> ComponentKind
pred :: ComponentKind -> ComponentKind
$cpred :: ComponentKind -> ComponentKind
succ :: ComponentKind -> ComponentKind
$csucc :: ComponentKind -> ComponentKind
Enum, ComponentKind
forall a. a -> a -> Bounded a
maxBound :: ComponentKind
$cmaxBound :: ComponentKind
minBound :: ComponentKind
$cminBound :: ComponentKind
Bounded)

componentKind :: ComponentName -> ComponentKind
componentKind :: ComponentName -> ComponentKind
componentKind (CLibName   LibraryName
_) = ComponentKind
LibKind
componentKind (CFLibName  UnqualComponentName
_) = ComponentKind
FLibKind
componentKind (CExeName   UnqualComponentName
_) = ComponentKind
ExeKind
componentKind (CTestName  UnqualComponentName
_) = ComponentKind
TestKind
componentKind (CBenchName UnqualComponentName
_) = ComponentKind
BenchKind

cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = ComponentName -> ComponentKind
componentKind forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentInfo -> ComponentName
cinfoName

matchComponentKind :: String -> Match ComponentKind
matchComponentKind :: FilePath -> Match ComponentKind
matchComponentKind FilePath
s
  | FilePath
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"lib", FilePath
"library"]                 = forall {b}. b -> Match b
return' ComponentKind
LibKind
  | FilePath
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"flib", FilePath
"foreign-lib", FilePath
"foreign-library"] = forall {b}. b -> Match b
return' ComponentKind
FLibKind
  | FilePath
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"exe", FilePath
"executable"]              = forall {b}. b -> Match b
return' ComponentKind
ExeKind
  | FilePath
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"tst", FilePath
"test", FilePath
"test-suite"]      = forall {b}. b -> Match b
return' ComponentKind
TestKind
  | FilePath
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"bench", FilePath
"benchmark"]             = forall {b}. b -> Match b
return' ComponentKind
BenchKind
  | Bool
otherwise = forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"component kind" FilePath
s
  where
    return' :: b -> Match b
return' b
ck = Match ()
increaseConfidence forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return b
ck

showComponentKind :: ComponentKind -> String
showComponentKind :: ComponentKind -> FilePath
showComponentKind ComponentKind
LibKind   = FilePath
"library"
showComponentKind ComponentKind
FLibKind  = FilePath
"foreign-library"
showComponentKind ComponentKind
ExeKind   = FilePath
"executable"
showComponentKind ComponentKind
TestKind  = FilePath
"test-suite"
showComponentKind ComponentKind
BenchKind = FilePath
"benchmark"

showComponentKindShort :: ComponentKind -> String
showComponentKindShort :: ComponentKind -> FilePath
showComponentKindShort ComponentKind
LibKind   = FilePath
"lib"
showComponentKindShort ComponentKind
FLibKind  = FilePath
"flib"
showComponentKindShort ComponentKind
ExeKind   = FilePath
"exe"
showComponentKindShort ComponentKind
TestKind  = FilePath
"test"
showComponentKindShort ComponentKind
BenchKind = FilePath
"bench"

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

matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 :: [ComponentInfo] -> FilePath -> Match BuildTarget
matchComponent1 [ComponentInfo]
cs = \FilePath
str1 -> do
    FilePath -> Match ()
guardComponentName FilePath
str1
    ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> BuildTarget
BuildTargetComponent (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c))

matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 :: [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchComponent2 [ComponentInfo]
cs = \FilePath
str1 FilePath
str2 -> do
    ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
    FilePath -> Match ()
guardComponentName FilePath
str2
    ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> BuildTarget
BuildTargetComponent (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c))

-- utils:

guardComponentName :: String -> Match ()
guardComponentName :: FilePath -> Match ()
guardComponentName FilePath
s
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validComponentChar FilePath
s
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s)  = Match ()
increaseConfidence
  | Bool
otherwise        = forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"component name" FilePath
s
  where
    validComponentChar :: Char -> Bool
validComponentChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.'
                        Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''

matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName :: [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str =
    forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"component" FilePath
str
  forall a b. (a -> b) -> a -> b
$ forall a. Match a -> Match a
increaseConfidenceFor
  forall a b. (a -> b) -> a -> b
$ forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold
      [ (ComponentInfo -> FilePath
cinfoStrName ComponentInfo
c, ComponentInfo
c) | ComponentInfo
c <- [ComponentInfo]
cs ]
      FilePath
str

matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
                          -> Match ComponentInfo
matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str =
    forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing (ComponentKind -> FilePath
showComponentKind ComponentKind
ckind forall a. [a] -> [a] -> [a]
++ FilePath
" component") FilePath
str
  forall a b. (a -> b) -> a -> b
$ forall a. Match a -> Match a
increaseConfidenceFor
  forall a b. (a -> b) -> a -> b
$ forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly (\(ComponentKind
ck, FilePath
cn) -> (ComponentKind
ck, ShowS
caseFold FilePath
cn))
      [ ((ComponentInfo -> ComponentKind
cinfoKind ComponentInfo
c, ComponentInfo -> FilePath
cinfoStrName ComponentInfo
c), ComponentInfo
c) | ComponentInfo
c <- [ComponentInfo]
cs ]
      (ComponentKind
ckind, FilePath
str)


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

matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 :: [ComponentInfo] -> FilePath -> Match BuildTarget
matchModule1 [ComponentInfo]
cs = \FilePath
str1 -> do
    FilePath -> Match ()
guardModuleName FilePath
str1
    forall a. Match a -> Match a
nubMatchErrors forall a b. (a -> b) -> a -> b
$ do
      ComponentInfo
c <- forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
      let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
      ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str1
      forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchModule2 :: [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchModule2 [ComponentInfo]
cs = \FilePath
str1 FilePath
str2 -> do
    FilePath -> Match ()
guardComponentName FilePath
str1
    FilePath -> Match ()
guardModuleName    FilePath
str2
    ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
    let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str2
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

matchModule3 :: [ComponentInfo] -> String -> String -> String
             -> Match BuildTarget
matchModule3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Match BuildTarget
matchModule3 [ComponentInfo]
cs FilePath
str1 FilePath
str2 FilePath
str3 = do
    ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
    FilePath -> Match ()
guardComponentName FilePath
str2
    ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
    FilePath -> Match ()
guardModuleName    FilePath
str3
    let ms :: [ModuleName]
ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    ModuleName
m <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str3
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> ModuleName -> BuildTarget
BuildTargetModule (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) ModuleName
m)

-- utils:

guardModuleName :: String -> Match ()
guardModuleName :: FilePath -> Match ()
guardModuleName FilePath
s
  | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar FilePath
s
    Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s)       = Match ()
increaseConfidence
  | Bool
otherwise             = forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"module name" FilePath
s
  where
    validModuleChar :: Char -> Bool
validModuleChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str =
    forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"module" FilePath
str
  forall a b. (a -> b) -> a -> b
$ forall a. Match a -> Match a
increaseConfidenceFor
  forall a b. (a -> b) -> a -> b
$ forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold
      [ (forall a. Pretty a => a -> FilePath
prettyShow ModuleName
m, ModuleName
m)
      | ModuleName
m <- [ModuleName]
ms ]
      FilePath
str


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

matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 :: [ComponentInfo] -> FilePath -> Bool -> Match BuildTarget
matchFile1 [ComponentInfo]
cs FilePath
str1 Bool
exists =
    forall a. Match a -> Match a
nubMatchErrors forall a b. (a -> b) -> a -> b
$ do
      ComponentInfo
c <- forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
      FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str1 Bool
exists
      forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)


matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 :: [ComponentInfo]
-> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile2 [ComponentInfo]
cs FilePath
str1 FilePath
str2 Bool
exists = do
    FilePath -> Match ()
guardComponentName FilePath
str1
    ComponentInfo
c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
    FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str2 Bool
exists
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)


matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
           -> Match BuildTarget
matchFile3 :: [ComponentInfo]
-> FilePath -> FilePath -> FilePath -> Bool -> Match BuildTarget
matchFile3 [ComponentInfo]
cs FilePath
str1 FilePath
str2 FilePath
str3 Bool
exists = do
    ComponentKind
ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
    FilePath -> Match ()
guardComponentName FilePath
str2
    ComponentInfo
c <- [ComponentInfo] -> ComponentKind -> FilePath -> Match ComponentInfo
matchComponentKindAndName [ComponentInfo]
cs ComponentKind
ckind FilePath
str2
    FilePath
filepath <- ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str3 Bool
exists
    forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> FilePath -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) FilePath
filepath)


matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile :: ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str Bool
fexists =
    forall a. FilePath -> FilePath -> Match a -> Match a
expecting FilePath
"file" FilePath
str forall a b. (a -> b) -> a -> b
$
      forall a. Match a -> Match a -> Match a
matchPlus
        (forall a. FilePath -> Bool -> Match a
matchFileExists FilePath
str Bool
fexists)
        (forall a. Match a -> Match a -> Match a
matchPlusShadowing
          (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ [FilePath] -> [ModuleName] -> FilePath -> Match FilePath
matchModuleFileRooted   [FilePath]
dirs [ModuleName]
ms      FilePath
str
                , [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted    [FilePath]
dirs [FilePath]
hsFiles FilePath
str ])
          (forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [ [ModuleName] -> FilePath -> Match FilePath
matchModuleFileUnrooted      [ModuleName]
ms      FilePath
str
                , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted       [FilePath]
hsFiles FilePath
str
                , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted       [FilePath]
cFiles  FilePath
str
                , [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted       [FilePath]
jsFiles FilePath
str ]))
  where
    dirs :: [FilePath]
dirs = ComponentInfo -> [FilePath]
cinfoSrcDirs ComponentInfo
c
    ms :: [ModuleName]
ms   = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    hsFiles :: [FilePath]
hsFiles = ComponentInfo -> [FilePath]
cinfoHsFiles ComponentInfo
c
    cFiles :: [FilePath]
cFiles  = ComponentInfo -> [FilePath]
cinfoCFiles ComponentInfo
c
    jsFiles :: [FilePath]
jsFiles = ComponentInfo -> [FilePath]
cinfoJsFiles ComponentInfo
c


-- utils

matchFileExists :: FilePath -> Bool -> Match a
matchFileExists :: forall a. FilePath -> Bool -> Match a
matchFileExists FilePath
_     Bool
False = forall (m :: * -> *) a. MonadPlus m => m a
mzero
matchFileExists FilePath
fname Bool
True  = do Match ()
increaseConfidence
                                 forall a. FilePath -> FilePath -> Match a
matchErrorNoSuch FilePath
"file" FilePath
fname

matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted :: [ModuleName] -> FilePath -> Match FilePath
matchModuleFileUnrooted [ModuleName]
ms FilePath
str = do
    let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
    ModuleName
_ <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms FilePath
filepath
    forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted :: [FilePath] -> [ModuleName] -> FilePath -> Match FilePath
matchModuleFileRooted [FilePath]
dirs [ModuleName]
ms FilePath
str = forall a. Eq a => Match a -> Match a
nubMatches forall a b. (a -> b) -> a -> b
$ do
    let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
    FilePath
filepath' <- [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath
    ModuleName
_ <- [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms FilePath
filepath'
    forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms =
      forall a. Match a -> Match a
increaseConfidenceFor
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold
        [ (ModuleName -> FilePath
toFilePath ModuleName
m, ModuleName
m) | ModuleName
m <- [ModuleName]
ms ]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropExtension

matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted [FilePath]
dirs [FilePath]
fs FilePath
str = do
    let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
    FilePath
filepath' <- [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath
    FilePath
_ <- [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs FilePath
filepath'
    forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted [FilePath]
fs FilePath
str = do
    let filepath :: FilePath
filepath = ShowS
normalise FilePath
str
    FilePath
_ <- [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs FilePath
filepath
    forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
filepath

matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs = forall a. Match a -> Match a
increaseConfidenceFor
             forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold [ (FilePath
f, FilePath
f) | FilePath
f <- [FilePath]
fs ]

matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath =
    forall a. [a] -> Match a
exactMatches forall a b. (a -> b) -> a -> b
$
      forall a. [Maybe a] -> [a]
catMaybes
       [ FilePath -> FilePath -> Maybe FilePath
stripDirectory (ShowS
normalise FilePath
dir) FilePath
filepath | FilePath
dir <- [FilePath]
dirs ]
  where
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
stripDirectory FilePath
dir FilePath
fp =
      [FilePath] -> FilePath
joinPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (FilePath -> [FilePath]
splitDirectories FilePath
dir) (FilePath -> [FilePath]
splitDirectories FilePath
fp)


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

-- | A matcher embodies a way to match some input as being some recognised
-- value. In particular it deals with multiple and ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
--

data Match a = NoMatch      Confidence [MatchError]
             | ExactMatch   Confidence [a]
             | InexactMatch Confidence [a]
  deriving Int -> Match a -> ShowS
forall a. Show a => Int -> Match a -> ShowS
forall a. Show a => [Match a] -> ShowS
forall a. Show a => Match a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Match a] -> ShowS
$cshowList :: forall a. Show a => [Match a] -> ShowS
show :: Match a -> FilePath
$cshow :: forall a. Show a => Match a -> FilePath
showsPrec :: Int -> Match a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Match a -> ShowS
Show

type Confidence = Int

data MatchError = MatchErrorExpected String String
                | MatchErrorNoSuch   String String
  deriving (Int -> MatchError -> ShowS
[MatchError] -> ShowS
MatchError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MatchError] -> ShowS
$cshowList :: [MatchError] -> ShowS
show :: MatchError -> FilePath
$cshow :: MatchError -> FilePath
showsPrec :: Int -> MatchError -> ShowS
$cshowsPrec :: Int -> MatchError -> ShowS
Show, MatchError -> MatchError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MatchError -> MatchError -> Bool
$c/= :: MatchError -> MatchError -> Bool
== :: MatchError -> MatchError -> Bool
$c== :: MatchError -> MatchError -> Bool
Eq)


instance Alternative Match where
      empty :: forall a. Match a
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
      <|> :: forall a. Match a -> Match a -> Match a
(<|>) = forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus Match where
  mzero :: forall a. Match a
mzero = forall a. Match a
matchZero
  mplus :: forall a. Match a -> Match a -> Match a
mplus = forall a. Match a -> Match a -> Match a
matchPlus

matchZero :: Match a
matchZero :: forall a. Match a
matchZero = forall a. Int -> [MatchError] -> Match a
NoMatch Int
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
-- ambiguous matches.
--
matchPlus :: Match a -> Match a -> Match a
matchPlus :: forall a. Match a -> Match a -> Match a
matchPlus   (ExactMatch   Int
d1 [a]
xs)   (ExactMatch   Int
d2 [a]
xs') =
  forall a. Int -> [a] -> Match a
ExactMatch (forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs forall a. [a] -> [a] -> [a]
++ [a]
xs')
matchPlus a :: Match a
a@(ExactMatch   Int
_  [a]
_ )   (InexactMatch Int
_  [a]
_  ) = Match a
a
matchPlus a :: Match a
a@(ExactMatch   Int
_  [a]
_ )   (NoMatch      Int
_  [MatchError]
_  ) = Match a
a
matchPlus   (InexactMatch Int
_  [a]
_ ) b :: Match a
b@(ExactMatch   Int
_  [a]
_  ) = Match a
b
matchPlus   (InexactMatch Int
d1 [a]
xs)   (InexactMatch Int
d2 [a]
xs') =
  forall a. Int -> [a] -> Match a
InexactMatch (forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs forall a. [a] -> [a] -> [a]
++ [a]
xs')
matchPlus a :: Match a
a@(InexactMatch Int
_  [a]
_ )   (NoMatch      Int
_  [MatchError]
_  ) = Match a
a
matchPlus   (NoMatch      Int
_  [MatchError]
_ ) b :: Match a
b@(ExactMatch   Int
_  [a]
_  ) = Match a
b
matchPlus   (NoMatch      Int
_  [MatchError]
_ ) b :: Match a
b@(InexactMatch Int
_  [a]
_  ) = Match a
b
matchPlus a :: Match a
a@(NoMatch      Int
d1 [MatchError]
ms) b :: Match a
b@(NoMatch      Int
d2 [MatchError]
ms')
                                             | Int
d1 forall a. Ord a => a -> a -> Bool
>  Int
d2  = Match a
a
                                             | Int
d1 forall a. Ord a => a -> a -> Bool
<  Int
d2  = Match a
b
                                             | Bool
otherwise = forall a. Int -> [MatchError] -> Match a
NoMatch Int
d1 ([MatchError]
ms forall a. [a] -> [a] -> [a]
++ [MatchError]
ms')

-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- 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 :: forall a. Match a -> Match a -> Match a
matchPlusShadowing a :: Match a
a@(ExactMatch Int
_ [a]
_) (ExactMatch Int
_ [a]
_) = Match a
a
matchPlusShadowing Match a
a                   Match a
b               = forall a. Match a -> Match a -> Match a
matchPlus Match a
a Match a
b

instance Functor Match where
  fmap :: forall a b. (a -> b) -> Match a -> Match b
fmap a -> b
_ (NoMatch      Int
d [MatchError]
ms) = forall a. Int -> [MatchError] -> Match a
NoMatch      Int
d [MatchError]
ms
  fmap a -> b
f (ExactMatch   Int
d [a]
xs) = forall a. Int -> [a] -> Match a
ExactMatch   Int
d (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs)
  fmap a -> b
f (InexactMatch Int
d [a]
xs) = forall a. Int -> [a] -> Match a
InexactMatch Int
d (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs)

instance Applicative Match where
  pure :: forall {b}. b -> Match b
pure a
a = forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a
a]
  <*> :: forall a b. Match (a -> b) -> Match a -> Match b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Match where
  return :: forall {b}. b -> Match b
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure

  NoMatch      Int
d [MatchError]
ms >>= :: forall a b. Match a -> (a -> Match b) -> Match b
>>= a -> Match b
_ = forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
  ExactMatch   Int
d [a]
xs >>= a -> Match b
f = forall a. Int -> Match a -> Match a
addDepth Int
d
                          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Match a -> Match a -> Match a
matchPlus forall a. Match a
matchZero (forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs)
  InexactMatch Int
d [a]
xs >>= a -> Match b
f = forall a. Int -> Match a -> Match a
addDepth Int
d forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall a. Match a -> Match a
forceInexact
                          forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Match a -> Match a -> Match a
matchPlus forall a. Match a
matchZero (forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs)

addDepth :: Confidence -> Match a -> Match a
addDepth :: forall a. Int -> Match a -> Match a
addDepth Int
d' (NoMatch      Int
d [MatchError]
msgs) = forall a. Int -> [MatchError] -> Match a
NoMatch      (Int
d'forall a. Num a => a -> a -> a
+Int
d) [MatchError]
msgs
addDepth Int
d' (ExactMatch   Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
ExactMatch   (Int
d'forall a. Num a => a -> a -> a
+Int
d) [a]
xs
addDepth Int
d' (InexactMatch Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
InexactMatch (Int
d'forall a. Num a => a -> a -> a
+Int
d) [a]
xs

forceInexact :: Match a -> Match a
forceInexact :: forall a. Match a -> Match a
forceInexact (ExactMatch Int
d [a]
ys) = forall a. Int -> [a] -> Match a
InexactMatch Int
d [a]
ys
forceInexact Match a
m                 = Match a
m

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

matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected :: forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
thing FilePath
got = forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 [FilePath -> FilePath -> MatchError
MatchErrorExpected FilePath
thing FilePath
got]
matchErrorNoSuch :: forall a. FilePath -> FilePath -> Match a
matchErrorNoSuch   FilePath
thing FilePath
got = forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 [FilePath -> FilePath -> MatchError
MatchErrorNoSuch   FilePath
thing FilePath
got]

expecting :: String -> String -> Match a -> Match a
expecting :: forall a. FilePath -> FilePath -> Match a -> Match a
expecting FilePath
thing FilePath
got (NoMatch Int
0 [MatchError]
_) = forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
thing FilePath
got
expecting FilePath
_     FilePath
_   Match a
m             = Match a
m

orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing :: forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
thing FilePath
got (NoMatch Int
0 [MatchError]
_) = forall a. FilePath -> FilePath -> Match a
matchErrorNoSuch FilePath
thing FilePath
got
orNoSuchThing FilePath
_     FilePath
_   Match a
m             = Match a
m

increaseConfidence :: Match ()
increaseConfidence :: Match ()
increaseConfidence = forall a. Int -> [a] -> Match a
ExactMatch Int
1 [()]

increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor :: forall a. Match a -> Match a
increaseConfidenceFor Match a
m = Match a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> Match ()
increaseConfidence forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
r

nubMatches :: Eq a => Match a -> Match a
nubMatches :: forall a. Eq a => Match a -> Match a
nubMatches (NoMatch      Int
d [MatchError]
msgs) = forall a. Int -> [MatchError] -> Match a
NoMatch      Int
d [MatchError]
msgs
nubMatches (ExactMatch   Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
ExactMatch   Int
d (forall a. Eq a => [a] -> [a]
nub [a]
xs)
nubMatches (InexactMatch Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
InexactMatch Int
d (forall a. Eq a => [a] -> [a]
nub [a]
xs)

nubMatchErrors :: Match a -> Match a
nubMatchErrors :: forall a. Match a -> Match a
nubMatchErrors (NoMatch      Int
d [MatchError]
msgs) = forall a. Int -> [MatchError] -> Match a
NoMatch      Int
d (forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
nubMatchErrors (ExactMatch   Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
ExactMatch   Int
d [a]
xs
nubMatchErrors (InexactMatch Int
d [a]
xs)   = forall a. Int -> [a] -> Match a
InexactMatch Int
d [a]
xs

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

exactMatches :: forall a. [a] -> Match a
exactMatches [] = forall a. Match a
matchZero
exactMatches [a]
xs = forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a]
xs

inexactMatches :: forall a. [a] -> Match a
inexactMatches [] = forall a. Match a
matchZero
inexactMatches [a]
xs = forall a. Int -> [a] -> Match a
InexactMatch Int
0 [a]
xs

tryEach :: [a] -> Match a
tryEach :: forall a. [a] -> Match a
tryEach = forall a. [a] -> Match a
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.
--
findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch :: forall b. Eq b => Match b -> MaybeAmbiguous b
findMatch Match b
match =
    case Match b
match of
      NoMatch    Int
_ [MatchError]
msgs -> forall a. [MatchError] -> MaybeAmbiguous a
None (forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
      ExactMatch   Int
_ [b]
xs -> forall {a}. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
      InexactMatch Int
_ [b]
xs -> forall {a}. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
  where
    checkAmbiguous :: [a] -> MaybeAmbiguous a
checkAmbiguous [a]
xs = case forall a. Eq a => [a] -> [a]
nub [a]
xs of
                          [a
x] -> forall a. a -> MaybeAmbiguous a
Unambiguous a
x
                          [a]
xs' -> forall a. [a] -> MaybeAmbiguous a
Ambiguous   [a]
xs'

data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
  deriving Int -> MaybeAmbiguous a -> ShowS
forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
forall a. Show a => [MaybeAmbiguous a] -> ShowS
forall a. Show a => MaybeAmbiguous a -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MaybeAmbiguous a] -> ShowS
$cshowList :: forall a. Show a => [MaybeAmbiguous a] -> ShowS
show :: MaybeAmbiguous a -> FilePath
$cshow :: forall a. Show a => MaybeAmbiguous a -> FilePath
showsPrec :: Int -> MaybeAmbiguous a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
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).
--
matchInexactly :: (Ord a, Ord a') =>
                        (a -> a') ->
                        [(a, b)] -> (a -> Match b)
matchInexactly :: forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly a -> a'
cannonicalise [(a, b)]
xs =
    \a
x -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a [b]
m of
            Just [b]
ys -> forall a. [a] -> Match a
exactMatches [b]
ys
            Maybe [b]
Nothing -> case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (a -> a'
cannonicalise a
x) Map a' [b]
m' of
                         Just [b]
ys -> forall a. [a] -> Match a
inexactMatches [b]
ys
                         Maybe [b]
Nothing -> forall a. Match a
matchZero
  where
    m :: Map a [b]
m = forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. [a] -> [a] -> [a]
(++) [ (a
k,[b
x]) | (a
k,b
x) <- [(a, b)]
xs ]

    -- the map of canonicalised keys to groups of inexact matches
    m' :: Map a' [b]
m' = forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith forall a. [a] -> [a] -> [a]
(++) a -> a'
cannonicalise Map a [b]
m



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

caseFold :: String -> String
caseFold :: ShowS
caseFold = ShowS
lowercase


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

checkBuildTargets Verbosity
verbosity PackageDescription
pkg_descr LocalBuildInfo
lbi [BuildTarget]
targets = do

    let ([(ComponentName, Maybe (Either ModuleName FilePath))]
enabled, [(ComponentName, ComponentDisabledReason)]
disabled) =
          forall a b. [Either a b] -> ([a], [b])
partitionEithers
            [ case ComponentRequestedSpec
-> Component -> Maybe ComponentDisabledReason
componentDisabledReason (LocalBuildInfo -> ComponentRequestedSpec
componentEnabledSpec LocalBuildInfo
lbi) Component
comp of
                Maybe ComponentDisabledReason
Nothing     -> forall a b. a -> Either a b
Left  (ComponentName, Maybe (Either ModuleName FilePath))
target'
                Just ComponentDisabledReason
reason -> forall a b. b -> Either a b
Right (ComponentName
cname, ComponentDisabledReason
reason)
            | BuildTarget
target <- [BuildTarget]
targets
            , let target' :: (ComponentName, Maybe (Either ModuleName FilePath))
target'@(ComponentName
cname,Maybe (Either ModuleName FilePath)
_) = BuildTarget -> (ComponentName, Maybe (Either ModuleName FilePath))
swizzleTarget BuildTarget
target
            , let comp :: Component
comp = PackageDescription -> ComponentName -> Component
getComponent PackageDescription
pkg_descr ComponentName
cname ]

    case [(ComponentName, ComponentDisabledReason)]
disabled of
      []                 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ((ComponentName
cname,ComponentDisabledReason
reason):[(ComponentName, ComponentDisabledReason)]
_) -> forall a. Verbosity -> FilePath -> IO a
die' Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath -> ComponentDisabledReason -> FilePath
formatReason (ComponentName -> FilePath
showComponentName ComponentName
cname) ComponentDisabledReason
reason

    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [ (ComponentName
c, Either ModuleName FilePath
t) | (ComponentName
c, Just Either ModuleName FilePath
t) <- [(ComponentName, Maybe (Either ModuleName FilePath))]
enabled ] forall a b. (a -> b) -> a -> b
$ \(ComponentName
c, Either ModuleName FilePath
t) ->
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity forall a b. (a -> b) -> a -> b
$ FilePath
"Ignoring '" forall a. [a] -> [a] -> [a]
++ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Pretty a => a -> FilePath
prettyShow forall a. a -> a
id Either ModuleName FilePath
t forall a. [a] -> [a] -> [a]
++ FilePath
". The whole "
                    forall a. [a] -> [a] -> [a]
++ ComponentName -> FilePath
showComponentName ComponentName
c forall a. [a] -> [a] -> [a]
++ FilePath
" will be processed. (Support for "
                    forall a. [a] -> [a] -> [a]
++ FilePath
"module and file targets has not been implemented yet.)"

    -- Pick out the actual CLBIs for each of these cnames
    [TargetInfo]
enabled' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ComponentName, Maybe (Either ModuleName FilePath))]
enabled forall a b. (a -> b) -> a -> b
$ \(ComponentName
cname, Maybe (Either ModuleName FilePath)
_) -> do
        case PackageDescription
-> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentName
cname of
            [] -> forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: nothing enabled"
            [TargetInfo
target] -> forall (m :: * -> *) a. Monad m => a -> m a
return TargetInfo
target
            [TargetInfo]
_targets -> forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: multiple copies enabled"

    forall (m :: * -> *) a. Monad m => a -> m a
return [TargetInfo]
enabled'

  where
    swizzleTarget :: BuildTarget -> (ComponentName, Maybe (Either ModuleName FilePath))
swizzleTarget (BuildTargetComponent ComponentName
c)   = (ComponentName
c, forall a. Maybe a
Nothing)
    swizzleTarget (BuildTargetModule    ComponentName
c ModuleName
m) = (ComponentName
c, forall a. a -> Maybe a
Just (forall a b. a -> Either a b
Left  ModuleName
m))
    swizzleTarget (BuildTargetFile      ComponentName
c FilePath
f) = (ComponentName
c, forall a. a -> Maybe a
Just (forall a b. b -> Either a b
Right FilePath
f))

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