{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 Distribution.Compat.Prelude
import Prelude ()

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

import qualified Distribution.Compat.CharParsing as P
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity

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

-- | 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
  build_targets <- Verbosity -> PackageDescription -> [FilePath] -> IO [BuildTarget]
readBuildTargets Verbosity
verbosity PackageDescription
pkg_descr [FilePath]
args
  checkBuildTargets verbosity pkg_descr lbi 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
(Int -> UserBuildTarget -> ShowS)
-> (UserBuildTarget -> FilePath)
-> ([UserBuildTarget] -> ShowS)
-> Show UserBuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserBuildTarget -> ShowS
showsPrec :: Int -> UserBuildTarget -> ShowS
$cshow :: UserBuildTarget -> FilePath
show :: UserBuildTarget -> FilePath
$cshowList :: [UserBuildTarget] -> ShowS
showList :: [UserBuildTarget] -> ShowS
Show, UserBuildTarget -> UserBuildTarget -> Bool
(UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> Eq UserBuildTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserBuildTarget -> UserBuildTarget -> Bool
== :: UserBuildTarget -> UserBuildTarget -> Bool
$c/= :: UserBuildTarget -> UserBuildTarget -> Bool
/= :: UserBuildTarget -> UserBuildTarget -> Bool
Eq, Eq UserBuildTarget
Eq UserBuildTarget =>
(UserBuildTarget -> UserBuildTarget -> Ordering)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> UserBuildTarget)
-> (UserBuildTarget -> UserBuildTarget -> UserBuildTarget)
-> Ord 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
$ccompare :: UserBuildTarget -> UserBuildTarget -> Ordering
compare :: UserBuildTarget -> UserBuildTarget -> Ordering
$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
>= :: UserBuildTarget -> UserBuildTarget -> Bool
$cmax :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
max :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmin :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
min :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
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
(BuildTarget -> BuildTarget -> Bool)
-> (BuildTarget -> BuildTarget -> Bool) -> Eq BuildTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BuildTarget -> BuildTarget -> Bool
== :: BuildTarget -> BuildTarget -> Bool
$c/= :: BuildTarget -> BuildTarget -> Bool
/= :: BuildTarget -> BuildTarget -> Bool
Eq, Int -> BuildTarget -> ShowS
[BuildTarget] -> ShowS
BuildTarget -> FilePath
(Int -> BuildTarget -> ShowS)
-> (BuildTarget -> FilePath)
-> ([BuildTarget] -> ShowS)
-> Show BuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildTarget -> ShowS
showsPrec :: Int -> BuildTarget -> ShowS
$cshow :: BuildTarget -> FilePath
show :: BuildTarget -> FilePath
$cshowList :: [BuildTarget] -> ShowS
showList :: [BuildTarget] -> ShowS
Show, (forall x. BuildTarget -> Rep BuildTarget x)
-> (forall x. Rep BuildTarget x -> BuildTarget)
-> Generic BuildTarget
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
$cfrom :: forall x. BuildTarget -> Rep BuildTarget x
from :: forall x. BuildTarget -> Rep BuildTarget x
$cto :: forall x. Rep BuildTarget x -> BuildTarget
to :: forall x. Rep BuildTarget x -> BuildTarget
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

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

  let (bproblems, btargets) = resolveBuildTargets pkg utargets'
  reportBuildTargetProblems verbosity bproblems

  return btargets

checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile UserBuildTarget
t = do
  fexists <- FilePath -> IO Bool
existsAsFile (UserBuildTarget -> FilePath
fileComponentOfTarget UserBuildTarget
t)
  return (t, fexists)
  where
    existsAsFile :: FilePath -> IO Bool
existsAsFile FilePath
f = do
      exists <- FilePath -> IO Bool
doesFileExist FilePath
f
      case splitPath 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]
_ -> Bool -> IO Bool
forall a. a -> IO a
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 = [Either UserBuildTargetProblem UserBuildTarget]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either UserBuildTargetProblem UserBuildTarget]
 -> ([UserBuildTargetProblem], [UserBuildTarget]))
-> ([FilePath] -> [Either UserBuildTargetProblem UserBuildTarget])
-> [FilePath]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Either UserBuildTargetProblem UserBuildTarget)
-> [FilePath] -> [Either UserBuildTargetProblem UserBuildTarget]
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 ParsecParser UserBuildTarget
-> FilePath -> Either FilePath UserBuildTarget
forall a. ParsecParser a -> FilePath -> Either FilePath a
explicitEitherParsec ParsecParser UserBuildTarget
forall (m :: * -> *). CabalParsing m => m UserBuildTarget
parseTargetApprox FilePath
targetstr of
    Left FilePath
_ -> UserBuildTargetProblem
-> Either UserBuildTargetProblem UserBuildTarget
forall a b. a -> Either a b
Left (FilePath -> UserBuildTargetProblem
UserBuildTargetUnrecognised FilePath
targetstr)
    Right UserBuildTarget
tgt -> UserBuildTarget -> Either UserBuildTargetProblem UserBuildTarget
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"
      ts <- m (FilePath, Maybe (FilePath, Maybe FilePath))
forall (m :: * -> *).
CabalParsing m =>
m (FilePath, Maybe (FilePath, Maybe FilePath))
tokens
      return $ case 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, Maybe (FilePath, Maybe FilePath)
