{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.BuildTarget (
readTargetInfos,
readBuildTargets,
BuildTarget(..),
showBuildTarget,
QualLevel(..),
buildTargetComponentName,
UserBuildTarget,
readUserBuildTargets,
showUserBuildTarget,
UserBuildTargetProblem(..),
reportUserBuildTargetProblems,
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 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
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [String]
-> IO [TargetInfo]
readTargetInfos verbosity :: Verbosity
verbosity pkg_descr :: PackageDescription
pkg_descr lbi :: LocalBuildInfo
lbi args :: [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
data UserBuildTarget =
UserBuildTargetSingle String
| UserBuildTargetDouble String String
| 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)
data BuildTarget =
BuildTargetComponent ComponentName
| BuildTargetModule ComponentName ModuleName
| 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 cn :: ComponentName
cn) = ComponentName
cn
buildTargetComponentName (BuildTargetModule cn :: ComponentName
cn _) = ComponentName
cn
buildTargetComponentName (BuildTargetFile cn :: ComponentName
cn _) = ComponentName
cn
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets verbosity :: Verbosity
verbosity pkg :: PackageDescription
pkg targetStrs :: [String]
targetStrs = do
let (uproblems :: [UserBuildTargetProblem]
uproblems, utargets :: [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 (bproblems :: [BuildTargetProblem]
bproblems, btargets :: [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 t :: 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 f :: String
f = do
Bool
exists <- String -> IO Bool
doesFileExist String
f
case String -> [String]
splitPath String
f of
(d :: String
d:_) | String -> Bool
hasTrailingPathSeparator String
d -> String -> IO Bool
doesDirectoryExist String
d
(d :: String
d:_:_) | Bool -> Bool
not Bool
exists -> String -> IO Bool
doesDirectoryExist String
d
_ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
exists
fileComponentOfTarget :: UserBuildTarget -> String
fileComponentOfTarget (UserBuildTargetSingle s1 :: String
s1) = String
s1
fileComponentOfTarget (UserBuildTargetDouble _ s2 :: String
s2) = String
s2
fileComponentOfTarget (UserBuildTargetTriple _ _ s3 :: String
s3) = String
s3
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 :: String -> Either UserBuildTargetProblem
UserBuildTarget
readUserBuildTarget :: String -> Either UserBuildTargetProblem UserBuildTarget
readUserBuildTarget targetstr :: 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 _ -> UserBuildTargetProblem
-> Either UserBuildTargetProblem UserBuildTarget
forall a b. a -> Either a b
Left (String -> UserBuildTargetProblem
UserBuildTargetUnrecognised String
targetstr)
Right tgt :: 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
(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
(a :: String
a, Nothing) -> String -> UserBuildTarget
UserBuildTargetSingle String
a
(a :: String
a, Just (b :: String
b, Nothing)) -> String -> String -> UserBuildTarget
UserBuildTargetDouble String
a String
b
(a :: String
a, Just (b :: String
b, Just c :: 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 = (\s :: 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 ':' 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 = (\s :: 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 ':' 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 (\x :: 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
/= ':')
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
verbosity problems :: [UserBuildTargetProblem]
problems = do
case [ String
target | UserBuildTargetUnrecognised target :: String
target <- [UserBuildTargetProblem]
problems ] of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
target :: [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
[ "Unrecognised build target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'."
| String
name <- [String]
target ]
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Examples:\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - build foo -- component name "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "(library, executable, test-suite or benchmark)\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - build Data.Foo -- module name\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - build Data/Foo.hsc -- file name\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - build lib:foo exe:foo -- component qualified by kind\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - build foo:Data.Foo -- module qualified by component\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ " - 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)
-> (UserBuildTarget -> [String]) -> UserBuildTarget -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserBuildTarget -> [String]
getComponents
where
getComponents :: UserBuildTarget -> [String]
getComponents (UserBuildTargetSingle s1 :: String
s1) = [String
s1]
getComponents (UserBuildTargetDouble s1 :: String
s1 s2 :: String
s2) = [String
s1,String
s2]
getComponents (UserBuildTargetTriple s1 :: String
s1 s2 :: String
s2 s3 :: String
s3) = [String
s1,String
s2,String
s3]
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' ql :: QualLevel
ql pkgid :: PackageId
pkgid bt :: BuildTarget
bt =
UserBuildTarget -> String
showUserBuildTarget (QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget QualLevel
ql BuildTarget
bt PackageId
pkgid)
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget pkgid :: PackageId
pkgid t :: 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 _ = QualLevel
QL3
resolveBuildTargets :: PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets :: PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets pkg :: 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 pkg :: PackageDescription
pkg userTarget :: UserBuildTarget
userTarget fexists :: 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 target :: BuildTarget
target -> BuildTarget -> Either BuildTargetProblem BuildTarget
forall a b. b -> Either a b
Right BuildTarget
target
Ambiguous targets :: [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 errs :: [MatchError]
errs -> BuildTargetProblem -> Either BuildTargetProblem BuildTarget
forall a b. a -> Either a b
Left ([MatchError] -> BuildTargetProblem
classifyMatchErrors [MatchError]
errs)
where
classifyMatchErrors :: [MatchError] -> BuildTargetProblem
classifyMatchErrors errs :: [MatchError]
errs
| Bool -> Bool
not ([(String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String)]
expected) = let (things :: [String]
things, got :: String
got:_) = [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip [(String, String)]
expected in
UserBuildTarget -> [String] -> String -> BuildTargetProblem
BuildTargetExpected UserBuildTarget
userTarget [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
$ "resolveBuildTarget: internal error in matching"
where
expected :: [(String, String)]
expected = [ (String
thing, String
got) | MatchErrorExpected thing :: String
thing got :: String
got <- [MatchError]
errs ]
nosuch :: [(String, String)]
nosuch = [ (String
thing, String
got) | MatchErrorNoSuch thing :: String
thing got :: String
got <- [MatchError]
errs ]
data BuildTargetProblem
= BuildTargetExpected UserBuildTarget [String] String
| BuildTargetNoSuch UserBuildTarget [(String, String)]
| 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 pkgid :: PackageId
pkgid original :: UserBuildTarget
original =
QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate (UserBuildTarget -> QualLevel
userTargetQualLevel UserBuildTarget
original)
where
disambiguate :: QualLevel -> [BuildTarget] -> [(UserBuildTarget, BuildTarget)]
disambiguate ql :: QualLevel
ql ts :: [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
(amb :: [BuildTarget]
amb, unamb :: [(UserBuildTarget, BuildTarget)]
unamb) = QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step QualLevel
ql [BuildTarget]
ts
userTargetQualLevel :: UserBuildTarget -> QualLevel
userTargetQualLevel (UserBuildTargetSingle _ ) = QualLevel
QL1
userTargetQualLevel (UserBuildTargetDouble _ _ ) = QualLevel
QL2
userTargetQualLevel (UserBuildTargetTriple _ _ _) = QualLevel
QL3
step :: QualLevel -> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step :: QualLevel
-> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step ql :: QualLevel
ql = (\(amb :: [[(UserBuildTarget, BuildTarget)]]
amb, unamb :: [[(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 (\g :: [(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
> 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 (\t :: 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 ql :: QualLevel
ql target :: BuildTarget
target pkgid :: PackageId
pkgid =
case QualLevel
ql of
QL1 -> String -> UserBuildTarget
UserBuildTargetSingle String
s1 where s1 :: String
s1 = BuildTarget -> String
single BuildTarget
target
QL2 -> String -> String -> UserBuildTarget
UserBuildTargetDouble String
s1 String
s2 where (s1 :: String
s1, s2 :: String
s2) = BuildTarget -> (String, String)
double BuildTarget
target
QL3 -> String -> String -> String -> UserBuildTarget
UserBuildTargetTriple String
s1 String
s2 String
s3 where (s1 :: String
s1, s2 :: String
s2, s3 :: String
s3) = BuildTarget -> (String, String, String)
triple BuildTarget
target
where
single :: BuildTarget -> String
single (BuildTargetComponent cn :: ComponentName
cn ) = ComponentName -> String
dispCName ComponentName
cn
single (BuildTargetModule _ m :: ModuleName
m) = ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m
single (BuildTargetFile _ f :: String
f) = String
f
double :: BuildTarget -> (String, String)
double (BuildTargetComponent cn :: ComponentName
cn ) = (ComponentName -> String
dispKind ComponentName
cn, ComponentName -> String
dispCName ComponentName
cn)
double (BuildTargetModule cn :: ComponentName
cn m :: ModuleName
m) = (ComponentName -> String
dispCName ComponentName
cn, ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m)
double (BuildTargetFile cn :: ComponentName
cn f :: String
f) = (ComponentName -> String
dispCName ComponentName
cn, String
f)
triple :: BuildTarget -> (String, String, String)
triple (BuildTargetComponent _ ) = String -> (String, String, String)
forall a. HasCallStack => String -> a
error "triple BuildTargetComponent"
triple (BuildTargetModule cn :: ComponentName
cn m :: 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 cn :: ComponentName
cn f :: 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
verbosity problems :: [BuildTargetProblem]
problems = do
case [ (UserBuildTarget
t, [String]
e, String
g) | BuildTargetExpected t :: UserBuildTarget
t e :: [String]
e g :: String
g <- [BuildTargetProblem]
problems ] of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
targets :: [(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
[ "Unrecognised build target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> String
showUserBuildTarget UserBuildTarget
target
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'.\n"
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "Expected a " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " or " [String]
expected
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", rather than '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'."
| (target :: UserBuildTarget
target, expected :: [String]
expected, got :: String
got) <- [(UserBuildTarget, [String], String)]
targets ]
case [ (UserBuildTarget
t, [(String, String)]
e) | BuildTargetNoSuch t :: UserBuildTarget
t e :: [(String, String)]
e <- [BuildTargetProblem]
problems ] of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
targets :: [(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
[ "Unknown build target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> String
showUserBuildTarget UserBuildTarget
target
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'.\nThere is no "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " or " [ ShowS
mungeThing String
thing String -> ShowS
forall a. [a] -> [a] -> [a]
++ " '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
got String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'"
| (thing :: String
thing, got :: String
got) <- [(String, String)]
nosuch ] String -> ShowS
forall a. [a] -> [a] -> [a]
++ "."
| (target :: UserBuildTarget
target, nosuch :: [(String, String)]
nosuch) <- [(UserBuildTarget, [(String, String)])]
targets ]
where
mungeThing :: ShowS
mungeThing "file" = "file target"
mungeThing thing :: String
thing = String
thing
case [ (UserBuildTarget
t, [(UserBuildTarget, BuildTarget)]
ts) | BuildTargetAmbiguous t :: UserBuildTarget
t ts :: [(UserBuildTarget, BuildTarget)]
ts <- [BuildTargetProblem]
problems ] of
[] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
targets :: [(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
[ "Ambiguous build target '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> String
showUserBuildTarget UserBuildTarget
target
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "'. It could be:\n "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [ " "String -> ShowS
forall a. [a] -> [a] -> [a]
++ UserBuildTarget -> String
showUserBuildTarget UserBuildTarget
ut String -> ShowS
forall a. [a] -> [a] -> [a]
++
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ BuildTarget -> String
showBuildTargetKind BuildTarget
bt String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")"
| (ut :: UserBuildTarget
ut, bt :: BuildTarget
bt) <- [(UserBuildTarget, BuildTarget)]
amb ]
| (target :: UserBuildTarget
target, amb :: [(UserBuildTarget, BuildTarget)]
amb) <- [(UserBuildTarget, [(UserBuildTarget, BuildTarget)])]
targets ]
where
showBuildTargetKind :: BuildTarget -> String
showBuildTargetKind (BuildTargetComponent _ ) = "component"
showBuildTargetKind (BuildTargetModule _ _) = "module"
showBuildTargetKind (BuildTargetFile _ _) = "file"
matchBuildTarget :: PackageDescription
-> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget :: PackageDescription -> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget pkg :: PackageDescription
pkg = \utarget :: UserBuildTarget
utarget fexists :: Bool
fexists ->
case UserBuildTarget
utarget of
UserBuildTargetSingle str1 :: String
str1 ->
[ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 [ComponentInfo]
cinfo String
str1 Bool
fexists
UserBuildTargetDouble str1 :: String
str1 str2 :: String
str2 ->
[ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchBuildTarget2 [ComponentInfo]
cinfo String
str1 String
str2 Bool
fexists
UserBuildTargetTriple str1 :: String
str1 str2 :: String
str2 str3 :: 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 cinfo :: [ComponentInfo]
cinfo str1 :: String
str1 fexists :: 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 cinfo :: [ComponentInfo]
cinfo str1 :: String
str1 str2 :: String
str2 fexists :: 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 cinfo :: [ComponentInfo]
cinfo str1 :: String
str1 str2 :: String
str2 str3 :: String
str3 fexists :: 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],
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 pkg :: 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
pkg (CLibName LMainLibName ) = PackageName -> String
forall a. Pretty a => a -> String
prettyShow (pkg -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName pkg
pkg)
componentStringName _ (CLibName (LSubLibName name :: UnqualComponentName
name)) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName _ (CFLibName name :: UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName _ (CExeName name :: UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName _ (CTestName name :: UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName _ (CBenchName name :: UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentModules :: Component -> [ModuleName]
componentModules :: Component -> [ModuleName]
componentModules (CLib lib :: Library
lib) = Library -> [ModuleName]
explicitLibModules Library
lib
componentModules (CFLib flib :: ForeignLib
flib) = ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
componentModules (CExe exe :: Executable
exe) = Executable -> [ModuleName]
exeModules Executable
exe
componentModules (CTest test :: TestSuite
test) = TestSuite -> [ModuleName]
testModules TestSuite
test
componentModules (CBench bench :: Benchmark
bench) = Benchmark -> [ModuleName]
benchmarkModules Benchmark
bench
componentHsFiles :: Component -> [FilePath]
componentHsFiles :: Component -> [String]
componentHsFiles (CExe exe :: Executable
exe) = [Executable -> String
modulePath Executable
exe]
componentHsFiles (CTest TestSuite {
testInterface :: TestSuite -> TestSuiteInterface
testInterface = TestSuiteExeV10 _ mainfile :: String
mainfile
}) = [String
mainfile]
componentHsFiles (CBench Benchmark {
benchmarkInterface :: Benchmark -> BenchmarkInterface
benchmarkInterface = BenchmarkExeV10 _ mainfile :: String
mainfile
}) = [String
mainfile]
componentHsFiles _ = []
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 _) = ComponentKind
LibKind
componentKind (CFLibName _) = ComponentKind
FLibKind
componentKind (CExeName _) = ComponentKind
ExeKind
componentKind (CTestName _) = ComponentKind
TestKind
componentKind (CBenchName _) = 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 s :: String
s
| String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ["lib", "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` ["flib", "foreign-lib", "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` ["exe", "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` ["tst", "test", "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` ["bench", "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 "component kind" String
s
where
return' :: b -> Match b
return' ck :: 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 LibKind = "library"
showComponentKind FLibKind = "foreign-library"
showComponentKind ExeKind = "executable"
showComponentKind TestKind = "test-suite"
showComponentKind BenchKind = "benchmark"
showComponentKindShort :: ComponentKind -> String
showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind = "lib"
showComponentKindShort FLibKind = "flib"
showComponentKindShort ExeKind = "exe"
showComponentKindShort TestKind = "test"
showComponentKindShort BenchKind = "bench"
matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 cs :: [ComponentInfo]
cs = \str1 :: 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 cs :: [ComponentInfo]
cs = \str1 :: String
str1 str2 :: 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))
guardComponentName :: String -> Match ()
guardComponentName :: String -> Match ()
guardComponentName s :: 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 "component name" String
s
where
validComponentChar :: Char -> Bool
validComponentChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.'
Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '-' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''
matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName cs :: [ComponentInfo]
cs str :: String
str =
String -> String -> Match ComponentInfo -> Match ComponentInfo
forall a. String -> String -> Match a -> Match a
orNoSuchThing "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 cs :: [ComponentInfo]
cs ckind :: ComponentKind
ckind str :: 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]
++ " 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 (\(ck :: ComponentKind
ck, cn :: 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)
matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 cs :: [ComponentInfo]
cs = \str1 :: 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 cs :: [ComponentInfo]
cs = \str1 :: String
str1 str2 :: 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 cs :: [ComponentInfo]
cs str1 :: String
str1 str2 :: String
str2 str3 :: 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)
guardModuleName :: String -> Match ()
guardModuleName :: String -> Match ()
guardModuleName s :: 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 "module name" String
s
where
validModuleChar :: Char -> Bool
validModuleChar c :: Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\''
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms :: [ModuleName]
ms str :: String
str =
String -> String -> Match ModuleName -> Match ModuleName
forall a. String -> String -> Match a -> Match a
orNoSuchThing "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
matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 cs :: [ComponentInfo]
cs str1 :: String
str1 exists :: 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 cs :: [ComponentInfo]
cs str1 :: String
str1 str2 :: String
str2 exists :: 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 cs :: [ComponentInfo]
cs str1 :: String
str1 str2 :: String
str2 str3 :: String
str3 exists :: 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 c :: ComponentInfo
c str :: String
str fexists :: Bool
fexists =
String -> String -> Match String -> Match String
forall a. String -> String -> Match a -> Match a
expecting "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
matchFileExists :: FilePath -> Bool -> Match a
matchFileExists :: String -> Bool -> Match a
matchFileExists _ False = Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
matchFileExists fname :: String
fname True = do Match ()
increaseConfidence
String -> String -> Match a
forall a. String -> String -> Match a
matchErrorNoSuch "file" String
fname
matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted :: [ModuleName] -> String -> Match String
matchModuleFileUnrooted ms :: [ModuleName]
ms str :: 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 dirs :: [String]
dirs ms :: [ModuleName]
ms str :: 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 ms :: [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 dirs :: [String]
dirs fs :: [String]
fs str :: 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 fs :: [String]
fs str :: 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 fs :: [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 dirs :: [String]
dirs filepath :: 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 dir :: String
dir fp :: 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)
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 0 []
matchPlus :: Match a -> Match a -> Match a
matchPlus :: Match a -> Match a -> Match a
matchPlus (ExactMatch d1 :: Int
d1 xs :: [a]
xs) (ExactMatch d2 :: Int
d2 xs' :: [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 _ _ ) (InexactMatch _ _ ) = Match a
a
matchPlus a :: Match a
a@(ExactMatch _ _ ) (NoMatch _ _ ) = Match a
a
matchPlus (InexactMatch _ _ ) b :: Match a
b@(ExactMatch _ _ ) = Match a
b
matchPlus (InexactMatch d1 :: Int
d1 xs :: [a]
xs) (InexactMatch d2 :: Int
d2 xs' :: [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 _ _ ) (NoMatch _ _ ) = Match a
a
matchPlus (NoMatch _ _ ) b :: Match a
b@(ExactMatch _ _ ) = Match a
b
matchPlus (NoMatch _ _ ) b :: Match a
b@(InexactMatch _ _ ) = Match a
b
matchPlus a :: Match a
a@(NoMatch d1 :: Int
d1 ms :: [MatchError]
ms) b :: Match a
b@(NoMatch d2 :: Int
d2 ms' :: [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')
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a :: Match a
a@(ExactMatch _ _) (ExactMatch _ _) = Match a
a
matchPlusShadowing a :: Match a
a b :: 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 _ (NoMatch d :: Int
d ms :: [MatchError]
ms) = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
fmap f :: a -> b
f (ExactMatch d :: Int
d xs :: [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 f :: a -> b
f (InexactMatch d :: Int
d xs :: [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
a = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch 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 d :: Int
d ms :: [MatchError]
ms >>= :: Match a -> (a -> Match b) -> Match b
>>= _ = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
ExactMatch d :: Int
d xs :: [a]
xs >>= f :: 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 d :: Int
d xs :: [a]
xs >>= f :: 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 d' :: Int
d' (NoMatch d :: Int
d msgs :: [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 d' :: Int
d' (ExactMatch d :: Int
d xs :: [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 d' :: Int
d' (InexactMatch d :: Int
d xs :: [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 d :: Int
d ys :: [a]
ys) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d [a]
ys
forceInexact m :: Match a
m = Match a
m
matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected :: String -> String -> Match a
matchErrorExpected thing :: String
thing got :: String
got = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch 0 [String -> String -> MatchError
MatchErrorExpected String
thing String
got]
matchErrorNoSuch :: String -> String -> Match a
matchErrorNoSuch thing :: String
thing got :: String
got = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch 0 [String -> String -> MatchError
MatchErrorNoSuch String
thing String
got]
expecting :: String -> String -> Match a -> Match a
expecting :: String -> String -> Match a -> Match a
expecting thing :: String
thing got :: String
got (NoMatch 0 _) = String -> String -> Match a
forall a. String -> String -> Match a
matchErrorExpected String
thing String
got
expecting _ _ m :: Match a
m = Match a
m
orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing thing :: String
thing got :: String
got (NoMatch 0 _) = String -> String -> Match a
forall a. String -> String -> Match a
matchErrorNoSuch String
thing String
got
orNoSuchThing _ _ m :: Match a
m = Match a
m
increaseConfidence :: Match ()
increaseConfidence :: Match ()
increaseConfidence = Int -> [()] -> Match ()
forall a. Int -> [a] -> Match a
ExactMatch 1 [()]
increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m :: 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
>>= \r :: 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 d :: Int
d msgs :: [MatchError]
msgs) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
msgs
nubMatches (ExactMatch d :: Int
d xs :: [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 d :: Int
d xs :: [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 d :: Int
d msgs :: [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 d :: Int
d xs :: [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch Int
d [a]
xs
nubMatchErrors (InexactMatch d :: Int
d xs :: [a]
xs) = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch Int
d [a]
xs
exactMatches, inexactMatches :: [a] -> Match a
exactMatches :: [a] -> Match a
exactMatches [] = Match a
forall a. Match a
matchZero
exactMatches xs :: [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
ExactMatch 0 [a]
xs
inexactMatches :: [a] -> Match a
inexactMatches [] = Match a
forall a. Match a
matchZero
inexactMatches xs :: [a]
xs = Int -> [a] -> Match a
forall a. Int -> [a] -> Match a
InexactMatch 0 [a]
xs
tryEach :: [a] -> Match a
tryEach :: [a] -> Match a
tryEach = [a] -> Match a
forall a. [a] -> Match a
exactMatches
findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch :: Match b -> MaybeAmbiguous b
findMatch match :: Match b
match =
case Match b
match of
NoMatch _ msgs :: [MatchError]
msgs -> [MatchError] -> MaybeAmbiguous b
forall a. [MatchError] -> MaybeAmbiguous a
None ([MatchError] -> [MatchError]
forall a. Eq a => [a] -> [a]
nub [MatchError]
msgs)
ExactMatch _ xs :: [b]
xs -> [b] -> MaybeAmbiguous b
forall a. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
InexactMatch _ xs :: [b]
xs -> [b] -> MaybeAmbiguous b
forall a. Eq a => [a] -> MaybeAmbiguous a
checkAmbiguous [b]
xs
where
checkAmbiguous :: [a] -> MaybeAmbiguous a
checkAmbiguous xs :: [a]
xs = case [a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
xs of
[x :: a
x] -> a -> MaybeAmbiguous a
forall a. a -> MaybeAmbiguous a
Unambiguous a
x
xs' :: [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
matchInexactly :: (Ord a, Ord a') =>
(a -> a') ->
[(a, b)] -> (a -> Match b)
matchInexactly :: (a -> a') -> [(a, b)] -> a -> Match b
matchInexactly cannonicalise :: a -> a'
cannonicalise xs :: [(a, b)]
xs =
\x :: 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 ys :: [b]
ys -> [b] -> Match b
forall a. [a] -> Match a
exactMatches [b]
ys
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 ys :: [b]
ys -> [b] -> Match b
forall a. [a] -> Match a
inexactMatches [b]
ys
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]) | (k :: a
k,x :: b
x) <- [(a, b)]
xs ]
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
caseFold :: String -> String
caseFold :: ShowS
caseFold = ShowS
lowercase
checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
-> IO [TargetInfo]
checkBuildTargets :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> [BuildTarget]
-> IO [TargetInfo]
checkBuildTargets _ pkg_descr :: PackageDescription
pkg_descr lbi :: 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
verbosity pkg_descr :: PackageDescription
pkg_descr lbi :: LocalBuildInfo
lbi targets :: [BuildTarget]
targets = do
let (enabled :: [(ComponentName, Maybe (Either ModuleName String))]
enabled, disabled :: [(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
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 reason :: 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'@(cname :: ComponentName
cname,_) = 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 ()
((cname :: ComponentName
cname,reason :: ComponentDisabledReason
reason):_) -> 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) | (c :: ComponentName
c, Just t :: 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
$ \(c :: ComponentName
c, t :: Either ModuleName String
t) ->
Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "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]
++ ". The whole "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ ComponentName -> String
showComponentName ComponentName
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ " will be processed. (Support for "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "module and file targets has not been implemented yet.)"
[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
$ \(cname :: ComponentName
cname, _) -> do
case PackageDescription
-> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' PackageDescription
pkg_descr LocalBuildInfo
lbi ComponentName
cname of
[] -> String -> IO TargetInfo
forall a. HasCallStack => String -> a
error "checkBuildTargets: nothing enabled"
[target :: TargetInfo
target] -> TargetInfo -> IO TargetInfo
forall (m :: * -> *) a. Monad m => a -> m a
return TargetInfo
target
_targets :: [TargetInfo]
_targets -> String -> IO TargetInfo
forall a. HasCallStack => String -> a
error "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 c :: ComponentName
c) = (ComponentName
c, Maybe (Either ModuleName String)
forall a. Maybe a
Nothing)
swizzleTarget (BuildTargetModule c :: ComponentName
c m :: 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 c :: ComponentName
c f :: 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 cn :: String
cn DisabledComponent =
"Cannot process the " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn String -> ShowS
forall a. [a] -> [a] -> [a]
++ " because the component is marked "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "as disabled in the .cabal file."
formatReason cn :: String
cn DisabledAllTests =
"Cannot process the " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn String -> ShowS
forall a. [a] -> [a] -> [a]
++ " because test suites are not "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "enabled. Run configure with the flag --enable-tests"
formatReason cn :: String
cn DisabledAllBenchmarks =
"Cannot process the " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn String -> ShowS
forall a. [a] -> [a] -> [a]
++ " because benchmarks are not "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "enabled. Re-run configure with the flag --enable-benchmarks"
formatReason cn :: String
cn (DisabledAllButOne cn' :: String
cn') =
"Cannot process the " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn String -> ShowS
forall a. [a] -> [a] -> [a]
++ " because this package was "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "configured only to build " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn' String -> ShowS
forall a. [a] -> [a] -> [a]
++ ". Re-run configure "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ "with the argument " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cn