{-# 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-----------------------------------------------------------------------------moduleDistribution.Simple.BuildTarget(-- * Main interfacereadTargetInfos,readBuildTargets,-- in case you don't have LocalBuildInfo-- * Build targetsBuildTarget(..),showBuildTarget,QualLevel(..),buildTargetComponentName,-- * Parsing user build targetsUserBuildTarget,readUserBuildTargets,showUserBuildTarget,UserBuildTargetProblem(..),reportUserBuildTargetProblems,-- * Resolving build targetsresolveBuildTargets,BuildTargetProblem(..),reportBuildTargetProblems,)whereimportPrelude()importDistribution.Compat.PreludeimportDistribution.Types.TargetInfoimportDistribution.Types.LocalBuildInfoimportDistribution.Types.ComponentRequestedSpecimportDistribution.Types.ForeignLibimportDistribution.Types.UnqualComponentNameimportDistribution.PackageimportDistribution.PackageDescriptionimportDistribution.ModuleNameimportDistribution.Simple.LocalBuildInfoimportDistribution.TextimportDistribution.Simple.UtilsimportDistribution.VerbosityimportqualifiedDistribution.Compat.ReadPasParseimportDistribution.Compat.ReadP((+++),(<++))importDistribution.ParseUtils(readPToMaybe)importControl.Monad(msum)importData.List(stripPrefix,groupBy,partition)importData.Either(partitionEithers)importSystem.FilePathasFilePath(dropExtension,normalise,splitDirectories,joinPath,splitPath,hasTrailingPathSeparator)importSystem.Directory(doesFileExist,doesDirectoryExist)importqualifiedData.MapasMap-- | 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]readTargetInfosverbositypkg_descrlbiargs=dobuild_targets<-readBuildTargetsverbositypkg_descrargscheckBuildTargetsverbositypkg_descrlbibuild_targets-- -------------------------------------------------------------- * User build targets-- -------------------------------------------------------------- | Various ways that a user may specify a build target.--dataUserBuildTarget=-- | 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--UserBuildTargetSingleString-- | 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--|UserBuildTargetDoubleStringString-- | 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--|UserBuildTargetTripleStringStringStringderiving(Show,Eq,Ord)-- -------------------------------------------------------------- * Resolved build targets-- -------------------------------------------------------------- | A fully resolved build target.--dataBuildTarget=-- | A specific component--BuildTargetComponentComponentName-- | A specific module within a specific component.--|BuildTargetModuleComponentNameModuleName-- | A specific file within a specific component.--|BuildTargetFileComponentNameFilePathderiving(Eq,Show,Generic)instanceBinaryBuildTargetbuildTargetComponentName::BuildTarget->ComponentNamebuildTargetComponentName(BuildTargetComponentcn)=cnbuildTargetComponentName(BuildTargetModulecn_)=cnbuildTargetComponentName(BuildTargetFilecn_)=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]readBuildTargetsverbositypkgtargetStrs=dolet(uproblems,utargets)=readUserBuildTargetstargetStrsreportUserBuildTargetProblemsverbosityuproblemsutargets'<-traversecheckTargetExistsAsFileutargetslet(bproblems,btargets)=resolveBuildTargetspkgutargets'reportBuildTargetProblemsverbositybproblemsreturnbtargetscheckTargetExistsAsFile::UserBuildTarget->NoCallStackIO(UserBuildTarget,Bool)checkTargetExistsAsFilet=dofexists<-existsAsFile(fileComponentOfTargett)return(t,fexists)whereexistsAsFilef=doexists<-doesFileExistfcasesplitPathfof(d:_)|hasTrailingPathSeparatord->doesDirectoryExistd(d:_:_)|notexists->doesDirectoryExistd_->returnexistsfileComponentOfTarget(UserBuildTargetSingles1)=s1fileComponentOfTarget(UserBuildTargetDouble_s2)=s2fileComponentOfTarget(UserBuildTargetTriple__s3)=s3-- -------------------------------------------------------------- * Parsing user targets-- ------------------------------------------------------------readUserBuildTargets::[String]->([UserBuildTargetProblem],[UserBuildTarget])readUserBuildTargets=partitionEithers.mapreadUserBuildTargetreadUserBuildTarget::String->EitherUserBuildTargetProblemUserBuildTargetreadUserBuildTargettargetstr=casereadPToMaybeparseTargetApproxtargetstrofNothing->Left(UserBuildTargetUnrecognisedtargetstr)Justtgt->RighttgtwhereparseTargetApprox::Parse.ReadPrUserBuildTargetparseTargetApprox=(doa<-tokenQreturn(UserBuildTargetSinglea))+++(doa<-token_<-Parse.char':'b<-tokenQreturn(UserBuildTargetDoubleab))+++(doa<-token_<-Parse.char':'b<-token_<-Parse.char':'c<-tokenQreturn(UserBuildTargetTripleabc))token=Parse.munch1(\x->not(isSpacex)&&x/=':')tokenQ=parseHaskellString<++tokenparseHaskellString::Parse.ReadPrStringparseHaskellString=Parse.readS_to_PreadsdataUserBuildTargetProblem=UserBuildTargetUnrecognisedStringderivingShowreportUserBuildTargetProblems::Verbosity->[UserBuildTargetProblem]->IO()reportUserBuildTargetProblemsverbosityproblems=docase[target|UserBuildTargetUnrecognisedtarget<-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->StringshowUserBuildTarget=intercalate":".getComponentswheregetComponents(UserBuildTargetSingles1)=[s1]getComponents(UserBuildTargetDoubles1s2)=[s1,s2]getComponents(UserBuildTargetTriples1s2s3)=[s1,s2,s3]-- | Unless you use 'QL1', this function is PARTIAL;-- use 'showBuildTarget' instead.showBuildTarget'::QualLevel->PackageId->BuildTarget->StringshowBuildTarget'qlpkgidbt=showUserBuildTarget(renderBuildTargetqlbtpkgid)-- | Unambiguously render a 'BuildTarget', so that it can-- be parsed in all situations.showBuildTarget::PackageId->BuildTarget->StringshowBuildTargetpkgidt=showBuildTarget'(qlBuildTargett)pkgidtwhereqlBuildTargetBuildTargetComponent{}=QL2qlBuildTarget_=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])resolveBuildTargetspkg=partitionEithers.map(uncurry(resolveBuildTargetpkg))resolveBuildTarget::PackageDescription->UserBuildTarget->Bool->EitherBuildTargetProblemBuildTargetresolveBuildTargetpkguserTargetfexists=casefindMatch(matchBuildTargetpkguserTargetfexists)ofUnambiguoustarget->RighttargetAmbiguoustargets->Left(BuildTargetAmbiguoususerTargettargets')wheretargets'=disambiguateBuildTargets(packageIdpkg)userTargettargetsNoneerrs->Left(classifyMatchErrorserrs)whereclassifyMatchErrorserrs|not(nullexpected)=let(things,got:_)=unzipexpectedinBuildTargetExpecteduserTargetthingsgot|not(nullnosuch)=BuildTargetNoSuchuserTargetnosuch|otherwise=error$"resolveBuildTarget: internal error in matching"whereexpected=[(thing,got)|MatchErrorExpectedthinggot<-errs]nosuch=[(thing,got)|MatchErrorNoSuchthinggot<-errs]dataBuildTargetProblem=BuildTargetExpectedUserBuildTarget[String]String-- ^ [expected thing] (actually got)|BuildTargetNoSuchUserBuildTarget[(String,String)]-- ^ [(no such thing, actually got)]|BuildTargetAmbiguousUserBuildTarget[(UserBuildTarget,BuildTarget)]derivingShowdisambiguateBuildTargets::PackageId->UserBuildTarget->[BuildTarget]->[(UserBuildTarget,BuildTarget)]disambiguateBuildTargetspkgidoriginal=disambiguate(userTargetQualLeveloriginal)wheredisambiguateqlts|nullamb=unamb|otherwise=unamb++disambiguate(succql)ambwhere(amb,unamb)=stepqltsuserTargetQualLevel(UserBuildTargetSingle_)=QL1userTargetQualLevel(UserBuildTargetDouble__)=QL2userTargetQualLevel(UserBuildTargetTriple___)=QL3step::QualLevel->[BuildTarget]->([BuildTarget],[(UserBuildTarget,BuildTarget)])stepql=(\(amb,unamb)->(mapsnd$concatamb,concatunamb)).partition(\g->lengthg>1).groupBy(equatingfst).sortBy(comparingfst).map(\t->(renderBuildTargetqltpkgid,t))dataQualLevel=QL1|QL2|QL3deriving(Enum,Show)renderBuildTarget::QualLevel->BuildTarget->PackageId->UserBuildTargetrenderBuildTargetqltargetpkgid=caseqlofQL1->UserBuildTargetSingles1wheres1=singletargetQL2->UserBuildTargetDoubles1s2where(s1,s2)=doubletargetQL3->UserBuildTargetTriples1s2s3where(s1,s2,s3)=tripletargetwheresingle(BuildTargetComponentcn)=dispCNamecnsingle(BuildTargetModule_m)=displaymsingle(BuildTargetFile_f)=fdouble(BuildTargetComponentcn)=(dispKindcn,dispCNamecn)double(BuildTargetModulecnm)=(dispCNamecn,displaym)double(BuildTargetFilecnf)=(dispCNamecn,f)triple(BuildTargetComponent_)=error"triple BuildTargetComponent"triple(BuildTargetModulecnm)=(dispKindcn,dispCNamecn,displaym)triple(BuildTargetFilecnf)=(dispKindcn,dispCNamecn,f)dispCName=componentStringNamepkgiddispKind=showComponentKindShort.componentKindreportBuildTargetProblems::Verbosity->[BuildTargetProblem]->IO()reportBuildTargetProblemsverbosityproblems=docase[(t,e,g)|BuildTargetExpectedteg<-problems]of[]->return()targets->die'verbosity$unlines["Unrecognised build target '"++showUserBuildTargettarget++"'.\n"++"Expected a "++intercalate" or "expected++", rather than '"++got++"'."|(target,expected,got)<-targets]case[(t,e)|BuildTargetNoSuchte<-problems]of[]->return()targets->die'verbosity$unlines["Unknown build target '"++showUserBuildTargettarget++"'.\nThere is no "++intercalate" or "[mungeThingthing++" '"++got++"'"|(thing,got)<-nosuch]++"."|(target,nosuch)<-targets]wheremungeThing"file"="file target"mungeThingthing=thingcase[(t,ts)|BuildTargetAmbiguoustts<-problems]of[]->return()targets->die'verbosity$unlines["Ambiguous build target '"++showUserBuildTargettarget++"'. It could be:\n "++unlines[" "++showUserBuildTargetut++" ("++showBuildTargetKindbt++")"|(ut,bt)<-amb]|(target,amb)<-targets]whereshowBuildTargetKind(BuildTargetComponent_)="component"showBuildTargetKind(BuildTargetModule__)="module"showBuildTargetKind(BuildTargetFile__)="file"------------------------------------ Top level BuildTarget matcher--matchBuildTarget::PackageDescription->UserBuildTarget->Bool->MatchBuildTargetmatchBuildTargetpkg=\utargetfexists->caseutargetofUserBuildTargetSinglestr1->matchBuildTarget1cinfostr1fexistsUserBuildTargetDoublestr1str2->matchBuildTarget2cinfostr1str2fexistsUserBuildTargetTriplestr1str2str3->matchBuildTarget3cinfostr1str2str3fexistswherecinfo=pkgComponentInfopkgmatchBuildTarget1::[ComponentInfo]->String->Bool->MatchBuildTargetmatchBuildTarget1cinfostr1fexists=matchComponent1cinfostr1`matchPlusShadowing`matchModule1cinfostr1`matchPlusShadowing`matchFile1cinfostr1fexistsmatchBuildTarget2::[ComponentInfo]->String->String->Bool->MatchBuildTargetmatchBuildTarget2cinfostr1str2fexists=matchComponent2cinfostr1str2`matchPlusShadowing`matchModule2cinfostr1str2`matchPlusShadowing`matchFile2cinfostr1str2fexistsmatchBuildTarget3::[ComponentInfo]->String->String->String->Bool->MatchBuildTargetmatchBuildTarget3cinfostr1str2str3fexists=matchModule3cinfostr1str2str3`matchPlusShadowing`matchFile3cinfostr1str2str3fexistsdataComponentInfo=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]}typeComponentStringName=StringpkgComponentInfo::PackageDescription->[ComponentInfo]pkgComponentInfopkg=[ComponentInfo{cinfoName=componentNamec,cinfoStrName=componentStringNamepkg(componentNamec),cinfoSrcDirs=hsSourceDirsbi,cinfoModules=componentModulesc,cinfoHsFiles=componentHsFilesc,cinfoAsmFiles=asmSourcesbi,cinfoCmmFiles=cmmSourcesbi,cinfoCFiles=cSourcesbi,cinfoCxxFiles=cxxSourcesbi,cinfoJsFiles=jsSourcesbi}|c<-pkgComponentspkg,letbi=componentBuildInfoc]componentStringName::Packagepkg=>pkg->ComponentName->ComponentStringNamecomponentStringNamepkgCLibName=display(packageNamepkg)componentStringName_(CSubLibNamename)=unUnqualComponentNamenamecomponentStringName_(CFLibNamename)=unUnqualComponentNamenamecomponentStringName_(CExeNamename)=unUnqualComponentNamenamecomponentStringName_(CTestNamename)=unUnqualComponentNamenamecomponentStringName_(CBenchNamename)=unUnqualComponentNamenamecomponentModules::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(CLiblib)=explicitLibModuleslibcomponentModules(CFLibflib)=foreignLibModulesflibcomponentModules(CExeexe)=exeModulesexecomponentModules(CTesttest)=testModulestestcomponentModules(CBenchbench)=benchmarkModulesbenchcomponentHsFiles::Component->[FilePath]componentHsFiles(CExeexe)=[modulePathexe]componentHsFiles(CTestTestSuite{testInterface=TestSuiteExeV10_mainfile})=[mainfile]componentHsFiles(CBenchBenchmark{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--dataComponentKind=LibKind|FLibKind|ExeKind|TestKind|BenchKindderiving(Eq,Ord,Show)componentKind::ComponentName->ComponentKindcomponentKindCLibName=LibKindcomponentKind(CSubLibName_)=LibKindcomponentKind(CFLibName_)=FLibKindcomponentKind(CExeName_)=ExeKindcomponentKind(CTestName_)=TestKindcomponentKind(CBenchName_)=BenchKindcinfoKind::ComponentInfo->ComponentKindcinfoKind=componentKind.cinfoNamematchComponentKind::String->MatchComponentKindmatchComponentKinds|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"swherereturn'ck=increaseConfidence>>returnckshowComponentKind::ComponentKind->StringshowComponentKindLibKind="library"showComponentKindFLibKind="foreign-library"showComponentKindExeKind="executable"showComponentKindTestKind="test-suite"showComponentKindBenchKind="benchmark"showComponentKindShort::ComponentKind->StringshowComponentKindShortLibKind="lib"showComponentKindShortFLibKind="flib"showComponentKindShortExeKind="exe"showComponentKindShortTestKind="test"showComponentKindShortBenchKind="bench"-------------------------------- Matching component targets--matchComponent1::[ComponentInfo]->String->MatchBuildTargetmatchComponent1cs=\str1->doguardComponentNamestr1c<-matchComponentNamecsstr1return(BuildTargetComponent(cinfoNamec))matchComponent2::[ComponentInfo]->String->String->MatchBuildTargetmatchComponent2cs=\str1str2->dockind<-matchComponentKindstr1guardComponentNamestr2c<-matchComponentKindAndNamecsckindstr2return(BuildTargetComponent(cinfoNamec))-- utils:guardComponentName::String->Match()guardComponentNames|allvalidComponentChars&&not(nulls)=increaseConfidence|otherwise=matchErrorExpected"component name"swherevalidComponentCharc=isAlphaNumc||c=='.'||c=='_'||c=='-'||c=='\''matchComponentName::[ComponentInfo]->String->MatchComponentInfomatchComponentNamecsstr=orNoSuchThing"component"str$increaseConfidenceFor$matchInexactlycaseFold[(cinfoStrNamec,c)|c<-cs]strmatchComponentKindAndName::[ComponentInfo]->ComponentKind->String->MatchComponentInfomatchComponentKindAndNamecsckindstr=orNoSuchThing(showComponentKindckind++" component")str$increaseConfidenceFor$matchInexactly(\(ck,cn)->(ck,caseFoldcn))[((cinfoKindc,cinfoStrNamec),c)|c<-cs](ckind,str)-------------------------------- Matching module targets--matchModule1::[ComponentInfo]->String->MatchBuildTargetmatchModule1cs=\str1->doguardModuleNamestr1nubMatchErrors$doc<-tryEachcsletms=cinfoModulescm<-matchModuleNamemsstr1return(BuildTargetModule(cinfoNamec)m)matchModule2::[ComponentInfo]->String->String->MatchBuildTargetmatchModule2cs=\str1str2->doguardComponentNamestr1guardModuleNamestr2c<-matchComponentNamecsstr1letms=cinfoModulescm<-matchModuleNamemsstr2return(BuildTargetModule(cinfoNamec)m)matchModule3::[ComponentInfo]->String->String->String->MatchBuildTargetmatchModule3csstr1str2str3=dockind<-matchComponentKindstr1guardComponentNamestr2c<-matchComponentKindAndNamecsckindstr2guardModuleNamestr3letms=cinfoModulescm<-matchModuleNamemsstr3return(BuildTargetModule(cinfoNamec)m)-- utils:guardModuleName::String->Match()guardModuleNames|allvalidModuleChars&&not(nulls)=increaseConfidence|otherwise=matchErrorExpected"module name"swherevalidModuleCharc=isAlphaNumc||c=='.'||c=='_'||c=='\''matchModuleName::[ModuleName]->String->MatchModuleNamematchModuleNamemsstr=orNoSuchThing"module"str$increaseConfidenceFor$matchInexactlycaseFold[(displaym,m)|m<-ms]str-------------------------------- Matching file targets--matchFile1::[ComponentInfo]->String->Bool->MatchBuildTargetmatchFile1csstr1exists=nubMatchErrors$doc<-tryEachcsfilepath<-matchComponentFilecstr1existsreturn(BuildTargetFile(cinfoNamec)filepath)matchFile2::[ComponentInfo]->String->String->Bool->MatchBuildTargetmatchFile2csstr1str2exists=doguardComponentNamestr1c<-matchComponentNamecsstr1filepath<-matchComponentFilecstr2existsreturn(BuildTargetFile(cinfoNamec)filepath)matchFile3::[ComponentInfo]->String->String->String->Bool->MatchBuildTargetmatchFile3csstr1str2str3exists=dockind<-matchComponentKindstr1guardComponentNamestr2c<-matchComponentKindAndNamecsckindstr2filepath<-matchComponentFilecstr3existsreturn(BuildTargetFile(cinfoNamec)filepath)matchComponentFile::ComponentInfo->String->Bool->MatchFilePathmatchComponentFilecstrfexists=expecting"file"str$matchPlus(matchFileExistsstrfexists)(matchPlusShadowing(msum[matchModuleFileRooteddirsmsstr,matchOtherFileRooteddirshsFilesstr])(msum[matchModuleFileUnrootedmsstr,matchOtherFileUnrootedhsFilesstr,matchOtherFileUnrootedcFilesstr,matchOtherFileUnrootedjsFilesstr]))wheredirs=cinfoSrcDirscms=cinfoModuleschsFiles=cinfoHsFilesccFiles=cinfoCFilescjsFiles=cinfoJsFilesc-- utilsmatchFileExists::FilePath->Bool->MatchamatchFileExists_False=mzeromatchFileExistsfnameTrue=doincreaseConfidencematchErrorNoSuch"file"fnamematchModuleFileUnrooted::[ModuleName]->String->MatchFilePathmatchModuleFileUnrootedmsstr=doletfilepath=normalisestr_<-matchModuleFileStemmsfilepathreturnfilepathmatchModuleFileRooted::[FilePath]->[ModuleName]->String->MatchFilePathmatchModuleFileRooteddirsmsstr=nubMatches$doletfilepath=normalisestrfilepath'<-matchDirectoryPrefixdirsfilepath_<-matchModuleFileStemmsfilepath'returnfilepathmatchModuleFileStem::[ModuleName]->FilePath->MatchModuleNamematchModuleFileStemms=increaseConfidenceFor.matchInexactlycaseFold[(toFilePathm,m)|m<-ms].dropExtensionmatchOtherFileRooted::[FilePath]->[FilePath]->FilePath->MatchFilePathmatchOtherFileRooteddirsfsstr=doletfilepath=normalisestrfilepath'<-matchDirectoryPrefixdirsfilepath_<-matchFilefsfilepath'returnfilepathmatchOtherFileUnrooted::[FilePath]->FilePath->MatchFilePathmatchOtherFileUnrootedfsstr=doletfilepath=normalisestr_<-matchFilefsfilepathreturnfilepathmatchFile::[FilePath]->FilePath->MatchFilePathmatchFilefs=increaseConfidenceFor.matchInexactlycaseFold[(f,f)|f<-fs]matchDirectoryPrefix::[FilePath]->FilePath->MatchFilePathmatchDirectoryPrefixdirsfilepath=exactMatches$catMaybes[stripDirectory(normalisedir)filepath|dir<-dirs]wherestripDirectory::FilePath->FilePath->MaybeFilePathstripDirectorydirfp=joinPath`fmap`stripPrefix(splitDirectoriesdir)(splitDirectoriesfp)-------------------------------- 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'.--dataMatcha=NoMatchConfidence[MatchError]|ExactMatchConfidence[a]|InexactMatchConfidence[a]derivingShowtypeConfidence=IntdataMatchError=MatchErrorExpectedStringString|MatchErrorNoSuchStringStringderiving(Show,Eq)instanceAlternativeMatchwhereempty=mzero(<|>)=mplusinstanceMonadPlusMatchwheremzero=matchZeromplus=matchPlusmatchZero::MatchamatchZero=NoMatch0[]-- | 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::Matcha->Matcha->MatchamatchPlus(ExactMatchd1xs)(ExactMatchd2xs')=ExactMatch(maxd1d2)(xs++xs')matchPlusa@(ExactMatch__)(InexactMatch__)=amatchPlusa@(ExactMatch__)(NoMatch__)=amatchPlus(InexactMatch__)b@(ExactMatch__)=bmatchPlus(InexactMatchd1xs)(InexactMatchd2xs')=InexactMatch(maxd1d2)(xs++xs')matchPlusa@(InexactMatch__)(NoMatch__)=amatchPlus(NoMatch__)b@(ExactMatch__)=bmatchPlus(NoMatch__)b@(InexactMatch__)=bmatchPlusa@(NoMatchd1ms)b@(NoMatchd2ms')|d1>d2=a|d1<d2=b|otherwise=NoMatchd1(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::Matcha->Matcha->MatchamatchPlusShadowinga@(ExactMatch__)(ExactMatch__)=amatchPlusShadowingab=matchPlusabinstanceFunctorMatchwherefmap_(NoMatchdms)=NoMatchdmsfmapf(ExactMatchdxs)=ExactMatchd(fmapfxs)fmapf(InexactMatchdxs)=InexactMatchd(fmapfxs)instanceApplicativeMatchwherepurea=ExactMatch0[a](<*>)=apinstanceMonadMatchwherereturn=pureNoMatchdms>>=_=NoMatchdmsExactMatchdxs>>=f=addDepthd$foldrmatchPlusmatchZero(mapfxs)InexactMatchdxs>>=f=addDepthd.forceInexact$foldrmatchPlusmatchZero(mapfxs)addDepth::Confidence->Matcha->MatchaaddDepthd'(NoMatchdmsgs)=NoMatch(d'+d)msgsaddDepthd'(ExactMatchdxs)=ExactMatch(d'+d)xsaddDepthd'(InexactMatchdxs)=InexactMatch(d'+d)xsforceInexact::Matcha->MatchaforceInexact(ExactMatchdys)=InexactMatchdysforceInexactm=m-------------------------------- Various match primitives--matchErrorExpected,matchErrorNoSuch::String->String->MatchamatchErrorExpectedthinggot=NoMatch0[MatchErrorExpectedthinggot]matchErrorNoSuchthinggot=NoMatch0[MatchErrorNoSuchthinggot]expecting::String->String->Matcha->Matchaexpectingthinggot(NoMatch0_)=matchErrorExpectedthinggotexpecting__m=morNoSuchThing::String->String->Matcha->MatchaorNoSuchThingthinggot(NoMatch0_)=matchErrorNoSuchthinggotorNoSuchThing__m=mincreaseConfidence::Match()increaseConfidence=ExactMatch1[()]increaseConfidenceFor::Matcha->MatchaincreaseConfidenceForm=m>>=\r->increaseConfidence>>returnrnubMatches::Eqa=>Matcha->MatchanubMatches(NoMatchdmsgs)=NoMatchdmsgsnubMatches(ExactMatchdxs)=ExactMatchd(nubxs)nubMatches(InexactMatchdxs)=InexactMatchd(nubxs)nubMatchErrors::Matcha->MatchanubMatchErrors(NoMatchdmsgs)=NoMatchd(nubmsgs)nubMatchErrors(ExactMatchdxs)=ExactMatchdxsnubMatchErrors(InexactMatchdxs)=InexactMatchdxs-- | Lift a list of matches to an exact match.--exactMatches,inexactMatches::[a]->MatchaexactMatches[]=matchZeroexactMatchesxs=ExactMatch0xsinexactMatches[]=matchZeroinexactMatchesxs=InexactMatch0xstryEach::[a]->MatchatryEach=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::Eqb=>Matchb->MaybeAmbiguousbfindMatchmatch=casematchofNoMatch_msgs->None(nubmsgs)ExactMatch_xs->checkAmbiguousxsInexactMatch_xs->checkAmbiguousxswherecheckAmbiguousxs=casenubxsof[x]->Unambiguousxxs'->Ambiguousxs'dataMaybeAmbiguousa=None[MatchError]|Unambiguousa|Ambiguous[a]derivingShow-------------------------------- 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::(Orda,Orda')=>(a->a')->[(a,b)]->(a->Matchb)matchInexactlycannonicalisexs=\x->caseMap.lookupxmofJustys->exactMatchesysNothing->caseMap.lookup(cannonicalisex)m'ofJustys->inexactMatchesysNothing->matchZerowherem=Map.fromListWith(++)[(k,[x])|(k,x)<-xs]-- the map of canonicalised keys to groups of inexact matchesm'=Map.mapKeysWith(++)cannonicalisem-------------------------------- Utils--caseFold::String->StringcaseFold=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_descrlbi[]=return(allTargetsInBuildOrder'pkg_descrlbi)checkBuildTargetsverbositypkg_descrlbitargets=dolet(enabled,disabled)=partitionEithers[casecomponentDisabledReason(componentEnabledSpeclbi)compofNothing->Lefttarget'Justreason->Right(cname,reason)|target<-targets,lettarget'@(cname,_)=swizzleTargettarget,letcomp=getComponentpkg_descrcname]casedisabledof[]->return()((cname,reason):_)->die'verbosity$formatReason(showComponentNamecname)reasonfor_[(c,t)|(c,Justt)<-enabled]$\(c,t)->warnverbosity$"Ignoring '"++eitherdisplayidt++". The whole "++showComponentNamec++" will be processed. (Support for "++"module and file targets has not been implemented yet.)"-- Pick out the actual CLBIs for each of these cnamesenabled'<-forenabled$\(cname,_)->docasecomponentNameTargets'pkg_descrlbicnameof[]->error"checkBuildTargets: nothing enabled"[target]->returntarget_targets->error"checkBuildTargets: multiple copies enabled"returnenabled'whereswizzleTarget(BuildTargetComponentc)=(c,Nothing)swizzleTarget(BuildTargetModulecm)=(c,Just(Leftm))swizzleTarget(BuildTargetFilecf)=(c,Just(Rightf))formatReasoncnDisabledComponent="Cannot process the "++cn++" because the component is marked "++"as disabled in the .cabal file."formatReasoncnDisabledAllTests="Cannot process the "++cn++" because test suites are not "++"enabled. Run configure with the flag --enable-tests"formatReasoncnDisabledAllBenchmarks="Cannot process the "++cn++" because benchmarks are not "++"enabled. Re-run configure with the flag --enable-benchmarks"formatReasoncn(DisabledAllButOnecn')="Cannot process the "++cn++" because this package was "++"configured only to build "++cn'++". Re-run configure "++"with the argument "++cn