{-# 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], cinfoCxxFiles:: [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, cinfoCxxFiles= cxxSources 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