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

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.BuildTargets
-- Copyright   :  (c) Duncan Coutts 2012
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
--
-- Handling for user-specified build targets
-----------------------------------------------------------------------------
module Distribution.Simple.BuildTarget (
    -- * Main interface
    readTargetInfos,
    readBuildTargets, -- in case you don't have LocalBuildInfo

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

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

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

import Prelude ()
import Distribution.Compat.Prelude

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

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

import qualified Distribution.Compat.CharParsing as P

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

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

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

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

     -- | A target specified by a single name. This could be a component
     -- module or file.
     --
     -- > cabal build foo
     -- > cabal build Data.Foo
     -- > cabal build Data/Foo.hs  Data/Foo.hsc
     --
     UserBuildTargetSingle String

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

     -- | A fully qualified target, either a module or file qualified by a
     -- component name with the component namespace kind.
     --
     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
     --
   | UserBuildTargetTriple String String String
  deriving (Int -> UserBuildTarget -> ShowS
[UserBuildTarget] -> ShowS
UserBuildTarget -> String
(Int -> UserBuildTarget -> ShowS)
-> (UserBuildTarget -> String)
-> ([UserBuildTarget] -> ShowS)
-> Show UserBuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserBuildTarget] -> ShowS
$cshowList :: [UserBuildTarget] -> ShowS
show :: UserBuildTarget -> String
$cshow :: UserBuildTarget -> String
showsPrec :: Int -> UserBuildTarget -> ShowS
$cshowsPrec :: Int -> UserBuildTarget -> ShowS
Show, UserBuildTarget -> UserBuildTarget -> Bool
(UserBuildTarget -> UserBuildTarget -> Bool)
-> (UserBuildTarget -> UserBuildTarget -> Bool)
-> Eq UserBuildTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserBuildTarget -> UserBuildTarget -> Bool
$c/= :: UserBuildTarget -> UserBuildTarget -> Bool
== :: UserBuildTarget -> UserBuildTarget -> Bool
$c== :: UserBuildTarget -> UserBuildTarget -> Bool
Eq, Eq UserBuildTarget
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
min :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmin :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
max :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
$cmax :: UserBuildTarget -> UserBuildTarget -> UserBuildTarget
>= :: UserBuildTarget -> UserBuildTarget -> Bool
$c>= :: UserBuildTarget -> UserBuildTarget -> Bool
> :: UserBuildTarget -> UserBuildTarget -> Bool
$c> :: UserBuildTarget -> UserBuildTarget -> Bool
<= :: UserBuildTarget -> UserBuildTarget -> Bool
$c<= :: UserBuildTarget -> UserBuildTarget -> Bool
< :: UserBuildTarget -> UserBuildTarget -> Bool
$c< :: UserBuildTarget -> UserBuildTarget -> Bool
compare :: UserBuildTarget -> UserBuildTarget -> Ordering
$ccompare :: UserBuildTarget -> UserBuildTarget -> Ordering
$cp1Ord :: Eq 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
/= :: BuildTarget -> BuildTarget -> Bool
$c/= :: BuildTarget -> BuildTarget -> Bool
== :: BuildTarget -> BuildTarget -> Bool
$c== :: BuildTarget -> BuildTarget -> Bool
Eq, Int -> BuildTarget -> ShowS
[BuildTarget] -> ShowS
BuildTarget -> String
(Int -> BuildTarget -> ShowS)
-> (BuildTarget -> String)
-> ([BuildTarget] -> ShowS)
-> Show BuildTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildTarget] -> ShowS
$cshowList :: [BuildTarget] -> ShowS
show :: BuildTarget -> String
$cshow :: BuildTarget -> String
showsPrec :: Int -> BuildTarget -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep BuildTarget x -> BuildTarget
$cfrom :: forall x. BuildTarget -> Rep BuildTarget x
Generic)

instance Binary BuildTarget

buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent ComponentName
cn)   = ComponentName
cn
buildTargetComponentName (BuildTargetModule    ComponentName
cn ModuleName
_) = ComponentName
cn
buildTargetComponentName (BuildTargetFile      ComponentName
cn String
_) = 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 -> [String] -> IO [BuildTarget]
readBuildTargets Verbosity
verbosity PackageDescription
pkg [String]
targetStrs = do
    let ([UserBuildTargetProblem]
uproblems, [UserBuildTarget]
utargets) = [String] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets [String]
targetStrs
    Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems Verbosity
