940 lines
32 KiB
Haskell
940 lines
32 KiB
Haskell
|
{-# LANGUAGE CPP #-}
|
||
|
|
-----------------------------------------------------------------------------
|
||
|
|
-- |
|
||
|
|
-- 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 (
|
||
|
|
|
||
|
|
-- * Build targets
|
||
|
|
BuildTarget(..),
|
||
|
|
readBuildTargets,
|
||
|
|
|
||
|
|
-- * Parsing user build targets
|
||
|
|
UserBuildTarget,
|
||
|
|
readUserBuildTargets,
|
||
|
|
UserBuildTargetProblem(..),
|
||
|
|
reportUserBuildTargetProblems,
|
||
|
|
|
||
|
|
-- * Resolving build targets
|
||
|
|
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
|
||
|
|
#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
|
||
|
|
( dropExtension, normalise, splitDirectories, joinPath, splitPath
|
||
|
|
, hasTrailingPathSeparator )
|
||
|
|
import System.Directory
|
||
|
|
( doesFileExist, doesDirectoryExist )
|
||
|
|
|
||
|
|
-- ------------------------------------------------------------
|
||
|
|
-- * 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 (Show,Eq)
|
||
|
|
|
||
|
|
|
||
|
|
-- ------------------------------------------------------------
|
||
|
|
-- * Do everything
|
||
|
|
-- ------------------------------------------------------------
|
||
|
|
|
||
|
|
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
|
||
|
|
|
||
|
|
|
||
|
|
-- ------------------------------------------------------------
|
||
|
|
-- * 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
|
||
|
|
|
||
|
|
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]
|
||
|
|
|
||
|
|
|
||
|
|
-- ------------------------------------------------------------
|
||
|
|
-- * 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 (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
|
||
|
|
-- ^ [expected thing] (actually got)
|
||
|
|
| BuildTargetNoSuch UserBuildTarget [(String, String)]
|
||
|
|
-- ^ [(no such thing, actually got)]
|
||
|
|
| 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"
|
||
|
|
|
||
|
|
|
||
|
|
----------------------------------
|
||
|
|
-- 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)
|
||
|
|
cinfoCFiles :: [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,
|
||
|
|
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 _ (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 _ = []
|
||
|
|
|
||
|
|
{-
|
||
|
|
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 | 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"
|
||
|
|
|
||
|
|
------------------------------
|
||
|
|
-- 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 ambigious matches.
|
||
|
|
--
|
||
|
|
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
|
||
|
|
-- ways to combine matchers ('ambigiousWith', '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
|
||
|
|
-- ambigious 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 'ambigiousWith' 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 = 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
|
||
|
|
|
||
|
|
------------------------------
|
||
|
|
-- 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 -> 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
|
||
|
|
|
||
|
|
|
||
|
|
------------------------------
|
||
|
|
-- 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
|