Cabal-2.2.0.0: Distribution/Simple/BuildTarget.hs
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.BuildTargets
-- Copyright : (c) Duncan Coutts 2012
-- License : BSD-like
--
-- Maintainer : duncan@community.haskell.org
--
-- Handling for user-specified build targets
-----------------------------------------------------------------------------
module Distribution.Simple.BuildTarget (
-- * Main interface
readTargetInfos,
readBuildTargets, -- in case you don't have LocalBuildInfo
-- * Build targets
BuildTarget(..),
showBuildTarget,
QualLevel(..),
buildTargetComponentName,
-- * Parsing user build targets
UserBuildTarget,
readUserBuildTargets,
showUserBuildTarget,
UserBuildTargetProblem(..),
reportUserBuildTargetProblems,
-- * Resolving build targets
resolveBuildTargets,
BuildTargetProblem(..),
reportBuildTargetProblems,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.TargetInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Text
import Distribution.Simple.Utils
import Distribution.Verbosity
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ( (+++), (<++) )
import Distribution.ParseUtils ( readPToMaybe )
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
-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos verbosity pkg_descr lbi args = do
build_targets <- readBuildTargets verbosity pkg_descr args
checkBuildTargets verbosity pkg_descr lbi build_targets
-- ------------------------------------------------------------
-- * User build targets
-- ------------------------------------------------------------
-- | Various ways that a user may specify a build target.
--
data UserBuildTarget =
-- | A target specified by a single name. This could be a component
-- module or file.
--
-- > cabal build foo
-- > cabal build Data.Foo
-- > cabal build Data/Foo.hs Data/Foo.hsc
--
UserBuildTargetSingle String
-- | A target specified by a qualifier and name. This could be a component
-- name qualified by the component namespace kind, or a module or file
-- qualified by the component name.
--
-- > cabal build lib:foo exe:foo
-- > cabal build foo:Data.Foo
-- > cabal build foo:Data/Foo.hs
--
| UserBuildTargetDouble String String
-- | A fully qualified target, either a module or file qualified by a
-- component name with the component namespace kind.
--
-- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
-- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
--
| UserBuildTargetTriple String String String
deriving (Show, Eq, Ord)
-- ------------------------------------------------------------
-- * Resolved build targets
-- ------------------------------------------------------------
-- | A fully resolved build target.
--
data BuildTarget =
-- | A specific component
--
BuildTargetComponent ComponentName
-- | A specific module within a specific component.
--
| BuildTargetModule ComponentName ModuleName
-- | A specific file within a specific component.
--
| BuildTargetFile ComponentName FilePath
deriving (Eq, Show, Generic)
instance Binary BuildTarget
buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent cn) = cn
buildTargetComponentName (BuildTargetModule cn _) = cn
buildTargetComponentName (BuildTargetFile cn _) = cn
-- | Read a list of user-supplied build target strings and resolve them to
-- 'BuildTarget's according to a 'PackageDescription'. If there are problems
-- with any of the targets e.g. they don't exist or are misformatted, throw an
-- 'IOException'.
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets verbosity pkg targetStrs = do
let (uproblems, utargets) = readUserBuildTargets targetStrs
reportUserBuildTargetProblems verbosity uproblems
utargets' <- traverse checkTargetExistsAsFile utargets
let (bproblems, btargets) = resolveBuildTargets pkg utargets'
reportBuildTargetProblems verbosity bproblems
return btargets
checkTargetExistsAsFile :: UserBuildTarget -> NoCallStackIO (UserBuildTarget, Bool)
checkTargetExistsAsFile t = do
fexists <- existsAsFile (fileComponentOfTarget t)
return (t, fexists)
where
existsAsFile f = do
exists <- doesFileExist f
case splitPath f of
(d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d
(d:_:_) | not exists -> doesDirectoryExist d
_ -> return exists
fileComponentOfTarget (UserBuildTargetSingle s1) = s1
fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3
-- ------------------------------------------------------------
-- * Parsing user targets
-- ------------------------------------------------------------
readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
,[UserBuildTarget])
readUserBuildTargets = partitionEithers . map readUserBuildTarget
readUserBuildTarget :: String -> Either UserBuildTargetProblem
UserBuildTarget
readUserBuildTarget targetstr =
case readPToMaybe parseTargetApprox targetstr of
Nothing -> Left (UserBuildTargetUnrecognised targetstr)
Just tgt -> Right tgt
where
parseTargetApprox :: Parse.ReadP r UserBuildTarget
parseTargetApprox =
(do a <- tokenQ
return (UserBuildTargetSingle a))
+++ (do a <- token
_ <- Parse.char ':'
b <- tokenQ
return (UserBuildTargetDouble a b))
+++ (do a <- token
_ <- Parse.char ':'
b <- token
_ <- Parse.char ':'
c <- tokenQ
return (UserBuildTargetTriple a b c))
token = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
tokenQ = parseHaskellString <++ token
parseHaskellString :: Parse.ReadP r String
parseHaskellString = Parse.readS_to_P reads
data UserBuildTargetProblem
= UserBuildTargetUnrecognised String
deriving Show
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
case [ target | UserBuildTargetUnrecognised target <- problems ] of
[] -> return ()
target ->
die' verbosity $ unlines
[ "Unrecognised build target '" ++ name ++ "'."
| name <- target ]
++ "Examples:\n"
++ " - build foo -- component name "
++ "(library, executable, test-suite or benchmark)\n"
++ " - build Data.Foo -- module name\n"
++ " - build Data/Foo.hsc -- file name\n"
++ " - build lib:foo exe:foo -- component qualified by kind\n"
++ " - build foo:Data.Foo -- module qualified by component\n"
++ " - build foo:Data/Foo.hsc -- file qualified by component"
showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget = intercalate ":" . getComponents
where
getComponents (UserBuildTargetSingle s1) = [s1]
getComponents (UserBuildTargetDouble s1 s2) = [s1,s2]
getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]
-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' ql pkgid bt =
showUserBuildTarget (renderBuildTarget ql bt pkgid)
-- | Unambiguously render a 'BuildTarget', so that it can
-- be parsed in all situations.
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget pkgid t =
showBuildTarget' (qlBuildTarget t) pkgid t
where
qlBuildTarget BuildTargetComponent{} = QL2
qlBuildTarget _ = QL3
-- ------------------------------------------------------------
-- * Resolving user targets to build targets
-- ------------------------------------------------------------
{-
stargets =
[ BuildTargetComponent (CExeName "foo")
, BuildTargetModule (CExeName "foo") (mkMn "Foo")
, BuildTargetModule (CExeName "tst") (mkMn "Foo")
]
where
mkMn :: String -> ModuleName
mkMn = fromJust . simpleParse
ex_pkgid :: PackageIdentifier
Just ex_pkgid = simpleParse "thelib"
-}
-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
--
resolveBuildTargets :: PackageDescription
-> [(UserBuildTarget, Bool)]
-> ([BuildTargetProblem], [BuildTarget])
resolveBuildTargets pkg = partitionEithers
. map (uncurry (resolveBuildTarget pkg))
resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
-> Either BuildTargetProblem BuildTarget
resolveBuildTarget pkg userTarget fexists =
case findMatch (matchBuildTarget pkg userTarget fexists) of
Unambiguous target -> Right target
Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')
where targets' = disambiguateBuildTargets
(packageId pkg)
userTarget
targets
None errs -> Left (classifyMatchErrors errs)
where
classifyMatchErrors errs
| not (null expected) = let (things, got:_) = unzip expected in
BuildTargetExpected userTarget things got
| not (null nosuch) = BuildTargetNoSuch userTarget nosuch
| otherwise = error $ "resolveBuildTarget: internal error in matching"
where
expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]
nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ]
data BuildTargetProblem
= BuildTargetExpected UserBuildTarget [String] String
-- ^ [expected thing] (actually got)
| BuildTargetNoSuch UserBuildTarget [(String, String)]
-- ^ [(no such thing, actually got)]
| BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
deriving Show
disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
-> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets pkgid original =
disambiguate (userTargetQualLevel original)
where
disambiguate ql ts
| null amb = unamb
| otherwise = unamb ++ disambiguate (succ ql) amb
where
(amb, unamb) = step ql ts
userTargetQualLevel (UserBuildTargetSingle _ ) = QL1
userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2
userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3
step :: QualLevel -> [BuildTarget]
-> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
. partition (\g -> length g > 1)
. groupBy (equating fst)
. sortBy (comparing fst)
. map (\t -> (renderBuildTarget ql t pkgid, t))
data QualLevel = QL1 | QL2 | QL3
deriving (Enum, Show)
renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget ql target pkgid =
case ql of
QL1 -> UserBuildTargetSingle s1 where s1 = single target
QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target
QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target
where
single (BuildTargetComponent cn ) = dispCName cn
single (BuildTargetModule _ m) = display m
single (BuildTargetFile _ f) = f
double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn)
double (BuildTargetModule cn m) = (dispCName cn, display m)
double (BuildTargetFile cn f) = (dispCName cn, f)
triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent"
triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, display m)
triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)
dispCName = componentStringName pkgid
dispKind = showComponentKindShort . componentKind
reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems verbosity problems = do
case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
[] -> return ()
targets ->
die' verbosity $ unlines
[ "Unrecognised build target '" ++ showUserBuildTarget target
++ "'.\n"
++ "Expected a " ++ intercalate " or " expected
++ ", rather than '" ++ got ++ "'."
| (target, expected, got) <- targets ]
case [ (t, e) | BuildTargetNoSuch t e <- problems ] of
[] -> return ()
targets ->
die' verbosity $ unlines
[ "Unknown build target '" ++ showUserBuildTarget target
++ "'.\nThere is no "
++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
| (thing, got) <- nosuch ] ++ "."
| (target, nosuch) <- targets ]
where
mungeThing "file" = "file target"
mungeThing thing = thing
case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of
[] -> return ()
targets ->
die' verbosity $ unlines
[ "Ambiguous build target '" ++ showUserBuildTarget target
++ "'. It could be:\n "
++ unlines [ " "++ showUserBuildTarget ut ++
" (" ++ showBuildTargetKind bt ++ ")"
| (ut, bt) <- amb ]
| (target, amb) <- targets ]
where
showBuildTargetKind (BuildTargetComponent _ ) = "component"
showBuildTargetKind (BuildTargetModule _ _) = "module"
showBuildTargetKind (BuildTargetFile _ _) = "file"
----------------------------------
-- Top level BuildTarget matcher
--
matchBuildTarget :: PackageDescription
-> UserBuildTarget -> Bool -> Match BuildTarget
matchBuildTarget pkg = \utarget fexists ->
case utarget of
UserBuildTargetSingle str1 ->
matchBuildTarget1 cinfo str1 fexists
UserBuildTargetDouble str1 str2 ->
matchBuildTarget2 cinfo str1 str2 fexists
UserBuildTargetTriple str1 str2 str3 ->
matchBuildTarget3 cinfo str1 str2 str3 fexists
where
cinfo = pkgComponentInfo pkg
matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 cinfo str1 fexists =
matchComponent1 cinfo str1
`matchPlusShadowing` matchModule1 cinfo str1
`matchPlusShadowing` matchFile1 cinfo str1 fexists
matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
-> Match BuildTarget
matchBuildTarget2 cinfo str1 str2 fexists =
matchComponent2 cinfo str1 str2
`matchPlusShadowing` matchModule2 cinfo str1 str2
`matchPlusShadowing` matchFile2 cinfo str1 str2 fexists
matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
-> Match BuildTarget
matchBuildTarget3 cinfo str1 str2 str3 fexists =
matchModule3 cinfo str1 str2 str3
`matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists
data ComponentInfo = ComponentInfo {
cinfoName :: ComponentName,
cinfoStrName :: ComponentStringName,
cinfoSrcDirs :: [FilePath],
cinfoModules :: [ModuleName],
cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
cinfoAsmFiles:: [FilePath],
cinfoCmmFiles:: [FilePath],
cinfoCFiles :: [FilePath],
cinfoJsFiles :: [FilePath]
}
type ComponentStringName = String
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
[ ComponentInfo {
cinfoName = componentName c,
cinfoStrName = componentStringName pkg (componentName c),
cinfoSrcDirs = hsSourceDirs bi,
cinfoModules = componentModules c,
cinfoHsFiles = componentHsFiles c,
cinfoAsmFiles= asmSources bi,
cinfoCmmFiles= cmmSources bi,
cinfoCFiles = cSources bi,
cinfoJsFiles = jsSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c ]
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg CLibName = display (packageName pkg)
componentStringName _ (CSubLibName name) = unUnqualComponentName name
componentStringName _ (CFLibName name) = unUnqualComponentName name
componentStringName _ (CExeName name) = unUnqualComponentName name
componentStringName _ (CTestName name) = unUnqualComponentName name
componentStringName _ (CBenchName name) = unUnqualComponentName name
componentModules :: Component -> [ModuleName]
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
-- a user could very well ask to build a specific signature
-- that was inherited from other packages. To fix this
-- we have to plumb 'LocalBuildInfo' through this code.
-- Fortunately, this is only used by 'pkgComponentInfo'
-- Please don't export this function unless you plan on fixing
-- this.
componentModules (CLib lib) = explicitLibModules lib
componentModules (CFLib flib) = foreignLibModules flib
componentModules (CExe exe) = exeModules exe
componentModules (CTest test) = testModules test
componentModules (CBench bench) = benchmarkModules bench
componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
componentHsFiles (CTest TestSuite {
testInterface = TestSuiteExeV10 _ mainfile
}) = [mainfile]
componentHsFiles (CBench Benchmark {
benchmarkInterface = BenchmarkExeV10 _ mainfile
}) = [mainfile]
componentHsFiles _ = []
{-
ex_cs :: [ComponentInfo]
ex_cs =
[ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
, (mkC (CExeName "tst") ["src1", "test"] ["Foo"])
]
where
mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)
mkMn :: String -> ModuleName
mkMn = fromJust . simpleParse
pkgid :: PackageIdentifier
Just pkgid = simpleParse "thelib"
-}
------------------------------
-- Matching component kinds
--
data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
deriving (Eq, Ord, Show)
componentKind :: ComponentName -> ComponentKind
componentKind CLibName = LibKind
componentKind (CSubLibName _) = LibKind
componentKind (CFLibName _) = FLibKind
componentKind (CExeName _) = ExeKind
componentKind (CTestName _) = TestKind
componentKind (CBenchName _) = BenchKind
cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = componentKind . cinfoName
matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
| s `elem` ["lib", "library"] = return' LibKind
| s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind
| s `elem` ["exe", "executable"] = return' ExeKind
| s `elem` ["tst", "test", "test-suite"] = return' TestKind
| s `elem` ["bench", "benchmark"] = return' BenchKind
| otherwise = matchErrorExpected "component kind" s
where
return' ck = increaseConfidence >> return ck
showComponentKind :: ComponentKind -> String
showComponentKind LibKind = "library"
showComponentKind FLibKind = "foreign-library"
showComponentKind ExeKind = "executable"
showComponentKind TestKind = "test-suite"
showComponentKind BenchKind = "benchmark"
showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind = "lib"
showComponentKindShort FLibKind = "flib"
showComponentKindShort ExeKind = "exe"
showComponentKindShort TestKind = "test"
showComponentKindShort BenchKind = "bench"
------------------------------
-- Matching component targets
--
matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 cs = \str1 -> do
guardComponentName str1
c <- matchComponentName cs str1
return (BuildTargetComponent (cinfoName c))
matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 cs = \str1 str2 -> do
ckind <- matchComponentKind str1
guardComponentName str2
c <- matchComponentKindAndName cs ckind str2
return (BuildTargetComponent (cinfoName c))
-- utils:
guardComponentName :: String -> Match ()
guardComponentName s
| all validComponentChar s
&& not (null s) = increaseConfidence
| otherwise = matchErrorExpected "component name" s
where
validComponentChar c = isAlphaNum c || c == '.'
|| c == '_' || c == '-' || c == '\''
matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName cs str =
orNoSuchThing "component" str
$ increaseConfidenceFor
$ matchInexactly caseFold
[ (cinfoStrName c, c) | c <- cs ]
str
matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
-> Match ComponentInfo
matchComponentKindAndName cs ckind str =
orNoSuchThing (showComponentKind ckind ++ " component") str
$ increaseConfidenceFor
$ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
[ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]
(ckind, str)
------------------------------
-- Matching module targets
--
matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 cs = \str1 -> do
guardModuleName str1
nubMatchErrors $ do
c <- tryEach cs
let ms = cinfoModules c
m <- matchModuleName ms str1
return (BuildTargetModule (cinfoName c) m)
matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchModule2 cs = \str1 str2 -> do
guardComponentName str1
guardModuleName str2
c <- matchComponentName cs str1
let ms = cinfoModules c
m <- matchModuleName ms str2
return (BuildTargetModule (cinfoName c) m)
matchModule3 :: [ComponentInfo] -> String -> String -> String
-> Match BuildTarget
matchModule3 cs str1 str2 str3 = do
ckind <- matchComponentKind str1
guardComponentName str2
c <- matchComponentKindAndName cs ckind str2
guardModuleName str3
let ms = cinfoModules c
m <- matchModuleName ms str3
return (BuildTargetModule (cinfoName c) m)
-- utils:
guardModuleName :: String -> Match ()
guardModuleName s
| all validModuleChar s
&& not (null s) = increaseConfidence
| otherwise = matchErrorExpected "module name" s
where
validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
orNoSuchThing "module" str
$ increaseConfidenceFor
$ matchInexactly caseFold
[ (display m, m)
| m <- ms ]
str
------------------------------
-- Matching file targets
--
matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 cs str1 exists =
nubMatchErrors $ do
c <- tryEach cs
filepath <- matchComponentFile c str1 exists
return (BuildTargetFile (cinfoName c) filepath)
matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 cs str1 str2 exists = do
guardComponentName str1
c <- matchComponentName cs str1
filepath <- matchComponentFile c str2 exists
return (BuildTargetFile (cinfoName c) filepath)
matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
-> Match BuildTarget
matchFile3 cs str1 str2 str3 exists = do
ckind <- matchComponentKind str1
guardComponentName str2
c <- matchComponentKindAndName cs ckind str2
filepath <- matchComponentFile c str3 exists
return (BuildTargetFile (cinfoName c) filepath)
matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile c str fexists =
expecting "file" str $
matchPlus
(matchFileExists str fexists)
(matchPlusShadowing
(msum [ matchModuleFileRooted dirs ms str
, matchOtherFileRooted dirs hsFiles str ])
(msum [ matchModuleFileUnrooted ms str
, matchOtherFileUnrooted hsFiles str
, matchOtherFileUnrooted cFiles str
, matchOtherFileUnrooted jsFiles str ]))
where
dirs = cinfoSrcDirs c
ms = cinfoModules c
hsFiles = cinfoHsFiles c
cFiles = cinfoCFiles c
jsFiles = cinfoJsFiles c
-- utils
matchFileExists :: FilePath -> Bool -> Match a
matchFileExists _ False = mzero
matchFileExists fname True = do increaseConfidence
matchErrorNoSuch "file" fname
matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted ms str = do
let filepath = normalise str
_ <- matchModuleFileStem ms filepath
return filepath
matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted dirs ms str = nubMatches $ do
let filepath = normalise str
filepath' <- matchDirectoryPrefix dirs filepath
_ <- matchModuleFileStem ms filepath'
return filepath
matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem ms =
increaseConfidenceFor
. matchInexactly caseFold
[ (toFilePath m, m) | m <- ms ]
. dropExtension
matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted dirs fs str = do
let filepath = normalise str
filepath' <- matchDirectoryPrefix dirs filepath
_ <- matchFile fs filepath'
return filepath
matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted fs str = do
let filepath = normalise str
_ <- matchFile fs filepath
return filepath
matchFile :: [FilePath] -> FilePath -> Match FilePath
matchFile fs = increaseConfidenceFor
. matchInexactly caseFold [ (f, f) | f <- fs ]
matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix dirs filepath =
exactMatches $
catMaybes
[ stripDirectory (normalise dir) filepath | dir <- dirs ]
where
stripDirectory :: FilePath -> FilePath -> Maybe FilePath
stripDirectory dir fp =
joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)
------------------------------
-- Matching monad
--
-- | A matcher embodies a way to match some input as being some recognised
-- value. In particular it deals with multiple and ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
--
data Match a = NoMatch Confidence [MatchError]
| ExactMatch Confidence [a]
| InexactMatch Confidence [a]
deriving Show
type Confidence = Int
data MatchError = MatchErrorExpected String String
| MatchErrorNoSuch String String
deriving (Show, Eq)
instance Alternative Match where
empty = mzero
(<|>) = mplus
instance MonadPlus Match where
mzero = matchZero
mplus = matchPlus
matchZero :: Match a
matchZero = NoMatch 0 []
-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
-- ambiguous matches.
--
matchPlus :: Match a -> Match a -> Match a
matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
ExactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a
matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a
matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b
matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =
InexactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a
matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b
matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b
matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
| d1 > d2 = a
| d1 < d2 = b
| otherwise = NoMatch d1 (ms ++ ms')
-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
--
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
matchPlusShadowing a b = matchPlus a b
instance Functor Match where
fmap _ (NoMatch d ms) = NoMatch d ms
fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)
fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)
instance Applicative Match where
pure a = ExactMatch 0 [a]
(<*>) = ap
instance Monad Match where
return = pure
NoMatch d ms >>= _ = NoMatch d ms
ExactMatch d xs >>= f = addDepth d
$ foldr matchPlus matchZero (map f xs)
InexactMatch d xs >>= f = addDepth d . forceInexact
$ foldr matchPlus matchZero (map f xs)
addDepth :: Confidence -> Match a -> Match a
addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs
addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs
addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs
forceInexact :: Match a -> Match a
forceInexact (ExactMatch d ys) = InexactMatch d ys
forceInexact m = m
------------------------------
-- Various match primitives
--
matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]
expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
expecting _ _ m = m
orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
orNoSuchThing _ _ m = m
increaseConfidence :: Match ()
increaseConfidence = ExactMatch 1 [()]
increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r
nubMatches :: Eq a => Match a -> Match a
nubMatches (NoMatch d msgs) = NoMatch d msgs
nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)
nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)
nubMatchErrors :: Match a -> Match a
nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
-- | Lift a list of matches to an exact match.
--
exactMatches, inexactMatches :: [a] -> Match a
exactMatches [] = matchZero
exactMatches xs = ExactMatch 0 xs
inexactMatches [] = matchZero
inexactMatches xs = InexactMatch 0 xs
tryEach :: [a] -> Match a
tryEach = exactMatches
------------------------------
-- Top level match runner
--
-- | Given a matcher and a key to look up, use the matcher to find all the
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
--
findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch match =
case match of
NoMatch _ msgs -> None (nub msgs)
ExactMatch _ xs -> checkAmbiguous xs
InexactMatch _ xs -> checkAmbiguous xs
where
checkAmbiguous xs = case nub xs of
[x] -> Unambiguous x
xs' -> Ambiguous xs'
data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
deriving Show
------------------------------
-- Basic matchers
--
{-
-- | A primitive matcher that looks up a value in a finite 'Map'. The
-- value must match exactly.
--
matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)
matchExactly xs =
\x -> case Map.lookup x m of
Nothing -> matchZero
Just ys -> ExactMatch 0 ys
where
m :: Ord a => Map a [b]
m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
-}
-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
-- is not exact, but the canonical forms match. It takes a canonicalisation
-- function for this purpose.
--
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
--
matchInexactly :: (Ord a, Ord a') =>
(a -> a') ->
[(a, b)] -> (a -> Match b)
matchInexactly cannonicalise xs =
\x -> case Map.lookup x m of
Just ys -> exactMatches ys
Nothing -> case Map.lookup (cannonicalise x) m' of
Just ys -> inexactMatches ys
Nothing -> matchZero
where
m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
-- the map of canonicalised keys to groups of inexact matches
m' = Map.mapKeysWith (++) cannonicalise m
------------------------------
-- Utils
--
caseFold :: String -> String
caseFold = lowercase
-- | Check that the given build targets are valid in the current context.
--
-- Also swizzle into a more convenient form.
--
checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
-> IO [TargetInfo]
checkBuildTargets _ pkg_descr lbi [] =
return (allTargetsInBuildOrder' pkg_descr lbi)
checkBuildTargets verbosity pkg_descr lbi targets = do
let (enabled, disabled) =
partitionEithers
[ case componentDisabledReason (componentEnabledSpec lbi) comp of
Nothing -> Left target'
Just reason -> Right (cname, reason)
| target <- targets
, let target'@(cname,_) = swizzleTarget target
, let comp = getComponent pkg_descr cname ]
case disabled of
[] -> return ()
((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason
for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->
warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "
++ showComponentName c ++ " will be processed. (Support for "
++ "module and file targets has not been implemented yet.)"
-- Pick out the actual CLBIs for each of these cnames
enabled' <- for enabled $ \(cname, _) -> do
case componentNameTargets' pkg_descr lbi cname of
[] -> error "checkBuildTargets: nothing enabled"
[target] -> return target
_targets -> error "checkBuildTargets: multiple copies enabled"
return enabled'
where
swizzleTarget (BuildTargetComponent c) = (c, Nothing)
swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))
swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))
formatReason cn DisabledComponent =
"Cannot process the " ++ cn ++ " because the component is marked "
++ "as disabled in the .cabal file."
formatReason cn DisabledAllTests =
"Cannot process the " ++ cn ++ " because test suites are not "
++ "enabled. Run configure with the flag --enable-tests"
formatReason cn DisabledAllBenchmarks =
"Cannot process the " ++ cn ++ " because benchmarks are not "
++ "enabled. Re-run configure with the flag --enable-benchmarks"
formatReason cn (DisabledAllButOne cn') =
"Cannot process the " ++ cn ++ " because this package was "
++ "configured only to build " ++ cn' ++ ". Re-run configure "
++ "with the argument " ++ cn