{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- TODO
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

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

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

-- |
-- Module      :  Distribution.Client.TargetSelector
-- Copyright   :  (c) Duncan Coutts 2012, 2015, 2016
-- License     :  BSD-like
--
-- Maintainer  :  duncan@community.haskell.org
--
-- Handling for user-specified target selectors.
module Distribution.Client.TargetSelector
  ( -- * Target selectors
    TargetSelector (..)
  , TargetImplicitCwd (..)
  , ComponentKind (..)
  , ComponentKindFilter
  , SubComponentTarget (..)
  , QualLevel (..)
  , componentKind

    -- * Reading target selectors
  , readTargetSelectors
  , TargetSelectorProblem (..)
  , reportTargetSelectorProblems
  , showTargetSelector
  , TargetString (..)
  , showTargetString
  , parseTargetString

    -- ** non-IO
  , readTargetSelectorsWith
  , DirActions (..)
  , defaultDirActions
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Client.Types
  ( PackageLocation (..)
  , PackageSpecifier (..)
  )
import Distribution.Package
  ( Package (..)
  , PackageId
  , PackageName
  , packageName
  )
import Distribution.Types.UnqualComponentName
  ( UnqualComponentName
  , mkUnqualComponentName
  , packageNameToUnqualComponentName
  , unUnqualComponentName
  )

import Distribution.ModuleName
  ( ModuleName
  , toFilePath
  )
import Distribution.PackageDescription
  ( Benchmark (..)
  , BenchmarkInterface (..)
  , BuildInfo (..)
  , Executable (..)
  , PackageDescription
  , TestSuite (..)
  , TestSuiteInterface (..)
  , benchmarkModules
  , exeModules
  , explicitLibModules
  , testModules
  )
import Distribution.PackageDescription.Configuration
  ( flattenPackageDescription
  )
import Distribution.Simple.LocalBuildInfo
  ( Component (..)
  , ComponentName (..)
  , LibraryName (..)
  , componentBuildInfo
  , componentName
  , pkgComponents
  )
import Distribution.Solver.Types.SourcePackage
  ( SourcePackage (..)
  )
import Distribution.Types.ForeignLib

import Control.Arrow ((&&&))
import Control.Monad hiding
  ( mfilter
  )
import Data.Bifunctor (second)
#if MIN_VERSION_base(4,20,0)
import Data.Functor as UZ (unzip)
#else
import qualified Data.List.NonEmpty as UZ (unzip)
#endif
import Data.List
  ( stripPrefix
  )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Lazy as Map.Lazy
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Distribution.Client.Errors
import Distribution.Client.Utils
  ( makeRelativeCanonical
  )
import Distribution.Deprecated.ParseUtils
  ( readPToMaybe
  )
import Distribution.Deprecated.ReadP
  ( (+++)
  , (<++)
  )
import qualified Distribution.Deprecated.ReadP as Parse
import Distribution.Simple.Utils
  ( dieWithException
  , lowercase
  , ordNub
  )
import Distribution.Utils.Path
  ( getSymbolicPath
  )
import qualified System.Directory as IO
  ( canonicalizePath
  , doesDirectoryExist
  , doesFileExist
  , getCurrentDirectory
  )
import System.FilePath
  ( dropExtension
  , dropTrailingPathSeparator
  , equalFilePath
  , joinPath
  , normalise
  , splitDirectories
  )
import qualified System.FilePath as FilePath
  ( splitPath
  , takeExtension
  , (<.>)
  , (</>)
  )
import Text.EditDistance
  ( defaultEditCosts
  , restrictedDamerauLevenshteinDistance
  )
import qualified Prelude (foldr1)

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

-- * Target selector terms

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

-- | A target selector is expression selecting a set of components (as targets
-- for a actions like @build@, @run@, @test@ etc). A target selector
-- corresponds to the user syntax for referring to targets on the command line.
--
-- From the users point of view a target can be many things: packages, dirs,
-- component names, files etc. Internally we consider a target to be a specific
-- component (or module\/file within a component), and all the users' notions
-- of targets are just different ways of referring to these component targets.
--
-- So target selectors are expressions in the sense that they are interpreted
-- to refer to one or more components. For example a 'TargetPackage' gets
-- interpreted differently by different commands to refer to all or a subset
-- of components within the package.
--
-- The syntax has lots of optional parts:
--
-- > [ package name | package dir | package .cabal file ]
-- > [ [lib:|exe:] component name ]
-- > [ module name | source file ]
data TargetSelector
  = -- | One (or more) packages as a whole, or all the components of a
    -- particular kind within the package(s).
    --
    -- These are always packages that are local to the project. In the case
    -- that there is more than one, they all share the same directory location.
    TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter)
  | -- | A package specified by name. This may refer to @extra-packages@ from
    -- the @cabal.project@ file, or a dependency of a known project package or
    -- could refer to a package from a hackage archive. It needs further
    -- context to resolve to a specific package.
    TargetPackageNamed PackageName (Maybe ComponentKindFilter)
  | -- | All packages, or all components of a particular kind in all packages.
    TargetAllPackages (Maybe ComponentKindFilter)
  | -- | A specific component in a package within the project.
    TargetComponent PackageId ComponentName SubComponentTarget
  | -- | A component in a package, but where it cannot be verified that the
    -- package has such a component, or because the package is itself not
    -- known.
    TargetComponentUnknown
      PackageName
      (Either UnqualComponentName ComponentName)
      SubComponentTarget
  deriving (Eq, Ord, Show, Generic)

-- | Does this 'TargetPackage' selector arise from syntax referring to a
-- package in the current directory (e.g. @tests@ or no giving no explicit
-- target at all) or does it come from syntax referring to a package name
-- or location.
data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed
  deriving (Eq, Ord, Show, Generic)

data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
  deriving (Eq, Ord, Enum, Show)

type ComponentKindFilter = ComponentKind

-- | Either the component as a whole or detail about a file or module target
-- within a component.
data SubComponentTarget
  = -- | The component as a whole
    WholeComponent
  | -- | A specific module within a component.
    ModuleTarget ModuleName
  | -- | A specific file within a component. Note that this does not carry the
    -- file extension.
    FileTarget FilePath
  deriving (Eq, Ord, Show, Generic)

instance Binary SubComponentTarget
instance Structured SubComponentTarget

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

-- * Top level, do everything

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

-- | Parse a bunch of command line args as 'TargetSelector's, failing with an
-- error if any are unrecognised. The possible target selectors are based on
-- the available packages (and their locations).
readTargetSelectors
  :: [PackageSpecifier (SourcePackage (PackageLocation a))]
  -> Maybe ComponentKindFilter
  -- ^ This parameter is used when there are ambiguous selectors.
  --   If it is 'Just', then we attempt to resolve ambiguity
  --   by applying it, since otherwise there is no way to allow
  --   contextually valid yet syntactically ambiguous selectors.
  --   (#4676, #5461)
  -> [String]
  -> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors = readTargetSelectorsWith defaultDirActions

readTargetSelectorsWith
  :: (Applicative m, Monad m)
  => DirActions m
  -> [PackageSpecifier (SourcePackage (PackageLocation a))]
  -> Maybe ComponentKindFilter
  -> [String]
  -> m (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =
  case parseTargetStrings targetStrs of
    ([], usertargets) -> do
      usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets
      knowntargets <- getKnownTargets dirActions pkgs
      case resolveTargetSelectors knowntargets usertargets' mfilter of
        ([], btargets) -> return (Right btargets)
        (problems, _) -> return (Left problems)
    (strs, _) -> return (Left (map TargetSelectorUnrecognised strs))

data DirActions m = DirActions
  { doesFileExist :: FilePath -> m Bool
  , doesDirectoryExist :: FilePath -> m Bool
  , canonicalizePath :: FilePath -> m FilePath
  , getCurrentDirectory :: m FilePath
  }

defaultDirActions :: DirActions IO
defaultDirActions =
  DirActions
    { doesFileExist = IO.doesFileExist
    , doesDirectoryExist = IO.doesDirectoryExist
    , -- Workaround for <https://github.com/haskell/directory/issues/63>
      canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator
    , getCurrentDirectory = IO.getCurrentDirectory
    }

makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath
makeRelativeToCwd DirActions{..} path =
  makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory

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

-- * Parsing target strings

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

-- | The outline parse of a target selector. It takes one of the forms:
--
-- > str1
-- > str1:str2
-- > str1:str2:str3
-- > str1:str2:str3:str4
data TargetString
  = TargetString1 String
  | TargetString2 String String
  | TargetString3 String String String
  | TargetString4 String String String String
  | TargetString5 String String String String String
  | TargetString7 String String String String String String String
  deriving (Show, Eq)

-- | Parse a bunch of 'TargetString's (purely without throwing exceptions).
parseTargetStrings :: [String] -> ([String], [TargetString])
parseTargetStrings =
  partitionEithers
    . map (\str -> maybe (Left str) Right (parseTargetString str))

parseTargetString :: String -> Maybe TargetString
parseTargetString =
  readPToMaybe parseTargetApprox
  where
    parseTargetApprox :: Parse.ReadP r TargetString
    parseTargetApprox =
      ( do
          a <- tokenQEnd
          return (TargetString1 a)
      )
        +++ ( do
                a <- tokenQ0
                _ <- Parse.char ':'
                b <- tokenQEnd
                return (TargetString2 a b)
            )
        +++ ( do
                a <- tokenQ0
                _ <- Parse.char ':'
                b <- tokenQ
                _ <- Parse.char ':'
                c <- tokenQEnd
                return (TargetString3 a b c)
            )
        +++ ( do
                a <- tokenQ0
                _ <- Parse.char ':'
                b <- token
                _ <- Parse.char ':'
                c <- tokenQ
                _ <- Parse.char ':'
                d <- tokenQEnd
                return (TargetString4 a b c d)
            )
        +++ ( do
                a <- tokenQ0
                _ <- Parse.char ':'
                b <- token
                _ <- Parse.char ':'
                c <- tokenQ
                _ <- Parse.char ':'
                d <- tokenQ
                _ <- Parse.char ':'
                e <- tokenQEnd
                return (TargetString5 a b c d e)
            )
        +++ ( do
                a <- tokenQ0
                _ <- Parse.char ':'
                b <- token
                _ <- Parse.char ':'
                c <- tokenQ
                _ <- Parse.char ':'
                d <- tokenQ
                _ <- Parse.char ':'
                e <- tokenQ
                _ <- Parse.char ':'
                f <- tokenQ
                _ <- Parse.char ':'
                g <- tokenQEnd
                return (TargetString7 a b c d e f g)
            )

    token = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
    tokenQ = parseHaskellString <++ token
    token0 = Parse.munch (\x -> not (isSpace x) && x /= ':')
    tokenQ0 = parseHaskellString <++ token0
    tokenEnd = Parse.munch1 (/= ':')
    tokenQEnd = parseHaskellString <++ tokenEnd
    parseHaskellString :: Parse.ReadP r String
    parseHaskellString = Parse.readS_to_P reads

-- | Render a 'TargetString' back as the external syntax. This is mainly for
-- error messages.
showTargetString :: TargetString -> String
showTargetString = intercalate ":" . components
  where
    components (TargetString1 s1) = [s1]
    components (TargetString2 s1 s2) = [s1, s2]
    components (TargetString3 s1 s2 s3) = [s1, s2, s3]
    components (TargetString4 s1 s2 s3 s4) = [s1, s2, s3, s4]
    components (TargetString5 s1 s2 s3 s4 s5) = [s1, s2, s3, s4, s5]
    components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1, s2, s3, s4, s5, s6, s7]

showTargetSelector :: TargetSelector -> String
showTargetSelector ts =
  case [ t | ql <- [QL1 .. QLFull], t <- renderTargetSelector ql ts
       ] of
    (t' : _) -> showTargetString (forgetFileStatus t')
    [] -> ""

showTargetSelectorKind :: TargetSelector -> String
showTargetSelectorKind bt = case bt of
  TargetPackage TargetExplicitNamed _ Nothing -> "package"
  TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"
  TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package"
  TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter"
  TargetPackageNamed _ Nothing -> "named-package"
  TargetPackageNamed _ (Just _) -> "named-package:filter"
  TargetAllPackages Nothing -> "package *"
  TargetAllPackages (Just _) -> "package *:filter"
  TargetComponent _ _ WholeComponent -> "component"
  TargetComponent _ _ ModuleTarget{} -> "module"
  TargetComponent _ _ FileTarget{} -> "file"
  TargetComponentUnknown _ _ WholeComponent -> "unknown-component"
  TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module"
  TargetComponentUnknown _ _ FileTarget{} -> "unknown-file"

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

-- * Checking if targets exist as files

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

data TargetStringFileStatus
  = TargetStringFileStatus1 String FileStatus
  | TargetStringFileStatus2 String FileStatus String
  | TargetStringFileStatus3 String FileStatus String String
  | TargetStringFileStatus4 String String String String
  | TargetStringFileStatus5 String String String String String
  | TargetStringFileStatus7 String String String String String String String
  deriving (Eq, Ord, Show)

data FileStatus
  = FileStatusExistsFile FilePath -- the canonicalised filepath
  | FileStatusExistsDir FilePath -- the canonicalised filepath
  | FileStatusNotExists Bool -- does the parent dir exist even?
  deriving (Eq, Ord, Show)

noFileStatus :: FileStatus
noFileStatus = FileStatusNotExists False

getTargetStringFileStatus
  :: (Applicative m, Monad m)
  => DirActions m
  -> TargetString
  -> m TargetStringFileStatus
getTargetStringFileStatus DirActions{..} t =
  case t of
    TargetString1 s1 ->
      (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1
    TargetString2 s1 s2 ->
      (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1
    TargetString3 s1 s2 s3 ->
      (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1
    TargetString4 s1 s2 s3 s4 ->
      return (TargetStringFileStatus4 s1 s2 s3 s4)
    TargetString5 s1 s2 s3 s4 s5 ->
      return (TargetStringFileStatus5 s1 s2 s3 s4 s5)
    TargetString7 s1 s2 s3 s4 s5 s6 s7 ->
      return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7)
  where
    fileStatus f = do
      fexists <- doesFileExist f
      dexists <- doesDirectoryExist f
      case FilePath.splitPath f of
        _
          | fexists -> FileStatusExistsFile <$> canonicalizePath f
          | dexists -> FileStatusExistsDir <$> canonicalizePath f
        (d : _) -> FileStatusNotExists <$> doesDirectoryExist d
        _ -> pure (FileStatusNotExists False)

forgetFileStatus :: TargetStringFileStatus -> TargetString
forgetFileStatus t = case t of
  TargetStringFileStatus1 s1 _ -> TargetString1 s1
  TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2
  TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3
  TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4
  TargetStringFileStatus5
    s1
    s2
    s3
    s4
    s5 -> TargetString5 s1 s2 s3 s4 s5
  TargetStringFileStatus7
    s1
    s2
    s3
    s4
    s5
    s6
    s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7

getFileStatus :: TargetStringFileStatus -> Maybe FileStatus
getFileStatus (TargetStringFileStatus1 _ f) = Just f
getFileStatus (TargetStringFileStatus2 _ f _) = Just f
getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f
getFileStatus _ = Nothing

setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus
setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f
setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2
setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3
setFileStatus _ t = t

copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus
copyFileStatus src dst =
  case getFileStatus src of
    Just f -> setFileStatus f dst
    Nothing -> dst

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

-- * Resolving target strings to target selectors

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

-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
resolveTargetSelectors
  :: KnownTargets
  -> [TargetStringFileStatus]
  -> Maybe ComponentKindFilter
  -> ( [TargetSelectorProblem]
     , [TargetSelector]
     )
-- default local dir target if there's no given target:
resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =
  ([TargetSelectorNoTargetsInProject], [])
-- if the component kind filter is just exes, we don't want to suggest "all" as a target.
resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf =
  ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind)], [])
resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =
  ([], [TargetPackage TargetImplicitCwd pkgids Nothing])
  where
    pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary]
