Cabal-3.16.1.0: src/Distribution/Simple/BuildTarget.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# 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 Distribution.Compat.Prelude
import Prelude ()
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Types.UnqualComponentName
import qualified Distribution.Compat.CharParsing as P
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity
import Control.Arrow ((&&&))
import Control.Monad (msum)
import Data.List (groupBy, stripPrefix)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath as FilePath
( dropExtension
, hasTrailingPathSeparator
, joinPath
, normalise
, splitDirectories
, splitPath
)
-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos verbosity 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 -> IO (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 "comp"
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:comp"
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp"
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "\"comp\""
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:\"comp\""
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:\"comp\""
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp:more"
-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")
--
-- >>> readUserBuildTarget "pkg:\"lib\":comp"
-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")
readUserBuildTarget
:: String
-> Either
UserBuildTargetProblem
UserBuildTarget
readUserBuildTarget targetstr =
case explicitEitherParsec parseTargetApprox targetstr of
Left _ -> Left (UserBuildTargetUnrecognised targetstr)
Right tgt -> Right tgt
where
parseTargetApprox :: CabalParsing m => m UserBuildTarget
parseTargetApprox = do
-- read one, two, or three tokens, where last could be "hs-string"
ts <- tokens
return $ case ts of
(a, Nothing) -> UserBuildTargetSingle a
(a, Just (b, Nothing)) -> UserBuildTargetDouble a b
(a, Just (b, Just c)) -> UserBuildTargetTriple a b c
tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
tokens =
(\s -> (s, Nothing)) <$> parsecHaskellString
<|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)
tokens2 :: CabalParsing m => m (String, Maybe String)
tokens2 =
(\s -> (s, Nothing)) <$> parsecHaskellString
<|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))
token :: CabalParsing m => m String
token = P.munch1 (\x -> not (isSpace x) && x /= ':')
data UserBuildTargetProblem
= UserBuildTargetUnrecognised String
deriving (Show)
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
case [target | UserBuildTargetUnrecognised target <- problems] of
[] -> return ()
target ->
dieWithException verbosity $
UnrecognisedBuildTarget target
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
| Just expected' <- NE.nonEmpty expected =
let unzip' = fmap fst &&& fmap snd
(things, got :| _) = unzip' expected'
in BuildTargetExpected userTarget (NE.toList 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
= -- | [expected thing] (actually got)
BuildTargetExpected UserBuildTarget [String] String
| -- | [(no such thing, actually got)]
BuildTargetNoSuch UserBuildTarget [(String, String)]
| 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) = prettyShow m
single (BuildTargetFile _ f) = f
double (BuildTargetComponent cn) = (dispKind cn, dispCName cn)
double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)
double (BuildTargetFile cn f) = (dispCName cn, f)
triple (BuildTargetComponent _) = error "triple BuildTargetComponent"
triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow 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 ->
dieWithException verbosity $
ReportBuildTargetProblems $
map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets
case [(t, e) | BuildTargetNoSuch t e <- problems] of
[] -> return ()
targets ->
dieWithException verbosity $
UnknownBuildTarget $
map (\(target, nosuch) -> (showUserBuildTarget target, nosuch)) targets
case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of
[] -> return ()
targets ->
dieWithException verbosity $
AmbiguousBuildTarget $
map
( \(target, amb) ->
( showUserBuildTarget target
, (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) 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]
, cinfoCxxFiles :: [FilePath]
, cinfoJsFiles :: [FilePath]
}
type ComponentStringName = String
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
[ ComponentInfo
{ cinfoName = componentName c
, cinfoStrName = componentStringName pkg (componentName c)
, cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi
, cinfoModules = componentModules c
, cinfoHsFiles = map getSymbolicPath $ componentHsFiles c
, cinfoAsmFiles = map getSymbolicPath $ asmSources bi
, cinfoCmmFiles = map getSymbolicPath $ cmmSources bi
, cinfoCFiles = map getSymbolicPath $ cSources bi
, cinfoCxxFiles = map getSymbolicPath $ cxxSources bi
, cinfoJsFiles = map getSymbolicPath $ jsSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c
]
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg)
componentStringName _ (CLibName (LSubLibName 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 -> [RelativePath Source File]
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, Enum, Bounded)
componentKind :: ComponentName -> ComponentKind
componentKind (CLibName _) = 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
[ (prettyShow 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@(LocalBuildInfo{componentEnabledSpec = enabledComps})
targets = do
let (enabled, disabled) =
partitionEithers
[ case componentDisabledReason enabledComps 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) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason
for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->
warn verbosity $
"Ignoring '"
++ either prettyShow 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