module Distribution.Simple.BuildTarget (
BuildTarget(..),
readBuildTargets,
UserBuildTarget,
readUserBuildTargets,
UserBuildTargetProblem(..),
reportUserBuildTargetProblems,
resolveBuildTargets,
BuildTargetProblem(..),
reportBuildTargetProblems,
) where
import Distribution.Package
( Package(..), PackageId, packageName )
import Distribution.PackageDescription
( PackageDescription
, Executable(..)
, TestSuite(..), TestSuiteInterface(..), testModules
, Benchmark(..), BenchmarkInterface(..), benchmarkModules
, BuildInfo(..), libModules, exeModules )
import Distribution.ModuleName
( ModuleName, toFilePath )
import Distribution.Simple.LocalBuildInfo
( Component(..), ComponentName(..)
, pkgComponents, componentName, componentBuildInfo )
import Distribution.Text
( display )
import Distribution.Simple.Utils
( die, lowercase, equating )
import Data.List
( nub, stripPrefix, sortBy, groupBy, partition, intercalate )
import Data.Ord
import Data.Maybe
( listToMaybe, catMaybes )
import Data.Either
( partitionEithers )
import qualified Data.Map as Map
import Control.Monad
import Control.Applicative (Applicative(..), Alternative(..))
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
import Data.Char
( isSpace, isAlphaNum )
import System.FilePath as FilePath
( dropExtension, normalise, splitDirectories, joinPath, splitPath
, hasTrailingPathSeparator )
import System.Directory
( doesFileExist, doesDirectoryExist )
data UserBuildTarget =
UserBuildTargetSingle String
| UserBuildTargetDouble String String
| UserBuildTargetTriple String String String
deriving (Show, Eq, Ord)
data BuildTarget =
BuildTargetComponent ComponentName
| BuildTargetModule ComponentName ModuleName
| BuildTargetFile ComponentName FilePath
deriving (Show,Eq)
readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets pkg targetStrs = do
let (uproblems, utargets) = readUserBuildTargets targetStrs
reportUserBuildTargetProblems uproblems
utargets' <- mapM checkTargetExistsAsFile utargets
let (bproblems, btargets) = resolveBuildTargets pkg utargets'
reportBuildTargetProblems bproblems
return btargets
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile t = do
fexists <- existsAsFile (fileComponentOfTarget t)
return (t, fexists)
where
existsAsFile f = do
exists <- doesFileExist f
case splitPath f of
(d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d
(d:_:_) | not exists -> doesDirectoryExist d
_ -> return exists
fileComponentOfTarget (UserBuildTargetSingle s1) = s1
fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3
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
readPToMaybe :: Parse.ReadP a a -> String -> Maybe a
readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str
, all isSpace s ]
data UserBuildTargetProblem
= UserBuildTargetUnrecognised String
deriving Show
reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems problems = do
case [ target | UserBuildTargetUnrecognised target <- problems ] of
[] -> return ()
target ->
die $ 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 ":" . components
where
components (UserBuildTargetSingle s1) = [s1]
components (UserBuildTargetDouble s1 s2) = [s1,s2]
components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]
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 (BuildTargetAmbigious 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
| BuildTargetNoSuch UserBuildTarget [(String, String)]
| BuildTargetAmbigious 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 :: [BuildTargetProblem] -> IO ()
reportBuildTargetProblems problems = do
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
++ "'.\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) | BuildTargetAmbigious 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 (BuildTargetComponent _ ) = "component"
showBuildTargetKind (BuildTargetModule _ _) = "module"
showBuildTargetKind (BuildTargetFile _ _) = "file"
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],
cinfoCFiles :: [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,
cinfoCFiles = cSources bi
}
| c <- pkgComponents pkg
, let bi = componentBuildInfo c ]
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg CLibName = display (packageName pkg)
componentStringName _ (CExeName name) = name
componentStringName _ (CTestName name) = name
componentStringName _ (CBenchName name) = name
componentModules :: Component -> [ModuleName]
componentModules (CLib lib) = libModules lib
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 _ = []
data ComponentKind = LibKind | ExeKind | TestKind | BenchKind
deriving (Eq, Ord, Show)
componentKind :: ComponentName -> ComponentKind
componentKind CLibName = LibKind
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 ExeKind = "executable"
showComponentKind TestKind = "test-suite"
showComponentKind BenchKind = "benchmark"
showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind = "lib"
showComponentKindShort ExeKind = "exe"
showComponentKindShort TestKind = "test"
showComponentKindShort BenchKind = "bench"
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))
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)
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)
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
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 ]))
where
dirs = cinfoSrcDirs c
ms = cinfoModules c
hsFiles = cinfoHsFiles c
cFiles = cinfoCFiles c
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)
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 []
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')
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 = return
(<*>) = ap
instance Monad Match where
return a = ExactMatch 0 [a]
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
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
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
findMatch :: Eq b => Match b -> MaybeAmbigious b
findMatch match =
case match of
NoMatch _ msgs -> None (nub msgs)
ExactMatch _ xs -> checkAmbigious xs
InexactMatch _ xs -> checkAmbigious xs
where
checkAmbigious xs = case nub xs of
[x] -> Unambiguous x
xs' -> Ambiguous xs'
data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]
deriving Show
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 ]
m' = Map.mapKeysWith (++) cannonicalise m
caseFold :: String -> String
caseFold = lowercase