resolveTargetSelectors knowntargets targetStrs mfilter =
  partitionEithers
    . map (resolveTargetSelector knowntargets mfilter)
    $ targetStrs

resolveTargetSelector
  :: KnownTargets
  -> Maybe ComponentKindFilter
  -> TargetStringFileStatus
  -> Either TargetSelectorProblem TargetSelector
resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
  case findMatch (matcher targetStrStatus) of
    Unambiguous _
      | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
    Unambiguous (TargetPackage TargetImplicitCwd [] _) ->
      Left (TargetSelectorNoCurrentPackage targetStr)
    Unambiguous target -> Right target
    None errs
      | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
      | otherwise -> Left (classifyMatchErrors errs)
    Ambiguous _ targets
      | Just kfilter <- mfilter
      , [target] <- applyKindFilter kfilter targets ->
          Right target
    Ambiguous exactMatch targets ->
      case disambiguateTargetSelectors
        matcher
        targetStrStatus
        exactMatch
        targets of
        Right targets' -> Left (TargetSelectorAmbiguous targetStr targets')
        Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms)
        Left [] -> internalError "resolveTargetSelector"
  where
    matcher = matchTargetSelector knowntargets

    targetStr = forgetFileStatus targetStrStatus

    projectIsEmpty = null knownPackagesAll

    classifyMatchErrors errs
      | Just expectedNE <- NE.nonEmpty expected =
          let (things, got :| _) = UZ.unzip expectedNE
           in TargetSelectorExpected targetStr (NE.toList things) got
      | not (null nosuch) =
          TargetSelectorNoSuch targetStr nosuch
      | otherwise =
          internalError $ "classifyMatchErrors: " ++ show errs
      where
        expected =
          [ (thing, got)
          | (_, MatchErrorExpected thing got) <-
              map (innerErr Nothing) errs
          ]
        -- Trim the list of alternatives by dropping duplicates and
        -- retaining only at most three most similar (by edit distance) ones.
        nosuch =
          Map.foldrWithKey genResults [] $
            Map.fromListWith Set.union $
              [ ((inside, thing, got), Set.fromList alts)
              | (inside, MatchErrorNoSuch thing got alts) <-
                  map (innerErr Nothing) errs
              ]

        genResults (inside, thing, got) alts acc =
          ( inside
          , thing
          , got
          , take maxResults $
              map fst $
                takeWhile distanceLow $
                  sortBy (comparing snd) $
                    map addLevDist $
                      Set.toList alts
          )
            : acc
          where
            addLevDist =
              id
                &&& restrictedDamerauLevenshteinDistance
                  defaultEditCosts
                  got

            distanceLow (_, dist) = dist < length got `div` 2

            maxResults = 3

        innerErr _ (MatchErrorIn kind thing m) =
          innerErr (Just (kind, thing)) m
        innerErr c m = (c, m)

    applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]
    applyKindFilter kfilter = filter go
      where
        go (TargetPackage _ _ (Just filter')) = kfilter == filter'
        go (TargetPackageNamed _ (Just filter')) = kfilter == filter'
        go (TargetAllPackages (Just filter')) = kfilter == filter'
        go (TargetComponent _ cname _)
          | CLibName _ <- cname = kfilter == LibKind
          | CFLibName _ <- cname = kfilter == FLibKind
          | CExeName _ <- cname = kfilter == ExeKind
          | CTestName _ <- cname = kfilter == TestKind
          | CBenchName _ <- cname = kfilter == BenchKind
        go _ = True

-- | The various ways that trying to resolve a 'TargetString' to a
-- 'TargetSelector' can fail.
data TargetSelectorProblem
  = -- |  [expected thing] (actually got)
    TargetSelectorExpected TargetString [String] String
  | -- | [([in thing], no such thing,  actually got, alternatives)]
    TargetSelectorNoSuch
      TargetString
      [(Maybe (String, String), String, String, [String])]
  | TargetSelectorAmbiguous
      TargetString
      [(TargetString, TargetSelector)]
  | MatchingInternalError
      TargetString
      TargetSelector
      [(TargetString, [TargetSelector])]
  | -- | Syntax error when trying to parse a target string.
    TargetSelectorUnrecognised String
  | TargetSelectorNoCurrentPackage TargetString
  | -- | bool that flags when it is acceptable to suggest "all" as a target
    TargetSelectorNoTargetsInCwd Bool
  | TargetSelectorNoTargetsInProject
  | TargetSelectorNoScript TargetString
  deriving (Show, Eq)

-- | Qualification levels.
-- Given the filepath src/F, executable component A, and package foo:
data QualLevel
  = -- | @src/F@
    QL1
  | -- | @foo:src/F | A:src/F@
    QL2
  | -- | @foo:A:src/F | exe:A:src/F@
    QL3
  | -- | @pkg:foo:exe:A:file:src/F@
    QLFull
  deriving (Eq, Enum, Show)

disambiguateTargetSelectors
  :: (TargetStringFileStatus -> Match TargetSelector)
  -> TargetStringFileStatus
  -> MatchClass
  -> [TargetSelector]
  -> Either
      [(TargetSelector, [(TargetString, [TargetSelector])])]
      [(TargetString, TargetSelector)]
disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
  case partitionEithers results of
    (errs@(_ : _), _) -> Left errs
    ([], ok) -> Right ok
  where
    -- So, here's the strategy. We take the original match results, and make a
    -- table of all their renderings at all qualification levels.
    -- Note there can be multiple renderings at each qualification level.

    -- Note that renderTargetSelector won't immediately work on any file syntax
    -- When rendering syntax, the FileStatus is always FileStatusNotExists,
    -- which will never match on syntaxForm1File!
    -- Because matchPackageDirectoryPrefix expects a FileStatusExistsFile.
    -- So we need to copy over the file status from the input
    -- TargetStringFileStatus, onto the new rendered TargetStringFileStatus
    matchResultsRenderings :: [(TargetSelector, [TargetStringFileStatus])]
    matchResultsRenderings =
      [ (matchResult, matchRenderings)
      | matchResult <- matchResults
      , let matchRenderings =
              [ copyFileStatus matchInput rendering
              | ql <- [QL1 .. QLFull]
              , rendering <- renderTargetSelector ql matchResult
              ]
      ]

    -- Of course the point is that we're looking for renderings that are
    -- unambiguous matches. So we build another memo table of all the matches
    -- for all of those renderings. So by looking up in this table we can see
    -- if we've got an unambiguous match.

    memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector)
    memoisedMatches =
      -- avoid recomputing the main one if it was an exact match
      ( if exactMatch == Exact
          then Map.insert matchInput (Match Exact 0 matchResults)
          else id
      )
        $ Map.Lazy.fromList
          -- (matcher rendering) should *always* be a Match! Otherwise we will hit
          -- the internal error later on.
          [ (rendering, matcher rendering)
          | rendering <- concatMap snd matchResultsRenderings
          ]

    -- Finally, for each of the match results, we go through all their
    -- possible renderings (in order of qualification level, though remember
    -- there can be multiple renderings per level), and find the first one
    -- that has an unambiguous match.
    results
      :: [ Either
            (TargetSelector, [(TargetString, [TargetSelector])])
            (TargetString, TargetSelector)
         ]
    results =
      [ case findUnambiguous originalMatch matchRenderings of
        Just unambiguousRendering ->
          Right
            ( forgetFileStatus unambiguousRendering
            , originalMatch
            )
        -- This case is an internal error, but we bubble it up and report it
        Nothing ->
          Left
            ( originalMatch
            , [ (forgetFileStatus rendering, matches)
              | rendering <- matchRenderings
              , let Match m _ matches =
                      memoisedMatches Map.! rendering
              , m /= Inexact
              ]
            )
      | (originalMatch, matchRenderings) <- matchResultsRenderings
      ]

    findUnambiguous
      :: TargetSelector
      -> [TargetStringFileStatus]
      -> Maybe TargetStringFileStatus
    findUnambiguous _ [] = Nothing
    findUnambiguous t (r : rs) =
      case memoisedMatches Map.! r of
        Match Exact _ [t']
          | t == t' ->
              Just r
        Match Exact _ _ -> findUnambiguous t rs
        Match Unknown _ _ -> findUnambiguous t rs
        Match Inexact _ _ -> internalError "Match Inexact"
        NoMatch _ _ -> internalError "NoMatch"

internalError :: String -> a
internalError msg =
  error $ "TargetSelector: internal error: " ++ msg

-- | Throw an exception with a formatted message if there are any problems.
reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems verbosity problems = do
  case [str | TargetSelectorUnrecognised str <- problems] of
    [] -> return ()
    targets -> dieWithException verbosity $ ReportTargetSelectorProblems targets

  case [(t, m, ms) | MatchingInternalError t m ms <- problems] of
    [] -> return ()
    ((target, originalMatch, renderingsAndMatches) : _) ->
      dieWithException verbosity
        $ MatchingInternalErrorErr
          (showTargetString target)
          (showTargetSelector originalMatch)
          (showTargetSelectorKind originalMatch)
        $ map
          ( \(rendering, matches) ->
              ( showTargetString rendering
              , (map (\match -> showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")") matches)
              )
          )
          renderingsAndMatches

  case [(t, e, g) | TargetSelectorExpected t e g <- problems] of
    [] -> return ()
    targets ->
      dieWithException verbosity $
        UnrecognisedTarget $
          map (\(target, expected, got) -> (showTargetString target, expected, got)) targets

  case [(t, e) | TargetSelectorNoSuch t e <- problems] of
    [] -> return ()
    targets ->
      dieWithException verbosity $
        NoSuchTargetSelectorErr $
          map (first showTargetString) targets

  case [(t, ts) | TargetSelectorAmbiguous t ts <- problems] of
    [] -> return ()
    targets ->
      dieWithException verbosity $
        TargetSelectorAmbiguousErr $
          map
            ( \(target, amb) ->
                ( showTargetString target
                , (map (\(ut, bt) -> (showTargetString ut, showTargetSelectorKind bt)) amb)
                )
            )
            targets

  case [t | TargetSelectorNoCurrentPackage t <- problems] of
    [] -> return ()
    target : _ ->
      dieWithException verbosity $ TargetSelectorNoCurrentPackageErr (showTargetString target)

  -- TODO: report a different error if there is a .cabal file but it's
  -- not a member of the project

  case [() | TargetSelectorNoTargetsInCwd True <- problems] of
    [] -> return ()
    _ : _ ->
      dieWithException verbosity TargetSelectorNoTargetsInCwdTrue

  case [() | TargetSelectorNoTargetsInCwd False <- problems] of
    [] -> return ()
    _ : _ ->
      dieWithException verbosity TargetSelectorNoTargetsInCwdFalse

  case [() | TargetSelectorNoTargetsInProject <- problems] of
    [] -> return ()
    _ : _ ->
      dieWithException verbosity TargetSelectorNoTargetsInProjectErr

  case [t | TargetSelectorNoScript t <- problems] of
    [] -> return ()
    target : _ ->
      dieWithException verbosity $ TargetSelectorNoScriptErr (showTargetString target)

  fail "reportTargetSelectorProblems: internal error"

----------------------------------
-- Syntax type
--

-- | Syntax for the 'TargetSelector': the matcher and renderer
data Syntax
  = Syntax QualLevel Matcher Renderer
  | AmbiguousAlternatives Syntax Syntax
  | ShadowingAlternatives Syntax Syntax

type Matcher = TargetStringFileStatus -> Match TargetSelector
type Renderer = TargetSelector -> [TargetStringFileStatus]

foldSyntax
  :: (a -> a -> a)
  -> (a -> a -> a)
  -> (QualLevel -> Matcher -> Renderer -> a)
  -> (Syntax -> a)
foldSyntax ambiguous unambiguous syntax = go
  where
    go (Syntax ql match render) = syntax ql match render
    go (AmbiguousAlternatives a b) = ambiguous (go a) (go b)
    go (ShadowingAlternatives a b) = unambiguous (go a) (go b)

----------------------------------
-- Top level renderer and matcher
--

renderTargetSelector
  :: QualLevel
  -> TargetSelector
  -> [TargetStringFileStatus]
renderTargetSelector ql ts =
  foldSyntax
    (++)
    (++)
    (\ql' _ render -> guard (ql == ql') >> render ts)
    syntax
  where
    syntax = syntaxForms emptyKnownTargets

-- don't need known targets for rendering

matchTargetSelector
  :: KnownTargets
  -> TargetStringFileStatus
  -> Match TargetSelector
matchTargetSelector knowntargets = \usertarget ->
  nubMatchesBy (==) $
    let ql = targetQualLevel usertarget
     in foldSyntax
          (<|>)
          (</>)
          (\ql' match _ -> guard (ql == ql') >> match usertarget)
          syntax
  where
    syntax = syntaxForms knowntargets

    targetQualLevel TargetStringFileStatus1{} = QL1
    targetQualLevel TargetStringFileStatus2{} = QL2
    targetQualLevel TargetStringFileStatus3{} = QL3
    targetQualLevel TargetStringFileStatus4{} = QLFull
    targetQualLevel TargetStringFileStatus5{} = QLFull
    targetQualLevel TargetStringFileStatus7{} = QLFull

----------------------------------
-- Syntax forms
--

-- | All the forms of syntax for 'TargetSelector'.
syntaxForms :: KnownTargets -> Syntax
syntaxForms
  KnownTargets
    { knownPackagesAll = pinfo
    , knownPackagesPrimary = ppinfo
    , knownComponentsAll = cinfo
    , knownComponentsPrimary = pcinfo
    , knownComponentsOther = ocinfo
    } =
    -- The various forms of syntax here are ambiguous in many cases.
    -- Our policy is by default we expose that ambiguity and report
    -- ambiguous matches. In certain cases we override the ambiguity
    -- by having some forms shadow others.
    --
    -- We make modules shadow files because module name "Q" clashes
    -- with file "Q" with no extension but these refer to the same
    -- thing anyway so it's not a useful ambiguity. Other cases are
    -- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q".

    ambiguousAlternatives
      -- convenient single-component forms
      [ shadowingAlternatives
          [ ambiguousAlternatives
              [ syntaxForm1All
              , syntaxForm1Filter ppinfo
              , shadowingAlternatives
                  [ syntaxForm1Component pcinfo
                  , syntaxForm1Package pinfo
                  ]
              ]
          , syntaxForm1Component ocinfo
          , syntaxForm1Module cinfo
          , syntaxForm1File pinfo
          ]
      , -- two-component partially qualified forms
        -- fully qualified form for 'all'
        syntaxForm2MetaAll
      , syntaxForm2AllFilter
      , syntaxForm2NamespacePackage pinfo
      , syntaxForm2PackageComponent pinfo
      , syntaxForm2PackageFilter pinfo
      , syntaxForm2KindComponent cinfo
      , shadowingAlternatives
          [ syntaxForm2PackageModule pinfo
          , syntaxForm2PackageFile pinfo
          ]
      , shadowingAlternatives
          [ syntaxForm2ComponentModule cinfo
          , syntaxForm2ComponentFile cinfo
          ]
      , -- rarely used partially qualified forms
        syntaxForm3PackageKindComponent pinfo
      , shadowingAlternatives
          [ syntaxForm3PackageComponentModule pinfo
          , syntaxForm3PackageComponentFile pinfo
          ]
      , shadowingAlternatives
          [ syntaxForm3KindComponentModule cinfo
          , syntaxForm3KindComponentFile cinfo
          ]
      , syntaxForm3NamespacePackageFilter pinfo
      , -- fully-qualified forms for all and cwd with filter
        syntaxForm3MetaAllFilter
      , syntaxForm3MetaCwdFilter ppinfo
      , -- fully-qualified form for package and package with filter
        syntaxForm3MetaNamespacePackage pinfo
      , syntaxForm4MetaNamespacePackageFilter pinfo
      , -- fully-qualified forms for component, module and file
        syntaxForm5MetaNamespacePackageKindComponent pinfo
      , syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo
      , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo
      ]
    where
      ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives
      shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives

-- | Syntax: "all" to select all packages in the project
--
-- > cabal build all
syntaxForm1All :: Syntax
syntaxForm1All =
  syntaxForm1 render $ \str1 _fstatus1 -> do
    guardMetaAll str1
    return (TargetAllPackages Nothing)
  where
    render (TargetAllPackages Nothing) =
      [TargetStringFileStatus1 "all" noFileStatus]
    render _ = []

-- | Syntax: filter
--
-- > cabal build tests
syntaxForm1Filter :: [KnownPackage] -> Syntax
syntaxForm1Filter ps =
  syntaxForm1 render $ \str1 _fstatus1 -> do
    kfilter <- matchComponentKindFilter str1
    return (TargetPackage TargetImplicitCwd pids (Just kfilter))
  where
    pids = [pinfoId | KnownPackage{pinfoId} <- ps]
    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
      [TargetStringFileStatus1 (dispF kfilter) noFileStatus]
    render _ = []

-- | Syntax: package (name, dir or file)
--
-- > cabal build foo
-- > cabal build ../bar ../bar/bar.cabal
syntaxForm1Package :: [KnownPackage] -> Syntax
syntaxForm1Package pinfo =
  syntaxForm1 render $ \str1 fstatus1 -> do
    guardPackage str1 fstatus1
    p <- matchPackage pinfo str1 fstatus1
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)
      KnownPackageName pn ->
        return (TargetPackageNamed pn Nothing)
  where
    render (TargetPackage TargetExplicitNamed [p] Nothing) =
      [TargetStringFileStatus1 (dispP p) noFileStatus]
    render (TargetPackageNamed pn Nothing) =
      [TargetStringFileStatus1 (dispPN pn) noFileStatus]
    render _ = []

-- | Syntax: component
--
-- > cabal build foo
syntaxForm1Component :: [KnownComponent] -> Syntax
syntaxForm1Component cs =
  syntaxForm1 render $ \str1 _fstatus1 -> do
    guardComponentName str1
    c <- matchComponentName cs str1
    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)
  where
    render (TargetComponent p c WholeComponent) =
      [TargetStringFileStatus1 (dispC p c) noFileStatus]
    render _ = []

-- | Syntax: module
--
-- > cabal build Data.Foo
syntaxForm1Module :: [KnownComponent] -> Syntax
syntaxForm1Module cs =
  syntaxForm1 render $ \str1 _fstatus1 -> do
    guardModuleName str1
    let ms = [(m, c) | c <- cs, m <- cinfoModules c]
    (m, c) <- matchModuleNameAnd ms str1
    return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m))
  where
    render (TargetComponent _p _c (ModuleTarget m)) =
      [TargetStringFileStatus1 (dispM m) noFileStatus]
    render _ = []