verbosity [UserBuildTargetProblem]
uproblems

    [(UserBuildTarget, Bool)]
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)
traverse UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile [UserBuildTarget]
utargets

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

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

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

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

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


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

readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
                                    ,[UserBuildTarget])
readUserBuildTargets :: [String] -> ([UserBuildTargetProblem], [UserBuildTarget])
readUserBuildTargets = [Either UserBuildTargetProblem UserBuildTarget]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either UserBuildTargetProblem UserBuildTarget]
 -> ([UserBuildTargetProblem], [UserBuildTarget]))
-> ([String] -> [Either UserBuildTargetProblem UserBuildTarget])
-> [String]
-> ([UserBuildTargetProblem], [UserBuildTarget])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Either UserBuildTargetProblem UserBuildTarget)
-> [String] -> [Either UserBuildTargetProblem UserBuildTarget]
forall a b. (a -> b) -> [a] -> [b]
map String -> 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 :: String -> Either UserBuildTargetProblem UserBuildTarget
readUserBuildTarget String
targetstr =
    case ParsecParser UserBuildTarget
-> String -> Either String UserBuildTarget
forall a. ParsecParser a -> String -> Either String a
explicitEitherParsec ParsecParser UserBuildTarget
forall (m :: * -> *). CabalParsing m => m UserBuildTarget
parseTargetApprox String
targetstr of
      Left String
