{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.BuildTargets
-- Copyright   :  (c) Duncan Coutts 2012
-- License     :  BSD-like
--
-- Maintainer  :  [email protected]
--
-- Handling for user-specified build targets
-----------------------------------------------------------------------------
module Distribution.Simple.BuildTarget (
    -- * Main interface
    readTargetInfos,
    readBuildTargets, -- in case you don't have LocalBuildInfo

    -- * Build targets
    BuildTarget(..),
    showBuildTarget,
    QualLevel(..),
    buildTargetComponentName,

    -- * Parsing user build targets
    UserBuildTarget,
    readUserBuildTargets,
    showUserBuildTarget,
    UserBuildTargetProblem(..),
    reportUserBuildTargetProblems,

    -- * Resolving build targets
    resolveBuildTargets,
    BuildTargetProblem(..),
    reportBuildTargetProblems,
  ) where

import Prelude ()
import Distribution.Compat.Prelude

import Distribution.Types.TargetInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
import Distribution.Types.UnqualComponentName

import Distribution.Package
import Distribution.PackageDescription
import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
import Distribution.Text
import Distribution.Simple.Utils
import Distribution.Verbosity

import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ( (+++), (<++) )
import Distribution.ParseUtils ( readPToMaybe )

import Control.Monad ( msum )
import Data.List ( stripPrefix, groupBy, partition )
import Data.Either ( partitionEithers )
import System.FilePath as FilePath
         ( dropExtension, normalise, splitDirectories, joinPath, splitPath
         , hasTrailingPathSeparator )
import System.Directory ( doesFileExist, doesDirectoryExist )
import qualified Data.Map as Map

-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos verbosity pkg_descr lbi args = do
    build_targets <- readBuildTargets verbosity pkg_descr args
    checkBuildTargets verbosity pkg_descr lbi build_targets

-- ------------------------------------------------------------
-- * 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 (Eq, Show, Generic)

instance Binary BuildTarget

buildTargetComponentName :: BuildTarget -> ComponentName
buildTargetComponentName (BuildTargetComponent cn)   = cn
buildTargetComponentName (BuildTargetModule    cn _) = cn
buildTargetComponentName (BuildTargetFile      cn _) = cn

-- | Read a list of user-supplied build target strings and resolve them to
-- 'BuildTarget's according to a 'PackageDescription'. If there are problems
-- with any of the targets e.g. they don't exist or are misformatted, throw an
-- 'IOException'.
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets verbosity pkg targetStrs = do
    let (uproblems, utargets) = readUserBuildTargets targetStrs
    reportUserBuildTargetProblems verbosity uproblems

    utargets' <- traverse checkTargetExistsAsFile utargets

    let (bproblems, btargets) = resolveBuildTargets pkg utargets'
    reportBuildTargetProblems verbosity bproblems

    return btargets

checkTargetExistsAsFile :: UserBuildTarget -> NoCallStackIO (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

data UserBuildTargetProblem
   = UserBuildTargetUnrecognised String
  deriving Show

reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
    case [ target | UserBuildTargetUnrecognised target <- problems ] of
      []     -> return ()
      target ->
        die' verbosity $ 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 ":" . getComponents
  where
    getComponents (UserBuildTargetSingle s1)       = [s1]
    getComponents (UserBuildTargetDouble s1 s2)    = [s1,s2]
    getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]

-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' ql pkgid bt =
    showUserBuildTarget (renderBuildTarget ql bt pkgid)

-- | Unambiguously render a 'BuildTarget', so that it can
-- be parsed in all situations.
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget pkgid t =
    showBuildTarget' (qlBuildTarget t) pkgid t
  where
    qlBuildTarget BuildTargetComponent{} = QL2
    qlBuildTarget _                      = QL3


-- ------------------------------------------------------------
-- * 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 (BuildTargetAmbiguous 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)]
   | BuildTargetAmbiguous 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 :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems verbosity problems = do

    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
      []      -> return ()
      targets ->
        die' verbosity $ 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' verbosity $ 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) | BuildTargetAmbiguous t ts <- problems ] of
      []      -> return ()
      targets ->
        die' verbosity $ 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 _   (CSubLibName name) = unUnqualComponentName name
componentStringName _   (CFLibName  name) = unUnqualComponentName name
componentStringName _   (CExeName   name) = unUnqualComponentName name
componentStringName _   (CTestName  name) = unUnqualComponentName name
componentStringName _   (CBenchName name) = unUnqualComponentName name

componentModules :: Component -> [ModuleName]
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
-- a user could very well ask to build a specific signature
-- that was inherited from other packages.  To fix this
-- we have to plumb 'LocalBuildInfo' through this code.
-- Fortunately, this is only used by 'pkgComponentInfo' 
-- Please don't export this function unless you plan on fixing
-- this.
componentModules (CLib   lib)   = explicitLibModules lib
componentModules (CFLib  flib)  = foreignLibModules flib
componentModules (CExe   exe)   = exeModules exe
componentModules (CTest  test)  = testModules test
componentModules (CBench bench) = benchmarkModules bench

componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
componentHsFiles (CTest  TestSuite {
                           testInterface = TestSuiteExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles (CBench Benchmark {
                           benchmarkInterface = BenchmarkExeV10 _ mainfile
                         }) = [mainfile]
componentHsFiles _          = []

{-
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 | FLibKind | ExeKind | TestKind | BenchKind
  deriving (Eq, Ord, Show)

componentKind :: ComponentName -> ComponentKind
componentKind CLibName = LibKind
componentKind (CSubLibName _) = LibKind
componentKind (CFLibName  _) = FLibKind
componentKind (CExeName   _) = ExeKind
componentKind (CTestName  _) = TestKind
componentKind (CBenchName _) = BenchKind

cinfoKind :: ComponentInfo -> ComponentKind
cinfoKind = componentKind . cinfoName

matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
  | s `elem` ["lib", "library"]                 = return' LibKind
  | s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind
  | s `elem` ["exe", "executable"]              = return' ExeKind
  | s `elem` ["tst", "test", "test-suite"]      = return' TestKind
  | s `elem` ["bench", "benchmark"]             = return' BenchKind
  | otherwise = matchErrorExpected "component kind" s
  where
    return' ck = increaseConfidence >> return ck

showComponentKind :: ComponentKind -> String
showComponentKind LibKind   = "library"
showComponentKind FLibKind  = "foreign-library"
showComponentKind ExeKind   = "executable"
showComponentKind TestKind  = "test-suite"
showComponentKind BenchKind = "benchmark"

showComponentKindShort :: ComponentKind -> String
showComponentKindShort LibKind   = "lib"
showComponentKindShort FLibKind  = "flib"
showComponentKindShort ExeKind   = "exe"
showComponentKindShort TestKind  = "test"
showComponentKindShort BenchKind = "bench"

------------------------------
-- Matching 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 ambiguous matches.
--
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', '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
-- ambiguous matches.
--
matchPlus :: Match a -> Match a -> Match a
matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =
  ExactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a
matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a
matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b
matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =
  InexactMatch (max d1 d2) (xs ++ xs')
matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a
matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b
matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b
matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')
                                             | d1 >  d2  = a
                                             | d1 <  d2  = b
                                             | otherwise = NoMatch d1 (ms ++ ms')

-- | Combine two matchers. This is similar to 'ambiguousWith' 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 a = ExactMatch 0 [a]
  (<*>) = ap

instance Monad Match where
  return = pure

  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 -> MaybeAmbiguous b
findMatch match =
    case match of
      NoMatch    _ msgs -> None (nub msgs)
      ExactMatch   _ xs -> checkAmbiguous xs
      InexactMatch _ xs -> checkAmbiguous xs
  where
    checkAmbiguous xs = case nub xs of
                          [x] -> Unambiguous x
                          xs' -> Ambiguous   xs'

data MaybeAmbiguous 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


-- | Check that the given build targets are valid in the current context.
--
-- Also swizzle into a more convenient form.
--
checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
                  -> IO [TargetInfo]
checkBuildTargets _ pkg_descr lbi []      =
    return (allTargetsInBuildOrder' pkg_descr lbi)

checkBuildTargets verbosity pkg_descr lbi targets = do

    let (enabled, disabled) =
          partitionEithers
            [ case componentDisabledReason (componentEnabledSpec lbi) comp of
                Nothing     -> Left  target'
                Just reason -> Right (cname, reason)
            | target <- targets
            , let target'@(cname,_) = swizzleTarget target
            , let comp = getComponent pkg_descr cname ]

    case disabled of
      []                 -> return ()
      ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason

    for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->
      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "
                    ++ showComponentName c ++ " will be processed. (Support for "
                    ++ "module and file targets has not been implemented yet.)"

    -- Pick out the actual CLBIs for each of these cnames
    enabled' <- for enabled $ \(cname, _) -> do
        case componentNameTargets' pkg_descr lbi cname of
            [] -> error "checkBuildTargets: nothing enabled"
            [target] -> return target
            _targets -> error "checkBuildTargets: multiple copies enabled"

    return enabled'

  where
    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)
    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))
    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))

    formatReason cn DisabledComponent =
        "Cannot process the " ++ cn ++ " because the component is marked "
     ++ "as disabled in the .cabal file."
    formatReason cn DisabledAllTests =
        "Cannot process the " ++ cn ++ " because test suites are not "
     ++ "enabled. Run configure with the flag --enable-tests"
    formatReason cn DisabledAllBenchmarks =
        "Cannot process the " ++ cn ++ " because benchmarks are not "
     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
    formatReason cn (DisabledAllButOne cn') =
        "Cannot process the " ++ cn ++ " because this package was "
     ++ "configured only to build " ++ cn' ++ ". Re-run configure "
     ++ "with the argument " ++ cn