-- | Syntax: file name
--
-- > cabal build Data/Foo.hs bar/Main.hsc
syntaxForm1File :: [KnownPackage] -> Syntax
syntaxForm1File ps =
  -- Note there's a bit of an inconsistency here vs the other syntax forms
  -- for files. For the single-part syntax the target has to point to a file
  -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for
  -- all the other forms we don't require that.
  syntaxForm1 render $ \str1 fstatus1 ->
    expecting "file" str1 $ do
      (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) <-
        -- always returns the KnownPackage case
        matchPackageDirectoryPrefix ps fstatus1
      orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
        (filepath, c) <- matchComponentFile pinfoComponents pkgfile
        return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
  where
    render (TargetComponent _p _c (FileTarget f)) =
      [TargetStringFileStatus1 f noFileStatus]
    render _ = []

---

-- | Syntax:  :all
--
-- > cabal build :all
syntaxForm2MetaAll :: Syntax
syntaxForm2MetaAll =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    guardNamespaceMeta str1
    guardMetaAll str2
    return (TargetAllPackages Nothing)
  where
    render (TargetAllPackages Nothing) =
      [TargetStringFileStatus2 "" noFileStatus "all"]
    render _ = []

-- | Syntax:  all : filer
--
-- > cabal build all:tests
syntaxForm2AllFilter :: Syntax
syntaxForm2AllFilter =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    guardMetaAll str1
    kfilter <- matchComponentKindFilter str2
    return (TargetAllPackages (Just kfilter))
  where
    render (TargetAllPackages (Just kfilter)) =
      [TargetStringFileStatus2 "all" noFileStatus (dispF kfilter)]
    render _ = []