_    -> UserBuildTargetProblem
-> Either UserBuildTargetProblem UserBuildTarget
forall a b. a -> Either a b
Left  (String -> UserBuildTargetProblem
UserBuildTargetUnrecognised String
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 :: m UserBuildTarget
parseTargetApprox = do
        -- read one, two, or three tokens, where last could be "hs-string"
        (String, Maybe (String, Maybe String))
ts <- m (String, Maybe (String, Maybe String))
forall (m :: * -> *).
CabalParsing m =>
m (String, Maybe (String, Maybe String))
tokens
        UserBuildTarget -> m UserBuildTarget
forall (m :: * -> *) a. Monad m => a -> m a
return (UserBuildTarget -> m UserBuildTarget)
-> UserBuildTarget -> m UserBuildTarget
forall a b. (a -> b) -> a -> b
$ case (String, Maybe (String, Maybe String))
ts of
            (String
a, Maybe (String, Maybe String)
Nothing)           -> String -> UserBuildTarget
UserBuildTargetSingle String
a
            (String
a, Just (String
b, Maybe String
Nothing)) -> String -> String -> UserBuildTarget
UserBuildTargetDouble String
a String
b
            (String
a, Just (String
b, Just String
c))  -> String -> String -> String -> UserBuildTarget
UserBuildTargetTriple String
a String
b String
c

    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
    tokens :: m (String, Maybe (String, Maybe String))
tokens = (\String
s -> (String
s, Maybe (String, Maybe String)
forall a. Maybe a
Nothing)) (String -> (String, Maybe (String, Maybe String)))
-> m String -> m (String, Maybe (String, Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). CabalParsing m => m String
parsecHaskellString
        m (String, Maybe (String, Maybe String))
-> m (String, Maybe (String, Maybe String))
-> m (String, Maybe (String, Maybe String))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (String
 -> Maybe (String, Maybe String)
 -> (String, Maybe (String, Maybe String)))
-> m String
-> m (Maybe (String, Maybe String)
      -> (String, Maybe (String, Maybe String)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). CabalParsing m => m String
token m (Maybe (String, Maybe String)
   -> (String, Maybe (String, Maybe String)))
-> m (Maybe (String, Maybe String))
-> m (String, Maybe (String, Maybe String))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (String, Maybe String) -> m (Maybe (String, Maybe String))
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 (String, Maybe String) -> m (String, Maybe String)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m (String, Maybe String)
forall (m :: * -> *). CabalParsing m => m (String, Maybe String)
tokens2)

    tokens2 :: CabalParsing m => m (String, Maybe String)
    tokens2 :: m (String, Maybe String)
tokens2 = (\String
s -> (String
s, Maybe String
forall a. Maybe a
Nothing)) (String -> (String, Maybe String))
-> m String -> m (String, Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). CabalParsing m => m String
parsecHaskellString
        m (String, Maybe String)
-> m (String, Maybe String) -> m (String, Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (,) (String -> Maybe String -> (String, Maybe String))
-> m String -> m (Maybe String -> (String, Maybe String))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
forall (m :: * -> *). CabalParsing m => m String
token m (Maybe String -> (String, Maybe String))
-> m (Maybe String) -> m (String, Maybe String)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m String -> m (Maybe String)
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 String -> m String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (m String
forall (m :: * -> *). CabalParsing m => m String
parsecHaskellString m String -> m String -> m String
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m String
forall (m :: * -> *). CabalParsing m => m String
token))

    token :: CabalParsing m => m String
    token :: m String
token  = (Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
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 -> String
(Int -> UserBuildTargetProblem -> ShowS)
-> (UserBuildTargetProblem -> String)
-> ([UserBuildTargetProblem] -> ShowS)
-> Show UserBuildTargetProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserBuildTargetProblem] -> ShowS
$cshowList :: [UserBuildTargetProblem] -> ShowS
show :: UserBuildTargetProblem -> String
$cshow :: UserBuildTargetProblem -> String
showsPrec :: Int -> UserBuildTargetProblem -> ShowS
$cshowsPrec :: Int -> UserBuildTargetProblem -> ShowS
Show

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

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

-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' QualLevel
ql PackageId
pkgid BuildTarget
bt =
    UserBuildTarget -> String
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 -> String
showBuildTarget PackageId
pkgid BuildTarget
t =
    QualLevel -> PackageId -> BuildTarget -> String
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 (String, String)
expected' <- [(String, String)] -> Maybe (NonEmpty (String, String))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(String, String)]
expected
                            = let (NonEmpty String
things, String
got:|[String]
_) = NonEmpty (String, String) -> (NonEmpty String, NonEmpty String)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip NonEmpty (String, String)
expected' in
                              UserBuildTarget -> [String] -> String -> BuildTargetProblem
BuildTargetExpected UserBuildTarget
userTarget (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
things) String
got
      | Bool -> Bool
not ([(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
nosuch)   = UserBuildTarget -> [(String, String)] -> BuildTargetProblem
BuildTargetNoSuch   UserBuildTarget
userTarget [(String, String)]
nosuch
      | Bool
otherwise = String -> BuildTargetProblem
forall a. HasCallStack => String -> a
error (String -> BuildTargetProblem) -> String -> BuildTargetProblem
forall a b. (a -> b) -> a -> b
$ String
"resolveBuildTarget: internal error in matching"
      where
        expected :: [(String, String)]
expected = [ (String
thing, String
got) | MatchErrorExpected String
thing String
got <- [MatchError]
errs ]
        nosuch :: [(String, String)]
nosuch   = [ (String
thing, String
got) | MatchErrorNoSuch   String
thing String
got <- [MatchError]
errs ]


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


disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
                         -> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets :: PackageId
-> UserBuildTarget
-> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets PackageId
pkgid UserBuildTarget
original =
    QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (UserBuildTarget -> QualLevel
userTargetQualLevel UserBuildTarget
original)
  where
    disambiguate :: QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate QualLevel
ql [BuildTarget]
ts
        | [BuildTarget] -> 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 String
_    ) = QualLevel
QL1
    userTargetQualLevel (UserBuildTargetDouble String
_ String
_  ) = QualLevel
QL2
    userTargetQualLevel (UserBuildTargetTriple String
_ String
_ String
_) = 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 (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
enumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
$cenumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
enumFromTo :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromTo :: QualLevel -> QualLevel -> [QualLevel]
enumFromThen :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromThen :: QualLevel -> QualLevel -> [QualLevel]
enumFrom :: QualLevel -> [QualLevel]
$cenumFrom :: QualLevel -> [QualLevel]
fromEnum :: QualLevel -> Int
$cfromEnum :: QualLevel -> Int
toEnum :: Int -> QualLevel
$ctoEnum :: Int -> QualLevel
pred :: QualLevel -> QualLevel
$cpred :: QualLevel -> QualLevel
succ :: QualLevel -> QualLevel
$csucc :: QualLevel -> QualLevel
Enum, Int -> QualLevel -> ShowS
[QualLevel] -> ShowS
QualLevel -> String
(Int -> QualLevel -> ShowS)
-> (QualLevel -> String)
-> ([QualLevel] -> ShowS)
-> Show QualLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QualLevel] -> ShowS
$cshowList :: [QualLevel] -> ShowS
show :: QualLevel -> String
$cshow :: QualLevel -> String
showsPrec :: Int -> QualLevel -> ShowS
$cshowsPrec :: Int -> QualLevel -> ShowS
Show)

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

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

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

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

    dispCName :: ComponentName -> String
dispCName = PackageId -> ComponentName -> String
forall pkg. Package pkg => pkg -> ComponentName -> String
componentStringName PackageId
pkgid
    dispKind :: ComponentName -> String
dispKind  = ComponentKind -> String
showComponentKindShort (ComponentKind -> String)
-> (ComponentName -> ComponentKind) -> ComponentName -> String
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, [String]
e, String
g) | BuildTargetExpected UserBuildTarget
t [String]
e String
g <- [BuildTargetProblem]
problems ] of
      []      -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      [(UserBuildTarget, [String], String)]
