Distribution/Simple/BuildTarget.hs

    -----------------------------------------------------------------------------
    -- |
    -- 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
    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 )

    -- ------------------------------------------------------------
    -- * 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]
         }

    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 _          = []

    {-
    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 ]))
      where
        dirs = cinfoSrcDirs c
        ms   = cinfoModules c
        hsFiles = cinfoHsFiles c
        cFiles  = cinfoCFiles 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