-- | Syntax:  package : filer
--
-- > cabal build foo:tests
syntaxForm2PackageFilter :: [KnownPackage] -> Syntax
syntaxForm2PackageFilter ps =
  syntaxForm2 render $ \str1 fstatus1 str2 -> do
    guardPackage str1 fstatus1
    p <- matchPackage ps str1 fstatus1
    kfilter <- matchComponentKindFilter str2
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))
      KnownPackageName pn ->
        return (TargetPackageNamed pn (Just kfilter))
  where
    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =
      [TargetStringFileStatus2 (dispP p) noFileStatus (dispF kfilter)]
    render (TargetPackageNamed pn (Just kfilter)) =
      [TargetStringFileStatus2 (dispPN pn) noFileStatus (dispF kfilter)]
    render _ = []

-- | Syntax: pkg : package name
--
-- > cabal build pkg:foo
syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax
syntaxForm2NamespacePackage pinfo =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    guardNamespacePackage str1
    guardPackageName str2
    p <- matchPackage pinfo str2 noFileStatus
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)
      KnownPackageName pn ->
        return (TargetPackageNamed pn Nothing)
  where
    render (TargetPackage TargetExplicitNamed [p] Nothing) =
      [TargetStringFileStatus2 "pkg" noFileStatus (dispP p)]
    render (TargetPackageNamed pn Nothing) =
      [TargetStringFileStatus2 "pkg" noFileStatus (dispPN pn)]
    render _ = []

-- | Syntax: package : component
--
-- > cabal build foo:foo
-- > cabal build ./foo:foo
-- > cabal build ./foo.cabal:foo
syntaxForm2PackageComponent :: [KnownPackage] -> Syntax
syntaxForm2PackageComponent ps =
  syntaxForm2 render $ \str1 fstatus1 str2 -> do
    guardPackage str1 fstatus1
    guardComponentName str2
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentName pinfoComponents str2
          return (TargetComponent pinfoId (cinfoName c) WholeComponent)
      -- TODO: the error here ought to say there's no component by that name in
      -- this package, and name the package
      KnownPackageName pn ->
        let cn = mkUnqualComponentName str2
         in return (TargetComponentUnknown pn (Left cn) WholeComponent)
  where
    render (TargetComponent p c WholeComponent) =
      [TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]
    render (TargetComponentUnknown pn (Left cn) WholeComponent) =
      [TargetStringFileStatus2 (dispPN pn) noFileStatus (prettyShow cn)]
    render _ = []

-- | Syntax: namespace : component
--
-- > cabal build lib:foo exe:foo
syntaxForm2KindComponent :: [KnownComponent] -> Syntax
syntaxForm2KindComponent cs =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    return (TargetComponent (cinfoPackageId c) (cinfoName c) WholeComponent)
  where
    render (TargetComponent p c WholeComponent) =
      [TargetStringFileStatus2 (dispCK c) noFileStatus (dispC p c)]
    render _ = []