targets ->
        Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [    String
"Unrecognised build target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> String
showUserBuildTarget UserBuildTarget
target
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'.\n"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"Expected a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" or " [String]
expected
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", rather than '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
          | (UserBuildTarget
target, [String]
expected, String
got) <- [(UserBuildTarget, [String], String)]
targets ]

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

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

  where
    showBuildTargetKind :: BuildTarget -> String
showBuildTargetKind (BuildTargetComponent ComponentName
_  ) = String
"component"
    showBuildTargetKind (BuildTargetModule    ComponentName
_ ModuleName
_) = String
"module"
    showBuildTargetKind (BuildTargetFile      ComponentName
_ String
_) = String
"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 String
str1 ->
        [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 [ComponentInfo]
cinfo String
str1 Bool
fexists

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

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

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


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


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


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

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo PackageDescription
pkg =
    [ ComponentInfo :: ComponentName
-> String
-> [String]
-> [ModuleName]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> [String]
-> ComponentInfo
ComponentInfo {
        cinfoName :: ComponentName
cinfoName    = Component -> ComponentName
componentName Component
c,
        cinfoStrName :: String
cinfoStrName = PackageDescription -> ComponentName -> String
forall pkg. Package pkg => pkg -> ComponentName -> String
componentStringName PackageDescription
pkg (Component -> ComponentName
componentName Component
c),
        cinfoSrcDirs :: [String]
cinfoSrcDirs = BuildInfo -> [String]
hsSourceDirs BuildInfo
bi,
        cinfoModules :: [ModuleName]
cinfoModules = Component -> [ModuleName]
componentModules Component
c,
        cinfoHsFiles :: [String]
cinfoHsFiles = Component -> [String]
componentHsFiles Component
c,
        cinfoAsmFiles :: [String]
cinfoAsmFiles= BuildInfo -> [String]
asmSources BuildInfo
bi,
        cinfoCmmFiles :: [String]
cinfoCmmFiles= BuildInfo -> [String]
cmmSources BuildInfo
bi,
        cinfoCFiles :: [String]
cinfoCFiles  = BuildInfo -> [String]
cSources BuildInfo
bi,
        cinfoCxxFiles :: [String]
cinfoCxxFiles= BuildInfo -> [String]
cxxSources BuildInfo
bi,
        cinfoJsFiles :: [String]
cinfoJsFiles = BuildInfo -> [String]
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 :: pkg -> ComponentName -> String
componentStringName pkg
pkg (CLibName LibraryName
LMainLibName      ) = PackageName -> String
forall a. Pretty a => a -> String
prettyShow (pkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName pkg
pkg)
componentStringName pkg
_   (CLibName (LSubLibName UnqualComponentName
name)) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CFLibName  UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CExeName   UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CTestName  UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName pkg
_   (CBenchName UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name

componentModules :: Component -> [ModuleName]
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
-- a user could very well ask to build a specific signature
-- that was inherited from other packages.  To fix this
-- we have to plumb 'LocalBuildInfo' through this code.
-- Fortunately, this is only used by 'pkgComponentInfo'
-- Please don't export this function unless you plan on fixing
-- this.
componentModules :: Component -> [ModuleName]
componentModules (CLib   Library
lib)   = Library -> [ModuleName]
explicitLibModules Library
lib
componentModules (CFLib  ForeignLib
flib)  = ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
componentModules (CExe   Executable
exe)   = Executable -> [ModuleName]
exeModules Executable
exe
componentModules (CTest  TestSuite
test)  = TestSuite -> [ModuleName]
testModules TestSuite
test
componentModules (CBench Benchmark
bench) = Benchmark -> [ModuleName]
benchmarkModules Benchmark
bench

componentHsFiles :: Component -> [FilePath]
componentHsFiles :: Component -> [String]
componentHsFiles (CExe Executable
exe) = [Executable -> String
modulePath Executable
exe]
componentHsFiles (CTest  TestSuite {
                           testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 Version
_ String
mainfile
                         }) = [String
mainfile]
componentHsFiles (CBench Benchmark {
                           benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 Version
_ String
mainfile
                         }) = [String
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
/= :: ComponentKind -> ComponentKind -> Bool
$c/= :: ComponentKind -> ComponentKind -> Bool
== :: ComponentKind -> ComponentKind -> Bool
$c== :: 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
min :: ComponentKind -> ComponentKind -> ComponentKind
$cmin :: ComponentKind -> ComponentKind -> ComponentKind
max :: ComponentKind -> ComponentKind -> ComponentKind
$cmax :: ComponentKind -> ComponentKind -> ComponentKind
>= :: ComponentKind -> ComponentKind -> Bool
$c>= :: ComponentKind -> ComponentKind -> Bool
> :: ComponentKind -> ComponentKind -> Bool
$c> :: ComponentKind -> ComponentKind -> Bool
<= :: ComponentKind -> ComponentKind -> Bool
$c<= :: ComponentKind -> ComponentKind -> Bool
< :: ComponentKind -> ComponentKind -> Bool
$c< :: ComponentKind -> ComponentKind -> Bool
compare :: ComponentKind -> ComponentKind -> Ordering
$ccompare :: ComponentKind -> ComponentKind -> Ordering
$cp1Ord :: Eq ComponentKind
Ord, Int -> ComponentKind -> ShowS
[ComponentKind] -> ShowS
ComponentKind -> String
(Int -> ComponentKind -> ShowS)
-> (ComponentKind -> String)
-> ([ComponentKind] -> ShowS)
-> Show ComponentKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ComponentKind] -> ShowS
$cshowList :: [ComponentKind] -> ShowS
show :: ComponentKind -> String
$cshow :: ComponentKind -> String
showsPrec :: Int -> ComponentKind -> ShowS
$cshowsPrec :: Int -> ComponentKind -> ShowS
Show)

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

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

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

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

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

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

-- utils:

guardComponentName :: String -> Match ()
guardComponentName :: String -> Match ()
guardComponentName String
s
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validComponentChar String
s
    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s)  = Match ()
increaseConfidence
  | Bool
otherwise        = String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
"component name" String
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] -> String -> Match ComponentInfo
matchComponentName [ComponentInfo]
cs String
str =
    String -> String -> Match ComponentInfo -> Match ComponentInfo
forall a. String -> String -> Match a -> Match a
orNoSuchThing String
"component" String
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 -> [(String, ComponentInfo)] -> String -> Match ComponentInfo
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold
      [ (ComponentInfo -> String
cinfoStrName ComponentInfo
c, ComponentInfo
c) | ComponentInfo
c <- [ComponentInfo]
cs ]
      String
str

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


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

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

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

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

-- utils:

guardModuleName :: String -> Match ()
guardModuleName :: String -> Match ()
guardModuleName String
s
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar String
s
    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s)       = Match ()
