{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- 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
  ( -- * 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 Data.Bifunctor (second)
import Distribution.Compat.Prelude
import Prelude ()

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

import qualified Distribution.Compat.CharParsing as P
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Simple.Errors
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity

import Control.Arrow ((&&&))
import Control.Monad (msum)
import Data.List (groupBy, stripPrefix)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath as FilePath
  ( dropExtension
  , hasTrailingPathSeparator
  , joinPath
  , normalise
  , splitDirectories
  , splitPath
  )

-- | 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 -> 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 "comp"
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:comp"
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp"
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "\"comp\""
-- Right (UserBuildTargetSingle "comp")
--
-- >>> readUserBuildTarget "lib:\"comp\""
-- Right (UserBuildTargetDouble "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:\"comp\""
-- Right (UserBuildTargetTriple "pkg" "lib" "comp")
--
-- >>> readUserBuildTarget "pkg:lib:comp:more"
-- Left (UserBuildTargetUnrecognised "pkg:lib:comp:more")
--
-- >>> readUserBuildTarget "pkg:\"lib\":comp"
-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")
readUserBuildTarget
  :: String
  -> Either
      UserBuildTargetProblem
      UserBuildTarget
readUserBuildTarget targetstr =
  case explicitEitherParsec parseTargetApprox targetstr of
    Left _ -> Left (UserBuildTargetUnrecognised targetstr)
    Right tgt -> Right tgt
  where
    parseTargetApprox :: CabalParsing m => m UserBuildTarget
    parseTargetApprox = do
      -- read one, two, or three tokens, where last could be "hs-string"
      ts <- tokens
      return $ case ts of
        (a, Nothing) -> UserBuildTargetSingle a
        (a, Just (b, Nothing)) -> UserBuildTargetDouble a b
        (a, Just (b, Just c)) -> UserBuildTargetTriple a b c

    tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
    tokens =
      (,Nothing) <$> parsecHaskellString
        <|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)

    tokens2 :: CabalParsing m => m (String, Maybe String)
    tokens2 =
      (,Nothing) <$> parsecHaskellString
        <|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))

    token :: CabalParsing m => m String
    token = P.munch1 (\x -> not (isSpace x) && x /= ':')

data UserBuildTargetProblem
  = UserBuildTargetUnrecognised String
  deriving (Show)

reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
  case [target | UserBuildTargetUnrecognised target <- problems] of
    [] -> return ()
    target ->
      dieWithException verbosity $
        UnrecognisedBuildTarget target

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
      | Just expected' <- NE.nonEmpty expected =
          let unzip' = fmap fst &&& fmap snd
              (things, got :| _) = unzip' expected'
           in BuildTargetExpected userTarget (NE.toList 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
  = -- |  [expected thing] (actually got)
    BuildTargetExpected UserBuildTarget [String] String
  | -- | [(no such thing,  actually got)]
    BuildTargetNoSuch UserBuildTarget [(String, String)]
  | 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) = prettyShow m
    single (BuildTargetFile _ f) = f

    double (BuildTargetComponent cn) = (dispKind cn, dispCName cn)
    double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)
    double (BuildTargetFile cn f) = (dispCName cn, f)

    triple (BuildTargetComponent _) = error "triple BuildTargetComponent"
    triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow 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 ->
      dieWithException verbosity $
        ReportBuildTargetProblems $
          map (\(target, expected, got) -> (showUserBuildTarget target, expected, got)) targets

  case [(t, e) | BuildTargetNoSuch t e <- problems] of
    [] -> return ()
    targets ->
      dieWithException verbosity $
        UnknownBuildTarget $
          map (first showUserBuildTarget) targets

  case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of
    [] -> return ()
    targets ->
      dieWithException verbosity $
        AmbiguousBuildTarget $
          map
            ( \(target, amb) ->
                ( showUserBuildTarget target
                , (map (\(ut, bt) -> (showUserBuildTarget ut, showBuildTargetKind bt)) 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)
  , cinfoAsmFiles :: [FilePath]
  , cinfoCmmFiles :: [FilePath]
  , cinfoCFiles :: [FilePath]
  , cinfoCxxFiles :: [FilePath]
  , cinfoJsFiles :: [FilePath]
  }

type ComponentStringName = String

pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
  [ ComponentInfo
    { cinfoName = componentName c
    , cinfoStrName = componentStringName pkg (componentName c)
    , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi
    , cinfoModules = componentModules c
    , cinfoHsFiles = map getSymbolicPath $ componentHsFiles c
    , cinfoAsmFiles = map getSymbolicPath $ asmSources bi
    , cinfoCmmFiles = map getSymbolicPath $ cmmSources bi
    , cinfoCFiles = map getSymbolicPath $ cSources bi
    , cinfoCxxFiles = map getSymbolicPath $ cxxSources bi
    , cinfoJsFiles = map getSymbolicPath $ jsSources bi
    }
  | c <- pkgComponents pkg
  , let bi = componentBuildInfo c
  ]

componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg)
componentStringName _ (CLibName (LSubLibName 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 -> [RelativePath Source File]
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, Enum, Bounded)

componentKind :: ComponentName -> ComponentKind
componentKind (CLibName _) = 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
        (second caseFold)
        [((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
        [ (prettyShow 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@(LocalBuildInfo{componentEnabledSpec = enabledComps})
  targets = do
    let (enabled, disabled) =
          partitionEithers
            [ case componentDisabledReason enabledComps 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) : _) -> dieWithException verbosity $ CheckBuildTargets $ formatReason (showComponentName cname) reason

    for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->
      warn verbosity $
        "Ignoring '"
          ++ either prettyShow 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
