content: -----------------------------------------------------------------------------
  -- |
  -- 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],
         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
  