increaseConfidence
  | Bool
otherwise             = String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
"module name" String
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] -> String -> Match ModuleName
matchModuleName [ModuleName]
ms String
str =
    String -> String -> Match ModuleName -> Match ModuleName
forall a. String -> String -> Match a -> Match a
orNoSuchThing String
"module" String
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 -> [(String, ModuleName)] -> String -> Match ModuleName
forall a a' b.
(Ord a, Ord a') =>
(a -> a') -> [(a, b)] -> a -> Match b
matchInexactly ShowS
caseFold
      [ (ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m, ModuleName
m)
      | ModuleName
m <- [ModuleName]
ms ]
      String
str


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

matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 [ComponentInfo]
cs String
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
      ComponentInfo
c <- [ComponentInfo] -> Match ComponentInfo
forall a. [a] -> Match a
tryEach [ComponentInfo]
cs
      String
filepath <- ComponentInfo -> String -> Bool -> Match String
matchComponentFile ComponentInfo
c String
str1 Bool
exists
      BuildTarget -> Match BuildTarget
forall (m :: * -> *) a. Monad m => a -> m a
return (ComponentName -> String -> BuildTarget
BuildTargetFile (ComponentInfo -> ComponentName
cinfoName ComponentInfo
c) String
filepath)


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


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


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


-- utils

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

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

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

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

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

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

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

matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix :: [String] -> String -> Match String
matchDirectoryPrefix [String]
dirs String
filepath =
    [String] -> Match String
forall a. [a] -> Match a
exactMatches ([String] -> Match String) -> [String] -> Match String
forall a b. (a -> b) -> a -> b
$
      [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
       [ String -> String -> Maybe String
stripDirectory (ShowS
normalise String
dir) String
filepath | String
dir <- [String]
dirs ]
  where
    stripDirectory :: FilePath -> FilePath -> Maybe FilePath
    stripDirectory :: String -> String -> Maybe String
stripDirectory String
dir String
fp =
      [String] -> String
joinPath ([String] -> String) -> Maybe [String] -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [String] -> [String] -> Maybe [String]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (String -> [String]
splitDirectories String
dir) (String -> [String]
splitDirectories String
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 -> String
(Int -> Match a -> ShowS)
-> (Match a -> String) -> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Match a] -> ShowS
$cshowList :: forall a. Show a => [Match a] -> ShowS
show :: Match a -> String
$cshow :: forall a. Show a => Match a -> String
showsPrec :: Int -> Match a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Match a -> ShowS
Show

type Confidence = Int

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


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

instance MonadPlus Match where
  mzero :: Match a
mzero = Match a
forall a. Match a
matchZero
  mplus :: 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 :: 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 :: 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 :: 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 :: (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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs)

instance Applicative Match where
  pure :: a -> Match a
pure a
a = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
0 [a
a]
  <*> :: 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 :: a -> Match a
return = a -> Match a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  NoMatch      Int
d [MatchError]
ms >>= :: 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 (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 (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 :: 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 :: 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 :: String -> String -> Match a
matchErrorExpected String
thing String
got = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 [String -> String -> MatchError
MatchErrorExpected String
thing String
got]
matchErrorNoSuch :: String -> String -> Match a
matchErrorNoSuch   String
thing String
got = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 [String -> String -> MatchError
MatchErrorNoSuch   String
thing String
got]

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

orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing String
thing String
got (NoMatch Int
0 [MatchError]
_) = String -> String -> Match a
forall a. String -> String -> Match a
matchErrorNoSuch String
thing String
got
orNoSuchThing String
_     String
_   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 :: Match a -> Match a
increaseConfidenceFor Match a
m = Match a
m Match a -> (a -> Match a) -> Match a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> Match ()
increaseConfidence Match () -> Match a -> Match a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

nubMatches :: Eq a => Match a -> Match a
nubMatches :: 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 :: 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 :: [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 :: [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 :: [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 :: 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 -> String
(Int -> MaybeAmbiguous a -> ShowS)
-> (MaybeAmbiguous a -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MaybeAmbiguous a] -> ShowS
$cshowList :: forall a. Show a => [MaybeAmbiguous a] -> ShowS
show :: MaybeAmbiguous a -> String
$cshow :: forall a. Show a => MaybeAmbiguous a -> String
showsPrec :: Int -> MaybeAmbiguous a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
Show


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

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

-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
-- is not exact, but the canonical forms match. It takes a canonicalisation
-- function for this purpose.
--
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
--
matchInexactly :: (Ord a, Ord a') =>
                        (a -> a') ->
                        [(a, b)] -> (a -> Match b)
matchInexactly :: (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 (m :: * -> *) a. Monad m => a -> m a
return (PackageDescription -> LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder' PackageDescription
pkg_descr LocalBuildInfo
lbi)

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

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

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

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

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

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

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

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