{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.BuildTargets -- Copyright : (c) Duncan Coutts 2012, 2015 -- License : BSD-like -- -- Maintainer : duncan@community.haskell.org -- -- Handling for user-specified build targets -- Unlike "Distribution.Simple.BuildTarget" these build -- targets also handle package qualification (so, up to -- four levels of qualification, as opposed to the former's -- three.) ----------------------------------------------------------------------------- module Distribution.Client.BuildTarget ( -- * Build targets BuildTarget(..), -- Don't export me: it's partial (if you try to qualify too -- much you will error.) --showBuildTarget, QualLevel(..), buildTargetPackage, buildTargetComponentName, -- * Top level convenience readUserBuildTargets, resolveUserBuildTargets, -- * Parsing user build targets UserBuildTarget, parseUserBuildTargets, showUserBuildTarget, UserBuildTargetProblem(..), reportUserBuildTargetProblems, -- * Resolving build targets resolveBuildTargets, BuildTargetProblem(..), reportBuildTargetProblems, ) where import Distribution.Package ( Package(..), PackageId, PackageName, packageName , unUnqualComponentName ) import Distribution.Client.Types ( PackageLocation(..) ) import Distribution.PackageDescription ( PackageDescription , Executable(..) , TestSuite(..), TestSuiteInterface(..), testModules , Benchmark(..), BenchmarkInterface(..), benchmarkModules , BuildInfo(..), explicitLibModules, exeModules ) import Distribution.ModuleName ( ModuleName, toFilePath ) import Distribution.Simple.LocalBuildInfo ( Component(..), ComponentName(..) , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib import Distribution.Text ( display, simpleParse ) import Distribution.Simple.Utils ( die, lowercase ) import Distribution.Client.Utils ( makeRelativeToCwd ) import Data.Either ( partitionEithers ) import Data.Function ( on ) import Data.List ( nubBy, stripPrefix, partition, intercalate, sortBy, groupBy ) import Data.Maybe ( listToMaybe, maybeToList ) import Data.Ord ( comparing ) import GHC.Generics (Generic) #if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Lazy as Map.Lazy import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) #else import qualified Data.Map as Map.Lazy import qualified Data.Map as Map import Data.Map (Map) #endif import qualified Data.Set as Set import Control.Arrow ((&&&)) import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..), (<$>)) #endif import Control.Applicative (Alternative(..)) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) import Data.Char ( isSpace, isAlphaNum ) import System.FilePath as FilePath ( takeExtension, dropExtension, addTrailingPathSeparator , splitDirectories, joinPath, splitPath ) import System.Directory ( doesFileExist, doesDirectoryExist, canonicalizePath , getCurrentDirectory ) import System.FilePath ( (), (<.>), normalise ) import Text.EditDistance ( defaultEditCosts, restrictedDamerauLevenshteinDistance ) -- ------------------------------------------------------------ -- * User build targets -- ------------------------------------------------------------ -- | Various ways that a user may specify a build target. -- -- The main general form has lots of optional parts: -- -- > [ package name | package dir | package .cabal file ] -- > [ [lib:|exe:] component name ] -- > [ module name | source file ] -- -- There's also a special case of a package tarball. It doesn't take part in -- the main general form since we always build a tarball package as a whole. -- -- > [package tar.gz file] -- data UserBuildTarget = -- | A simple target specified by a single part. This is any of the -- general forms that can be expressed using one part, which are: -- -- > cabal build foo -- package name -- > cabal build ../bar ../bar/bar.cabal -- package dir or package file -- > cabal build foo -- component name -- > cabal build Data.Foo -- module name -- > cabal build Data/Foo.hs bar/Main.hsc -- file name -- -- It can also be a package tarball. -- -- > cabal build bar.tar.gz -- UserBuildTarget1 String -- | A qualified target with two parts. This is any of the general -- forms that can be expressed using two parts, which are: -- -- > cabal build foo:foo -- package : component -- > cabal build foo:Data.Foo -- package : module -- > cabal build foo:Data/Foo.hs -- package : filename -- -- > cabal build ./foo:foo -- package dir : component -- > cabal build ./foo:Data.Foo -- package dir : module -- -- > cabal build ./foo.cabal:foo -- package file : component -- > cabal build ./foo.cabal:Data.Foo -- package file : module -- > cabal build ./foo.cabal:Main.hs -- package file : filename -- -- > cabal build lib:foo exe:foo -- namespace : component -- > cabal build foo:Data.Foo -- component : module -- > cabal build foo:Data/Foo.hs -- component : filename -- | UserBuildTarget2 String String -- A (very) qualified target with three parts. This is any of the general -- forms that can be expressed using three parts, which are: -- -- > cabal build foo:lib:foo -- package : namespace : component -- > cabal build foo:foo:Data.Foo -- package : component : module -- > cabal build foo:foo:Data/Foo.hs -- package : component : filename -- -- > cabal build foo/:lib:foo -- pkg dir : namespace : component -- > cabal build foo/:foo:Data.Foo -- pkg dir : component : module -- > cabal build foo/:foo:Data/Foo.hs -- pkg dir : component : filename -- -- > cabal build foo.cabal:lib:foo -- pkg file : namespace : component -- > cabal build foo.cabal:foo:Data.Foo -- pkg file : component : module -- > cabal build foo.cabal:foo:Data/Foo.hs -- pkg file : component : filename -- -- > cabal build lib:foo:Data.Foo -- namespace : component : module -- > cabal build lib:foo:Data/Foo.hs -- namespace : component : filename -- | UserBuildTarget3 String String String -- A (rediculously) qualified target with four parts. This is any of the -- general forms that can be expressed using all four parts, which are: -- -- > cabal build foo:lib:foo:Data.Foo -- package : namespace : component : module -- > cabal build foo:lib:foo:Data/Foo.hs -- package : namespace : component : filename -- -- > cabal build foo/:lib:foo:Data.Foo -- pkg dir : namespace : component : module -- > cabal build foo/:lib:foo:Data/Foo.hs -- pkg dir : namespace : component : filename -- -- > cabal build foo.cabal:lib:foo:Data.Foo -- pkg file : namespace : component : module -- > cabal build foo.cabal:lib:foo:Data/Foo.hs -- pkg file : namespace : component : filename -- | UserBuildTarget4 String String String String deriving (Show, Eq, Ord) -- ------------------------------------------------------------ -- * Resolved build targets -- ------------------------------------------------------------ -- | A fully resolved build target. -- data BuildTarget pkg = -- | A package as a whole -- BuildTargetPackage pkg -- | A specific component -- | BuildTargetComponent pkg ComponentName -- | A specific module within a specific component. -- | BuildTargetModule pkg ComponentName ModuleName -- | A specific file within a specific component. -- | BuildTargetFile pkg ComponentName FilePath deriving (Eq, Ord, Functor, Show, Generic) -- | Get the package that the 'BuildTarget' is referring to. -- buildTargetPackage :: BuildTarget pkg -> pkg buildTargetPackage (BuildTargetPackage p) = p buildTargetPackage (BuildTargetComponent p _cn) = p buildTargetPackage (BuildTargetModule p _cn _mn) = p buildTargetPackage (BuildTargetFile p _cn _fn) = p -- | Get the 'ComponentName' that the 'BuildTarget' is referring to, if any. -- The 'BuildTargetPackage' target kind doesn't refer to any individual -- component, while the component, module and file kinds do. -- buildTargetComponentName :: BuildTarget pkg -> Maybe ComponentName buildTargetComponentName (BuildTargetPackage _p) = Nothing buildTargetComponentName (BuildTargetComponent _p cn) = Just cn buildTargetComponentName (BuildTargetModule _p cn _mn) = Just cn buildTargetComponentName (BuildTargetFile _p cn _fn) = Just cn -- ------------------------------------------------------------ -- * Top level, do everything -- ------------------------------------------------------------ -- | Parse a bunch of command line args as user build targets, failing with an -- error if any targets are unrecognised. -- readUserBuildTargets :: [String] -> IO [UserBuildTarget] readUserBuildTargets targetStrs = do let (uproblems, utargets) = parseUserBuildTargets targetStrs reportUserBuildTargetProblems uproblems return utargets -- | A 'UserBuildTarget's is just a semi-structured string. We sill have quite -- a bit of work to do to figure out which targets they refer to (ie packages, -- components, file locations etc). -- -- The possible targets are based on the available packages (and their -- locations). It fails with an error if any user string cannot be matched to -- a valid target. -- resolveUserBuildTargets :: [(PackageDescription, PackageLocation a)] -> [UserBuildTarget] -> IO [BuildTarget PackageName] resolveUserBuildTargets pkgs utargets = do utargets' <- mapM getUserTargetFileStatus utargets pkgs' <- mapM (uncurry selectPackageInfo) pkgs pwd <- getCurrentDirectory let (primaryPkg, otherPkgs) = selectPrimaryLocalPackage pwd pkgs' (bproblems, btargets) = resolveBuildTargets primaryPkg otherPkgs utargets'' utargets'' -- default local dir target if there's no given target | not (null primaryPkg) , null utargets = [UserBuildTargetFileStatus1 "./" (FileStatusExistsDir pwd)] | otherwise = utargets' -- if there's nothing to build, build everything btargets' | null utargets , null primaryPkg = [ BuildTargetPackage pkg | pkg <- otherPkgs ] | otherwise = btargets reportBuildTargetProblems bproblems return (map (fmap packageName) btargets') where selectPrimaryLocalPackage :: FilePath -> [PackageInfo] -> ([PackageInfo], [PackageInfo]) selectPrimaryLocalPackage pwd pkgs' = let (primary, others) = partition isPrimary pkgs' in (primary, others) where isPrimary PackageInfo { pinfoDirectory = Just (dir,_) } | dir == pwd = True isPrimary _ = False -- ------------------------------------------------------------ -- * Checking if targets exist as files -- ------------------------------------------------------------ data UserBuildTargetFileStatus = UserBuildTargetFileStatus1 String FileStatus | UserBuildTargetFileStatus2 String FileStatus String | UserBuildTargetFileStatus3 String FileStatus String String | UserBuildTargetFileStatus4 String FileStatus String String String deriving (Eq, Ord, Show) data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath | FileStatusExistsDir FilePath -- the canonicalised filepath | FileStatusNotExists Bool -- does the parent dir exist even? deriving (Eq, Ord, Show) getUserTargetFileStatus :: UserBuildTarget -> IO UserBuildTargetFileStatus getUserTargetFileStatus t = case t of UserBuildTarget1 s1 -> (\f1 -> UserBuildTargetFileStatus1 s1 f1) <$> fileStatus s1 UserBuildTarget2 s1 s2 -> (\f1 -> UserBuildTargetFileStatus2 s1 f1 s2) <$> fileStatus s1 UserBuildTarget3 s1 s2 s3 -> (\f1 -> UserBuildTargetFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 UserBuildTarget4 s1 s2 s3 s4 -> (\f1 -> UserBuildTargetFileStatus4 s1 f1 s2 s3 s4) <$> fileStatus s1 where fileStatus f = do fexists <- doesFileExist f dexists <- doesDirectoryExist f case splitPath f of _ | fexists -> FileStatusExistsFile <$> canonicalizePath f | dexists -> FileStatusExistsDir <$> canonicalizePath f (d:_) -> FileStatusNotExists <$> doesDirectoryExist d _ -> error "getUserTargetFileStatus: empty path" forgetFileStatus :: UserBuildTargetFileStatus -> UserBuildTarget forgetFileStatus t = case t of UserBuildTargetFileStatus1 s1 _ -> UserBuildTarget1 s1 UserBuildTargetFileStatus2 s1 _ s2 -> UserBuildTarget2 s1 s2 UserBuildTargetFileStatus3 s1 _ s2 s3 -> UserBuildTarget3 s1 s2 s3 UserBuildTargetFileStatus4 s1 _ s2 s3 s4 -> UserBuildTarget4 s1 s2 s3 s4 -- ------------------------------------------------------------ -- * Parsing user targets -- ------------------------------------------------------------ -- | Parse a bunch of 'UserBuildTarget's (purely without throwing exceptions). -- parseUserBuildTargets :: [String] -> ([UserBuildTargetProblem] ,[UserBuildTarget]) parseUserBuildTargets = partitionEithers . map parseUserBuildTarget parseUserBuildTarget :: String -> Either UserBuildTargetProblem UserBuildTarget parseUserBuildTarget 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 (UserBuildTarget1 a)) +++ (do a <- tokenQ _ <- Parse.char ':' b <- tokenQ return (UserBuildTarget2 a b)) +++ (do a <- tokenQ _ <- Parse.char ':' b <- tokenQ _ <- Parse.char ':' c <- tokenQ return (UserBuildTarget3 a b c)) +++ (do a <- tokenQ _ <- Parse.char ':' b <- token _ <- Parse.char ':' c <- tokenQ _ <- Parse.char ':' d <- tokenQ return (UserBuildTarget4 a b c d)) token = Parse.munch1 (\x -> not (isSpace x) && x /= ':') tokenQ = parseHaskellString <++ token parseHaskellString :: Parse.ReadP r String parseHaskellString = Parse.readS_to_P reads readPToMaybe :: Parse.ReadP a a -> String -> Maybe a readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str , all isSpace s ] -- | Syntax error when trying to parse a 'UserBuildTarget'. data UserBuildTargetProblem = UserBuildTargetUnrecognised String deriving Show -- | Throw an exception with a formatted message if there are any problems. -- reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO () reportUserBuildTargetProblems problems = do case [ target | UserBuildTargetUnrecognised target <- problems ] of [] -> return () target -> die $ unlines [ "Unrecognised build target syntax for '" ++ name ++ "'." | name <- target ] ++ "Syntax:\n" ++ " - build [package]\n" ++ " - build [package:]component\n" ++ " - build [package:][component:]module\n" ++ " - build [package:][component:]file\n" ++ " where\n" ++ " package is a package name, package dir or .cabal file\n\n" ++ "Examples:\n" ++ " - build foo -- package name\n" ++ " - build tests -- component name\n" ++ " (name of library, executable, test-suite or benchmark)\n" ++ " - build Data.Foo -- module name\n" ++ " - build Data/Foo.hsc -- file name\n\n" ++ "An ambigious target can be qualified by package, component\n" ++ "and/or component kind (lib|exe|test|bench)\n" ++ " - build foo:tests -- component qualified by package\n" ++ " - build tests:Data.Foo -- module qualified by component\n" ++ " - build lib:foo -- component qualified by kind" -- | Render a 'UserBuildTarget' back as the external syntax. This is mainly for -- error messages. -- showUserBuildTarget :: UserBuildTarget -> String showUserBuildTarget = intercalate ":" . components where components (UserBuildTarget1 s1) = [s1] components (UserBuildTarget2 s1 s2) = [s1,s2] components (UserBuildTarget3 s1 s2 s3) = [s1,s2,s3] components (UserBuildTarget4 s1 s2 s3 s4) = [s1,s2,s3,s4] showBuildTarget :: QualLevel -> BuildTarget PackageInfo -> String showBuildTarget ql = showUserBuildTarget . forgetFileStatus . hd . renderBuildTarget ql where hd [] = error "showBuildTarget: head" hd (x:_) = x -- ------------------------------------------------------------ -- * Resolving user targets to build targets -- ------------------------------------------------------------ -- | Given a bunch of user-specified targets, try to resolve what it is they -- refer to. -- resolveBuildTargets :: [PackageInfo] -- any primary pkg, e.g. cur dir -> [PackageInfo] -- all the other local packages -> [UserBuildTargetFileStatus] -> ([BuildTargetProblem], [BuildTarget PackageInfo]) resolveBuildTargets ppinfo opinfo = partitionEithers . map (resolveBuildTarget ppinfo opinfo) resolveBuildTarget :: [PackageInfo] -> [PackageInfo] -> UserBuildTargetFileStatus -> Either BuildTargetProblem (BuildTarget PackageInfo) resolveBuildTarget ppinfo opinfo userTarget = case findMatch (matcher userTarget) of Unambiguous target -> Right target None errs -> Left (classifyMatchErrors errs) Ambiguous exactMatch targets -> case disambiguateBuildTargets matcher userTarget exactMatch targets of Right targets' -> Left (BuildTargetAmbiguous userTarget' targets') Left ((m, ms):_) -> Left (MatchingInternalError userTarget' m ms) Left [] -> internalError "resolveBuildTarget" where matcher = matchBuildTarget ppinfo opinfo userTarget' = forgetFileStatus userTarget classifyMatchErrors errs | not (null expected) = let (things, got:_) = unzip expected in BuildTargetExpected userTarget' things got | not (null nosuch) = BuildTargetNoSuch userTarget' nosuch | otherwise = internalError $ "classifyMatchErrors: " ++ show errs where expected = [ (thing, got) | (_, MatchErrorExpected thing got) <- map (innerErr Nothing) errs ] -- Trim the list of alternatives by dropping duplicates and -- retaining only at most three most similar (by edit distance) ones. nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $ [ ((inside, thing, got), Set.fromList alts) | (inside, MatchErrorNoSuch thing got alts) <- map (innerErr Nothing) errs ] genResults (inside, thing, got) alts acc = ( inside , thing , got , take maxResults $ map fst $ takeWhile distanceLow $ sortBy (comparing snd) $ map addLevDist $ Set.toList alts ) : acc where addLevDist = id &&& restrictedDamerauLevenshteinDistance defaultEditCosts got distanceLow (_, dist) = dist < length got `div` 2 maxResults = 3 innerErr _ (MatchErrorIn kind thing m) = innerErr (Just (kind,thing)) m innerErr c m = (c,m) -- | The various ways that trying to resolve a 'UserBuildTarget' to a -- 'BuildTarget' can fail. -- data BuildTargetProblem = BuildTargetExpected UserBuildTarget [String] String -- ^ [expected thing] (actually got) | BuildTargetNoSuch UserBuildTarget [(Maybe (String, String), String, String, [String])] -- ^ [([in thing], no such thing, actually got, alternatives)] | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget PackageInfo)] | MatchingInternalError UserBuildTarget (BuildTarget PackageInfo) [(UserBuildTarget, [BuildTarget PackageInfo])] disambiguateBuildTargets :: (UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo)) -> UserBuildTargetFileStatus -> Bool -> [BuildTarget PackageInfo] -> Either [(BuildTarget PackageInfo, [(UserBuildTarget, [BuildTarget PackageInfo])])] [(UserBuildTarget, BuildTarget PackageInfo)] disambiguateBuildTargets matcher matchInput exactMatch matchResults = case partitionEithers results of (errs@(_:_), _) -> Left errs ([], ok) -> Right ok where -- So, here's the strategy. We take the original match results, and make a -- table of all their renderings at all qualification levels. -- Note there can be multiple renderings at each qualification level. matchResultsRenderings :: [(BuildTarget PackageInfo, [UserBuildTargetFileStatus])] matchResultsRenderings = [ (matchResult, matchRenderings) | matchResult <- matchResults , let matchRenderings = [ rendering | ql <- [QL1 .. QL4] , rendering <- renderBuildTarget ql matchResult ] ] -- Of course the point is that we're looking for renderings that are -- unambiguous matches. So we build another memo table of all the matches -- for all of those renderings. So by looking up in this table we can see -- if we've got an unambiguous match. memoisedMatches :: Map UserBuildTargetFileStatus (Match (BuildTarget PackageInfo)) memoisedMatches = -- avoid recomputing the main one if it was an exact match (if exactMatch then Map.insert matchInput (ExactMatch 0 matchResults) else id) $ Map.Lazy.fromList [ (rendering, matcher rendering) | rendering <- concatMap snd matchResultsRenderings ] -- Finally, for each of the match results, we go through all their -- possible renderings (in order of qualification level, though remember -- there can be multiple renderings per level), and find the first one -- that has an unambiguous match. results :: [Either (BuildTarget PackageInfo, [(UserBuildTarget, [BuildTarget PackageInfo])]) (UserBuildTarget, BuildTarget PackageInfo)] results = [ case findUnambiguous originalMatch matchRenderings of Just unambiguousRendering -> Right ( forgetFileStatus unambiguousRendering , originalMatch) -- This case is an internal error, but we bubble it up and report it Nothing -> Left ( originalMatch , [ (forgetFileStatus rendering, matches) | rendering <- matchRenderings , let (ExactMatch _ matches) = memoisedMatches Map.! rendering ] ) | (originalMatch, matchRenderings) <- matchResultsRenderings ] findUnambiguous :: BuildTarget PackageInfo -> [UserBuildTargetFileStatus] -> Maybe UserBuildTargetFileStatus findUnambiguous _ [] = Nothing findUnambiguous t (r:rs) = case memoisedMatches Map.! r of ExactMatch _ [t'] | fmap packageName t == fmap packageName t' -> Just r ExactMatch _ _ -> findUnambiguous t rs InexactMatch _ _ -> internalError "InexactMatch" NoMatch _ _ -> internalError "NoMatch" internalError :: String -> a internalError msg = error $ "BuildTargets: internal error: " ++ msg data QualLevel = QL1 | QL2 | QL3 | QL4 deriving (Enum, Show) renderBuildTarget :: QualLevel -> BuildTarget PackageInfo -> [UserBuildTargetFileStatus] renderBuildTarget ql t = case t of BuildTargetPackage p -> case ql of QL1 -> [t1 (dispP p)] QL2 -> [t1' pf fs | (pf, fs) <- dispPF p] QL3 -> [] QL4 -> [] BuildTargetComponent p c -> case ql of QL1 -> [t1 (dispC p c)] QL2 -> [t2 (dispP p) (dispC p c), t2 (dispK c) (dispC p c)] QL3 -> [t3 (dispP p) (dispK c) (dispC p c)] QL4 -> [] BuildTargetModule p c m -> case ql of QL1 -> [t1 (dispM m)] QL2 -> [t2 (dispP p) (dispM m), t2 (dispC p c) (dispM m)] QL3 -> [t3 (dispP p) (dispC p c) (dispM m), t3 (dispK c) (dispC p c) (dispM m)] QL4 -> [t4 (dispP p) (dispK c) (dispC p c) (dispM m)] BuildTargetFile p c f -> case ql of QL1 -> [t1 f] QL2 -> [t2 (dispP p) f, t2 (dispC p c) f] QL3 -> [t3 (dispP p) (dispC p c) f, t3 (dispK c) (dispC p c) f] QL4 -> [t4 (dispP p) (dispK c) (dispC p c) f] where t1 s1 = UserBuildTargetFileStatus1 s1 none t1' s1 = UserBuildTargetFileStatus1 s1 t2 s1 = UserBuildTargetFileStatus2 s1 none t3 s1 = UserBuildTargetFileStatus3 s1 none t4 s1 = UserBuildTargetFileStatus4 s1 none none = FileStatusNotExists False dispP = display . packageName dispC = componentStringName dispK = showComponentKindShort . componentKind dispM = display dispPF p = [ (addTrailingPathSeparator drel, FileStatusExistsDir dabs) | PackageInfo { pinfoDirectory = Just (dabs,drel) } <- [p] ] ++ [ (frel, FileStatusExistsFile fabs) | PackageInfo { pinfoPackageFile = Just (fabs,frel) } <- [p] ] -- | Throw an exception with a formatted message if there are any problems. -- reportBuildTargetProblems :: [BuildTargetProblem] -> IO () reportBuildTargetProblems problems = do case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of [] -> return () ((target, originalMatch, renderingsAndMatches):_) -> die $ "Internal error in build target matching. It should always be " ++ "possible to find a syntax that's sufficiently qualified to " ++ "give an unambigious match. However when matching '" ++ showUserBuildTarget target ++ "' we found " ++ showBuildTarget QL1 originalMatch ++ " (" ++ showBuildTargetKind originalMatch ++ ") which does not " ++ "have an unambigious syntax. The possible syntax and the " ++ "targets they match are as follows:\n" ++ unlines [ "'" ++ showUserBuildTarget rendering ++ "' which matches " ++ intercalate ", " [ showBuildTarget QL1 match ++ " (" ++ showBuildTargetKind match ++ ")" | match <- matches ] | (rendering, matches) <- renderingsAndMatches ] case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of [] -> return () targets -> die $ 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 $ unlines [ "Unknown build target '" ++ showUserBuildTarget target ++ "'.\n" ++ unlines [ (case inside of Just (kind, thing) -> "The " ++ kind ++ " " ++ thing ++ " has no " Nothing -> "There is no ") ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'" | (thing, got, _alts) <- nosuch' ] ++ "." ++ if null alternatives then "" else "\nPerhaps you meant " ++ intercalate ";\nor " [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?" | (thing, alts) <- alternatives ] | (inside, nosuch') <- groupByContainer nosuch , let alternatives = [ (thing, alts) | (thing,_got,alts@(_:_)) <- nosuch' ] ] | (target, nosuch) <- targets , let groupByContainer = map (\g@((inside,_,_,_):_) -> (inside, [ (thing,got,alts) | (_,thing,got,alts) <- g ])) . groupBy ((==) `on` (\(x,_,_,_) -> x)) . sortBy (compare `on` (\(x,_,_,_) -> x)) ] where mungeThing "file" = "file target" mungeThing thing = thing case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of [] -> return () targets -> die $ unlines [ "Ambiguous build target '" ++ showUserBuildTarget target ++ "'. It could be:\n " ++ unlines [ " "++ showUserBuildTarget ut ++ " (" ++ showBuildTargetKind bt ++ ")" | (ut, bt) <- amb ] | (target, amb) <- targets ] where showBuildTargetKind (BuildTargetPackage _ ) = "package" showBuildTargetKind (BuildTargetComponent _ _ ) = "component" showBuildTargetKind (BuildTargetModule _ _ _) = "module" showBuildTargetKind (BuildTargetFile _ _ _) = "file" ---------------------------------- -- Top level BuildTarget matcher -- matchBuildTarget :: [PackageInfo] -> [PackageInfo] -> UserBuildTargetFileStatus -> Match (BuildTarget PackageInfo) matchBuildTarget ppinfo opinfo = \utarget -> nubMatchesBy ((==) `on` (fmap packageName)) $ case utarget of UserBuildTargetFileStatus1 str1 fstatus1 -> matchBuildTarget1 ppinfo opinfo str1 fstatus1 UserBuildTargetFileStatus2 str1 fstatus1 str2 -> matchBuildTarget2 pinfo str1 fstatus1 str2 UserBuildTargetFileStatus3 str1 fstatus1 str2 str3 -> matchBuildTarget3 pinfo str1 fstatus1 str2 str3 UserBuildTargetFileStatus4 str1 fstatus1 str2 str3 str4 -> matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 where pinfo = ppinfo ++ opinfo --TODO: sort this out matchBuildTarget1 :: [PackageInfo] -> [PackageInfo] -> String -> FileStatus -> Match (BuildTarget PackageInfo) matchBuildTarget1 ppinfo opinfo = \str1 fstatus1 -> match1Cmp pcinfo str1 match1Pkg pinfo str1 fstatus1 match1Cmp ocinfo str1 match1Mod cinfo str1 match1Fil pinfo str1 fstatus1 where pinfo = ppinfo ++ opinfo cinfo = concatMap pinfoComponents pinfo pcinfo = concatMap pinfoComponents ppinfo ocinfo = concatMap pinfoComponents opinfo matchBuildTarget2 :: [PackageInfo] -> String -> FileStatus -> String -> Match (BuildTarget PackageInfo) matchBuildTarget2 pinfo str1 fstatus1 str2 = match2PkgCmp pinfo str1 fstatus1 str2 <|> match2KndCmp cinfo str1 str2 match2PkgMod pinfo str1 fstatus1 str2 match2CmpMod cinfo str1 str2 match2PkgFil pinfo str1 fstatus1 str2 match2CmpFil cinfo str1 str2 where cinfo = concatMap pinfoComponents pinfo --TODO: perhaps we actually do want to prioritise local/primary components matchBuildTarget3 :: [PackageInfo] -> String -> FileStatus -> String -> String -> Match (BuildTarget PackageInfo) matchBuildTarget3 pinfo str1 fstatus1 str2 str3 = match3PkgKndCmp pinfo str1 fstatus1 str2 str3 match3PkgCmpMod pinfo str1 fstatus1 str2 str3 match3PkgCmpFil pinfo str1 fstatus1 str2 str3 match3KndCmpMod cinfo str1 str2 str3 match3KndCmpFil cinfo str1 str2 str3 where cinfo = concatMap pinfoComponents pinfo matchBuildTarget4 :: [PackageInfo] -> String -> FileStatus -> String -> String -> String -> Match (BuildTarget PackageInfo) matchBuildTarget4 pinfo str1 fstatus1 str2 str3 str4 = match4PkgKndCmpMod pinfo str1 fstatus1 str2 str3 str4 match4PkgKndCmpFil pinfo str1 fstatus1 str2 str3 str4 ------------------------------------ -- Individual BuildTarget matchers -- match1Pkg :: [PackageInfo] -> String -> FileStatus -> Match (BuildTarget PackageInfo) match1Pkg pinfo = \str1 fstatus1 -> do guardPackage str1 fstatus1 p <- matchPackage pinfo str1 fstatus1 return (BuildTargetPackage p) match1Cmp :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) match1Cmp cs = \str1 -> do guardComponentName str1 c <- matchComponentName cs str1 return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) match1Mod :: [ComponentInfo] -> String -> Match (BuildTarget PackageInfo) match1Mod cs = \str1 -> do guardModuleName str1 let ms = [ (m,c) | c <- cs, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str1 return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) match1Fil :: [PackageInfo] -> String -> FileStatus -> Match (BuildTarget PackageInfo) match1Fil ps str1 fstatus1 = expecting "file" str1 $ do (pkgfile, p) <- matchPackageDirectoryPrefix ps fstatus1 orNoThingIn "package" (display (packageName p)) $ do (filepath, c) <- matchComponentFile (pinfoComponents p) pkgfile return (BuildTargetFile p (cinfoName c) filepath) --- match2PkgCmp :: [PackageInfo] -> String -> FileStatus -> String -> Match (BuildTarget PackageInfo) match2PkgCmp ps = \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentName (pinfoComponents p) str2 return (BuildTargetComponent p (cinfoName c)) --TODO: the error here ought to say there's no component by that name in -- this package, and name the package match2KndCmp :: [ComponentInfo] -> String -> String -> Match (BuildTarget PackageInfo) match2KndCmp cs = \str1 str2 -> do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 return (BuildTargetComponent (cinfoPackage c) (cinfoName c)) match2PkgMod :: [PackageInfo] -> String -> FileStatus -> String -> Match (BuildTarget PackageInfo) match2PkgMod ps = \str1 fstatus1 str2 -> do guardPackage str1 fstatus1 guardModuleName str2 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do let ms = [ (m,c) | c <- pinfoComponents p, m <- cinfoModules c ] (m,c) <- matchModuleNameAnd ms str2 return (BuildTargetModule p (cinfoName c) m) match2CmpMod :: [ComponentInfo] -> String -> String -> Match (BuildTarget PackageInfo) match2CmpMod cs = \str1 str2 -> do guardComponentName str1 guardModuleName str2 c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str2 return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) match2PkgFil :: [PackageInfo] -> String -> FileStatus -> String -> Match (BuildTarget PackageInfo) match2PkgFil ps str1 fstatus1 str2 = do guardPackage str1 fstatus1 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do (filepath, c) <- matchComponentFile (pinfoComponents p) str2 return (BuildTargetFile p (cinfoName c) filepath) match2CmpFil :: [ComponentInfo] -> String -> String -> Match (BuildTarget PackageInfo) match2CmpFil cs str1 str2 = do guardComponentName str1 c <- matchComponentName cs str1 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str2 return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) --- match3PkgKndCmp :: [PackageInfo] -> String -> FileStatus -> String -> String -> Match (BuildTarget PackageInfo) match3PkgKndCmp ps = \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 ckind <- matchComponentKind str2 guardComponentName str3 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentKindAndName (pinfoComponents p) ckind str3 return (BuildTargetComponent p (cinfoName c)) match3PkgCmpMod :: [PackageInfo] -> String -> FileStatus -> String -> String -> Match (BuildTarget PackageInfo) match3PkgCmpMod ps = \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 guardComponentName str2 guardModuleName str3 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentName (pinfoComponents p) str2 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 return (BuildTargetModule p (cinfoName c) m) match3KndCmpMod :: [ComponentInfo] -> String -> String -> String -> Match (BuildTarget PackageInfo) match3KndCmpMod cs = \str1 str2 str3 -> do ckind <- matchComponentKind str1 guardComponentName str2 guardModuleName str3 c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str3 return (BuildTargetModule (cinfoPackage c) (cinfoName c) m) match3PkgCmpFil :: [PackageInfo] -> String -> FileStatus -> String -> String -> Match (BuildTarget PackageInfo) match3PkgCmpFil ps = \str1 fstatus1 str2 str3 -> do guardPackage str1 fstatus1 guardComponentName str2 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentName (pinfoComponents p) str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 return (BuildTargetFile p (cinfoName c) filepath) match3KndCmpFil :: [ComponentInfo] -> String -> String -> String -> Match (BuildTarget PackageInfo) match3KndCmpFil cs = \str1 str2 str3 -> do ckind <- matchComponentKind str1 guardComponentName str2 c <- matchComponentKindAndName cs ckind str2 orNoThingIn "component" (cinfoStrName c) $ do (filepath, _) <- matchComponentFile [c] str3 return (BuildTargetFile (cinfoPackage c) (cinfoName c) filepath) -- match4PkgKndCmpMod :: [PackageInfo] -> String-> FileStatus -> String -> String -> String -> Match (BuildTarget PackageInfo) match4PkgKndCmpMod ps = \str1 fstatus1 str2 str3 str4 -> do guardPackage str1 fstatus1 ckind <- matchComponentKind str2 guardComponentName str3 guardModuleName str4 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentKindAndName (pinfoComponents p) ckind str3 orNoThingIn "component" (cinfoStrName c) $ do let ms = cinfoModules c m <- matchModuleName ms str4 return (BuildTargetModule p (cinfoName c) m) match4PkgKndCmpFil :: [PackageInfo] -> String -> FileStatus -> String -> String -> String -> Match (BuildTarget PackageInfo) match4PkgKndCmpFil ps = \str1 fstatus1 str2 str3 str4 -> do guardPackage str1 fstatus1 ckind <- matchComponentKind str2 guardComponentName str3 p <- matchPackage ps str1 fstatus1 orNoThingIn "package" (display (packageName p)) $ do c <- matchComponentKindAndName (pinfoComponents p) ckind str3 orNoThingIn "component" (cinfoStrName c) $ do (filepath,_) <- matchComponentFile [c] str4 return (BuildTargetFile p (cinfoName c) filepath) ------------------------------- -- Package and component info -- data PackageInfo = PackageInfo { pinfoId :: PackageId, pinfoLocation :: PackageLocation (), pinfoDirectory :: Maybe (FilePath, FilePath), pinfoPackageFile :: Maybe (FilePath, FilePath), pinfoComponents :: [ComponentInfo] } data ComponentInfo = ComponentInfo { cinfoName :: ComponentName, cinfoStrName :: ComponentStringName, cinfoPackage :: PackageInfo, cinfoSrcDirs :: [FilePath], cinfoModules :: [ModuleName], cinfoHsFiles :: [FilePath], -- other hs files (like main.hs) cinfoCFiles :: [FilePath], cinfoJsFiles :: [FilePath] } type ComponentStringName = String instance Package PackageInfo where packageId = pinfoId --TODO: [required eventually] need the original GenericPackageDescription or -- the flattening thereof because we need to be able to target modules etc -- that are not enabled in the current configuration. selectPackageInfo :: PackageDescription -> PackageLocation a -> IO PackageInfo selectPackageInfo pkg loc = do (pkgdir, pkgfile) <- case loc of --TODO: local tarballs, remote tarballs etc LocalUnpackedPackage dir -> do dirabs <- canonicalizePath dir dirrel <- makeRelativeToCwd dirabs --TODO: ought to get this earlier in project reading let fileabs = dirabs display (packageName pkg) <.> "cabal" filerel = dirrel display (packageName pkg) <.> "cabal" exists <- doesFileExist fileabs return ( Just (dirabs, dirrel) , if exists then Just (fileabs, filerel) else Nothing ) _ -> return (Nothing, Nothing) let pinfo = PackageInfo { pinfoId = packageId pkg, pinfoLocation = fmap (const ()) loc, pinfoDirectory = pkgdir, pinfoPackageFile = pkgfile, pinfoComponents = selectComponentInfo pinfo pkg } return pinfo selectComponentInfo :: PackageInfo -> PackageDescription -> [ComponentInfo] selectComponentInfo pinfo pkg = [ ComponentInfo { cinfoName = componentName c, cinfoStrName = componentStringName pkg (componentName c), cinfoPackage = pinfo, cinfoSrcDirs = hsSourceDirs bi, -- [ pkgroot srcdir -- | (pkgroot,_) <- maybeToList (pinfoDirectory pinfo) -- , srcdir <- hsSourceDirs bi ], cinfoModules = componentModules c, cinfoHsFiles = componentHsFiles c, cinfoCFiles = cSources bi, cinfoJsFiles = jsSources bi } | c <- pkgComponents pkg , let bi = componentBuildInfo c ] componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName componentStringName pkg CLibName = display (packageName pkg) componentStringName _ (CSubLibName name) = unUnqualComponentName name componentStringName _ (CFLibName name) = unUnqualComponentName name componentStringName _ (CExeName name) = unUnqualComponentName name componentStringName _ (CTestName name) = unUnqualComponentName name componentStringName _ (CBenchName name) = unUnqualComponentName name componentModules :: Component -> [ModuleName] -- I think it's unlikely users will ask to build a requirement -- which is not mentioned locally. 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 _ = [] ------------------------------ -- 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"] = increaseConfidence >> return LibKind | s `elem` ["exe", "executable"] = increaseConfidence >> return ExeKind | s `elem` ["tst", "test", "test-suite"] = increaseConfidence >> return TestKind | s `elem` ["bench", "benchmark"] = increaseConfidence >> return BenchKind | otherwise = matchErrorExpected "component kind" s 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 package targets -- guardPackage :: String -> FileStatus -> Match () guardPackage str fstatus = guardPackageName str <|> guardPackageDir str fstatus <|> guardPackageFile str fstatus guardPackageName :: String -> Match () guardPackageName s | validPackageName s = increaseConfidence | otherwise = matchErrorExpected "package name" s where validPackageName :: String -> Bool validPackageName s = all validPackageNameChar s && not (null s) where validPackageNameChar c = isAlphaNum c || c == '-' guardPackageDir :: String -> FileStatus -> Match () guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence guardPackageDir str _ = matchErrorExpected "package directory" str guardPackageFile :: String -> FileStatus -> Match () guardPackageFile _ (FileStatusExistsFile file) | takeExtension file == ".cabal" = increaseConfidence guardPackageFile str _ = matchErrorExpected "package .cabal file" str matchPackage :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo matchPackage pinfo = \str fstatus -> orNoThingIn "project" "" $ matchPackageName pinfo str (matchPackageDir pinfo str fstatus <|> matchPackageFile pinfo str fstatus) matchPackageName :: [PackageInfo] -> String -> Match PackageInfo matchPackageName ps = \str -> do guard (validPackageName str) orNoSuchThing "package" str (map (display . packageName) ps) $ increaseConfidenceFor $ matchInexactly caseFold (display . packageName) ps str matchPackageDir :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo matchPackageDir ps = \str fstatus -> case fstatus of FileStatusExistsDir canondir -> orNoSuchThing "package directory" str (map (snd . fst) dirs) $ increaseConfidenceFor $ fmap snd $ matchExactly (fst . fst) dirs canondir _ -> mzero where dirs = [ ((dabs,drel),p) | p@PackageInfo{ pinfoDirectory = Just (dabs,drel) } <- ps ] matchPackageFile :: [PackageInfo] -> String -> FileStatus -> Match PackageInfo matchPackageFile ps = \str fstatus -> do case fstatus of FileStatusExistsFile canonfile -> orNoSuchThing "package .cabal file" str (map (snd . fst) files) $ increaseConfidenceFor $ fmap snd $ matchExactly (fst . fst) files canonfile _ -> mzero where files = [ ((fabs,frel),p) | p@PackageInfo{ pinfoPackageFile = Just (fabs,frel) } <- ps ] --TODO: test outcome when dir exists but doesn't match any known one --TODO: perhaps need another distinction, vs no such thing, point is the -- thing is not known, within the project, but could be outside project ------------------------------ -- Matching component targets -- 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 (map cinfoStrName cs) $ increaseConfidenceFor $ matchInexactly caseFold cinfoStrName cs str matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String -> Match ComponentInfo matchComponentKindAndName cs ckind str = orNoSuchThing (showComponentKind ckind ++ " component") str (map render cs) $ increaseConfidenceFor $ matchInexactly (\(ck, cn) -> (ck, caseFold cn)) (\c -> (cinfoKind c, cinfoStrName c)) cs (ckind, str) where render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c ------------------------------ -- Matching module targets -- guardModuleName :: String -> Match () guardModuleName s = case simpleParse s :: Maybe ModuleName of Just _ -> increaseConfidence _ | all validModuleChar s && not (null s) -> return () | otherwise -> matchErrorExpected "module name" s where validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\'' matchModuleName :: [ModuleName] -> String -> Match ModuleName matchModuleName ms str = orNoSuchThing "module" str (map display ms) $ increaseConfidenceFor $ matchInexactly caseFold display ms str matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a) matchModuleNameAnd ms str = orNoSuchThing "module" str (map (display . fst) ms) $ increaseConfidenceFor $ matchInexactly caseFold (display . fst) ms str ------------------------------ -- Matching file targets -- matchPackageDirectoryPrefix :: [PackageInfo] -> FileStatus -> Match (FilePath, PackageInfo) matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) = increaseConfidenceFor $ matchDirectoryPrefix pkgdirs filepath where pkgdirs = [ (dir, p) | p@PackageInfo { pinfoDirectory = Just (dir,_) } <- ps ] matchPackageDirectoryPrefix _ _ = mzero matchComponentFile :: [ComponentInfo] -> String -> Match (FilePath, ComponentInfo) matchComponentFile cs str = orNoSuchThing "file" str [] $ matchComponentModuleFile cs str <|> matchComponentOtherFile cs str matchComponentOtherFile :: [ComponentInfo] -> String -> Match (FilePath, ComponentInfo) matchComponentOtherFile cs = matchFile [ (file, c) | c <- cs , file <- cinfoHsFiles c ++ cinfoCFiles c ++ cinfoJsFiles c ] matchComponentModuleFile :: [ComponentInfo] -> String -> Match (FilePath, ComponentInfo) matchComponentModuleFile cs str = do matchFile [ (normalise (d toFilePath m), c) | c <- cs , d <- cinfoSrcDirs c , m <- cinfoModules c ] (dropExtension (normalise str)) -- utils matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) matchFile fs = increaseConfidenceFor . matchInexactly caseFold fst fs matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a) matchDirectoryPrefix dirs filepath = tryEach $ [ (file, x) | (dir,x) <- dirs , file <- maybeToList (stripDirectory dir) ] where stripDirectory :: FilePath -> Maybe FilePath stripDirectory dir = joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit filepathsplit = splitDirectories filepath ------------------------------ -- 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 ('matchPlus', 'matchPlusShadowing') 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 -- thing got | MatchErrorNoSuch String String [String] -- thing got alts | MatchErrorIn String String MatchError -- kind thing deriving (Show, Eq) 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 Alternative Match where empty = NoMatch 0 [] (<|>) = matchPlus instance Monad Match where return = pure NoMatch d ms >>= _ = NoMatch d ms ExactMatch d xs >>= f = addDepth d $ msum (map f xs) InexactMatch d xs >>= f = addDepth d . forceInexact $ msum (map f xs) instance MonadPlus Match where mzero = empty mplus = matchPlus () :: Match a -> Match a -> Match a () = matchPlusShadowing infixl 3 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 -- | 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 'matchPlus' 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 ------------------------------ -- Various match primitives -- matchErrorExpected :: String -> String -> Match a matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got] matchErrorNoSuch :: String -> String -> [String] -> Match a matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts] expecting :: String -> String -> Match a -> Match a expecting thing got (NoMatch 0 _) = matchErrorExpected thing got expecting _ _ m = m orNoSuchThing :: String -> String -> [String] -> Match a -> Match a orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts orNoSuchThing _ _ _ m = m orNoThingIn :: String -> String -> Match a -> Match a orNoThingIn kind name (NoMatch n ms) = NoMatch n [ MatchErrorIn kind name m | m <- ms ] orNoThingIn _ _ m = m increaseConfidence :: Match () increaseConfidence = ExactMatch 1 [()] increaseConfidenceFor :: Match a -> Match a increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs) nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs) -- | Lift a list of matches to an exact match. -- exactMatches, inexactMatches :: [a] -> Match a exactMatches [] = mzero exactMatches xs = ExactMatch 0 xs inexactMatches [] = mzero 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 :: Match a -> MaybeAmbiguous a findMatch match = case match of NoMatch _ msgs -> None msgs ExactMatch _ [x] -> Unambiguous x InexactMatch _ [x] -> Unambiguous x ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []" InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []" ExactMatch _ xs -> Ambiguous True xs InexactMatch _ xs -> Ambiguous False xs data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a] deriving Show ------------------------------ -- Basic matchers -- -- | A primitive matcher that looks up a value in a finite 'Map'. The -- value must match exactly. -- matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a) matchExactly key xs = \k -> case Map.lookup k m of Nothing -> mzero Just ys -> exactMatches ys where m = Map.fromListWith (++) [ (key x, [x]) | 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 k, Ord k') => (k -> k') -> (a -> k) -> [a] -> (k -> Match a) matchInexactly cannonicalise key xs = \k -> case Map.lookup k m of Just ys -> exactMatches ys Nothing -> case Map.lookup (cannonicalise k) m' of Just ys -> inexactMatches ys Nothing -> mzero where m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ] -- the map of canonicalised keys to groups of inexact matches m' = Map.mapKeysWith (++) cannonicalise m ------------------------------ -- Utils -- caseFold :: String -> String caseFold = lowercase ------------------------------ -- Example inputs -- {- ex1pinfo :: [PackageInfo] ex1pinfo = [ PackageInfo { pinfoName = PackageName "foo", pinfoDirectory = Just "/the/foo", pinfoPackageFile = Just "/the/foo/foo.cabal", pinfoComponents = [] } , PackageInfo { pinfoName = PackageName "bar", pinfoDirectory = Just "/the/bar", pinfoPackageFile = Just "/the/bar/bar.cabal", pinfoComponents = [] } ] -} {- 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" -} {- 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 n) ds (map mkMn ms) mkMn :: String -> ModuleName mkMn = fromJust . simpleParse pkgid :: PackageIdentifier Just pkgid = simpleParse "thelib" -}