-- | Syntax: package : module
--
-- > cabal build foo:Data.Foo
-- > cabal build ./foo:Data.Foo
-- > cabal build ./foo.cabal:Data.Foo
syntaxForm2PackageModule :: [KnownPackage] -> Syntax
syntaxForm2PackageModule ps =
  syntaxForm2 render $ \str1 fstatus1 str2 -> do
    guardPackage str1 fstatus1
    guardModuleName str2
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          let ms = [(m, c) | c <- pinfoComponents, m <- cinfoModules c]
          (m, c) <- matchModuleNameAnd ms str2
          return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))
      KnownPackageName pn -> do
        m <- matchModuleNameUnknown str2
        -- We assume the primary library component of the package:
        return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (ModuleTarget m))
  where
    render (TargetComponent p _c (ModuleTarget m)) =
      [TargetStringFileStatus2 (dispP p) noFileStatus (dispM m)]
    render _ = []

-- | Syntax: component : module
--
-- > cabal build foo:Data.Foo
syntaxForm2ComponentModule :: [KnownComponent] -> Syntax
syntaxForm2ComponentModule cs =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    guardComponentName str1
    guardModuleName str2
    c <- matchComponentName cs str1
    orNoThingIn "component" (cinfoStrName c) $ do
      let ms = cinfoModules c
      m <- matchModuleName ms str2
      return
        ( TargetComponent
            (cinfoPackageId c)
            (cinfoName c)
            (ModuleTarget m)
        )
  where
    render (TargetComponent p c (ModuleTarget m)) =
      [TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)]
    render _ = []

-- | Syntax: package : filename
--
-- > cabal build foo:Data/Foo.hs
-- > cabal build ./foo:Data/Foo.hs
-- > cabal build ./foo.cabal:Data/Foo.hs
syntaxForm2PackageFile :: [KnownPackage] -> Syntax
syntaxForm2PackageFile ps =
  syntaxForm2 render $ \str1 fstatus1 str2 -> do
    guardPackage str1 fstatus1
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          (filepath, c) <- matchComponentFile pinfoComponents str2
          return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
      KnownPackageName pn ->
        let filepath = str2
         in -- We assume the primary library component of the package:
            return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath))
  where
    render (TargetComponent p _c (FileTarget f)) =
      [TargetStringFileStatus2 (dispP p) noFileStatus f]
    render _ = []

-- | Syntax: component : filename
--
-- > cabal build foo:Data/Foo.hs
syntaxForm2ComponentFile :: [KnownComponent] -> Syntax
syntaxForm2ComponentFile cs =
  syntaxForm2 render $ \str1 _fstatus1 str2 -> do
    guardComponentName str1
    c <- matchComponentName cs str1
    orNoThingIn "component" (cinfoStrName c) $ do
      (filepath, _) <- matchComponentFile [c] str2
      return
        ( TargetComponent
            (cinfoPackageId c)
            (cinfoName c)
            (FileTarget filepath)
        )
  where
    render (TargetComponent p c (FileTarget f)) =
      [TargetStringFileStatus2 (dispC p c) noFileStatus f]
    render _ = []

---

-- | Syntax: :all : filter
--
-- > cabal build :all:tests
syntaxForm3MetaAllFilter :: Syntax
syntaxForm3MetaAllFilter =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    guardNamespaceMeta str1
    guardMetaAll str2
    kfilter <- matchComponentKindFilter str3
    return (TargetAllPackages (Just kfilter))
  where
    render (TargetAllPackages (Just kfilter)) =
      [TargetStringFileStatus3 "" noFileStatus "all" (dispF kfilter)]
    render _ = []

syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax
syntaxForm3MetaCwdFilter ps =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    guardNamespaceMeta str1
    guardNamespaceCwd str2
    kfilter <- matchComponentKindFilter str3
    return (TargetPackage TargetImplicitCwd pids (Just kfilter))
  where
    pids = [pinfoId | KnownPackage{pinfoId} <- ps]
    render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
      [TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]
    render _ = []

-- | Syntax: :pkg : package name
--
-- > cabal build :pkg:foo
syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax
syntaxForm3MetaNamespacePackage pinfo =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    guardNamespaceMeta str1
    guardNamespacePackage str2
    guardPackageName str3
    p <- matchPackage pinfo str3 noFileStatus
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] Nothing)
      KnownPackageName pn ->
        return (TargetPackageNamed pn Nothing)
  where
    render (TargetPackage TargetExplicitNamed [p] Nothing) =
      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispP p)]
    render (TargetPackageNamed pn Nothing) =
      [TargetStringFileStatus3 "" noFileStatus "pkg" (dispPN pn)]
    render _ = []

-- | Syntax: package : namespace : component
--
-- > cabal build foo:lib:foo
-- > cabal build foo/:lib:foo
-- > cabal build foo.cabal:lib:foo
syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm3PackageKindComponent ps =
  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
    guardPackage str1 fstatus1
    ckind <- matchComponentKind str2
    guardComponentName str3
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentKindAndName pinfoComponents ckind str3
          return (TargetComponent pinfoId (cinfoName c) WholeComponent)
      KnownPackageName pn ->
        let cn = mkComponentName pn ckind (mkUnqualComponentName str3)
         in return (TargetComponentUnknown pn (Right cn) WholeComponent)
  where
    render (TargetComponent p c WholeComponent) =
      [TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)]
    render (TargetComponentUnknown pn (Right c) WholeComponent) =
      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCK c) (dispC' pn c)]
    render _ = []

-- | Syntax: package : component : module
--
-- > cabal build foo:foo:Data.Foo
-- > cabal build foo/:foo:Data.Foo
-- > cabal build foo.cabal:foo:Data.Foo
syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentModule ps =
  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
    guardPackage str1 fstatus1
    guardComponentName str2
    guardModuleName str3
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentName pinfoComponents str2
          orNoThingIn "component" (cinfoStrName c) $ do
            let ms = cinfoModules c
            m <- matchModuleName ms str3
            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))
      KnownPackageName pn -> do
        let cn = mkUnqualComponentName str2
        m <- matchModuleNameUnknown str3
        return (TargetComponentUnknown pn (Left cn) (ModuleTarget m))
  where
    render (TargetComponent p c (ModuleTarget m)) =
      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) (dispM m)]
    render (TargetComponentUnknown pn (Left c) (ModuleTarget m)) =
      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) (dispM m)]
    render _ = []

-- | Syntax: namespace : component : module
--
-- > cabal build lib:foo:Data.Foo
syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax
syntaxForm3KindComponentModule cs =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    ckind <- matchComponentKind str1
    guardComponentName str2
    guardModuleName str3
    c <- matchComponentKindAndName cs ckind str2
    orNoThingIn "component" (cinfoStrName c) $ do
      let ms = cinfoModules c
      m <- matchModuleName ms str3
      return
        ( TargetComponent
            (cinfoPackageId c)
            (cinfoName c)
            (ModuleTarget m)
        )
  where
    render (TargetComponent p c (ModuleTarget m)) =
      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)]
    render _ = []

-- | Syntax: package : component : filename
--
-- > cabal build foo:foo:Data/Foo.hs
-- > cabal build foo/:foo:Data/Foo.hs
-- > cabal build foo.cabal:foo:Data/Foo.hs
syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentFile ps =
  syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
    guardPackage str1 fstatus1
    guardComponentName str2
    p <- matchPackage ps str1 fstatus1
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentName pinfoComponents str2
          orNoThingIn "component" (cinfoStrName c) $ do
            (filepath, _) <- matchComponentFile [c] str3
            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
      KnownPackageName pn ->
        let cn = mkUnqualComponentName str2
            filepath = str3
         in return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))
  where
    render (TargetComponent p c (FileTarget f)) =
      [TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]
    render (TargetComponentUnknown pn (Left c) (FileTarget f)) =
      [TargetStringFileStatus3 (dispPN pn) noFileStatus (dispCN c) f]
    render _ = []

-- | Syntax: namespace : component : filename
--
-- > cabal build lib:foo:Data/Foo.hs
syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax
syntaxForm3KindComponentFile cs =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    ckind <- matchComponentKind str1
    guardComponentName str2
    c <- matchComponentKindAndName cs ckind str2
    orNoThingIn "component" (cinfoStrName c) $ do
      (filepath, _) <- matchComponentFile [c] str3
      return
        ( TargetComponent
            (cinfoPackageId c)
            (cinfoName c)
            (FileTarget filepath)
        )
  where
    render (TargetComponent p c (FileTarget f)) =
      [TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f]
    render _ = []

syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm3NamespacePackageFilter ps =
  syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
    guardNamespacePackage str1
    guardPackageName str2
    p <- matchPackage ps str2 noFileStatus
    kfilter <- matchComponentKindFilter str3
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))
      KnownPackageName pn ->
        return (TargetPackageNamed pn (Just kfilter))
  where
    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =
      [TargetStringFileStatus3 "pkg" noFileStatus (dispP p) (dispF kfilter)]
    render (TargetPackageNamed pn (Just kfilter)) =
      [TargetStringFileStatus3 "pkg" noFileStatus (dispPN pn) (dispF kfilter)]
    render _ = []

--

syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm4MetaNamespacePackageFilter ps =
  syntaxForm4 render $ \str1 str2 str3 str4 -> do
    guardNamespaceMeta str1
    guardNamespacePackage str2
    guardPackageName str3
    p <- matchPackage ps str3 noFileStatus
    kfilter <- matchComponentKindFilter str4
    case p of
      KnownPackage{pinfoId} ->
        return (TargetPackage TargetExplicitNamed [pinfoId] (Just kfilter))
      KnownPackageName pn ->
        return (TargetPackageNamed pn (Just kfilter))
  where
    render (TargetPackage TargetExplicitNamed [p] (Just kfilter)) =
      [TargetStringFileStatus4 "" "pkg" (dispP p) (dispF kfilter)]
    render (TargetPackageNamed pn (Just kfilter)) =
      [TargetStringFileStatus4 "" "pkg" (dispPN pn) (dispF kfilter)]
    render _ = []