forall a. Maybe a
Nothing)) (FilePath -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m FilePath -> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        m (FilePath, Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (FilePath
 -> Maybe (FilePath, Maybe FilePath)
 -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m FilePath
-> m (Maybe (FilePath, Maybe FilePath)
      -> (FilePath, Maybe (FilePath, Maybe FilePath)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token m (Maybe (FilePath, Maybe FilePath)
   -> (FilePath, Maybe (FilePath, Maybe FilePath)))
-> m (Maybe (FilePath, Maybe FilePath))
-> m (FilePath, Maybe (FilePath, Maybe FilePath))
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (FilePath, Maybe FilePath)
-> m (Maybe (FilePath, Maybe FilePath))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' m Char
-> m (FilePath, Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (FilePath, Maybe FilePath)
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, Maybe FilePath
forall a. Maybe a
Nothing)) (FilePath -> (FilePath, Maybe FilePath))
-> m FilePath -> m (FilePath, Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString
        m (FilePath, Maybe FilePath)
-> m (FilePath, Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (FilePath -> Maybe FilePath -> (FilePath, Maybe FilePath))
-> m FilePath -> m (Maybe FilePath -> (FilePath, Maybe FilePath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token m (Maybe FilePath -> (FilePath, Maybe FilePath))
-> m (Maybe FilePath) -> m (FilePath, Maybe FilePath)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m FilePath -> m (Maybe FilePath)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':' m Char -> m FilePath -> m FilePath
forall a b. m a -> m b -> m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecHaskellString m FilePath -> m FilePath -> m FilePath
forall a. m a -> m a -> m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
token))

    token :: CabalParsing m => m String
    token :: forall (m :: * -> *). CabalParsing m => m FilePath
token = (Char -> Bool) -> m FilePath
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')

data UserBuildTargetProblem
  = UserBuildTargetUnrecognised String
  deriving (Int -> UserBuildTargetProblem -> ShowS
[UserBuildTargetProblem] -> ShowS
UserBuildTargetProblem -> FilePath
(Int -> UserBuildTargetProblem -> ShowS)
-> (UserBuildTargetProblem -> FilePath)
-> ([UserBuildTargetProblem] -> ShowS)
-> Show UserBuildTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserBuildTargetProblem -> ShowS
showsPrec :: Int -> UserBuildTargetProblem -> ShowS
$cshow :: UserBuildTargetProblem -> FilePath
show :: UserBuildTargetProblem -> FilePath
$cshowList :: [UserBuildTargetProblem] -> ShowS
showList :: [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
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [FilePath]
target ->
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [FilePath] -> CabalException
UnrecognisedBuildTarget [FilePath]
target

showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget :: UserBuildTarget -> FilePath
showUserBuildTarget = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
":" ([FilePath] -> FilePath)
-> (UserBuildTarget -> [FilePath]) -> UserBuildTarget -> 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 =
  [Either BuildTargetProblem BuildTarget]
-> ([BuildTargetProblem], [BuildTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
    ([Either BuildTargetProblem BuildTarget]
 -> ([BuildTargetProblem], [BuildTarget]))
-> ([(UserBuildTarget, Bool)]
    -> [Either BuildTargetProblem BuildTarget])
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, Bool) -> Either BuildTargetProblem BuildTarget)
-> [(UserBuildTarget, Bool)]
-> [Either BuildTargetProblem BuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map ((UserBuildTarget -> Bool -> Either BuildTargetProblem BuildTarget)
-> (UserBuildTarget, Bool) -> Either BuildTargetProblem BuildTarget
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 Match BuildTarget -> MaybeAmbiguous BuildTarget
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 -> BuildTarget -> Either BuildTargetProblem BuildTarget
forall a b. b -> Either a b
Right BuildTarget
target
    Ambiguous [BuildTarget]
targets -> BuildTargetProblem -> Either BuildTargetProblem BuildTarget
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
            (PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg)
            UserBuildTarget
userTarget
            [BuildTarget]
targets
    None [MatchError]
errs -> BuildTargetProblem -> Either BuildTargetProblem BuildTarget
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' <- [(FilePath, FilePath)] -> Maybe (NonEmpty (FilePath, FilePath))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(FilePath, FilePath)]
expected =
          let unzip' :: NonEmpty (b, b) -> (NonEmpty b, NonEmpty b)
unzip' = ((b, b) -> b) -> NonEmpty (b, b) -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, b) -> b
forall a b. (a, b) -> a
fst (NonEmpty (b, b) -> NonEmpty b)
-> (NonEmpty (b, b) -> NonEmpty b)
-> NonEmpty (b, b)
-> (NonEmpty b, NonEmpty b)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((b, b) -> b) -> NonEmpty (b, b) -> NonEmpty b
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b, b) -> b
forall a b. (a, b) -> b
snd
              (NonEmpty FilePath
things, FilePath
got :| [FilePath]
_) = NonEmpty (FilePath, FilePath)
-> (NonEmpty FilePath, NonEmpty FilePath)
forall {b} {b}. NonEmpty (b, b) -> (NonEmpty b, NonEmpty b)
unzip' NonEmpty (FilePath, FilePath)
expected'
           in UserBuildTarget -> [FilePath] -> FilePath -> BuildTargetProblem
BuildTargetExpected UserBuildTarget
userTarget (NonEmpty FilePath -> [FilePath]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty FilePath
things) FilePath
got
      | Bool -> Bool
not ([(FilePath, FilePath)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(FilePath, FilePath)]
nosuch) = UserBuildTarget -> [(FilePath, FilePath)] -> BuildTargetProblem
BuildTargetNoSuch UserBuildTarget
userTarget [(FilePath, FilePath)]
nosuch
      | Bool
otherwise = FilePath -> BuildTargetProblem
forall a. HasCallStack => FilePath -> a
error (FilePath -> BuildTargetProblem) -> FilePath -> BuildTargetProblem
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
  = -- |  [expected thing] (actually got)
    BuildTargetExpected UserBuildTarget [String] String
  | -- | [(no such thing,  actually got)]
    BuildTargetNoSuch UserBuildTarget [(String, String)]
  | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
  deriving (Int -> BuildTargetProblem -> ShowS
[BuildTargetProblem] -> ShowS
BuildTargetProblem -> FilePath
(Int -> BuildTargetProblem -> ShowS)
-> (BuildTargetProblem -> FilePath)
-> ([BuildTargetProblem] -> ShowS)
-> Show BuildTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildTargetProblem -> ShowS
showsPrec :: Int -> BuildTargetProblem -> ShowS
$cshow :: BuildTargetProblem -> FilePath
show :: BuildTargetProblem -> FilePath
$cshowList :: [BuildTargetProblem] -> ShowS
showList :: [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
      | [BuildTarget] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BuildTarget]
amb = [(UserBuildTarget, BuildTarget)]
unamb
      | Bool
otherwise = [(UserBuildTarget, BuildTarget)]
unamb [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
forall a. [a] -> [a] -> [a]
++ QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (QualLevel -> QualLevel
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) -> (((UserBuildTarget, BuildTarget) -> BuildTarget)
-> [(UserBuildTarget, BuildTarget)] -> [BuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map (UserBuildTarget, BuildTarget) -> BuildTarget
forall a b. (a, b) -> b
snd ([(UserBuildTarget, BuildTarget)] -> [BuildTarget])
-> [(UserBuildTarget, BuildTarget)] -> [BuildTarget]
forall a b. (a -> b) -> a -> b
$ [[(UserBuildTarget, BuildTarget)]]
-> [(UserBuildTarget, BuildTarget)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
amb, [[(UserBuildTarget, BuildTarget)]]
-> [(UserBuildTarget, BuildTarget)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(UserBuildTarget, BuildTarget)]]
unamb))
        (([[(UserBuildTarget, BuildTarget)]],
  [[(UserBuildTarget, BuildTarget)]])
 -> ([BuildTarget], [(UserBuildTarget, BuildTarget)]))
-> ([BuildTarget]
    -> ([[(UserBuildTarget, BuildTarget)]],
        [[(UserBuildTarget, BuildTarget)]]))
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(UserBuildTarget, BuildTarget)] -> Bool)
-> [[(UserBuildTarget, BuildTarget)]]
-> ([[(UserBuildTarget, BuildTarget)]],
    [[(UserBuildTarget, BuildTarget)]])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\[(UserBuildTarget, BuildTarget)]
g -> [(UserBuildTarget, BuildTarget)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(UserBuildTarget, BuildTarget)]
g Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1)
        ([[(UserBuildTarget, BuildTarget)]]
 -> ([[(UserBuildTarget, BuildTarget)]],
     [[(UserBuildTarget, BuildTarget)]]))
-> ([BuildTarget] -> [[(UserBuildTarget, BuildTarget)]])
-> [BuildTarget]
-> ([[(UserBuildTarget, BuildTarget)]],
    [[(UserBuildTarget, BuildTarget)]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, BuildTarget)
 -> (UserBuildTarget, BuildTarget) -> Bool)
-> [(UserBuildTarget, BuildTarget)]
-> [[(UserBuildTarget, BuildTarget)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (((UserBuildTarget, BuildTarget) -> UserBuildTarget)
-> (UserBuildTarget, BuildTarget)
-> (UserBuildTarget, BuildTarget)
-> Bool
forall a b. Eq a => (b -> a) -> b -> b -> Bool
equating (UserBuildTarget, BuildTarget) -> UserBuildTarget
forall a b. (a, b) -> a
fst)
        ([(UserBuildTarget, BuildTarget)]
 -> [[(UserBuildTarget, BuildTarget)]])
-> ([BuildTarget] -> [(UserBuildTarget, BuildTarget)])
-> [BuildTarget]
-> [[(UserBuildTarget, BuildTarget)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UserBuildTarget, BuildTarget)
 -> (UserBuildTarget, BuildTarget) -> Ordering)
-> [(UserBuildTarget, BuildTarget)]
-> [(UserBuildTarget, BuildTarget)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((UserBuildTarget, BuildTarget) -> UserBuildTarget)
-> (UserBuildTarget, BuildTarget)
-> (UserBuildTarget, BuildTarget)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (UserBuildTarget, BuildTarget) -> UserBuildTarget
forall a b. (a, b) -> a
fst)
        ([(UserBuildTarget, BuildTarget)]
 -> [(UserBuildTarget, BuildTarget)])
-> ([BuildTarget] -> [(UserBuildTarget, BuildTarget)])
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BuildTarget -> (UserBuildTarget, BuildTarget))
-> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
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]
(QualLevel -> QualLevel)
-> (QualLevel -> QualLevel)
-> (Int -> QualLevel)
-> (QualLevel -> Int)
-> (QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> QualLevel -> [QualLevel])
-> Enum 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
$csucc :: QualLevel -> QualLevel
succ :: QualLevel -> QualLevel
$cpred :: QualLevel -> QualLevel
pred :: QualLevel -> QualLevel
$ctoEnum :: Int -> QualLevel
toEnum :: Int -> QualLevel
$cfromEnum :: QualLevel -> Int
fromEnum :: QualLevel -> Int
$cenumFrom :: QualLevel -> [QualLevel]
enumFrom :: QualLevel -> [QualLevel]
$cenumFromThen :: QualLevel -> QualLevel -> [QualLevel]
enumFromThen :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromTo :: QualLevel -> QualLevel -> [QualLevel]
enumFromTo :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
enumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
Enum, Int -> QualLevel -> ShowS
[QualLevel] -> ShowS
QualLevel -> FilePath
(Int -> QualLevel -> ShowS)
-> (QualLevel -> FilePath)
-> ([QualLevel] -> ShowS)
-> Show QualLevel
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QualLevel -> ShowS
showsPrec :: Int -> QualLevel -> ShowS
$cshow :: QualLevel -> FilePath
show :: QualLevel -> FilePath
$cshowList :: [QualLevel] -> ShowS
showList :: [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) = ModuleName -> FilePath
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, ModuleName -> FilePath
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
_) = FilePath -> (FilePath, FilePath, FilePath)
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, ModuleName -> FilePath
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 = PackageId -> ComponentName -> FilePath
forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageId
pkgid
    dispKind :: ComponentName -> FilePath
dispKind = ComponentKind -> FilePath
showComponentKindShort (ComponentKind -> FilePath)
-> (ComponentName -> ComponentKind) -> ComponentName -> FilePath
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
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [FilePath], FilePath)]
targets ->
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(FilePath, [FilePath], FilePath)] -> CabalException
ReportBuildTargetProblems ([(FilePath, [FilePath], FilePath)] -> CabalException)
-> [(FilePath, [FilePath], FilePath)] -> CabalException
forall a b. (a -> b) -> a -> b
$
          ((UserBuildTarget, [FilePath], FilePath)
 -> (FilePath, [FilePath], FilePath))
-> [(UserBuildTarget, [FilePath], FilePath)]
-> [(FilePath, [FilePath], FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(UserBuildTarget
target, [FilePath]
expected, FilePath
got) -> (UserBuildTarget -> FilePath
showUserBuildTarget 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
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [(FilePath, FilePath)])]
targets ->
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(FilePath, [(FilePath, FilePath)])] -> CabalException
UnknownBuildTarget ([(FilePath, [(FilePath, FilePath)])] -> CabalException)
-> [(FilePath, [(FilePath, FilePath)])] -> CabalException
forall a b. (a -> b) -> a -> b
$
          ((UserBuildTarget, [(FilePath, FilePath)])
 -> (FilePath, [(FilePath, FilePath)]))
-> [(UserBuildTarget, [(FilePath, FilePath)])]
-> [(FilePath, [(FilePath, FilePath)])]
forall a b. (a -> b) -> [a] -> [b]
map (\(UserBuildTarget
target, [(FilePath, FilePath)]
nosuch) -> (UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target, [(FilePath, FilePath)]
nosuch)) [(UserBuildTarget, [(FilePath, FilePath)])]
targets

  case [(UserBuildTarget
t, [(UserBuildTarget, BuildTarget)]
ts) | BuildTargetAmbiguous UserBuildTarget
t [(UserBuildTarget, BuildTarget)]
ts <- [BuildTargetProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets ->
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(FilePath, [(FilePath, FilePath)])] -> CabalException
AmbiguousBuildTarget ([(FilePath, [(FilePath, FilePath)])] -> CabalException)
-> [(FilePath, [(FilePath, FilePath)])] -> CabalException
forall a b. (a -> b) -> a -> b
$
          ((UserBuildTarget, [(UserBuildTarget, BuildTarget)])
 -> (FilePath, [(FilePath, FilePath)]))
-> [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
-> [(FilePath, [(FilePath, FilePath)])]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \(UserBuildTarget
target, [(UserBuildTarget, BuildTarget)]
amb) ->
                ( UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
target
                , (((UserBuildTarget, BuildTarget) -> (FilePath, FilePath))
-> [(UserBuildTarget, BuildTarget)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\(UserBuildTarget
ut, BuildTarget
bt) -> (UserBuildTarget -> FilePath
showUserBuildTarget UserBuildTarget
ut, BuildTarget -> FilePath
showBuildTargetKind BuildTarget
bt)) [(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
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> Match BuildTarget
matchModule1 [ComponentInfo]
cinfo FilePath
str1
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
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
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a -> Match a
`matchPlusShadowing` [ComponentInfo] -> FilePath -> FilePath -> Match BuildTarget
matchModule2 [ComponentInfo]
cinfo FilePath
str1 FilePath
str2
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
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
    Match BuildTarget -> Match BuildTarget -> Match BuildTarget
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 = PackageDescription -> ComponentName -> FilePath
forall pkg. Package pkg => pkg -> ComponentName -> FilePath
componentStringName PackageDescription
pkg (Component -> ComponentName
componentName Component
c)
    , cinfoSrcDirs :: [FilePath]
cinfoSrcDirs = (SymbolicPath Pkg ('Dir Source) -> FilePath)
-> [SymbolicPath Pkg ('Dir Source)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg ('Dir Source) -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg ('Dir Source)] -> [FilePath])
-> [SymbolicPath Pkg ('Dir Source)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs BuildInfo
bi
    , cinfoModules :: [ModuleName]
cinfoModules = Component -> [ModuleName]
componentModules Component
c
    , cinfoHsFiles :: [FilePath]
cinfoHsFiles = (RelativePath Source 'File -> FilePath)
-> [RelativePath Source 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map RelativePath Source 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([RelativePath Source 'File] -> [FilePath])
-> [RelativePath Source 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Component -> [RelativePath Source 'File]
componentHsFiles Component
c
    , cinfoAsmFiles :: [FilePath]
cinfoAsmFiles = (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg 'File] -> [FilePath])
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg 'File]
asmSources BuildInfo
bi
    , cinfoCmmFiles :: [FilePath]
cinfoCmmFiles = (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg 'File] -> [FilePath])
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg 'File]
cmmSources BuildInfo
bi
    , cinfoCFiles :: [FilePath]
cinfoCFiles = (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg 'File] -> [FilePath])
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg 'File]
cSources BuildInfo
bi
    , cinfoCxxFiles :: [FilePath]
cinfoCxxFiles = (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg 'File] -> [FilePath])
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources BuildInfo
bi
    , cinfoJsFiles :: [FilePath]
cinfoJsFiles = (SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath ([SymbolicPath Pkg 'File] -> [FilePath])
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg 'File]
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) = PackageName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (pkg -> PackageName
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 -> [RelativePath Source File]
componentHsFiles :: Component -> [RelativePath Source 'File]
componentHsFiles (CExe Executable
exe) = [Executable -> RelativePath Source 'File
modulePath Executable
exe]
componentHsFiles
  ( CTest
      TestSuite
        { testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ RelativePath Source 'File
mainfile
        }
    ) = [RelativePath Source 'File
mainfile]
componentHsFiles
  ( CBench
      Benchmark
        { benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 Version
_ RelativePath Source 'File
mainfile
        }
    ) = [RelativePath Source 'File
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
(ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool) -> Eq ComponentKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComponentKind -> ComponentKind -> Bool
== :: ComponentKind -> ComponentKind -> Bool
$c/= :: ComponentKind -> ComponentKind -> Bool
/= :: ComponentKind -> ComponentKind -> Bool
Eq, Eq ComponentKind
Eq ComponentKind =>
(ComponentKind -> ComponentKind -> Ordering)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> ComponentKind)
-> (ComponentKind -> ComponentKind -> ComponentKind)
-> Ord 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
$ccompare :: ComponentKind -> ComponentKind -> Ordering
compare :: ComponentKind -> ComponentKind -> Ordering
$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
>= :: ComponentKind -> ComponentKind -> Bool
$cmax :: ComponentKind -> ComponentKind -> ComponentKind
max :: ComponentKind -> ComponentKind -> ComponentKind
$cmin :: ComponentKind -> ComponentKind -> ComponentKind
min :: ComponentKind -> ComponentKind -> ComponentKind
Ord, Int -> ComponentKind -> ShowS
[ComponentKind] -> ShowS
ComponentKind -> FilePath
(Int -> ComponentKind -> ShowS)
-> (ComponentKind -> FilePath)
-> ([ComponentKind] -> ShowS)
-> Show ComponentKind
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComponentKind -> ShowS
showsPrec :: Int -> ComponentKind -> ShowS
$cshow :: ComponentKind -> FilePath
show :: ComponentKind -> FilePath
$cshowList :: [ComponentKind] -> ShowS
showList :: [ComponentKind] -> ShowS
Show, Int -> ComponentKind
ComponentKind -> Int
ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind
ComponentKind -> ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
(ComponentKind -> ComponentKind)
-> (ComponentKind -> ComponentKind)
-> (Int -> ComponentKind)
-> (ComponentKind -> Int)
-> (ComponentKind -> [ComponentKind])
-> (ComponentKind -> ComponentKind -> [ComponentKind])
-> (ComponentKind -> ComponentKind -> [ComponentKind])
-> (ComponentKind
    -> ComponentKind -> ComponentKind -> [ComponentKind])
-> Enum 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
$csucc :: ComponentKind -> ComponentKind
succ :: ComponentKind -> ComponentKind
$cpred :: ComponentKind -> ComponentKind
pred :: ComponentKind -> ComponentKind
$ctoEnum :: Int -> ComponentKind
toEnum :: Int -> ComponentKind
$cfromEnum :: ComponentKind -> Int
fromEnum :: ComponentKind -> Int
$cenumFrom :: ComponentKind -> [ComponentKind]
enumFrom :: ComponentKind -> [ComponentKind]
$cenumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
enumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
Enum, ComponentKind
ComponentKind -> ComponentKind -> Bounded ComponentKind
forall a. a -> a -> Bounded a
$cminBound :: ComponentKind
minBound :: ComponentKind
$cmaxBound :: ComponentKind
maxBound :: 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 (ComponentName -> ComponentKind)
-> (ComponentInfo -> ComponentName)
-> ComponentInfo
-> 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 FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"lib", FilePath
"library"] = ComponentKind -> Match ComponentKind
forall {b}. b -> Match b
return' ComponentKind
LibKind
  | FilePath
s FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"flib", FilePath
"foreign-lib", FilePath
"foreign-library"] = ComponentKind -> Match ComponentKind
forall {b}. b -> Match b
return' ComponentKind
FLibKind
  | FilePath
s FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"exe", FilePath
"executable"] = ComponentKind -> Match ComponentKind
forall {b}. b -> Match b
return' ComponentKind
ExeKind
  | FilePath
s FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"tst", FilePath
"test", FilePath
"test-suite"] = ComponentKind -> Match ComponentKind
forall {b}. b -> Match b
return' ComponentKind
TestKind
  | FilePath
s FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"bench", FilePath
"benchmark"] = ComponentKind -> Match ComponentKind
forall {b}. b -> Match b
return' ComponentKind
BenchKind
  | Bool
otherwise = FilePath -> FilePath -> Match ComponentKind
forall a. FilePath -> FilePath -> Match a
matchErrorExpected FilePath
"component kind" FilePath
s
  where
    return' :: b -> Match b
return' b
ck = Match ()
increaseConfidence Match () -> Match b -> Match b
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Match b
forall {b}. b -> Match 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
  c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  return (BuildTargetComponent (cinfoName c))

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

-- utils:

guardComponentName :: String -> Match ()
guardComponentName :: FilePath -> Match ()
guardComponentName FilePath
s
  | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validComponentChar FilePath
s
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s) =
      Match ()
increaseConfidence
  | Bool
otherwise = FilePath -> FilePath -> Match ()
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName :: [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str =
  FilePath -> FilePath -> Match ComponentInfo -> Match ComponentInfo
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"component" FilePath
str (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
    Match ComponentInfo -> Match ComponentInfo
forall a. Match a -> Match a
increaseConfidenceFor (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
      ShowS
-> [(FilePath, ComponentInfo)] -> FilePath -> Match ComponentInfo
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 =
  FilePath -> FilePath -> Match ComponentInfo -> Match ComponentInfo
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing (ComponentKind -> FilePath
showComponentKind ComponentKind
ckind FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" component") FilePath
str (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
    Match ComponentInfo -> Match ComponentInfo
forall a. Match a -> Match a
increaseConfidenceFor (Match ComponentInfo -> Match ComponentInfo)
-> Match ComponentInfo -> Match ComponentInfo
forall a b. (a -> b) -> a -> b
$
      ((ComponentKind, FilePath) -> (ComponentKind, FilePath))
-> [((ComponentKind, FilePath), ComponentInfo)]
-> (ComponentKind, FilePath)
-> Match ComponentInfo
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
  Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a
nubMatchErrors (Match BuildTarget -> Match BuildTarget)
-> Match BuildTarget -> Match BuildTarget
forall a b. (a -> b) -> a -> b
$ do
    c <- [ComponentInfo] -> Match ComponentInfo
forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
    let ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
    m <- matchModuleName ms str1
    return (BuildTargetModule (cinfoName c) 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
  c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  let ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
  m <- matchModuleName ms str2
  return (BuildTargetModule (cinfoName c) 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
  ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
str1
  guardComponentName str2
  c <- matchComponentKindAndName cs ckind str2
  guardModuleName str3
  let ms = ComponentInfo -> [ModuleName]
cinfoModules ComponentInfo
c
  m <- matchModuleName ms str3
  return (BuildTargetModule (cinfoName c) m)

-- utils:

guardModuleName :: String -> Match ()
guardModuleName :: FilePath -> Match ()
guardModuleName FilePath
s
  | (Char -> Bool) -> FilePath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar FilePath
s
      Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
s) =
      Match ()
increaseConfidence
  | Bool
otherwise = FilePath -> FilePath -> Match ()
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 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleName [ModuleName]
ms FilePath
str =
  FilePath -> FilePath -> Match ModuleName -> Match ModuleName
forall a. FilePath -> FilePath -> Match a -> Match a
orNoSuchThing FilePath
"module" FilePath
str (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
    Match ModuleName -> Match ModuleName
forall a. Match a -> Match a
increaseConfidenceFor (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
      ShowS -> [(FilePath, ModuleName)] -> FilePath -> Match ModuleName
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly
        ShowS
caseFold
        [ (ModuleName -> FilePath
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 =
  Match BuildTarget -> Match BuildTarget
forall a. Match a -> Match a
nubMatchErrors (Match BuildTarget -> Match BuildTarget)
-> Match BuildTarget -> Match BuildTarget
forall a b. (a -> b) -> a -> b
$ do
    c <- [ComponentInfo] -> Match ComponentInfo
forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
    filepath <- matchComponentFile c str1 exists
    return (BuildTargetFile (cinfoName c) 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
  c <- [ComponentInfo] -> FilePath -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs FilePath
str1
  filepath <- matchComponentFile c str2 exists
  return (BuildTargetFile (cinfoName c) 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
  ckind <- FilePath -> Match ComponentKind
matchComponentKind FilePath
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 :: ComponentInfo -> FilePath -> Bool -> Match FilePath
matchComponentFile ComponentInfo
c FilePath
str Bool
fexists =
  FilePath -> FilePath -> Match FilePath -> Match FilePath
forall a. FilePath -> FilePath -> Match a -> Match a
expecting FilePath
"file" FilePath
str (Match FilePath -> Match FilePath)
-> Match FilePath -> Match FilePath
forall a b. (a -> b) -> a -> b
$
    Match FilePath -> Match FilePath -> Match FilePath
forall a. Match a -> Match a -> Match a
matchPlus
      (FilePath -> Bool -> Match FilePath
forall a. FilePath -> Bool -> Match a
matchFileExists FilePath
str Bool
fexists)
      ( Match FilePath -> Match FilePath -> Match FilePath
forall a. Match a -> Match a -> Match a
matchPlusShadowing
          ( [Match FilePath] -> Match FilePath
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
              ]
          )
          ( [Match FilePath] -> Match FilePath
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 = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
matchFileExists FilePath
fname Bool
True = do
  Match ()
increaseConfidence
  FilePath -> FilePath -> Match a
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] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms FilePath
filepath
  return filepath

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

matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem [ModuleName]
ms =
  Match ModuleName -> Match ModuleName
forall a. Match a -> Match a
increaseConfidenceFor
    (Match ModuleName -> Match ModuleName)
-> (FilePath -> Match ModuleName) -> FilePath -> Match ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [(FilePath, ModuleName)] -> FilePath -> Match ModuleName
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]
    (FilePath -> Match ModuleName)
-> ShowS -> FilePath -> Match ModuleName
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 -> Match FilePath
matchDirectoryPrefix [FilePath]
dirs FilePath
filepath
  _ <- matchFile fs filepath'
  return 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 -> Match FilePath
matchFile [FilePath]
fs FilePath
filepath
  return filepath

matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile [FilePath]
fs =
  Match FilePath -> Match FilePath
forall a. Match a -> Match a
increaseConfidenceFor
    (Match FilePath -> Match FilePath)
-> (FilePath -> Match FilePath) -> FilePath -> Match FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [(FilePath, FilePath)] -> FilePath -> Match FilePath
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 =
  [FilePath] -> Match FilePath
forall a. [a] -> Match a
exactMatches ([FilePath] -> Match FilePath) -> [FilePath] -> Match FilePath
forall a b. (a -> b) -> a -> b
$
    [Maybe FilePath] -> [FilePath]
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 ([FilePath] -> FilePath) -> Maybe [FilePath] -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [FilePath] -> [FilePath] -> Maybe [FilePath]
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
[Match a] -> ShowS
Match a -> FilePath
(Int -> Match a -> ShowS)
-> (Match a -> FilePath) -> ([Match a] -> ShowS) -> Show (Match a)
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
$cshowsPrec :: forall a. Show a => Int -> Match a -> ShowS
showsPrec :: Int -> Match a -> ShowS
$cshow :: forall a. Show a => Match a -> FilePath
show :: Match a -> FilePath
$cshowList :: forall a. Show a => [Match a] -> ShowS
showList :: [Match a] -> ShowS
Show)

type Confidence = Int

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

instance Alternative Match where
  empty :: forall a. Match a
empty = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall a. Match a -> Match a -> Match a
(<|>) = Match a -> Match a -> Match a
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 = Match a
forall a. Match a
matchZero
  mplus :: forall a. Match a -> Match a -> Match a
mplus = Match a -> Match a -> Match a
forall a. Match a -> Match a -> Match a
matchPlus

matchZero :: Match a
matchZero :: forall a. Match a
matchZero = Int -> [MatchError] -> Match a
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') =
  Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs [a] -> [a] -> [a]
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') =
  Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
d1 Int
d2) ([a]
xs [a] -> [a] -> [a]
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
d2 = Match a
a
  | Int
d1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d2 = Match a
b
  | Bool
otherwise = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d1 ([MatchError]
ms [MatchError] -> [MatchError] -> [MatchError]
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 = Match a -> Match a -> Match a
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) = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
  fmap a -> b
f (ExactMatch Int
d [a]
xs) = Int -> [b] -> Match b
forall a. Int -> [a] -> Match a
ExactMatch Int
d ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
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) = Int -> [b] -> Match b
forall a. Int -> [a] -> Match a
InexactMatch Int
d ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
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 = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a
a]
  <*> :: forall a b. Match (a -> b) -> Match a -> Match 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 = a -> Match a
forall {b}. b -> Match b
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
_ = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
  ExactMatch Int
d [a]
xs >>= a -> Match b
f =
    Int -> Match b -> Match b
forall a. Int -> Match a -> Match a
addDepth Int
d (Match b -> Match b) -> Match b -> Match b
forall a b. (a -> b) -> a -> b
$
      (Match b -> Match b -> Match b) -> Match b -> [Match b] -> Match b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Match b -> Match b -> Match b
forall a. Match a -> Match a -> Match a
matchPlus Match b
forall a. Match a
matchZero ((a -> Match b) -> [a] -> [Match b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs)
  InexactMatch Int
d [a]
xs >>= a -> Match b
f =
    Int -> Match b -> Match b
forall a. Int -> Match a -> Match a
addDepth Int
d (Match b -> Match b) -> (Match b -> Match b) -> Match b -> Match b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Match b -> Match b
forall a. Match a -> Match a
forceInexact (Match b -> Match b) -> Match b -> Match b
forall a b. (a -> b) -> a -> b
$
      (Match b -> Match b -> Match b) -> Match b -> [Match b] -> Match b
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Match b -> Match b -> Match b
forall a. Match a -> Match a -> Match a
matchPlus Match b
forall a. Match a
matchZero ((a -> Match b) -> [a] -> [Match b]
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) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch (Int
d' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) [MatchError]
msgs
addDepth Int
d' (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch (Int
d' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d) [a]
xs
addDepth Int
d' (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch (Int
d' Int -> Int -> Int
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) = Int -> [a] -> Match a
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 = Int -> [MatchError] -> Match a
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 = Int -> [MatchError] -> Match a
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]
_) = FilePath -> FilePath -> Match a
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]
_) = FilePath -> FilePath -> Match a
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 = Int -> [()] -> Match ()
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 Match a -> (a -> Match a) -> Match a
forall a b. Match a -> (a -> Match b) -> Match b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> Match ()
increaseConfidence Match () -> Match a -> Match a
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Match a
forall {b}. b -> Match 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) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
msgs
nubMatches (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
d ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs)
nubMatches (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d ([a] -> [a]
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) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d ([MatchError] -> [MatchError]
forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
nubMatchErrors (ExactMatch Int
d [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
d [a]
xs
nubMatchErrors (InexactMatch Int
d [a]
xs) = Int -> [a] -> Match a
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 [] = Match a
forall a. Match a
matchZero
exactMatches [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a]
xs
inexactMatches :: forall a. [a] -> Match a
inexactMatches [] = Match a
forall a. Match a
matchZero
inexactMatches [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
0 [a]
xs

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

data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
  deriving (Int -> MaybeAmbiguous a -> ShowS
[MaybeAmbiguous a] -> ShowS
MaybeAmbiguous a -> FilePath
(Int -> MaybeAmbiguous a -> ShowS)
-> (MaybeAmbiguous a -> FilePath)
-> ([MaybeAmbiguous a] -> ShowS)
-> Show (MaybeAmbiguous a)
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
$cshowsPrec :: forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
showsPrec :: Int -> MaybeAmbiguous a -> ShowS
$cshow :: forall a. Show a => MaybeAmbiguous a -> FilePath
show :: MaybeAmbiguous a -> FilePath
$cshowList :: forall a. Show a => [MaybeAmbiguous a] -> ShowS
showList :: [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 a -> Map a [b] -> Maybe [b]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup a
x Map a [b]
m of
    Just [b]
ys -> [b] -> Match b
forall a. [a] -> Match a
exactMatches [b]
ys
    Maybe [b]
Nothing -> case a' -> Map a' [b] -> Maybe [b]
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 -> [b] -> Match b
forall a. [a] -> Match a
inexactMatches [b]
ys
      Maybe [b]
Nothing -> Match b
forall a. Match a
matchZero
  where
    m :: Map a [b]
m = ([b] -> [b] -> [b]) -> [(a, [b])] -> Map a [b]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [b] -> [b] -> [b]
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' = ([b] -> [b] -> [b]) -> (a -> a') -> Map a [b] -> Map a' [b]
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith [b] -> [b] -> [b]
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 [] =
  [TargetInfo] -> IO [TargetInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder' PackageDescription
pkg_descr LocalBuildInfo
lbi)
checkBuildTargets
  Verbosity
verbosity
  PackageDescription
pkg_descr
  lbi :: LocalBuildInfo
lbi@(LocalBuildInfo{componentEnabledSpec :: LocalBuildInfo -> ComponentRequestedSpec
componentEnabledSpec = ComponentRequestedSpec
enabledComps})
  [BuildTarget]
targets = do
    let ([(ComponentName, Maybe (Either ModuleName FilePath))]
enabled, [(ComponentName, ComponentDisabledReason)]
disabled) =
          [Either
   (ComponentName, Maybe (Either ModuleName FilePath))
   (ComponentName, ComponentDisabledReason)]
-> ([(ComponentName, Maybe (Either ModuleName FilePath))],
    [(ComponentName, ComponentDisabledReason)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
            [ case ComponentRequestedSpec
-> Component -> Maybe ComponentDisabledReason
componentDisabledReason ComponentRequestedSpec
enabledComps Component
comp of
              Maybe ComponentDisabledReason
Nothing -> (ComponentName, Maybe (Either ModuleName FilePath))
-> Either
     (ComponentName, Maybe (Either ModuleName FilePath))
     (ComponentName, ComponentDisabledReason)
forall a b. a -> Either a b
Left (ComponentName, Maybe (Either ModuleName FilePath))
target'
              Just ComponentDisabledReason
reason -> (ComponentName, ComponentDisabledReason)
-> Either
     (ComponentName, Maybe (Either ModuleName FilePath))
     (ComponentName, ComponentDisabledReason)
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
      [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      ((ComponentName
cname, ComponentDisabledReason
reason) : [(ComponentName, ComponentDisabledReason)]
_) -> Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO ()) -> CabalException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalException
CheckBuildTargets (FilePath -> CabalException) -> FilePath -> CabalException
forall a b. (a -> b) -> a -> b
$ FilePath -> ComponentDisabledReason -> FilePath
formatReason (ComponentName -> FilePath
showComponentName ComponentName
cname) ComponentDisabledReason
reason

    [(ComponentName, Either ModuleName FilePath)]
-> ((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ()
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] (((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ())
-> ((ComponentName, Either ModuleName FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ComponentName
c, Either ModuleName FilePath
t) ->
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"Ignoring '"
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ (ModuleName -> FilePath)
-> ShowS -> Either ModuleName FilePath -> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ModuleName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow ShowS
forall a. a -> a
id Either ModuleName FilePath
t
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
". The whole "
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> FilePath
showComponentName ComponentName
c
          FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" will be processed. (Support for "
          FilePath -> ShowS
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
    enabled' <- [(ComponentName, Maybe (Either ModuleName FilePath))]
-> ((ComponentName, Maybe (Either ModuleName FilePath))
    -> IO TargetInfo)
-> IO [TargetInfo]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(ComponentName, Maybe (Either ModuleName FilePath))]
enabled (((ComponentName, Maybe (Either ModuleName FilePath))
  -> IO TargetInfo)
 -> IO [TargetInfo])
-> ((ComponentName, Maybe (Either ModuleName FilePath))
    -> IO TargetInfo)
-> IO [TargetInfo]
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
        [] -> FilePath -> IO TargetInfo
forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: nothing enabled"
        [TargetInfo
target] -> TargetInfo -> IO TargetInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TargetInfo
target
        [TargetInfo]
_targets -> FilePath -> IO TargetInfo
forall a. HasCallStack => FilePath -> a
error FilePath
"checkBuildTargets: multiple copies enabled"

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

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