-- | Syntax: :pkg : package : namespace : component
--
-- > cabal build :pkg:foo:lib:foo
syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm5MetaNamespacePackageKindComponent ps =
  syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do
    guardNamespaceMeta str1
    guardNamespacePackage str2
    guardPackageName str3
    ckind <- matchComponentKind str4
    guardComponentName str5
    p <- matchPackage ps str3 noFileStatus
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentKindAndName pinfoComponents ckind str5
          return (TargetComponent pinfoId (cinfoName c) WholeComponent)
      KnownPackageName pn ->
        let cn = mkComponentName pn ckind (mkUnqualComponentName str5)
         in return (TargetComponentUnknown pn (Right cn) WholeComponent)
  where
    render (TargetComponent p c WholeComponent) =
      [TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)]
    render (TargetComponentUnknown pn (Right c) WholeComponent) =
      [TargetStringFileStatus5 "" "pkg" (dispPN pn) (dispCK c) (dispC' pn c)]
    render _ = []

-- | Syntax: :pkg : package : namespace : component : module : module
--
-- > cabal build :pkg:foo:lib:foo:module:Data.Foo
syntaxForm7MetaNamespacePackageKindComponentNamespaceModule
  :: [KnownPackage] -> Syntax
syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =
  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do
    guardNamespaceMeta str1
    guardNamespacePackage str2
    guardPackageName str3
    ckind <- matchComponentKind str4
    guardComponentName str5
    guardNamespaceModule str6
    p <- matchPackage ps str3 noFileStatus
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentKindAndName pinfoComponents ckind str5
          orNoThingIn "component" (cinfoStrName c) $ do
            let ms = cinfoModules c
            m <- matchModuleName ms str7
            return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))
      KnownPackageName pn -> do
        let cn = mkComponentName pn ckind (mkUnqualComponentName str2)
        m <- matchModuleNameUnknown str7
        return (TargetComponentUnknown pn (Right cn) (ModuleTarget m))
  where
    render (TargetComponent p c (ModuleTarget m)) =
      [ TargetStringFileStatus7
          ""
          "pkg"
          (dispP p)
          (dispCK c)
          (dispC p c)
          "module"
          (dispM m)
      ]
    render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) =
      [ TargetStringFileStatus7
          ""
          "pkg"
          (dispPN pn)
          (dispCK c)
          (dispC' pn c)
          "module"
          (dispM m)
      ]
    render _ = []

-- | Syntax: :pkg : package : namespace : component : file : filename
--
-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs
syntaxForm7MetaNamespacePackageKindComponentNamespaceFile
  :: [KnownPackage] -> Syntax
syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps =
  syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do
    guardNamespaceMeta str1
    guardNamespacePackage str2
    guardPackageName str3
    ckind <- matchComponentKind str4
    guardComponentName str5
    guardNamespaceFile str6
    p <- matchPackage ps str3 noFileStatus
    case p of
      KnownPackage{pinfoId, pinfoComponents} ->
        orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
          c <- matchComponentKindAndName pinfoComponents ckind str5
          orNoThingIn "component" (cinfoStrName c) $ do
            (filepath, _) <- matchComponentFile [c] str7
            return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
      KnownPackageName pn ->
        let cn = mkComponentName pn ckind (mkUnqualComponentName str5)
            filepath = str7
         in return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))
  where
    render (TargetComponent p c (FileTarget f)) =
      [ TargetStringFileStatus7
          ""
          "pkg"
          (dispP p)
          (dispCK c)
          (dispC p c)
          "file"
          f
      ]
    render (TargetComponentUnknown pn (Right c) (FileTarget f)) =
      [ TargetStringFileStatus7
          ""
          "pkg"
          (dispPN pn)
          (dispCK c)
          (dispC' pn c)
          "file"
          f
      ]
    render _ = []

---------------------------------------
-- Syntax utils
--

type Match1 = String -> FileStatus -> Match TargetSelector
type Match2 =
  String
  -> FileStatus
  -> String
  -> Match TargetSelector
type Match3 =
  String
  -> FileStatus
  -> String
  -> String
  -> Match TargetSelector
type Match4 =
  String
  -> String
  -> String
  -> String
  -> Match TargetSelector
type Match5 =
  String
  -> String
  -> String
  -> String
  -> String
  -> Match TargetSelector
type Match7 =
  String
  -> String
  -> String
  -> String
  -> String
  -> String
  -> String
  -> Match TargetSelector

syntaxForm1 :: Renderer -> Match1 -> Syntax
syntaxForm2 :: Renderer -> Match2 -> Syntax
syntaxForm3 :: Renderer -> Match3 -> Syntax
syntaxForm4 :: Renderer -> Match4 -> Syntax
syntaxForm5 :: Renderer -> Match5 -> Syntax
syntaxForm7 :: Renderer -> Match7 -> Syntax
syntaxForm1 render f =
  Syntax QL1 match render
  where
    match = \(TargetStringFileStatus1 str1 fstatus1) ->
      f str1 fstatus1

syntaxForm2 render f =
  Syntax QL2 match render
  where
    match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->
      f str1 fstatus1 str2

syntaxForm3 render f =
  Syntax QL3 match render
  where
    match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->
      f str1 fstatus1 str2 str3

syntaxForm4 render f =
  Syntax QLFull match render
  where
    match (TargetStringFileStatus4 str1 str2 str3 str4) =
      f str1 str2 str3 str4
    match _ = mzero

syntaxForm5 render f =
  Syntax QLFull match render
  where
    match (TargetStringFileStatus5 str1 str2 str3 str4 str5) =
      f str1 str2 str3 str4 str5
    match _ = mzero

syntaxForm7 render f =
  Syntax QLFull match render
  where
    match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) =
      f str1 str2 str3 str4 str5 str6 str7
    match _ = mzero

dispP :: Package p => p -> String
dispP = prettyShow . packageName

dispPN :: PackageName -> String
dispPN = prettyShow

dispC :: PackageId -> ComponentName -> String
dispC = componentStringName . packageName

dispC' :: PackageName -> ComponentName -> String
dispC' = componentStringName

dispCN :: UnqualComponentName -> String
dispCN = prettyShow

dispK :: ComponentKind -> String
dispK = showComponentKindShort

dispCK :: ComponentName -> String
dispCK = dispK . componentKind

dispF :: ComponentKind -> String
dispF = showComponentKindFilterShort

dispM :: ModuleName -> String
dispM = prettyShow

-------------------------------
-- Package and component info
--

data KnownTargets = KnownTargets
  { knownPackagesAll :: [KnownPackage]
  , knownPackagesPrimary :: [KnownPackage]
  , knownPackagesOther :: [KnownPackage]
  , knownComponentsAll :: [KnownComponent]
  , knownComponentsPrimary :: [KnownComponent]
  , knownComponentsOther :: [KnownComponent]
  }
  deriving (Show)

data KnownPackage
  = KnownPackage
      { pinfoId :: PackageId
      , pinfoDirectory :: Maybe (FilePath, FilePath)
      , pinfoPackageFile :: Maybe (FilePath, FilePath)
      , pinfoComponents :: [KnownComponent]
      }
  | KnownPackageName
      { pinfoName :: PackageName
      }
  deriving (Show)

data KnownComponent = KnownComponent
  { cinfoName :: ComponentName
  , cinfoStrName :: ComponentStringName
  , cinfoPackageId :: PackageId
  , cinfoSrcDirs :: [FilePath]
  , cinfoModules :: [ModuleName]
  , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
  , cinfoCFiles :: [FilePath]
  , cinfoJsFiles :: [FilePath]
  }
  deriving (Show)

type ComponentStringName = String

knownPackageName :: KnownPackage -> PackageName
knownPackageName KnownPackage{pinfoId} = packageName pinfoId
knownPackageName KnownPackageName{pinfoName} = pinfoName

emptyKnownTargets :: KnownTargets
emptyKnownTargets = KnownTargets [] [] [] [] [] []

getKnownTargets
  :: forall m a
   . (Applicative m, Monad m)
  => DirActions m
  -> [PackageSpecifier (SourcePackage (PackageLocation a))]
  -> m KnownTargets
getKnownTargets dirActions@DirActions{..} pkgs = do
  pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs
  cwd <- getCurrentDirectory
  (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo
  return
    KnownTargets
      { knownPackagesAll = pinfo
      , knownPackagesPrimary = ppinfo
      , knownPackagesOther = opinfo
      , knownComponentsAll = allComponentsIn pinfo
      , knownComponentsPrimary = allComponentsIn ppinfo
      , knownComponentsOther = allComponentsIn opinfo
      }
  where
    mPkgDir :: KnownPackage -> Maybe FilePath
    mPkgDir KnownPackage{pinfoDirectory = Just (dir, _)} = Just dir
    mPkgDir _ = Nothing

    selectPrimaryPackage
      :: FilePath
      -> [KnownPackage]
      -> m ([KnownPackage], [KnownPackage])
    selectPrimaryPackage _ [] = return ([], [])
    selectPrimaryPackage cwd (pkg : packages) = do
      (ppinfo, opinfo) <- selectPrimaryPackage cwd packages
      isPkgDirCwd <- maybe (pure False) (compareFilePath dirActions cwd) (mPkgDir pkg)
      return (if isPkgDirCwd then (pkg : ppinfo, opinfo) else (ppinfo, pkg : opinfo))

    allComponentsIn ps =
      [c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents]

collectKnownPackageInfo
  :: (Applicative m, Monad m)
  => DirActions m
  -> PackageSpecifier (SourcePackage (PackageLocation a))
  -> m KnownPackage
collectKnownPackageInfo _ (NamedPackage pkgname _props) =
  return (KnownPackageName pkgname)
collectKnownPackageInfo
  dirActions@DirActions{..}
  ( SpecificSourcePackage
      SourcePackage
        { srcpkgDescription = pkg
        , srcpkgSource = loc
        }
    ) = do
    (pkgdir, pkgfile) <-
      case loc of
        -- TODO: local tarballs, remote tarballs etc
        LocalUnpackedPackage dir -> do
          dirabs <- canonicalizePath dir
          dirrel <- makeRelativeToCwd dirActions dirabs
          -- TODO: ought to get this earlier in project reading
          let fileabs = dirabs FilePath.</> prettyShow (packageName pkg) FilePath.<.> "cabal"
              filerel = dirrel FilePath.</> prettyShow (packageName pkg) FilePath.<.> "cabal"
          exists <- doesFileExist fileabs
          return
            ( Just (dirabs, dirrel)
            , if exists then Just (fileabs, filerel) else Nothing
            )
        _ -> return (Nothing, Nothing)
    let pinfo =
          KnownPackage
            { pinfoId = packageId pkg
            , pinfoDirectory = pkgdir
            , pinfoPackageFile = pkgfile
            , pinfoComponents =
                collectKnownComponentInfo
                  (flattenPackageDescription pkg)
            }
    return pinfo

collectKnownComponentInfo :: PackageDescription -> [KnownComponent]
collectKnownComponentInfo pkg =
  [ KnownComponent
    { cinfoName = componentName c
    , cinfoStrName = componentStringName (packageName pkg) (componentName c)
    , cinfoPackageId = packageId pkg
    , cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi))
    , cinfoModules = ordNub (componentModules c)
    , cinfoHsFiles = ordNub (componentHsFiles c)
    , cinfoCFiles = ordNub (map getSymbolicPath $ cSources bi)
    , cinfoJsFiles = ordNub (map getSymbolicPath $ jsSources bi)
    }
  | c <- pkgComponents pkg
  , let bi = componentBuildInfo c
  ]

componentStringName :: PackageName -> ComponentName -> ComponentStringName
componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname
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]
-- I think it's unlikely users will ask to build a requirement
-- which is not mentioned locally.
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) = [getSymbolicPath $ modulePath exe]
componentHsFiles
  ( CTest
      TestSuite
        { testInterface = TestSuiteExeV10 _ mainfile
        }
    ) = [getSymbolicPath mainfile]
componentHsFiles
  ( CBench
      Benchmark
        { benchmarkInterface = BenchmarkExeV10 _ mainfile
        }
    ) = [getSymbolicPath mainfile]
componentHsFiles _ = []

------------------------------
-- Matching meta targets
--

guardNamespaceMeta :: String -> Match ()
guardNamespaceMeta = guardToken [""] "meta namespace"

guardMetaAll :: String -> Match ()
guardMetaAll = guardToken ["all"] "meta-target 'all'"

guardNamespacePackage :: String -> Match ()
guardNamespacePackage = guardToken ["pkg", "package"] "'pkg' namespace"

guardNamespaceCwd :: String -> Match ()
guardNamespaceCwd = guardToken ["cwd"] "'cwd' namespace"

guardNamespaceModule :: String -> Match ()
guardNamespaceModule = guardToken ["mod", "module"] "'module' namespace"

guardNamespaceFile :: String -> Match ()
guardNamespaceFile = guardToken ["file"] "'file' namespace"

guardToken :: [String] -> String -> String -> Match ()
guardToken tokens msg s
  | caseFold s `elem` tokens = increaseConfidence
  | otherwise = matchErrorExpected msg s

------------------------------
-- Matching component kinds
--

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

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

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

matchComponentKindFilter :: String -> Match ComponentKind
matchComponentKindFilter s
  | s' `elem` liblabels = increaseConfidence >> return LibKind
  | s' `elem` fliblabels = increaseConfidence >> return FLibKind
  | s' `elem` exelabels = increaseConfidence >> return ExeKind
  | s' `elem` testlabels = increaseConfidence >> return TestKind
  | s' `elem` benchlabels = increaseConfidence >> return BenchKind
  | otherwise = matchErrorExpected "component kind filter" s
  where
    s' = caseFold s
    liblabels = ["libs", "libraries"]
    fliblabels = ["flibs", "foreign-libraries"]
    exelabels = ["exes", "executables"]
    testlabels = ["tests", "test-suites"]
    benchlabels = ["benches", "benchmarks"]

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"

showComponentKindFilterShort :: ComponentKind -> String
showComponentKindFilterShort LibKind = "libs"
showComponentKindFilterShort FLibKind = "flibs"
showComponentKindFilterShort ExeKind = "exes"
showComponentKindFilterShort TestKind = "tests"
showComponentKindFilterShort BenchKind = "benchmarks"

------------------------------
-- Matching package targets
--

guardPackage :: String -> FileStatus -> Match ()
guardPackage str fstatus =
  guardPackageName str
    <|> guardPackageDir str fstatus
    <|> guardPackageFile str fstatus

guardPackageName :: String -> Match ()
guardPackageName s
  | validPackageName s = increaseConfidence
  | otherwise = matchErrorExpected "package name" s

validPackageName :: String -> Bool
validPackageName s =
  all validPackageNameChar s
    && not (null s)
  where
    validPackageNameChar c = isAlphaNum c || c == '-'

guardPackageDir :: String -> FileStatus -> Match ()
guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence
guardPackageDir str _ = matchErrorExpected "package directory" str

guardPackageFile :: String -> FileStatus -> Match ()
guardPackageFile _ (FileStatusExistsFile file)
  | FilePath.takeExtension file == ".cabal" =
      increaseConfidence
guardPackageFile str _ = matchErrorExpected "package .cabal file" str

matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage pinfo = \str fstatus ->
  orNoThingIn "project" "" $
    matchPackageName pinfo str
      </> ( matchPackageNameUnknown str
              <|> matchPackageDir pinfo str fstatus
              <|> matchPackageFile pinfo str fstatus
          )

matchPackageName :: [KnownPackage] -> String -> Match KnownPackage
matchPackageName ps = \str -> do
  guard (validPackageName str)
  orNoSuchThing
    "package"
    str
    (map (prettyShow . knownPackageName) ps)
    $ increaseConfidenceFor
    $ matchInexactly caseFold (prettyShow . knownPackageName) ps str

matchPackageNameUnknown :: String -> Match KnownPackage
matchPackageNameUnknown str = do
  pn <- matchParse str
  unknownMatch (KnownPackageName pn)

matchPackageDir
  :: [KnownPackage]
  -> String
  -> FileStatus
  -> Match KnownPackage
matchPackageDir ps = \str fstatus ->
  case fstatus of
    FileStatusExistsDir canondir ->
      orNoSuchThing "package directory" str (map (snd . fst) dirs) $
        increaseConfidenceFor $
          fmap snd $
            matchExactly (fst . fst) dirs canondir
    _ -> mzero
  where
    dirs =
      [ ((dabs, drel), p)
      | p@KnownPackage{pinfoDirectory = Just (dabs, drel)} <- ps
      ]

matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackageFile ps = \str fstatus -> do
  case fstatus of
    FileStatusExistsFile canonfile ->
      orNoSuchThing "package .cabal file" str (map (snd . fst) files) $
        increaseConfidenceFor $
          fmap snd $
            matchExactly (fst . fst) files canonfile
    _ -> mzero
  where
    files =
      [ ((fabs, frel), p)
      | p@KnownPackage{pinfoPackageFile = Just (fabs, frel)} <- ps
      ]

-- TODO: test outcome when dir exists but doesn't match any known one

-- TODO: perhaps need another distinction, vs no such thing, point is the
--      thing is not known, within the project, but could be outside project

------------------------------
-- Matching component targets
--

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 :: [KnownComponent] -> String -> Match KnownComponent
matchComponentName cs str =
  orNoSuchThing "component" str (map cinfoStrName cs) $
    increaseConfidenceFor $
      matchInexactly caseFold cinfoStrName cs str

matchComponentKindAndName
  :: [KnownComponent]
  -> ComponentKind
  -> String
  -> Match KnownComponent
matchComponentKindAndName cs ckind str =
  orNoSuchThing
    (showComponentKind ckind ++ " component")
    str
    (map render cs)
    $ increaseConfidenceFor
    $ matchInexactly
      (second caseFold)
      (\c -> (cinfoKind c, cinfoStrName c))
      cs
      (ckind, str)
  where
    render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c

------------------------------
-- Matching module targets
--

guardModuleName :: String -> Match ()
guardModuleName s =
  case simpleParsec s :: Maybe ModuleName of
    Just _ -> increaseConfidence
    _
      | all validModuleChar s
          && not (null s) ->
          return ()
      | otherwise -> matchErrorExpected "module name" s
  where
    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
  orNoSuchThing "module" str (map prettyShow ms) $
    increaseConfidenceFor $
      matchInexactly caseFold prettyShow ms str

matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd ms str =
  orNoSuchThing "module" str (map (prettyShow . fst) ms) $
    increaseConfidenceFor $
      matchInexactly caseFold (prettyShow . fst) ms str

matchModuleNameUnknown :: String -> Match ModuleName
matchModuleNameUnknown str =
  expecting "module" str $
    increaseConfidenceFor $
      matchParse str

------------------------------
-- Matching file targets
--

matchPackageDirectoryPrefix
  :: [KnownPackage]
  -> FileStatus
  -> Match (FilePath, KnownPackage)
matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =
  increaseConfidenceFor $
    matchDirectoryPrefix pkgdirs filepath
  where
    pkgdirs =
      [ (dir, p)
      | p@KnownPackage{pinfoDirectory = Just (dir, _)} <- ps
      ]
matchPackageDirectoryPrefix _ _ = mzero

matchComponentFile
  :: [KnownComponent]
  -> String
  -> Match (FilePath, KnownComponent)
matchComponentFile cs str =
  orNoSuchThing "file" str [] $
    matchComponentModuleFile cs str
      <|> matchComponentOtherFile cs str

matchComponentOtherFile
  :: [KnownComponent]
  -> String
  -> Match (FilePath, KnownComponent)
matchComponentOtherFile cs =
  matchFile
    [ (normalise (srcdir FilePath.</> file), c)
    | c <- cs
    , srcdir <- cinfoSrcDirs c
    , file <-
        cinfoHsFiles c
          ++ cinfoCFiles c
          ++ cinfoJsFiles c
    ]
    . normalise

matchComponentModuleFile
  :: [KnownComponent]
  -> String
  -> Match (FilePath, KnownComponent)
matchComponentModuleFile cs str = do
  matchFile
    [ (normalise (d FilePath.</> toFilePath m), c)
    | c <- cs
    , d <- cinfoSrcDirs c
    , m <- cinfoModules c
    ]
    (dropExtension (normalise str)) -- Drop the extension because FileTarget
    -- is stored without the extension

-- utils

-- | Compare two filepaths for equality using DirActions' canonicalizePath
-- to normalize AND canonicalize filepaths before comparison.
compareFilePath
  :: (Applicative m, Monad m)
  => DirActions m
  -> FilePath
  -> FilePath
  -> m Bool
compareFilePath DirActions{..} fp1 fp2
  | equalFilePath fp1 fp2 = pure True -- avoid unnecessary IO if we can match earlier
  | otherwise = do
      c1 <- canonicalizePath fp1
      c2 <- canonicalizePath fp2
      pure $ equalFilePath c1 c2

matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)
matchFile fs =
  increaseConfidenceFor
    . matchInexactly caseFold fst fs

matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)
matchDirectoryPrefix dirs filepath =
  tryEach $
    [ (file, x)
    | (dir, x) <- dirs
    , file <- maybeToList (stripDirectory dir)
    ]
  where
    stripDirectory :: FilePath -> Maybe FilePath
    stripDirectory dir =
      joinPath `fmap` stripPrefix (splitDirectories dir) filepathsplit

    filepathsplit = splitDirectories filepath

------------------------------
-- 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 ('matchPlus', 'matchPlusShadowing') and finally we
-- can run a matcher against an input using 'findMatch'.
data Match a
  = NoMatch !Confidence [MatchError]
  | Match !MatchClass !Confidence [a]
  deriving (Show)

-- | The kind of match, inexact or exact. We keep track of this so we can
-- prefer exact over inexact matches. The 'Ord' here is important: we try
-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom.
data MatchClass
  = -- | Matches an unknown thing e.g. parses as a package
    --   name without it being a specific known package
    Unknown
  | -- | Matches a known thing inexactly
    --   e.g. matches a known package case insensitively
    Inexact
  | -- | Exactly matches a known thing,
    --   e.g. matches a known package case sensitively
    Exact
  deriving (Show, Eq, Ord)

type Confidence = Int

data MatchError
  = MatchErrorExpected String String -- thing got
  | MatchErrorNoSuch String String [String] -- thing got alts
  | MatchErrorIn String String MatchError -- kind  thing
  deriving (Show, Eq)

instance Functor Match where
  fmap _ (NoMatch d ms) = NoMatch d ms
  fmap f (Match m d xs) = Match m d (fmap f xs)

instance Applicative Match where
  pure a = Match Exact 0 [a]
  (<*>) = ap

instance Alternative Match where
  empty = NoMatch 0 []
  (<|>) = matchPlus

instance Monad Match where
  return = pure
  NoMatch d ms >>= _ = NoMatch d ms
  Match m d xs >>= f =
    -- To understand this, it needs to be read in context with the
    -- implementation of 'matchPlus' below
    case msum (map f xs) of
      Match m' d' xs' -> Match (min m m') (d + d') xs'
      -- The minimum match class is the one we keep. The match depth is
      -- tracked but not used in the Match case.

      NoMatch d' ms -> NoMatch (d + d') ms

-- Here is where we transfer the depth we were keeping track of in
-- the Match case over to the NoMatch case where it finally gets used.

instance MonadPlus Match where
  mzero = empty
  mplus = matchPlus

(</>) :: Match a -> Match a -> Match a
(</>) = matchPlusShadowing

infixl 3 </>

-- | 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.
--
-- This operator is associative, has unit 'mzero' and is also commutative.
matchPlus :: Match a -> Match a -> Match a
matchPlus a@(Match _ _ _) (NoMatch _ _) = a
matchPlus (NoMatch _ _) b@(Match _ _ _) = b
matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)
  | d_a > d_b = a -- We only really make use of the depth in the NoMatch case.
  | d_a < d_b = b
  | otherwise = NoMatch d_a (ms_a ++ ms_b)
matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)
  | m_a > m_b = a -- exact over inexact
  | m_a < m_b = b -- exact over inexact
  | otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b)

-- | Combine two matchers. This is similar to 'matchPlus' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
--
-- This operator is associative, has unit 'mzero' and is not commutative.
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(Match Exact _ _) _ = a
matchPlusShadowing a b = matchPlus a b

------------------------------
-- Various match primitives
--

matchErrorExpected :: String -> String -> Match a
matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]

matchErrorNoSuch :: String -> String -> [String] -> Match a
matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts]

expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
expecting _ _ m = m

orNoSuchThing :: String -> String -> [String] -> Match a -> Match a
orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts
orNoSuchThing _ _ _ m = m

orNoThingIn :: String -> String -> Match a -> Match a
orNoThingIn kind name (NoMatch n ms) =
  NoMatch n [MatchErrorIn kind name m | m <- ms]
orNoThingIn _ _ m = m

increaseConfidence :: Match ()
increaseConfidence = Match Exact 1 [()]

increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r

nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a
nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs
nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs)

-- | Lift a list of matches to an exact match.
exactMatches, inexactMatches :: [a] -> Match a
exactMatches [] = mzero
exactMatches xs = Match Exact 0 xs
inexactMatches [] = mzero
inexactMatches xs = Match Inexact 0 xs

unknownMatch :: a -> Match a
unknownMatch x = Match Unknown 0 [x]

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 :: Match a -> MaybeAmbiguous a
findMatch match = case match of
  NoMatch _ msgs -> None msgs
  Match _ _ [x] -> Unambiguous x
  Match m d [] -> error $ "findMatch: impossible: " ++ show match'
    where
      match' = Match m d [] :: Match ()
  -- TODO: Maybe use Data.List.NonEmpty inside
  -- Match so that this case would be correct
  -- by construction?
  Match m _ xs -> Ambiguous m xs

data MaybeAmbiguous a
  = None [MatchError]
  | Unambiguous a
  | Ambiguous MatchClass [a]
  deriving (Show)

------------------------------
-- Basic matchers
--

-- | A primitive matcher that looks up a value in a finite 'Map'. The
-- value must match exactly.
matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)
matchExactly key xs =
  \k -> case Map.lookup k m of
    Nothing -> mzero
    Just ys -> exactMatches ys
  where
    m = Map.fromListWith (++) [(key x, [x]) | 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 k, Ord k')
  => (k -> k')
  -> (a -> k)
  -> [a]
  -> (k -> Match a)
matchInexactly cannonicalise key xs =
  \k -> case Map.lookup k m of
    Just ys -> exactMatches ys
    Nothing -> case Map.lookup (cannonicalise k) m' of
      Just ys -> inexactMatches ys
      Nothing -> mzero
  where
    m = Map.fromListWith (++) [(key x, [x]) | x <- xs]

    -- the map of canonicalised keys to groups of inexact matches
    m' = Map.mapKeysWith (++) cannonicalise m

matchParse :: Parsec a => String -> Match a
matchParse = maybe mzero return . simpleParsec

------------------------------
-- Utils
--

caseFold :: String -> String
caseFold = lowercase

-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the
-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's
-- primary library from named private libraries.
mkComponentName
  :: PackageName
  -> ComponentKind
  -> UnqualComponentName
  -> ComponentName
mkComponentName pkgname ckind ucname =
  case ckind of
    LibKind
      | packageNameToUnqualComponentName pkgname == ucname ->
          CLibName LMainLibName
      | otherwise -> CLibName $ LSubLibName ucname
    FLibKind -> CFLibName ucname
    ExeKind -> CExeName ucname
    TestKind -> CTestName ucname
    BenchKind -> CBenchName ucname

------------------------------
-- Example inputs
--

{-
ex1pinfo :: [KnownPackage]
ex1pinfo =
  [ addComponent (CExeName (mkUnqualComponentName "foo-exe")) [] ["Data.Foo"] $
    KnownPackage {
      pinfoId          = PackageIdentifier (mkPackageName "foo") (mkVersion [1]),
      pinfoDirectory   = Just ("/the/foo", "foo"),
      pinfoPackageFile = Just ("/the/foo/foo.cabal", "foo/foo.cabal"),
      pinfoComponents  = []
    }
  , KnownPackage {
      pinfoId          = PackageIdentifier (mkPackageName "bar") (mkVersion [1]),
      pinfoDirectory   = Just ("/the/bar", "bar"),
      pinfoPackageFile = Just ("/the/bar/bar.cabal", "bar/bar.cabal"),
      pinfoComponents  = []
    }
  ]
  where
    addComponent n ds ms p =
      p {
        pinfoComponents =
            KnownComponent n (componentStringName (pinfoId p) n)
                          p ds (map mkMn ms)
                          [] [] []
          : pinfoComponents p
      }

    mkMn :: String -> ModuleName
    mkMn  = ModuleName.fromString
-}
{-
stargets =
  [ TargetComponent (CExeName "foo")  WholeComponent
  , TargetComponent (CExeName "foo") (ModuleTarget (mkMn "Foo"))
  , TargetComponent (CExeName "tst") (ModuleTarget (mkMn "Foo"))
  ]
    where
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse

ex_pkgid :: PackageIdentifier
Just ex_pkgid = simpleParse "thelib"
-}

{-
ex_cs :: [KnownComponent]
ex_cs =
  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])
  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])
  ]
    where
    mkC n ds ms = KnownComponent n (componentStringName n) ds (map mkMn ms)
    mkMn :: String -> ModuleName
    mkMn  = fromJust . simpleParse
    pkgid :: PackageIdentifier
    Just pkgid = simpleParse "thelib"
-}
