{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- TODO
{-# OPTIONS_GHC -fno-warn-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
  )
#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
import qualified System.Directory as IO
  ( canonicalizePath
  , doesDirectoryExist
  , doesFileExist
  , getCurrentDirectory
  )
import System.FilePath
  ( dropTrailingPathSeparator
  , equalFilePath
  , normalise
  , (<.>)
  , (</>)
  )
import System.FilePath as FilePath
  ( dropExtension
  , joinPath
  , splitDirectories
  , 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 (TargetSelector -> TargetSelector -> Bool
(TargetSelector -> TargetSelector -> Bool)
-> (TargetSelector -> TargetSelector -> Bool) -> Eq TargetSelector
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetSelector -> TargetSelector -> Bool
== :: TargetSelector -> TargetSelector -> Bool
$c/= :: TargetSelector -> TargetSelector -> Bool
/= :: TargetSelector -> TargetSelector -> Bool
Eq, Eq TargetSelector
Eq TargetSelector =>
(TargetSelector -> TargetSelector -> Ordering)
-> (TargetSelector -> TargetSelector -> Bool)
-> (TargetSelector -> TargetSelector -> Bool)
-> (TargetSelector -> TargetSelector -> Bool)
-> (TargetSelector -> TargetSelector -> Bool)
-> (TargetSelector -> TargetSelector -> TargetSelector)
-> (TargetSelector -> TargetSelector -> TargetSelector)
-> Ord TargetSelector
TargetSelector -> TargetSelector -> Bool
TargetSelector -> TargetSelector -> Ordering
TargetSelector -> TargetSelector -> TargetSelector
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TargetSelector -> TargetSelector -> Ordering
compare :: TargetSelector -> TargetSelector -> Ordering
$c< :: TargetSelector -> TargetSelector -> Bool
< :: TargetSelector -> TargetSelector -> Bool
$c<= :: TargetSelector -> TargetSelector -> Bool
<= :: TargetSelector -> TargetSelector -> Bool
$c> :: TargetSelector -> TargetSelector -> Bool
> :: TargetSelector -> TargetSelector -> Bool
$c>= :: TargetSelector -> TargetSelector -> Bool
>= :: TargetSelector -> TargetSelector -> Bool
$cmax :: TargetSelector -> TargetSelector -> TargetSelector
max :: TargetSelector -> TargetSelector -> TargetSelector
$cmin :: TargetSelector -> TargetSelector -> TargetSelector
min :: TargetSelector -> TargetSelector -> TargetSelector
Ord, Int -> TargetSelector -> ShowS
[TargetSelector] -> ShowS
TargetSelector -> String
(Int -> TargetSelector -> ShowS)
-> (TargetSelector -> String)
-> ([TargetSelector] -> ShowS)
-> Show TargetSelector
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetSelector -> ShowS
showsPrec :: Int -> TargetSelector -> ShowS
$cshow :: TargetSelector -> String
show :: TargetSelector -> String
$cshowList :: [TargetSelector] -> ShowS
showList :: [TargetSelector] -> ShowS
Show, (forall x. TargetSelector -> Rep TargetSelector x)
-> (forall x. Rep TargetSelector x -> TargetSelector)
-> Generic TargetSelector
forall x. Rep TargetSelector x -> TargetSelector
forall x. TargetSelector -> Rep TargetSelector x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TargetSelector -> Rep TargetSelector x
from :: forall x. TargetSelector -> Rep TargetSelector x
$cto :: forall x. Rep TargetSelector x -> TargetSelector
to :: forall x. Rep TargetSelector x -> TargetSelector
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 (TargetImplicitCwd -> TargetImplicitCwd -> Bool
(TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> (TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> Eq TargetImplicitCwd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
== :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
$c/= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
/= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
Eq, Eq TargetImplicitCwd
Eq TargetImplicitCwd =>
(TargetImplicitCwd -> TargetImplicitCwd -> Ordering)
-> (TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> (TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> (TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> (TargetImplicitCwd -> TargetImplicitCwd -> Bool)
-> (TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd)
-> (TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd)
-> Ord TargetImplicitCwd
TargetImplicitCwd -> TargetImplicitCwd -> Bool
TargetImplicitCwd -> TargetImplicitCwd -> Ordering
TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TargetImplicitCwd -> TargetImplicitCwd -> Ordering
compare :: TargetImplicitCwd -> TargetImplicitCwd -> Ordering
$c< :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
< :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
$c<= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
<= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
$c> :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
> :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
$c>= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
>= :: TargetImplicitCwd -> TargetImplicitCwd -> Bool
$cmax :: TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd
max :: TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd
$cmin :: TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd
min :: TargetImplicitCwd -> TargetImplicitCwd -> TargetImplicitCwd
Ord, Int -> TargetImplicitCwd -> ShowS
[TargetImplicitCwd] -> ShowS
TargetImplicitCwd -> String
(Int -> TargetImplicitCwd -> ShowS)
-> (TargetImplicitCwd -> String)
-> ([TargetImplicitCwd] -> ShowS)
-> Show TargetImplicitCwd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetImplicitCwd -> ShowS
showsPrec :: Int -> TargetImplicitCwd -> ShowS
$cshow :: TargetImplicitCwd -> String
show :: TargetImplicitCwd -> String
$cshowList :: [TargetImplicitCwd] -> ShowS
showList :: [TargetImplicitCwd] -> ShowS
Show, (forall x. TargetImplicitCwd -> Rep TargetImplicitCwd x)
-> (forall x. Rep TargetImplicitCwd x -> TargetImplicitCwd)
-> Generic TargetImplicitCwd
forall x. Rep TargetImplicitCwd x -> TargetImplicitCwd
forall x. TargetImplicitCwd -> Rep TargetImplicitCwd x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TargetImplicitCwd -> Rep TargetImplicitCwd x
from :: forall x. TargetImplicitCwd -> Rep TargetImplicitCwd x
$cto :: forall x. Rep TargetImplicitCwd x -> TargetImplicitCwd
to :: forall x. Rep TargetImplicitCwd x -> TargetImplicitCwd
Generic)

data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
  deriving (ComponentKind -> ComponentKind -> Bool
(ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool) -> Eq ComponentKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ComponentKind -> ComponentKind -> Bool
== :: ComponentKind -> ComponentKind -> Bool
$c/= :: ComponentKind -> ComponentKind -> Bool
/= :: ComponentKind -> ComponentKind -> Bool
Eq, Eq ComponentKind
Eq ComponentKind =>
(ComponentKind -> ComponentKind -> Ordering)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> Bool)
-> (ComponentKind -> ComponentKind -> ComponentKind)
-> (ComponentKind -> ComponentKind -> ComponentKind)
-> Ord ComponentKind
ComponentKind -> ComponentKind -> Bool
ComponentKind -> ComponentKind -> Ordering
ComponentKind -> ComponentKind -> ComponentKind
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ComponentKind -> ComponentKind -> Ordering
compare :: ComponentKind -> ComponentKind -> Ordering
$c< :: ComponentKind -> ComponentKind -> Bool
< :: ComponentKind -> ComponentKind -> Bool
$c<= :: ComponentKind -> ComponentKind -> Bool
<= :: ComponentKind -> ComponentKind -> Bool
$c> :: ComponentKind -> ComponentKind -> Bool
> :: ComponentKind -> ComponentKind -> Bool
$c>= :: ComponentKind -> ComponentKind -> Bool
>= :: ComponentKind -> ComponentKind -> Bool
$cmax :: ComponentKind -> ComponentKind -> ComponentKind
max :: ComponentKind -> ComponentKind -> ComponentKind
$cmin :: ComponentKind -> ComponentKind -> ComponentKind
min :: ComponentKind -> ComponentKind -> ComponentKind
Ord, Int -> ComponentKind
ComponentKind -> Int
ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind
ComponentKind -> ComponentKind -> [ComponentKind]
ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
(ComponentKind -> ComponentKind)
-> (ComponentKind -> ComponentKind)
-> (Int -> ComponentKind)
-> (ComponentKind -> Int)
-> (ComponentKind -> [ComponentKind])
-> (ComponentKind -> ComponentKind -> [ComponentKind])
-> (ComponentKind -> ComponentKind -> [ComponentKind])
-> (ComponentKind
    -> ComponentKind -> ComponentKind -> [ComponentKind])
-> Enum ComponentKind
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: ComponentKind -> ComponentKind
succ :: ComponentKind -> ComponentKind
$cpred :: ComponentKind -> ComponentKind
pred :: ComponentKind -> ComponentKind
$ctoEnum :: Int -> ComponentKind
toEnum :: Int -> ComponentKind
$cfromEnum :: ComponentKind -> Int
fromEnum :: ComponentKind -> Int
$cenumFrom :: ComponentKind -> [ComponentKind]
enumFrom :: ComponentKind -> [ComponentKind]
$cenumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFromThen :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
enumFromTo :: ComponentKind -> ComponentKind -> [ComponentKind]
$cenumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
enumFromThenTo :: ComponentKind -> ComponentKind -> ComponentKind -> [ComponentKind]
Enum, Int -> ComponentKind -> ShowS
[ComponentKind] -> ShowS
ComponentKind -> String
(Int -> ComponentKind -> ShowS)
-> (ComponentKind -> String)
-> ([ComponentKind] -> ShowS)
-> Show ComponentKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ComponentKind -> ShowS
showsPrec :: Int -> ComponentKind -> ShowS
$cshow :: ComponentKind -> String
show :: ComponentKind -> String
$cshowList :: [ComponentKind] -> ShowS
showList :: [ComponentKind] -> ShowS
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 (SubComponentTarget -> SubComponentTarget -> Bool
(SubComponentTarget -> SubComponentTarget -> Bool)
-> (SubComponentTarget -> SubComponentTarget -> Bool)
-> Eq SubComponentTarget
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubComponentTarget -> SubComponentTarget -> Bool
== :: SubComponentTarget -> SubComponentTarget -> Bool
$c/= :: SubComponentTarget -> SubComponentTarget -> Bool
/= :: SubComponentTarget -> SubComponentTarget -> Bool
Eq, Eq SubComponentTarget
Eq SubComponentTarget =>
(SubComponentTarget -> SubComponentTarget -> Ordering)
-> (SubComponentTarget -> SubComponentTarget -> Bool)
-> (SubComponentTarget -> SubComponentTarget -> Bool)
-> (SubComponentTarget -> SubComponentTarget -> Bool)
-> (SubComponentTarget -> SubComponentTarget -> Bool)
-> (SubComponentTarget -> SubComponentTarget -> SubComponentTarget)
-> (SubComponentTarget -> SubComponentTarget -> SubComponentTarget)
-> Ord SubComponentTarget
SubComponentTarget -> SubComponentTarget -> Bool
SubComponentTarget -> SubComponentTarget -> Ordering
SubComponentTarget -> SubComponentTarget -> SubComponentTarget
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SubComponentTarget -> SubComponentTarget -> Ordering
compare :: SubComponentTarget -> SubComponentTarget -> Ordering
$c< :: SubComponentTarget -> SubComponentTarget -> Bool
< :: SubComponentTarget -> SubComponentTarget -> Bool
$c<= :: SubComponentTarget -> SubComponentTarget -> Bool
<= :: SubComponentTarget -> SubComponentTarget -> Bool
$c> :: SubComponentTarget -> SubComponentTarget -> Bool
> :: SubComponentTarget -> SubComponentTarget -> Bool
$c>= :: SubComponentTarget -> SubComponentTarget -> Bool
>= :: SubComponentTarget -> SubComponentTarget -> Bool
$cmax :: SubComponentTarget -> SubComponentTarget -> SubComponentTarget
max :: SubComponentTarget -> SubComponentTarget -> SubComponentTarget
$cmin :: SubComponentTarget -> SubComponentTarget -> SubComponentTarget
min :: SubComponentTarget -> SubComponentTarget -> SubComponentTarget
Ord, Int -> SubComponentTarget -> ShowS
[SubComponentTarget] -> ShowS
SubComponentTarget -> String
(Int -> SubComponentTarget -> ShowS)
-> (SubComponentTarget -> String)
-> ([SubComponentTarget] -> ShowS)
-> Show SubComponentTarget
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubComponentTarget -> ShowS
showsPrec :: Int -> SubComponentTarget -> ShowS
$cshow :: SubComponentTarget -> String
show :: SubComponentTarget -> String
$cshowList :: [SubComponentTarget] -> ShowS
showList :: [SubComponentTarget] -> ShowS
Show, (forall x. SubComponentTarget -> Rep SubComponentTarget x)
-> (forall x. Rep SubComponentTarget x -> SubComponentTarget)
-> Generic SubComponentTarget
forall x. Rep SubComponentTarget x -> SubComponentTarget
forall x. SubComponentTarget -> Rep SubComponentTarget x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SubComponentTarget -> Rep SubComponentTarget x
from :: forall x. SubComponentTarget -> Rep SubComponentTarget x
$cto :: forall x. Rep SubComponentTarget x -> SubComponentTarget
to :: forall x. Rep SubComponentTarget x -> SubComponentTarget
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 :: forall a.
[PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors = DirActions IO
-> [PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
forall (m :: * -> *) a.
(Applicative m, Monad m) =>
DirActions m
-> [PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKind
-> [String]
-> m (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectorsWith DirActions IO
defaultDirActions

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

data DirActions m = DirActions
  { forall (m :: * -> *). DirActions m -> String -> m Bool
doesFileExist :: FilePath -> m Bool
  , forall (m :: * -> *). DirActions m -> String -> m Bool
doesDirectoryExist :: FilePath -> m Bool
  , forall (m :: * -> *). DirActions m -> String -> m String
canonicalizePath :: FilePath -> m FilePath
  , forall (m :: * -> *). DirActions m -> m String
getCurrentDirectory :: m FilePath
  }

defaultDirActions :: DirActions IO
defaultDirActions :: DirActions IO
defaultDirActions =
  DirActions
    { doesFileExist :: String -> IO Bool
doesFileExist = String -> IO Bool
IO.doesFileExist
    , doesDirectoryExist :: String -> IO Bool
doesDirectoryExist = String -> IO Bool
IO.doesDirectoryExist
    , -- Workaround for <https://github.com/haskell/directory/issues/63>
      canonicalizePath :: String -> IO String
canonicalizePath = String -> IO String
IO.canonicalizePath (String -> IO String) -> ShowS -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropTrailingPathSeparator
    , getCurrentDirectory :: IO String
getCurrentDirectory = IO String
IO.getCurrentDirectory
    }

makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath
makeRelativeToCwd :: forall (m :: * -> *).
Applicative m =>
DirActions m -> String -> m String
makeRelativeToCwd DirActions{m String
String -> m Bool
String -> m String
doesFileExist :: forall (m :: * -> *). DirActions m -> String -> m Bool
doesDirectoryExist :: forall (m :: * -> *). DirActions m -> String -> m Bool
canonicalizePath :: forall (m :: * -> *). DirActions m -> String -> m String
getCurrentDirectory :: forall (m :: * -> *). DirActions m -> m String
doesFileExist :: String -> m Bool
doesDirectoryExist :: String -> m Bool
canonicalizePath :: String -> m String
getCurrentDirectory :: m String
..} String
path =
  String -> ShowS
makeRelativeCanonical (String -> ShowS) -> m String -> m ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> m String
canonicalizePath String
path m ShowS -> m String -> m String
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m String
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 (Int -> TargetString -> ShowS
[TargetString] -> ShowS
TargetString -> String
(Int -> TargetString -> ShowS)
-> (TargetString -> String)
-> ([TargetString] -> ShowS)
-> Show TargetString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetString -> ShowS
showsPrec :: Int -> TargetString -> ShowS
$cshow :: TargetString -> String
show :: TargetString -> String
$cshowList :: [TargetString] -> ShowS
showList :: [TargetString] -> ShowS
Show, TargetString -> TargetString -> Bool
(TargetString -> TargetString -> Bool)
-> (TargetString -> TargetString -> Bool) -> Eq TargetString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetString -> TargetString -> Bool
== :: TargetString -> TargetString -> Bool
$c/= :: TargetString -> TargetString -> Bool
/= :: TargetString -> TargetString -> Bool
Eq)

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

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

    token :: ReadP r String
token = (Char -> Bool) -> ReadP r String
forall r. (Char -> Bool) -> ReadP r String
Parse.munch1 (\Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')
    tokenQ :: ReadP r String
tokenQ = ReadP String String
forall {r}. ReadP r String
parseHaskellString ReadP String String -> ReadP r String -> ReadP r String
forall a r. ReadP a a -> ReadP r a -> ReadP r a
<++ ReadP r String
forall {r}. ReadP r String
token
    token0 :: ReadP r String
token0 = (Char -> Bool) -> ReadP r String
forall r. (Char -> Bool) -> ReadP r String
Parse.munch (\Char
x -> Bool -> Bool
not (Char -> Bool
isSpace Char
x) Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')
    tokenQ0 :: ReadP r String
tokenQ0 = ReadP String String
forall {r}. ReadP r String
parseHaskellString ReadP String String -> ReadP r String -> ReadP r String
forall a r. ReadP a a -> ReadP r a -> ReadP r a
<++ ReadP r String
forall {r}. ReadP r String
token0
    tokenEnd :: ReadP r String
tokenEnd = (Char -> Bool) -> ReadP r String
forall r. (Char -> Bool) -> ReadP r String
Parse.munch1 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':')
    tokenQEnd :: ReadP r String
tokenQEnd = ReadP String String
forall {r}. ReadP r String
parseHaskellString ReadP String String -> ReadP r String -> ReadP r String
forall a r. ReadP a a -> ReadP r a -> ReadP r a
<++ ReadP r String
forall {r}. ReadP r String
tokenEnd
    parseHaskellString :: Parse.ReadP r String
    parseHaskellString :: forall {r}. ReadP r String
parseHaskellString = ReadS String -> ReadP r String
forall a r. ReadS a -> ReadP r a
Parse.readS_to_P ReadS String
forall a. Read a => ReadS a
reads

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

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

showTargetSelectorKind :: TargetSelector -> String
showTargetSelectorKind :: TargetSelector -> String
showTargetSelectorKind TargetSelector
bt = case TargetSelector
bt of
  TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId]
_ Maybe ComponentKind
Nothing -> String
"package"
  TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId]
_ (Just ComponentKind
_) -> String
"package:filter"
  TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
_ Maybe ComponentKind
Nothing -> String
"cwd-package"
  TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
_ (Just ComponentKind
_) -> String
"cwd-package:filter"
  TargetPackageNamed PackageName
_ Maybe ComponentKind
Nothing -> String
"named-package"
  TargetPackageNamed PackageName
_ (Just ComponentKind
_) -> String
"named-package:filter"
  TargetAllPackages Maybe ComponentKind
Nothing -> String
"package *"
  TargetAllPackages (Just ComponentKind
_) -> String
"package *:filter"
  TargetComponent PackageId
_ ComponentName
_ SubComponentTarget
WholeComponent -> String
"component"
  TargetComponent PackageId
_ ComponentName
_ ModuleTarget{} -> String
"module"
  TargetComponent PackageId
_ ComponentName
_ FileTarget{} -> String
"file"
  TargetComponentUnknown PackageName
_ Either UnqualComponentName ComponentName
_ SubComponentTarget
WholeComponent -> String
"unknown-component"
  TargetComponentUnknown PackageName
_ Either UnqualComponentName ComponentName
_ ModuleTarget{} -> String
"unknown-module"
  TargetComponentUnknown PackageName
_ Either UnqualComponentName ComponentName
_ FileTarget{} -> String
"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 (TargetStringFileStatus -> TargetStringFileStatus -> Bool
(TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> (TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> Eq TargetStringFileStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
== :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
$c/= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
/= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
Eq, Eq TargetStringFileStatus
Eq TargetStringFileStatus =>
(TargetStringFileStatus -> TargetStringFileStatus -> Ordering)
-> (TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> (TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> (TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> (TargetStringFileStatus -> TargetStringFileStatus -> Bool)
-> (TargetStringFileStatus
    -> TargetStringFileStatus -> TargetStringFileStatus)
-> (TargetStringFileStatus
    -> TargetStringFileStatus -> TargetStringFileStatus)
-> Ord TargetStringFileStatus
TargetStringFileStatus -> TargetStringFileStatus -> Bool
TargetStringFileStatus -> TargetStringFileStatus -> Ordering
TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TargetStringFileStatus -> TargetStringFileStatus -> Ordering
compare :: TargetStringFileStatus -> TargetStringFileStatus -> Ordering
$c< :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
< :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
$c<= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
<= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
$c> :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
> :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
$c>= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
>= :: TargetStringFileStatus -> TargetStringFileStatus -> Bool
$cmax :: TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
max :: TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
$cmin :: TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
min :: TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
Ord, Int -> TargetStringFileStatus -> ShowS
[TargetStringFileStatus] -> ShowS
TargetStringFileStatus -> String
(Int -> TargetStringFileStatus -> ShowS)
-> (TargetStringFileStatus -> String)
-> ([TargetStringFileStatus] -> ShowS)
-> Show TargetStringFileStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetStringFileStatus -> ShowS
showsPrec :: Int -> TargetStringFileStatus -> ShowS
$cshow :: TargetStringFileStatus -> String
show :: TargetStringFileStatus -> String
$cshowList :: [TargetStringFileStatus] -> ShowS
showList :: [TargetStringFileStatus] -> ShowS
Show)

data FileStatus
  = FileStatusExistsFile FilePath -- the canonicalised filepath
  | FileStatusExistsDir FilePath -- the canonicalised filepath
  | FileStatusNotExists Bool -- does the parent dir exist even?
  deriving (FileStatus -> FileStatus -> Bool
(FileStatus -> FileStatus -> Bool)
-> (FileStatus -> FileStatus -> Bool) -> Eq FileStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FileStatus -> FileStatus -> Bool
== :: FileStatus -> FileStatus -> Bool
$c/= :: FileStatus -> FileStatus -> Bool
/= :: FileStatus -> FileStatus -> Bool
Eq, Eq FileStatus
Eq FileStatus =>
(FileStatus -> FileStatus -> Ordering)
-> (FileStatus -> FileStatus -> Bool)
-> (FileStatus -> FileStatus -> Bool)
-> (FileStatus -> FileStatus -> Bool)
-> (FileStatus -> FileStatus -> Bool)
-> (FileStatus -> FileStatus -> FileStatus)
-> (FileStatus -> FileStatus -> FileStatus)
-> Ord FileStatus
FileStatus -> FileStatus -> Bool
FileStatus -> FileStatus -> Ordering
FileStatus -> FileStatus -> FileStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: FileStatus -> FileStatus -> Ordering
compare :: FileStatus -> FileStatus -> Ordering
$c< :: FileStatus -> FileStatus -> Bool
< :: FileStatus -> FileStatus -> Bool
$c<= :: FileStatus -> FileStatus -> Bool
<= :: FileStatus -> FileStatus -> Bool
$c> :: FileStatus -> FileStatus -> Bool
> :: FileStatus -> FileStatus -> Bool
$c>= :: FileStatus -> FileStatus -> Bool
>= :: FileStatus -> FileStatus -> Bool
$cmax :: FileStatus -> FileStatus -> FileStatus
max :: FileStatus -> FileStatus -> FileStatus
$cmin :: FileStatus -> FileStatus -> FileStatus
min :: FileStatus -> FileStatus -> FileStatus
Ord, Int -> FileStatus -> ShowS
[FileStatus] -> ShowS
FileStatus -> String
(Int -> FileStatus -> ShowS)
-> (FileStatus -> String)
-> ([FileStatus] -> ShowS)
-> Show FileStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FileStatus -> ShowS
showsPrec :: Int -> FileStatus -> ShowS
$cshow :: FileStatus -> String
show :: FileStatus -> String
$cshowList :: [FileStatus] -> ShowS
showList :: [FileStatus] -> ShowS
Show)

noFileStatus :: FileStatus
noFileStatus :: FileStatus
noFileStatus = Bool -> FileStatus
FileStatusNotExists Bool
False

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

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

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

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

copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus
copyFileStatus :: TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
copyFileStatus TargetStringFileStatus
src TargetStringFileStatus
dst =
  case TargetStringFileStatus -> Maybe FileStatus
getFileStatus TargetStringFileStatus
src of
    Just FileStatus
f -> FileStatus -> TargetStringFileStatus -> TargetStringFileStatus
setFileStatus FileStatus
f TargetStringFileStatus
dst
    Maybe FileStatus
Nothing -> TargetStringFileStatus
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
-> [TargetStringFileStatus]
-> Maybe ComponentKind
-> ([TargetSelectorProblem], [TargetSelector])
resolveTargetSelectors (KnownTargets{knownPackagesAll :: KnownTargets -> [KnownPackage]
knownPackagesAll = []}) [] Maybe ComponentKind
_ =
  ([TargetSelectorProblem
TargetSelectorNoTargetsInProject], [])
-- if the component kind filter is just exes, we don't want to suggest "all" as a target.
resolveTargetSelectors (KnownTargets{knownPackagesPrimary :: KnownTargets -> [KnownPackage]
knownPackagesPrimary = []}) [] Maybe ComponentKind
ckf =
  ([Bool -> TargetSelectorProblem
TargetSelectorNoTargetsInCwd (Maybe ComponentKind
ckf Maybe ComponentKind -> Maybe ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
ExeKind)], [])
resolveTargetSelectors (KnownTargets{[KnownPackage]
knownPackagesPrimary :: KnownTargets -> [KnownPackage]
knownPackagesPrimary :: [KnownPackage]
knownPackagesPrimary}) [] Maybe ComponentKind
_ =
  ([], [TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
pkgids Maybe ComponentKind
forall a. Maybe a
Nothing])
  where
    pkgids :: [PackageId]
pkgids = [PackageId
pinfoId | KnownPackage{PackageId
pinfoId :: PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId} <- [KnownPackage]
knownPackagesPrimary]
resolveTargetSelectors KnownTargets
knowntargets [TargetStringFileStatus]
targetStrs Maybe ComponentKind
mfilter =
  [Either TargetSelectorProblem TargetSelector]
-> ([TargetSelectorProblem], [TargetSelector])
forall a b. [Either a b] -> ([a], [b])
partitionEithers
    ([Either TargetSelectorProblem TargetSelector]
 -> ([TargetSelectorProblem], [TargetSelector]))
-> ([TargetStringFileStatus]
    -> [Either TargetSelectorProblem TargetSelector])
-> [TargetStringFileStatus]
-> ([TargetSelectorProblem], [TargetSelector])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TargetStringFileStatus
 -> Either TargetSelectorProblem TargetSelector)
-> [TargetStringFileStatus]
-> [Either TargetSelectorProblem TargetSelector]
forall a b. (a -> b) -> [a] -> [b]
map (KnownTargets
-> Maybe ComponentKind
-> TargetStringFileStatus
-> Either TargetSelectorProblem TargetSelector
resolveTargetSelector KnownTargets
knowntargets Maybe ComponentKind
mfilter)
    ([TargetStringFileStatus]
 -> ([TargetSelectorProblem], [TargetSelector]))
-> [TargetStringFileStatus]
-> ([TargetSelectorProblem], [TargetSelector])
forall a b. (a -> b) -> a -> b
$ [TargetStringFileStatus]
targetStrs

resolveTargetSelector
  :: KnownTargets
  -> Maybe ComponentKindFilter
  -> TargetStringFileStatus
  -> Either TargetSelectorProblem TargetSelector
resolveTargetSelector :: KnownTargets
-> Maybe ComponentKind
-> TargetStringFileStatus
-> Either TargetSelectorProblem TargetSelector
resolveTargetSelector knowntargets :: KnownTargets
knowntargets@KnownTargets{[KnownComponent]
[KnownPackage]
knownPackagesAll :: KnownTargets -> [KnownPackage]
knownPackagesPrimary :: KnownTargets -> [KnownPackage]
knownPackagesAll :: [KnownPackage]
knownPackagesPrimary :: [KnownPackage]
knownPackagesOther :: [KnownPackage]
knownComponentsAll :: [KnownComponent]
knownComponentsPrimary :: [KnownComponent]
knownComponentsOther :: [KnownComponent]
knownPackagesOther :: KnownTargets -> [KnownPackage]
knownComponentsAll :: KnownTargets -> [KnownComponent]
knownComponentsPrimary :: KnownTargets -> [KnownComponent]
knownComponentsOther :: KnownTargets -> [KnownComponent]
..} Maybe ComponentKind
mfilter TargetStringFileStatus
targetStrStatus =
  case Match TargetSelector -> MaybeAmbiguous TargetSelector
forall a. Match a -> MaybeAmbiguous a
findMatch (TargetStringFileStatus -> Match TargetSelector
matcher TargetStringFileStatus
targetStrStatus) of
    Unambiguous TargetSelector
_
      | Bool
projectIsEmpty -> TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left TargetSelectorProblem
TargetSelectorNoTargetsInProject
    Unambiguous (TargetPackage TargetImplicitCwd
TargetImplicitCwd [] Maybe ComponentKind
_) ->
      TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left (TargetString -> TargetSelectorProblem
TargetSelectorNoCurrentPackage TargetString
targetStr)
    Unambiguous TargetSelector
target -> TargetSelector -> Either TargetSelectorProblem TargetSelector
forall a b. b -> Either a b
Right TargetSelector
target
    None [MatchError]
errs
      | Bool
projectIsEmpty -> TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left TargetSelectorProblem
TargetSelectorNoTargetsInProject
      | Bool
otherwise -> TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left ([MatchError] -> TargetSelectorProblem
classifyMatchErrors [MatchError]
errs)
    Ambiguous MatchClass
_ [TargetSelector]
targets
      | Just ComponentKind
kfilter <- Maybe ComponentKind
mfilter
      , [TargetSelector
target] <- ComponentKind -> [TargetSelector] -> [TargetSelector]
applyKindFilter ComponentKind
kfilter [TargetSelector]
targets ->
          TargetSelector -> Either TargetSelectorProblem TargetSelector
forall a b. b -> Either a b
Right TargetSelector
target
    Ambiguous MatchClass
exactMatch [TargetSelector]
targets ->
      case (TargetStringFileStatus -> Match TargetSelector)
-> TargetStringFileStatus
-> MatchClass
-> [TargetSelector]
-> Either
     [(TargetSelector, [(TargetString, [TargetSelector])])]
     [(TargetString, TargetSelector)]
disambiguateTargetSelectors
        TargetStringFileStatus -> Match TargetSelector
matcher
        TargetStringFileStatus
targetStrStatus
        MatchClass
exactMatch
        [TargetSelector]
targets of
        Right [(TargetString, TargetSelector)]
targets' -> TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left (TargetString
-> [(TargetString, TargetSelector)] -> TargetSelectorProblem
TargetSelectorAmbiguous TargetString
targetStr [(TargetString, TargetSelector)]
targets')
        Left ((TargetSelector
m, [(TargetString, [TargetSelector])]
ms) : [(TargetSelector, [(TargetString, [TargetSelector])])]
_) -> TargetSelectorProblem
-> Either TargetSelectorProblem TargetSelector
forall a b. a -> Either a b
Left (TargetString
-> TargetSelector
-> [(TargetString, [TargetSelector])]
-> TargetSelectorProblem
MatchingInternalError TargetString
targetStr TargetSelector
m [(TargetString, [TargetSelector])]
ms)
        Left [] -> String -> Either TargetSelectorProblem TargetSelector
forall a. String -> a
internalError String
"resolveTargetSelector"
  where
    matcher :: TargetStringFileStatus -> Match TargetSelector
matcher = KnownTargets -> TargetStringFileStatus -> Match TargetSelector
matchTargetSelector KnownTargets
knowntargets

    targetStr :: TargetString
targetStr = TargetStringFileStatus -> TargetString
forgetFileStatus TargetStringFileStatus
targetStrStatus

    projectIsEmpty :: Bool
projectIsEmpty = [KnownPackage] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [KnownPackage]
knownPackagesAll

    classifyMatchErrors :: [MatchError] -> TargetSelectorProblem
classifyMatchErrors [MatchError]
errs
      | Just NonEmpty (String, String)
expectedNE <- [(String, String)] -> Maybe (NonEmpty (String, String))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [(String, String)]
expected =
          let (NonEmpty String
things, String
got :| [String]
_) = NonEmpty (String, String) -> (NonEmpty String, NonEmpty String)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
UZ.unzip NonEmpty (String, String)
expectedNE
           in TargetString -> [String] -> String -> TargetSelectorProblem
TargetSelectorExpected TargetString
targetStr (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty String
things) String
got
      | Bool -> Bool
not ([(Maybe (String, String), String, String, [String])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe (String, String), String, String, [String])]
nosuch) =
          TargetString
-> [(Maybe (String, String), String, String, [String])]
-> TargetSelectorProblem
TargetSelectorNoSuch TargetString
targetStr [(Maybe (String, String), String, String, [String])]
nosuch
      | Bool
otherwise =
          String -> TargetSelectorProblem
forall a. String -> a
internalError (String -> TargetSelectorProblem)
-> String -> TargetSelectorProblem
forall a b. (a -> b) -> a -> b
$ String
"classifyMatchErrors: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [MatchError] -> String
forall a. Show a => a -> String
show [MatchError]
errs
      where
        expected :: [(String, String)]
expected =
          [ (String
thing, String
got)
          | (Maybe (String, String)
_, MatchErrorExpected String
thing String
got) <-
              (MatchError -> (Maybe (String, String), MatchError))
-> [MatchError] -> [(Maybe (String, String), MatchError)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (String, String)
-> MatchError -> (Maybe (String, String), MatchError)
innerErr Maybe (String, String)
forall a. Maybe a
Nothing) [MatchError]
errs
          ]
        -- Trim the list of alternatives by dropping duplicates and
        -- retaining only at most three most similar (by edit distance) ones.
        nosuch :: [(Maybe (String, String), String, String, [String])]
nosuch =
          ((Maybe (String, String), String, String)
 -> Set String
 -> [(Maybe (String, String), String, String, [String])]
 -> [(Maybe (String, String), String, String, [String])])
-> [(Maybe (String, String), String, String, [String])]
-> Map (Maybe (String, String), String, String) (Set String)
-> [(Maybe (String, String), String, String, [String])]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (Maybe (String, String), String, String)
-> Set String
-> [(Maybe (String, String), String, String, [String])]
-> [(Maybe (String, String), String, String, [String])]
forall {a} {b}.
(a, b, String)
-> Set String
-> [(a, b, String, [String])]
-> [(a, b, String, [String])]
genResults [] (Map (Maybe (String, String), String, String) (Set String)
 -> [(Maybe (String, String), String, String, [String])])
-> Map (Maybe (String, String), String, String) (Set String)
-> [(Maybe (String, String), String, String, [String])]
forall a b. (a -> b) -> a -> b
$
            (Set String -> Set String -> Set String)
-> [((Maybe (String, String), String, String), Set String)]
-> Map (Maybe (String, String), String, String) (Set String)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([((Maybe (String, String), String, String), Set String)]
 -> Map (Maybe (String, String), String, String) (Set String))
-> [((Maybe (String, String), String, String), Set String)]
-> Map (Maybe (String, String), String, String) (Set String)
forall a b. (a -> b) -> a -> b
$
              [ ((Maybe (String, String)
inside, String
thing, String
got), [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
alts)
              | (Maybe (String, String)
inside, MatchErrorNoSuch String
thing String
got [String]
alts) <-
                  (MatchError -> (Maybe (String, String), MatchError))
-> [MatchError] -> [(Maybe (String, String), MatchError)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (String, String)
-> MatchError -> (Maybe (String, String), MatchError)
innerErr Maybe (String, String)
forall a. Maybe a
Nothing) [MatchError]
errs
              ]

        genResults :: (a, b, String)
-> Set String
-> [(a, b, String, [String])]
-> [(a, b, String, [String])]
genResults (a
inside, b
thing, String
got) Set String
alts [(a, b, String, [String])]
acc =
          ( a
inside
          , b
thing
          , String
got
          , Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
maxResults ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
              ((String, Int) -> String) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Int) -> String
forall a b. (a, b) -> a
fst ([(String, Int)] -> [String]) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> a -> b
$
                ((String, Int) -> Bool) -> [(String, Int)] -> [(String, Int)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (String, Int) -> Bool
forall {a}. (a, Int) -> Bool
distanceLow ([(String, Int)] -> [(String, Int)])
-> [(String, Int)] -> [(String, Int)]
forall a b. (a -> b) -> a -> b
$
                  ((String, Int) -> (String, Int) -> Ordering)
-> [(String, Int)] -> [(String, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, Int) -> Int)
-> (String, Int) -> (String, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (String, Int) -> Int
forall a b. (a, b) -> b
snd) ([(String, Int)] -> [(String, Int)])
-> [(String, Int)] -> [(String, Int)]
forall a b. (a -> b) -> a -> b
$
                    (String -> (String, Int)) -> [String] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
map String -> (String, Int)
addLevDist ([String] -> [(String, Int)]) -> [String] -> [(String, Int)]
forall a b. (a -> b) -> a -> b
$
                      Set String -> [String]
forall a. Set a -> [a]
Set.toList Set String
alts
          )
            (a, b, String, [String])
-> [(a, b, String, [String])] -> [(a, b, String, [String])]
forall a. a -> [a] -> [a]
: [(a, b, String, [String])]
acc
          where
            addLevDist :: String -> (String, Int)
addLevDist =
              ShowS
forall a. a -> a
id
                ShowS -> (String -> Int) -> String -> (String, Int)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& EditCosts -> String -> String -> Int
restrictedDamerauLevenshteinDistance
                  EditCosts
defaultEditCosts
                  String
got

            distanceLow :: (a, Int) -> Bool
distanceLow (a
_, Int
dist) = Int
dist Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
got Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2

            maxResults :: Int
maxResults = Int
3

        innerErr :: Maybe (String, String)
-> MatchError -> (Maybe (String, String), MatchError)
innerErr Maybe (String, String)
_ (MatchErrorIn String
kind String
thing MatchError
m) =
          Maybe (String, String)
-> MatchError -> (Maybe (String, String), MatchError)
innerErr ((String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
kind, String
thing)) MatchError
m
        innerErr Maybe (String, String)
c MatchError
m = (Maybe (String, String)
c, MatchError
m)

    applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]
    applyKindFilter :: ComponentKind -> [TargetSelector] -> [TargetSelector]
applyKindFilter ComponentKind
kfilter = (TargetSelector -> Bool) -> [TargetSelector] -> [TargetSelector]
forall a. (a -> Bool) -> [a] -> [a]
filter TargetSelector -> Bool
go
      where
        go :: TargetSelector -> Bool
go (TargetPackage TargetImplicitCwd
_ [PackageId]
_ (Just ComponentKind
filter')) = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
filter'
        go (TargetPackageNamed PackageName
_ (Just ComponentKind
filter')) = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
filter'
        go (TargetAllPackages (Just ComponentKind
filter')) = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
filter'
        go (TargetComponent PackageId
_ ComponentName
cname SubComponentTarget
_)
          | CLibName LibraryName
_ <- ComponentName
cname = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
LibKind
          | CFLibName UnqualComponentName
_ <- ComponentName
cname = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
FLibKind
          | CExeName UnqualComponentName
_ <- ComponentName
cname = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
ExeKind
          | CTestName UnqualComponentName
_ <- ComponentName
cname = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
TestKind
          | CBenchName UnqualComponentName
_ <- ComponentName
cname = ComponentKind
kfilter ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
== ComponentKind
BenchKind
        go TargetSelector
_ = Bool
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 (Int -> TargetSelectorProblem -> ShowS
[TargetSelectorProblem] -> ShowS
TargetSelectorProblem -> String
(Int -> TargetSelectorProblem -> ShowS)
-> (TargetSelectorProblem -> String)
-> ([TargetSelectorProblem] -> ShowS)
-> Show TargetSelectorProblem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TargetSelectorProblem -> ShowS
showsPrec :: Int -> TargetSelectorProblem -> ShowS
$cshow :: TargetSelectorProblem -> String
show :: TargetSelectorProblem -> String
$cshowList :: [TargetSelectorProblem] -> ShowS
showList :: [TargetSelectorProblem] -> ShowS
Show, TargetSelectorProblem -> TargetSelectorProblem -> Bool
(TargetSelectorProblem -> TargetSelectorProblem -> Bool)
-> (TargetSelectorProblem -> TargetSelectorProblem -> Bool)
-> Eq TargetSelectorProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetSelectorProblem -> TargetSelectorProblem -> Bool
== :: TargetSelectorProblem -> TargetSelectorProblem -> Bool
$c/= :: TargetSelectorProblem -> TargetSelectorProblem -> Bool
/= :: TargetSelectorProblem -> TargetSelectorProblem -> Bool
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 (QualLevel -> QualLevel -> Bool
(QualLevel -> QualLevel -> Bool)
-> (QualLevel -> QualLevel -> Bool) -> Eq QualLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QualLevel -> QualLevel -> Bool
== :: QualLevel -> QualLevel -> Bool
$c/= :: QualLevel -> QualLevel -> Bool
/= :: QualLevel -> QualLevel -> Bool
Eq, Int -> QualLevel
QualLevel -> Int
QualLevel -> [QualLevel]
QualLevel -> QualLevel
QualLevel -> QualLevel -> [QualLevel]
QualLevel -> QualLevel -> QualLevel -> [QualLevel]
(QualLevel -> QualLevel)
-> (QualLevel -> QualLevel)
-> (Int -> QualLevel)
-> (QualLevel -> Int)
-> (QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> [QualLevel])
-> (QualLevel -> QualLevel -> QualLevel -> [QualLevel])
-> Enum QualLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: QualLevel -> QualLevel
succ :: QualLevel -> QualLevel
$cpred :: QualLevel -> QualLevel
pred :: QualLevel -> QualLevel
$ctoEnum :: Int -> QualLevel
toEnum :: Int -> QualLevel
$cfromEnum :: QualLevel -> Int
fromEnum :: QualLevel -> Int
$cenumFrom :: QualLevel -> [QualLevel]
enumFrom :: QualLevel -> [QualLevel]
$cenumFromThen :: QualLevel -> QualLevel -> [QualLevel]
enumFromThen :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromTo :: QualLevel -> QualLevel -> [QualLevel]
enumFromTo :: QualLevel -> QualLevel -> [QualLevel]
$cenumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
enumFromThenTo :: QualLevel -> QualLevel -> QualLevel -> [QualLevel]
Enum, Int -> QualLevel -> ShowS
[QualLevel] -> ShowS
QualLevel -> String
(Int -> QualLevel -> ShowS)
-> (QualLevel -> String)
-> ([QualLevel] -> ShowS)
-> Show QualLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QualLevel -> ShowS
showsPrec :: Int -> QualLevel -> ShowS
$cshow :: QualLevel -> String
show :: QualLevel -> String
$cshowList :: [QualLevel] -> ShowS
showList :: [QualLevel] -> ShowS
Show)

disambiguateTargetSelectors
  :: (TargetStringFileStatus -> Match TargetSelector)
  -> TargetStringFileStatus
  -> MatchClass
  -> [TargetSelector]
  -> Either
      [(TargetSelector, [(TargetString, [TargetSelector])])]
      [(TargetString, TargetSelector)]
disambiguateTargetSelectors :: (TargetStringFileStatus -> Match TargetSelector)
-> TargetStringFileStatus
-> MatchClass
-> [TargetSelector]
-> Either
     [(TargetSelector, [(TargetString, [TargetSelector])])]
     [(TargetString, TargetSelector)]
disambiguateTargetSelectors TargetStringFileStatus -> Match TargetSelector
matcher TargetStringFileStatus
matchInput MatchClass
exactMatch [TargetSelector]
matchResults =
  case [Either
   (TargetSelector, [(TargetString, [TargetSelector])])
   (TargetString, TargetSelector)]
-> ([(TargetSelector, [(TargetString, [TargetSelector])])],
    [(TargetString, TargetSelector)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either
   (TargetSelector, [(TargetString, [TargetSelector])])
   (TargetString, TargetSelector)]
results of
    (errs :: [(TargetSelector, [(TargetString, [TargetSelector])])]
errs@((TargetSelector, [(TargetString, [TargetSelector])])
_ : [(TargetSelector, [(TargetString, [TargetSelector])])]
_), [(TargetString, TargetSelector)]
_) -> [(TargetSelector, [(TargetString, [TargetSelector])])]
-> Either
     [(TargetSelector, [(TargetString, [TargetSelector])])]
     [(TargetString, TargetSelector)]
forall a b. a -> Either a b
Left [(TargetSelector, [(TargetString, [TargetSelector])])]
errs
    ([], [(TargetString, TargetSelector)]
ok) -> [(TargetString, TargetSelector)]
-> Either
     [(TargetSelector, [(TargetString, [TargetSelector])])]
     [(TargetString, TargetSelector)]
forall a b. b -> Either a b
Right [(TargetString, TargetSelector)]
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 :: [(TargetSelector, [TargetStringFileStatus])]
matchResultsRenderings =
      [ (TargetSelector
matchResult, [TargetStringFileStatus]
matchRenderings)
      | TargetSelector
matchResult <- [TargetSelector]
matchResults
      , let matchRenderings :: [TargetStringFileStatus]
matchRenderings =
              [ TargetStringFileStatus
-> TargetStringFileStatus -> TargetStringFileStatus
copyFileStatus TargetStringFileStatus
matchInput TargetStringFileStatus
rendering
              | QualLevel
ql <- [QualLevel
QL1 .. QualLevel
QLFull]
              , TargetStringFileStatus
rendering <- QualLevel -> TargetSelector -> [TargetStringFileStatus]
renderTargetSelector QualLevel
ql TargetSelector
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 :: Map TargetStringFileStatus (Match TargetSelector)
memoisedMatches =
      -- avoid recomputing the main one if it was an exact match
      ( if MatchClass
exactMatch MatchClass -> MatchClass -> Bool
forall a. Eq a => a -> a -> Bool
== MatchClass
Exact
          then TargetStringFileStatus
-> Match TargetSelector
-> Map TargetStringFileStatus (Match TargetSelector)
-> Map TargetStringFileStatus (Match TargetSelector)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert TargetStringFileStatus
matchInput (MatchClass -> Int -> [TargetSelector] -> Match TargetSelector
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Exact Int
0 [TargetSelector]
matchResults)
          else Map TargetStringFileStatus (Match TargetSelector)
-> Map TargetStringFileStatus (Match TargetSelector)
forall a. a -> a
id
      )
        (Map TargetStringFileStatus (Match TargetSelector)
 -> Map TargetStringFileStatus (Match TargetSelector))
-> Map TargetStringFileStatus (Match TargetSelector)
-> Map TargetStringFileStatus (Match TargetSelector)
forall a b. (a -> b) -> a -> b
$ [(TargetStringFileStatus, Match TargetSelector)]
-> Map TargetStringFileStatus (Match TargetSelector)
forall k a. Ord k => [(k, a)] -> Map k a
Map.Lazy.fromList
          -- (matcher rendering) should *always* be a Match! Otherwise we will hit
          -- the internal error later on.
          [ (TargetStringFileStatus
rendering, TargetStringFileStatus -> Match TargetSelector
matcher TargetStringFileStatus
rendering)
          | TargetStringFileStatus
rendering <- ((TargetSelector, [TargetStringFileStatus])
 -> [TargetStringFileStatus])
-> [(TargetSelector, [TargetStringFileStatus])]
-> [TargetStringFileStatus]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TargetSelector, [TargetStringFileStatus])
-> [TargetStringFileStatus]
forall a b. (a, b) -> b
snd [(TargetSelector, [TargetStringFileStatus])]
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 :: [Either
   (TargetSelector, [(TargetString, [TargetSelector])])
   (TargetString, TargetSelector)]
results =
      [ case TargetSelector
-> [TargetStringFileStatus] -> Maybe TargetStringFileStatus
findUnambiguous TargetSelector
originalMatch [TargetStringFileStatus]
matchRenderings of
        Just TargetStringFileStatus
unambiguousRendering ->
          (TargetString, TargetSelector)
-> Either
     (TargetSelector, [(TargetString, [TargetSelector])])
     (TargetString, TargetSelector)
forall a b. b -> Either a b
Right
            ( TargetStringFileStatus -> TargetString
forgetFileStatus TargetStringFileStatus
unambiguousRendering
            , TargetSelector
originalMatch
            )
        -- This case is an internal error, but we bubble it up and report it
        Maybe TargetStringFileStatus
Nothing ->
          (TargetSelector, [(TargetString, [TargetSelector])])
-> Either
     (TargetSelector, [(TargetString, [TargetSelector])])
     (TargetString, TargetSelector)
forall a b. a -> Either a b
Left
            ( TargetSelector
originalMatch
            , [ (TargetStringFileStatus -> TargetString
forgetFileStatus TargetStringFileStatus
rendering, [TargetSelector]
matches)
              | TargetStringFileStatus
rendering <- [TargetStringFileStatus]
matchRenderings
              , let Match MatchClass
m Int
_ [TargetSelector]
matches =
                      Map TargetStringFileStatus (Match TargetSelector)
memoisedMatches Map TargetStringFileStatus (Match TargetSelector)
-> TargetStringFileStatus -> Match TargetSelector
forall k a. Ord k => Map k a -> k -> a
Map.! TargetStringFileStatus
rendering
              , MatchClass
m MatchClass -> MatchClass -> Bool
forall a. Eq a => a -> a -> Bool
/= MatchClass
Inexact
              ]
            )
      | (TargetSelector
originalMatch, [TargetStringFileStatus]
matchRenderings) <- [(TargetSelector, [TargetStringFileStatus])]
matchResultsRenderings
      ]

    findUnambiguous
      :: TargetSelector
      -> [TargetStringFileStatus]
      -> Maybe TargetStringFileStatus
    findUnambiguous :: TargetSelector
-> [TargetStringFileStatus] -> Maybe TargetStringFileStatus
findUnambiguous TargetSelector
_ [] = Maybe TargetStringFileStatus
forall a. Maybe a
Nothing
    findUnambiguous TargetSelector
t (TargetStringFileStatus
r : [TargetStringFileStatus]
rs) =
      case Map TargetStringFileStatus (Match TargetSelector)
memoisedMatches Map TargetStringFileStatus (Match TargetSelector)
-> TargetStringFileStatus -> Match TargetSelector
forall k a. Ord k => Map k a -> k -> a
Map.! TargetStringFileStatus
r of
        Match MatchClass
Exact Int
_ [TargetSelector
t']
          | TargetSelector
t TargetSelector -> TargetSelector -> Bool
forall a. Eq a => a -> a -> Bool
== TargetSelector
t' ->
              TargetStringFileStatus -> Maybe TargetStringFileStatus
forall a. a -> Maybe a
Just TargetStringFileStatus
r
        Match MatchClass
Exact Int
_ [TargetSelector]
_ -> TargetSelector
-> [TargetStringFileStatus] -> Maybe TargetStringFileStatus
findUnambiguous TargetSelector
t [TargetStringFileStatus]
rs
        Match MatchClass
Unknown Int
_ [TargetSelector]
_ -> TargetSelector
-> [TargetStringFileStatus] -> Maybe TargetStringFileStatus
findUnambiguous TargetSelector
t [TargetStringFileStatus]
rs
        Match MatchClass
Inexact Int
_ [TargetSelector]
_ -> String -> Maybe TargetStringFileStatus
forall a. String -> a
internalError String
"Match Inexact"
        NoMatch Int
_ [MatchError]
_ -> String -> Maybe TargetStringFileStatus
forall a. String -> a
internalError String
"NoMatch"

internalError :: String -> a
internalError :: forall a. String -> a
internalError String
msg =
  String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"TargetSelector: internal error: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg

-- | Throw an exception with a formatted message if there are any problems.
reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems :: forall a. Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems Verbosity
verbosity [TargetSelectorProblem]
problems = do
  case [String
str | TargetSelectorUnrecognised String
str <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [String]
targets -> Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> CabalInstallException
ReportTargetSelectorProblems [String]
targets

  case [(TargetString
t, TargetSelector
m, [(TargetString, [TargetSelector])]
ms) | MatchingInternalError TargetString
t TargetSelector
m [(TargetString, [TargetSelector])]
ms <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ((TargetString
target, TargetSelector
originalMatch, [(TargetString, [TargetSelector])]
renderingsAndMatches) : [(TargetString, TargetSelector,
  [(TargetString, [TargetSelector])])]
_) ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity
        (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String
-> String
-> String
-> [(String, [String])]
-> CabalInstallException
MatchingInternalErrorErr
          (TargetString -> String
showTargetString TargetString
target)
          (TargetSelector -> String
showTargetSelector TargetSelector
originalMatch)
          (TargetSelector -> String
showTargetSelectorKind TargetSelector
originalMatch)
        ([(String, [String])] -> CabalInstallException)
-> [(String, [String])] -> CabalInstallException
forall a b. (a -> b) -> a -> b
$ ((TargetString, [TargetSelector]) -> (String, [String]))
-> [(TargetString, [TargetSelector])] -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \(TargetString
rendering, [TargetSelector]
matches) ->
              ( TargetString -> String
showTargetString TargetString
rendering
              , ((TargetSelector -> String) -> [TargetSelector] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\TargetSelector
match -> TargetSelector -> String
showTargetSelector TargetSelector
match String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelectorKind TargetSelector
match String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")") [TargetSelector]
matches)
              )
          )
          [(TargetString, [TargetSelector])]
renderingsAndMatches

  case [(TargetString
t, [String]
e, String
g) | TargetSelectorExpected TargetString
t [String]
e String
g <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(TargetString, [String], String)]
targets ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(String, [String], String)] -> CabalInstallException
UnrecognisedTarget ([(String, [String], String)] -> CabalInstallException)
-> [(String, [String], String)] -> CabalInstallException
forall a b. (a -> b) -> a -> b
$
          ((TargetString, [String], String) -> (String, [String], String))
-> [(TargetString, [String], String)]
-> [(String, [String], String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TargetString
target, [String]
expected, String
got) -> (TargetString -> String
showTargetString TargetString
target, [String]
expected, String
got)) [(TargetString, [String], String)]
targets

  case [(TargetString
t, [(Maybe (String, String), String, String, [String])]
e) | TargetSelectorNoSuch TargetString
t [(Maybe (String, String), String, String, [String])]
e <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(TargetString,
  [(Maybe (String, String), String, String, [String])])]
targets ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(String, [(Maybe (String, String), String, String, [String])])]
-> CabalInstallException
NoSuchTargetSelectorErr ([(String, [(Maybe (String, String), String, String, [String])])]
 -> CabalInstallException)
-> [(String, [(Maybe (String, String), String, String, [String])])]
-> CabalInstallException
forall a b. (a -> b) -> a -> b
$
          ((TargetString,
  [(Maybe (String, String), String, String, [String])])
 -> (String, [(Maybe (String, String), String, String, [String])]))
-> [(TargetString,
     [(Maybe (String, String), String, String, [String])])]
-> [(String, [(Maybe (String, String), String, String, [String])])]
forall a b. (a -> b) -> [a] -> [b]
map (\(TargetString
target, [(Maybe (String, String), String, String, [String])]
nosuch) -> (TargetString -> String
showTargetString TargetString
target, [(Maybe (String, String), String, String, [String])]
nosuch)) [(TargetString,
  [(Maybe (String, String), String, String, [String])])]
targets

  case [(TargetString
t, [(TargetString, TargetSelector)]
ts) | TargetSelectorAmbiguous TargetString
t [(TargetString, TargetSelector)]
ts <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    [(TargetString, [(TargetString, TargetSelector)])]
targets ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$
        [(String, [(String, String)])] -> CabalInstallException
TargetSelectorAmbiguousErr ([(String, [(String, String)])] -> CabalInstallException)
-> [(String, [(String, String)])] -> CabalInstallException
forall a b. (a -> b) -> a -> b
$
          ((TargetString, [(TargetString, TargetSelector)])
 -> (String, [(String, String)]))
-> [(TargetString, [(TargetString, TargetSelector)])]
-> [(String, [(String, String)])]
forall a b. (a -> b) -> [a] -> [b]
map
            ( \(TargetString
target, [(TargetString, TargetSelector)]
amb) ->
                ( TargetString -> String
showTargetString TargetString
target
                , (((TargetString, TargetSelector) -> (String, String))
-> [(TargetString, TargetSelector)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TargetString
ut, TargetSelector
bt) -> (TargetString -> String
showTargetString TargetString
ut, TargetSelector -> String
showTargetSelectorKind TargetSelector
bt)) [(TargetString, TargetSelector)]
amb)
                )
            )
            [(TargetString, [(TargetString, TargetSelector)])]
targets

  case [TargetString
t | TargetSelectorNoCurrentPackage TargetString
t <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TargetString
target : [TargetString]
_ ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
TargetSelectorNoCurrentPackageErr (TargetString -> String
showTargetString TargetString
target)

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

  case [() | TargetSelectorNoTargetsInCwd Bool
True <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ()
_ : [()]
_ ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
TargetSelectorNoTargetsInCwdTrue

  case [() | TargetSelectorNoTargetsInCwd Bool
False <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ()
_ : [()]
_ ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
TargetSelectorNoTargetsInCwdFalse

  case [() | TargetSelectorProblem
TargetSelectorNoTargetsInProject <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ()
_ : [()]
_ ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
TargetSelectorNoTargetsInProjectErr

  case [TargetString
t | TargetSelectorNoScript TargetString
t <- [TargetSelectorProblem]
problems] of
    [] -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    TargetString
target : [TargetString]
_ ->
      Verbosity -> CabalInstallException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ()) -> CabalInstallException -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
TargetSelectorNoScriptErr (TargetString -> String
showTargetString TargetString
target)

  String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 :: forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (QualLevel
    -> (TargetStringFileStatus -> Match TargetSelector)
    -> (TargetSelector -> [TargetStringFileStatus])
    -> a)
-> Syntax
-> a
foldSyntax a -> a -> a
ambiguous a -> a -> a
unambiguous QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> a
syntax = Syntax -> a
go
  where
    go :: Syntax -> a
go (Syntax QualLevel
ql TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render) = QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> a
syntax QualLevel
ql TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
    go (AmbiguousAlternatives Syntax
a Syntax
b) = a -> a -> a
ambiguous (Syntax -> a
go Syntax
a) (Syntax -> a
go Syntax
b)
    go (ShadowingAlternatives Syntax
a Syntax
b) = a -> a -> a
unambiguous (Syntax -> a
go Syntax
a) (Syntax -> a
go Syntax
b)

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

renderTargetSelector
  :: QualLevel
  -> TargetSelector
  -> [TargetStringFileStatus]
renderTargetSelector :: QualLevel -> TargetSelector -> [TargetStringFileStatus]
renderTargetSelector QualLevel
ql TargetSelector
ts =
  ([TargetStringFileStatus]
 -> [TargetStringFileStatus] -> [TargetStringFileStatus])
-> ([TargetStringFileStatus]
    -> [TargetStringFileStatus] -> [TargetStringFileStatus])
-> (QualLevel
    -> (TargetStringFileStatus -> Match TargetSelector)
    -> (TargetSelector -> [TargetStringFileStatus])
    -> [TargetStringFileStatus])
-> Syntax
-> [TargetStringFileStatus]
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (QualLevel
    -> (TargetStringFileStatus -> Match TargetSelector)
    -> (TargetSelector -> [TargetStringFileStatus])
    -> a)
-> Syntax
-> a
foldSyntax
    [TargetStringFileStatus]
-> [TargetStringFileStatus] -> [TargetStringFileStatus]
forall a. [a] -> [a] -> [a]
(++)
    [TargetStringFileStatus]
-> [TargetStringFileStatus] -> [TargetStringFileStatus]
forall a. [a] -> [a] -> [a]
(++)
    (\QualLevel
ql' TargetStringFileStatus -> Match TargetSelector
_ TargetSelector -> [TargetStringFileStatus]
render -> Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualLevel
ql QualLevel -> QualLevel -> Bool
forall a. Eq a => a -> a -> Bool
== QualLevel
ql') [()] -> [TargetStringFileStatus] -> [TargetStringFileStatus]
forall a b. [a] -> [b] -> [b]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TargetSelector -> [TargetStringFileStatus]
render TargetSelector
ts)
    Syntax
syntax
  where
    syntax :: Syntax
syntax = KnownTargets -> Syntax
syntaxForms KnownTargets
emptyKnownTargets

-- don't need known targets for rendering

matchTargetSelector
  :: KnownTargets
  -> TargetStringFileStatus
  -> Match TargetSelector
matchTargetSelector :: KnownTargets -> TargetStringFileStatus -> Match TargetSelector
matchTargetSelector KnownTargets
knowntargets = \TargetStringFileStatus
usertarget ->
  (TargetSelector -> TargetSelector -> Bool)
-> Match TargetSelector -> Match TargetSelector
forall a. (a -> a -> Bool) -> Match a -> Match a
nubMatchesBy TargetSelector -> TargetSelector -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$
    let ql :: QualLevel
ql = TargetStringFileStatus -> QualLevel
targetQualLevel TargetStringFileStatus
usertarget
     in (Match TargetSelector
 -> Match TargetSelector -> Match TargetSelector)
-> (Match TargetSelector
    -> Match TargetSelector -> Match TargetSelector)
-> (QualLevel
    -> (TargetStringFileStatus -> Match TargetSelector)
    -> (TargetSelector -> [TargetStringFileStatus])
    -> Match TargetSelector)
-> Syntax
-> Match TargetSelector
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (QualLevel
    -> (TargetStringFileStatus -> Match TargetSelector)
    -> (TargetSelector -> [TargetStringFileStatus])
    -> a)
-> Syntax
-> a
foldSyntax
          Match TargetSelector
-> Match TargetSelector -> Match TargetSelector
forall a. Match a -> Match a -> Match a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>)
          Match TargetSelector
-> Match TargetSelector -> Match TargetSelector
forall a. Match a -> Match a -> Match a
(<//>)
          (\QualLevel
ql' TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
_ -> Bool -> Match ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (QualLevel
ql QualLevel -> QualLevel -> Bool
forall a. Eq a => a -> a -> Bool
== QualLevel
ql') Match () -> Match TargetSelector -> Match TargetSelector
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TargetStringFileStatus -> Match TargetSelector
match TargetStringFileStatus
usertarget)
          Syntax
syntax
  where
    syntax :: Syntax
syntax = KnownTargets -> Syntax
syntaxForms KnownTargets
knowntargets

    targetQualLevel :: TargetStringFileStatus -> QualLevel
targetQualLevel TargetStringFileStatus1{} = QualLevel
QL1
    targetQualLevel TargetStringFileStatus2{} = QualLevel
QL2
    targetQualLevel TargetStringFileStatus3{} = QualLevel
QL3
    targetQualLevel TargetStringFileStatus4{} = QualLevel
QLFull
    targetQualLevel TargetStringFileStatus5{} = QualLevel
QLFull
    targetQualLevel TargetStringFileStatus7{} = QualLevel
QLFull

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

-- | All the forms of syntax for 'TargetSelector'.
syntaxForms :: KnownTargets -> Syntax
syntaxForms :: KnownTargets -> Syntax
syntaxForms
  KnownTargets
    { knownPackagesAll :: KnownTargets -> [KnownPackage]
knownPackagesAll = [KnownPackage]
pinfo
    , knownPackagesPrimary :: KnownTargets -> [KnownPackage]
knownPackagesPrimary = [KnownPackage]
ppinfo
    , knownComponentsAll :: KnownTargets -> [KnownComponent]
knownComponentsAll = [KnownComponent]
cinfo
    , knownComponentsPrimary :: KnownTargets -> [KnownComponent]
knownComponentsPrimary = [KnownComponent]
pcinfo
    , knownComponentsOther :: KnownTargets -> [KnownComponent]
knownComponentsOther = [KnownComponent]
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".

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

-- | Syntax: "all" to select all packages in the project
--
-- > cabal build all
syntaxForm1All :: Syntax
syntaxForm1All :: Syntax
syntaxForm1All =
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 -> do
    String -> Match ()
guardMetaAll String
str1
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComponentKind -> TargetSelector
TargetAllPackages Maybe ComponentKind
forall a. Maybe a
Nothing)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetAllPackages Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 String
"all" FileStatus
noFileStatus]
    render TargetSelector
_ = []

-- | Syntax: filter
--
-- > cabal build tests
syntaxForm1Filter :: [KnownPackage] -> Syntax
syntaxForm1Filter :: [KnownPackage] -> Syntax
syntaxForm1Filter [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 -> do
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str1
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
pids (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    pids :: [PackageId]
pids = [PackageId
pinfoId | KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} <- [KnownPackage]
ps]
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
_ (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 (ComponentKind -> String
dispF ComponentKind
kfilter) FileStatus
noFileStatus]
    render TargetSelector
_ = []

-- | Syntax: package (name, dir or file)
--
-- > cabal build foo
-- > cabal build ../bar ../bar/bar.cabal
syntaxForm1Package :: [KnownPackage] -> Syntax
syntaxForm1Package :: [KnownPackage] -> Syntax
syntaxForm1Package [KnownPackage]
pinfo =
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
pinfo String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] Maybe ComponentKind
forall a. Maybe a
Nothing)
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn Maybe ComponentKind
forall a. Maybe a
Nothing)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus]
    render (TargetPackageNamed PackageName
pn Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus]
    render TargetSelector
_ = []

-- | Syntax: component
--
-- > cabal build foo
syntaxForm1Component :: [KnownComponent] -> Syntax
syntaxForm1Component :: [KnownComponent] -> Syntax
syntaxForm1Component [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 -> do
    String -> Match ()
guardComponentName String
str1
    KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
cs String
str1
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c) (KnownComponent -> ComponentName
cinfoName KnownComponent
c) SubComponentTarget
WholeComponent)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) FileStatus
noFileStatus]
    render TargetSelector
_ = []

-- | Syntax: module
--
-- > cabal build Data.Foo
syntaxForm1Module :: [KnownComponent] -> Syntax
syntaxForm1Module :: [KnownComponent] -> Syntax
syntaxForm1Module [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 -> do
    String -> Match ()
guardModuleName String
str1
    let ms :: [(ModuleName, KnownComponent)]
ms = [(ModuleName
m, KnownComponent
c) | KnownComponent
c <- [KnownComponent]
cs, ModuleName
m <- KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c]
    (ModuleName
m, KnownComponent
c) <- [(ModuleName, KnownComponent)]
-> String -> Match (ModuleName, KnownComponent)
forall a. [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd [(ModuleName, KnownComponent)]
ms String
str1
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c) (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
_p ComponentName
_c (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 (ModuleName -> String
dispM ModuleName
m) FileStatus
noFileStatus]
    render TargetSelector
_ = []

-- | Syntax: file name
--
-- > cabal build Data/Foo.hs bar/Main.hsc
syntaxForm1File :: [KnownPackage] -> Syntax
syntaxForm1File :: [KnownPackage] -> Syntax
syntaxForm1File [KnownPackage]
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.
  (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render (Match1 -> Syntax) -> Match1 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 ->
    String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
expecting String
"file" String
str1 (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
      (String
pkgfile, ~KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents}) <-
        -- always returns the KnownPackage case
        [KnownPackage] -> FileStatus -> Match (String, KnownPackage)
matchPackageDirectoryPrefix [KnownPackage]
ps FileStatus
fstatus1
      String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
        (String
filepath, KnownComponent
c) <- [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent]
pinfoComponents String
pkgfile
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (String -> SubComponentTarget
FileTarget String
filepath))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
_p ComponentName
_c (FileTarget String
f)) =
      [String -> FileStatus -> TargetStringFileStatus
TargetStringFileStatus1 String
f FileStatus
noFileStatus]
    render TargetSelector
_ = []

---

-- | Syntax:  :all
--
-- > cabal build :all
syntaxForm2MetaAll :: Syntax
syntaxForm2MetaAll :: Syntax
syntaxForm2MetaAll =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardMetaAll String
str2
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComponentKind -> TargetSelector
TargetAllPackages Maybe ComponentKind
forall a. Maybe a
Nothing)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetAllPackages Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 String
"" FileStatus
noFileStatus String
"all"]
    render TargetSelector
_ = []

-- | Syntax:  all : filer
--
-- > cabal build all:tests
syntaxForm2AllFilter :: Syntax
syntaxForm2AllFilter :: Syntax
syntaxForm2AllFilter =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    String -> Match ()
guardMetaAll String
str1
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str2
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComponentKind -> TargetSelector
TargetAllPackages (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetAllPackages (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 String
"all" FileStatus
noFileStatus (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

-- | Syntax:  package : filer
--
-- > cabal build foo:tests
syntaxForm2PackageFilter :: [KnownPackage] -> Syntax
syntaxForm2PackageFilter :: [KnownPackage] -> Syntax
syntaxForm2PackageFilter [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str2
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render (TargetPackageNamed PackageName
pn (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

-- | Syntax: pkg : package name
--
-- > cabal build pkg:foo
syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax
syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax
syntaxForm2NamespacePackage [KnownPackage]
pinfo =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    String -> Match ()
guardNamespacePackage String
str1
    String -> Match ()
guardPackageName String
str2
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
pinfo String
str2 FileStatus
noFileStatus
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] Maybe ComponentKind
forall a. Maybe a
Nothing)
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn Maybe ComponentKind
forall a. Maybe a
Nothing)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 String
"pkg" FileStatus
noFileStatus (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p)]
    render (TargetPackageNamed PackageName
pn Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 String
"pkg" FileStatus
noFileStatus (PackageName -> String
dispPN PackageName
pn)]
    render TargetSelector
_ = []

-- | Syntax: package : component
--
-- > cabal build foo:foo
-- > cabal build ./foo:foo
-- > cabal build ./foo.cabal:foo
syntaxForm2PackageComponent :: [KnownPackage] -> Syntax
syntaxForm2PackageComponent :: [KnownPackage] -> Syntax
syntaxForm2PackageComponent [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    String -> Match ()
guardComponentName String
str2
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
pinfoComponents String
str2
          TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) SubComponentTarget
WholeComponent)
      -- TODO: the error here ought to say there's no component by that name in
      -- this package, and name the package
      KnownPackageName PackageName
pn ->
        let cn :: UnqualComponentName
cn = String -> UnqualComponentName
mkUnqualComponentName String
str2
         in TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (UnqualComponentName -> Either UnqualComponentName ComponentName
forall a b. a -> Either a b
Left UnqualComponentName
cn) SubComponentTarget
WholeComponent)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c)]
    render (TargetComponentUnknown PackageName
pn (Left UnqualComponentName
cn) SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus (UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
cn)]
    render TargetSelector
_ = []

-- | Syntax: namespace : component
--
-- > cabal build lib:foo exe:foo
syntaxForm2KindComponent :: [KnownComponent] -> Syntax
syntaxForm2KindComponent :: [KnownComponent] -> Syntax
syntaxForm2KindComponent [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    ComponentKind
ckind <- String -> Match ComponentKind
matchComponentKind String
str1
    String -> Match ()
guardComponentName String
str2
    KnownComponent
c <- [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
cs ComponentKind
ckind String
str2
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c) (KnownComponent -> ComponentName
cinfoName KnownComponent
c) SubComponentTarget
WholeComponent)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (ComponentName -> String
dispCK ComponentName
c) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c)]
    render TargetSelector
_ = []

-- | Syntax: package : module
--
-- > cabal build foo:Data.Foo
-- > cabal build ./foo:Data.Foo
-- > cabal build ./foo.cabal:Data.Foo
syntaxForm2PackageModule :: [KnownPackage] -> Syntax
syntaxForm2PackageModule :: [KnownPackage] -> Syntax
syntaxForm2PackageModule [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    String -> Match ()
guardModuleName String
str2
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          let ms :: [(ModuleName, KnownComponent)]
ms = [(ModuleName
m, KnownComponent
c) | KnownComponent
c <- [KnownComponent]
pinfoComponents, ModuleName
m <- KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c]
          (ModuleName
m, KnownComponent
c) <- [(ModuleName, KnownComponent)]
-> String -> Match (ModuleName, KnownComponent)
forall a. [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd [(ModuleName, KnownComponent)]
ms String
str2
          TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m))
      KnownPackageName PackageName
pn -> do
        ModuleName
m <- String -> Match ModuleName
matchModuleNameUnknown String
str2
        -- We assume the primary library component of the package:
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (ComponentName -> Either UnqualComponentName ComponentName
forall a b. b -> Either a b
Right (ComponentName -> Either UnqualComponentName ComponentName)
-> ComponentName -> Either UnqualComponentName ComponentName
forall a b. (a -> b) -> a -> b
$ LibraryName -> ComponentName
CLibName LibraryName
LMainLibName) (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
_c (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (ModuleName -> String
dispM ModuleName
m)]
    render TargetSelector
_ = []

-- | Syntax: component : module
--
-- > cabal build foo:Data.Foo
syntaxForm2ComponentModule :: [KnownComponent] -> Syntax
syntaxForm2ComponentModule :: [KnownComponent] -> Syntax
syntaxForm2ComponentModule [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    String -> Match ()
guardComponentName String
str1
    String -> Match ()
guardModuleName String
str2
    KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
cs String
str1
    String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
      let ms :: [ModuleName]
ms = KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c
      ModuleName
m <- [ModuleName] -> String -> Match ModuleName
matchModuleName [ModuleName]
ms String
str2
      TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent
            (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c)
            (KnownComponent -> ComponentName
cinfoName KnownComponent
c)
            (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m)
        )
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) FileStatus
noFileStatus (ModuleName -> String
dispM ModuleName
m)]
    render TargetSelector
_ = []

-- | 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 :: [KnownPackage] -> Syntax
syntaxForm2PackageFile [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          (String
filepath, KnownComponent
c) <- [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent]
pinfoComponents String
str2
          TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (String -> SubComponentTarget
FileTarget String
filepath))
      KnownPackageName PackageName
pn ->
        let filepath :: String
filepath = String
str2
         in -- We assume the primary library component of the package:
            TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (ComponentName -> Either UnqualComponentName ComponentName
forall a b. b -> Either a b
Right (ComponentName -> Either UnqualComponentName ComponentName)
-> ComponentName -> Either UnqualComponentName ComponentName
forall a b. (a -> b) -> a -> b
$ LibraryName -> ComponentName
CLibName LibraryName
LMainLibName) (String -> SubComponentTarget
FileTarget String
filepath))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
_c (FileTarget String
f)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus String
f]
    render TargetSelector
_ = []

-- | Syntax: component : filename
--
-- > cabal build foo:Data/Foo.hs
syntaxForm2ComponentFile :: [KnownComponent] -> Syntax
syntaxForm2ComponentFile :: [KnownComponent] -> Syntax
syntaxForm2ComponentFile [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render (Match2 -> Syntax) -> Match2 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 -> do
    String -> Match ()
guardComponentName String
str1
    KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
cs String
str1
    String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
      (String
filepath, KnownComponent
_) <- [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent
c] String
str2
      TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent
            (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c)
            (KnownComponent -> ComponentName
cinfoName KnownComponent
c)
            (String -> SubComponentTarget
FileTarget String
filepath)
        )
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (FileTarget String
f)) =
      [String -> FileStatus -> String -> TargetStringFileStatus
TargetStringFileStatus2 (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) FileStatus
noFileStatus String
f]
    render TargetSelector
_ = []

---

-- | Syntax: :all : filter
--
-- > cabal build :all:tests
syntaxForm3MetaAllFilter :: Syntax
syntaxForm3MetaAllFilter :: Syntax
syntaxForm3MetaAllFilter =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardMetaAll String
str2
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str3
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ComponentKind -> TargetSelector
TargetAllPackages (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetAllPackages (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"" FileStatus
noFileStatus String
"all" (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax
syntaxForm3MetaCwdFilter :: [KnownPackage] -> Syntax
syntaxForm3MetaCwdFilter [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardNamespaceCwd String
str2
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str3
    TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
pids (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    pids :: [PackageId]
pids = [PackageId
pinfoId | KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} <- [KnownPackage]
ps]
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetImplicitCwd [PackageId]
_ (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"" FileStatus
noFileStatus String
"cwd" (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

-- | Syntax: :pkg : package name
--
-- > cabal build :pkg:foo
syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax
syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax
syntaxForm3MetaNamespacePackage [KnownPackage]
pinfo =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardNamespacePackage String
str2
    String -> Match ()
guardPackageName String
str3
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
pinfo String
str3 FileStatus
noFileStatus
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] Maybe ComponentKind
forall a. Maybe a
Nothing)
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn Maybe ComponentKind
forall a. Maybe a
Nothing)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"" FileStatus
noFileStatus String
"pkg" (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p)]
    render (TargetPackageNamed PackageName
pn Maybe ComponentKind
Nothing) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"" FileStatus
noFileStatus String
"pkg" (PackageName -> String
dispPN PackageName
pn)]
    render TargetSelector
_ = []

-- | Syntax: package : namespace : component
--
-- > cabal build foo:lib:foo
-- > cabal build foo/:lib:foo
-- > cabal build foo.cabal:lib:foo
syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm3PackageKindComponent [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 String
str3 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    ComponentKind
ckind <- String -> Match ComponentKind
matchComponentKind String
str2
    String -> Match ()
guardComponentName String
str3
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          KnownComponent
c <- [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
pinfoComponents ComponentKind
ckind String
str3
          TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) SubComponentTarget
WholeComponent)
      KnownPackageName PackageName
pn ->
        let cn :: ComponentName
cn = PackageName
-> ComponentKind -> UnqualComponentName -> ComponentName
mkComponentName PackageName
pn ComponentKind
ckind (String -> UnqualComponentName
mkUnqualComponentName String
str3)
         in TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (ComponentName -> Either UnqualComponentName ComponentName
forall a b. b -> Either a b
Right ComponentName
cn) SubComponentTarget
WholeComponent)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (ComponentName -> String
dispCK ComponentName
c) (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c)]
    render (TargetComponentUnknown PackageName
pn (Right ComponentName
c) SubComponentTarget
WholeComponent) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus (ComponentName -> String
dispCK ComponentName
c) (PackageName -> ComponentName -> String
dispC' PackageName
pn ComponentName
c)]
    render TargetSelector
_ = []

-- | 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 :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentModule [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 String
str3 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    String -> Match ()
guardComponentName String
str2
    String -> Match ()
guardModuleName String
str3
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
pinfoComponents String
str2
          String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
            let ms :: [ModuleName]
ms = KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c
            ModuleName
m <- [ModuleName] -> String -> Match ModuleName
matchModuleName [ModuleName]
ms String
str3
            TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m))
      KnownPackageName PackageName
pn -> do
        let cn :: UnqualComponentName
cn = String -> UnqualComponentName
mkUnqualComponentName String
str2
        ModuleName
m <- String -> Match ModuleName
matchModuleNameUnknown String
str3
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (UnqualComponentName -> Either UnqualComponentName ComponentName
forall a b. a -> Either a b
Left UnqualComponentName
cn) (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) (ModuleName -> String
dispM ModuleName
m)]
    render (TargetComponentUnknown PackageName
pn (Left UnqualComponentName
c) (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus (UnqualComponentName -> String
dispCN UnqualComponentName
c) (ModuleName -> String
dispM ModuleName
m)]
    render TargetSelector
_ = []

-- | Syntax: namespace : component : module
--
-- > cabal build lib:foo:Data.Foo
syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax
syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax
syntaxForm3KindComponentModule [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    ComponentKind
ckind <- String -> Match ComponentKind
matchComponentKind String
str1
    String -> Match ()
guardComponentName String
str2
    String -> Match ()
guardModuleName String
str3
    KnownComponent
c <- [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
cs ComponentKind
ckind String
str2
    String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
      let ms :: [ModuleName]
ms = KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c
      ModuleName
m <- [ModuleName] -> String -> Match ModuleName
matchModuleName [ModuleName]
ms String
str3
      TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent
            (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c)
            (KnownComponent -> ComponentName
cinfoName KnownComponent
c)
            (ModuleName -> SubComponentTarget
ModuleTarget ModuleName
m)
        )
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (ModuleTarget ModuleName
m)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (ComponentName -> String
dispCK ComponentName
c) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) (ModuleName -> String
dispM ModuleName
m)]
    render TargetSelector
_ = []

-- | 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 :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentFile [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
fstatus1 String
str2 String
str3 -> do
    String -> FileStatus -> Match ()
guardPackage String
str1 FileStatus
fstatus1
    String -> Match ()
guardComponentName String
str2
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str1 FileStatus
fstatus1
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          KnownComponent
c <- [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
pinfoComponents String
str2
          String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
            (String
filepath, KnownComponent
_) <- [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent
c] String
str3
            TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) (String -> SubComponentTarget
FileTarget String
filepath))
      KnownPackageName PackageName
pn ->
        let cn :: UnqualComponentName
cn = String -> UnqualComponentName
mkUnqualComponentName String
str2
            filepath :: String
filepath = String
str3
         in TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (UnqualComponentName -> Either UnqualComponentName ComponentName
forall a b. a -> Either a b
Left UnqualComponentName
cn) (String -> SubComponentTarget
FileTarget String
filepath))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (FileTarget String
f)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) String
f]
    render (TargetComponentUnknown PackageName
pn (Left UnqualComponentName
c) (FileTarget String
f)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (PackageName -> String
dispPN PackageName
pn) FileStatus
noFileStatus (UnqualComponentName -> String
dispCN UnqualComponentName
c) String
f]
    render TargetSelector
_ = []

-- | Syntax: namespace : component : filename
--
-- > cabal build lib:foo:Data/Foo.hs
syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax
syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax
syntaxForm3KindComponentFile [KnownComponent]
cs =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    ComponentKind
ckind <- String -> Match ComponentKind
matchComponentKind String
str1
    String -> Match ()
guardComponentName String
str2
    KnownComponent
c <- [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
cs ComponentKind
ckind String
str2
    String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"component" (KnownComponent -> String
cinfoStrName KnownComponent
c) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
      (String
filepath, KnownComponent
_) <- [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent
c] String
str3
      TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent
            (KnownComponent -> PackageId
cinfoPackageId KnownComponent
c)
            (KnownComponent -> ComponentName
cinfoName KnownComponent
c)
            (String -> SubComponentTarget
FileTarget String
filepath)
        )
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c (FileTarget String
f)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 (ComponentName -> String
dispCK ComponentName
c) FileStatus
noFileStatus (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c) String
f]
    render TargetSelector
_ = []

syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm3NamespacePackageFilter [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render (Match3 -> Syntax) -> Match3 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 FileStatus
_fstatus1 String
str2 String
str3 -> do
    String -> Match ()
guardNamespacePackage String
str1
    String -> Match ()
guardPackageName String
str2
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str2 FileStatus
noFileStatus
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str3
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"pkg" FileStatus
noFileStatus (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render (TargetPackageNamed PackageName
pn (Just ComponentKind
kfilter)) =
      [String -> FileStatus -> String -> String -> TargetStringFileStatus
TargetStringFileStatus3 String
"pkg" FileStatus
noFileStatus (PackageName -> String
dispPN PackageName
pn) (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

--

syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm4MetaNamespacePackageFilter [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match4 -> Syntax
syntaxForm4 TargetSelector -> [TargetStringFileStatus]
render (Match4 -> Syntax) -> Match4 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 String
str2 String
str3 String
str4 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardNamespacePackage String
str2
    String -> Match ()
guardPackageName String
str3
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str3 FileStatus
noFileStatus
    ComponentKind
kfilter <- String -> Match ComponentKind
matchComponentKindFilter String
str4
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetImplicitCwd
-> [PackageId] -> Maybe ComponentKind -> TargetSelector
TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
pinfoId] (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
      KnownPackageName PackageName
pn ->
        TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName -> Maybe ComponentKind -> TargetSelector
TargetPackageNamed PackageName
pn (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
kfilter))
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetPackage TargetImplicitCwd
TargetExplicitNamed [PackageId
p] (Just ComponentKind
kfilter)) =
      [String -> String -> String -> String -> TargetStringFileStatus
TargetStringFileStatus4 String
"" String
"pkg" (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render (TargetPackageNamed PackageName
pn (Just ComponentKind
kfilter)) =
      [String -> String -> String -> String -> TargetStringFileStatus
TargetStringFileStatus4 String
"" String
"pkg" (PackageName -> String
dispPN PackageName
pn) (ComponentKind -> String
dispF ComponentKind
kfilter)]
    render TargetSelector
_ = []

-- | Syntax: :pkg : package : namespace : component
--
-- > cabal build :pkg:foo:lib:foo
syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm5MetaNamespacePackageKindComponent [KnownPackage]
ps =
  (TargetSelector -> [TargetStringFileStatus]) -> Match5 -> Syntax
syntaxForm5 TargetSelector -> [TargetStringFileStatus]
render (Match5 -> Syntax) -> Match5 -> Syntax
forall a b. (a -> b) -> a -> b
$ \String
str1 String
str2 String
str3 String
str4 String
str5 -> do
    String -> Match ()
guardNamespaceMeta String
str1
    String -> Match ()
guardNamespacePackage String
str2
    String -> Match ()
guardPackageName String
str3
    ComponentKind
ckind <- String -> Match ComponentKind
matchComponentKind String
str4
    String -> Match ()
guardComponentName String
str5
    KnownPackage
p <- [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage [KnownPackage]
ps String
str3 FileStatus
noFileStatus
    case KnownPackage
p of
      KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId, [KnownComponent]
pinfoComponents :: KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
pinfoComponents} ->
        String -> String -> Match TargetSelector -> Match TargetSelector
forall a. String -> String -> Match a -> Match a
orNoThingIn String
"package" (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId)) (Match TargetSelector -> Match TargetSelector)
-> Match TargetSelector -> Match TargetSelector
forall a b. (a -> b) -> a -> b
$ do
          KnownComponent
c <- [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
pinfoComponents ComponentKind
ckind String
str5
          TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pinfoId (KnownComponent -> ComponentName
cinfoName KnownComponent
c) SubComponentTarget
WholeComponent)
      KnownPackageName PackageName
pn ->
        let cn :: ComponentName
cn = PackageName
-> ComponentKind -> UnqualComponentName -> ComponentName
mkComponentName PackageName
pn ComponentKind
ckind (String -> UnqualComponentName
mkUnqualComponentName String
str5)
         in TargetSelector -> Match TargetSelector
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageName
-> Either UnqualComponentName ComponentName
-> SubComponentTarget
-> TargetSelector
TargetComponentUnknown PackageName
pn (ComponentName -> Either UnqualComponentName ComponentName
forall a b. b -> Either a b
Right ComponentName
cn) SubComponentTarget
WholeComponent)
  where
    render :: TargetSelector -> [TargetStringFileStatus]
render (TargetComponent PackageId
p ComponentName
c SubComponentTarget
WholeComponent) =
      [String
-> String -> String -> String -> String -> TargetStringFileStatus
TargetStringFileStatus5 String
"" String
"pkg" (PackageId -> String
forall p. Package p => p -> String
dispP PackageId
p) (ComponentName -> String
dispCK ComponentName
c) (PackageId -> ComponentName -> String
dispC PackageId
p ComponentName
c)]
    render (TargetComponentUnknown PackageName
pn (Right ComponentName
c) SubComponentTarget
WholeComponent) =
      [String
-> String -> String -> String -> String -> TargetStringFileStatus
TargetStringFileStatus5 String
"" String
"pkg" (PackageName -> String
dispPN PackageName
pn) (ComponentName -> String
dispCK ComponentName
c) (PackageName -> ComponentName -> String
dispC' PackageName
pn ComponentName
c)]
    render TargetSelector
_ = []

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

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

---------------------------------------
-- 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 :: (TargetSelector -> [TargetStringFileStatus]) -> Match1 -> Syntax
syntaxForm1 TargetSelector -> [TargetStringFileStatus]
render Match1
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QL1 TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match = \(TargetStringFileStatus1 String
str1 FileStatus
fstatus1) ->
      Match1
f String
str1 FileStatus
fstatus1

syntaxForm2 :: (TargetSelector -> [TargetStringFileStatus]) -> Match2 -> Syntax
syntaxForm2 TargetSelector -> [TargetStringFileStatus]
render Match2
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QL2 TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match = \(TargetStringFileStatus2 String
str1 FileStatus
fstatus1 String
str2) ->
      Match2
f String
str1 FileStatus
fstatus1 String
str2

syntaxForm3 :: (TargetSelector -> [TargetStringFileStatus]) -> Match3 -> Syntax
syntaxForm3 TargetSelector -> [TargetStringFileStatus]
render Match3
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QL3 TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match = \(TargetStringFileStatus3 String
str1 FileStatus
fstatus1 String
str2 String
str3) ->
      Match3
f String
str1 FileStatus
fstatus1 String
str2 String
str3

syntaxForm4 :: (TargetSelector -> [TargetStringFileStatus]) -> Match4 -> Syntax
syntaxForm4 TargetSelector -> [TargetStringFileStatus]
render Match4
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QLFull TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match (TargetStringFileStatus4 String
str1 String
str2 String
str3 String
str4) =
      Match4
f String
str1 String
str2 String
str3 String
str4
    match TargetStringFileStatus
_ = Match TargetSelector
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

syntaxForm5 :: (TargetSelector -> [TargetStringFileStatus]) -> Match5 -> Syntax
syntaxForm5 TargetSelector -> [TargetStringFileStatus]
render Match5
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QLFull TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match (TargetStringFileStatus5 String
str1 String
str2 String
str3 String
str4 String
str5) =
      Match5
f String
str1 String
str2 String
str3 String
str4 String
str5
    match TargetStringFileStatus
_ = Match TargetSelector
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

syntaxForm7 :: (TargetSelector -> [TargetStringFileStatus]) -> Match7 -> Syntax
syntaxForm7 TargetSelector -> [TargetStringFileStatus]
render Match7
f =
  QualLevel
-> (TargetStringFileStatus -> Match TargetSelector)
-> (TargetSelector -> [TargetStringFileStatus])
-> Syntax
Syntax QualLevel
QLFull TargetStringFileStatus -> Match TargetSelector
match TargetSelector -> [TargetStringFileStatus]
render
  where
    match :: TargetStringFileStatus -> Match TargetSelector
match (TargetStringFileStatus7 String
str1 String
str2 String
str3 String
str4 String
str5 String
str6 String
str7) =
      Match7
f String
str1 String
str2 String
str3 String
str4 String
str5 String
str6 String
str7
    match TargetStringFileStatus
_ = Match TargetSelector
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

dispP :: Package p => p -> String
dispP :: forall p. Package p => p -> String
dispP = PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageName -> String) -> (p -> PackageName) -> p -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName

dispPN :: PackageName -> String
dispPN :: PackageName -> String
dispPN = PackageName -> String
forall a. Pretty a => a -> String
prettyShow

dispC :: PackageId -> ComponentName -> String
dispC :: PackageId -> ComponentName -> String
dispC = PackageName -> ComponentName -> String
componentStringName (PackageName -> ComponentName -> String)
-> (PackageId -> PackageName)
-> PackageId
-> ComponentName
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName

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

dispCN :: UnqualComponentName -> String
dispCN :: UnqualComponentName -> String
dispCN = UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow

dispK :: ComponentKind -> String
dispK :: ComponentKind -> String
dispK = ComponentKind -> String
showComponentKindShort

dispCK :: ComponentName -> String
dispCK :: ComponentName -> String
dispCK = ComponentKind -> String
dispK (ComponentKind -> String)
-> (ComponentName -> ComponentKind) -> ComponentName -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComponentName -> ComponentKind
componentKind

dispF :: ComponentKind -> String
dispF :: ComponentKind -> String
dispF = ComponentKind -> String
showComponentKindFilterShort

dispM :: ModuleName -> String
dispM :: ModuleName -> String
dispM = ModuleName -> String
forall a. Pretty a => a -> String
prettyShow

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

data KnownTargets = KnownTargets
  { KnownTargets -> [KnownPackage]
knownPackagesAll :: [KnownPackage]
  , KnownTargets -> [KnownPackage]
knownPackagesPrimary :: [KnownPackage]
  , KnownTargets -> [KnownPackage]
knownPackagesOther :: [KnownPackage]
  , KnownTargets -> [KnownComponent]
knownComponentsAll :: [KnownComponent]
  , KnownTargets -> [KnownComponent]
knownComponentsPrimary :: [KnownComponent]
  , KnownTargets -> [KnownComponent]
knownComponentsOther :: [KnownComponent]
  }
  deriving (Int -> KnownTargets -> ShowS
[KnownTargets] -> ShowS
KnownTargets -> String
(Int -> KnownTargets -> ShowS)
-> (KnownTargets -> String)
-> ([KnownTargets] -> ShowS)
-> Show KnownTargets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KnownTargets -> ShowS
showsPrec :: Int -> KnownTargets -> ShowS
$cshow :: KnownTargets -> String
show :: KnownTargets -> String
$cshowList :: [KnownTargets] -> ShowS
showList :: [KnownTargets] -> ShowS
Show)

data KnownPackage
  = KnownPackage
      { KnownPackage -> PackageId
pinfoId :: PackageId
      , KnownPackage -> Maybe (String, String)
pinfoDirectory :: Maybe (FilePath, FilePath)
      , KnownPackage -> Maybe (String, String)
pinfoPackageFile :: Maybe (FilePath, FilePath)
      , KnownPackage -> [KnownComponent]
pinfoComponents :: [KnownComponent]
      }
  | KnownPackageName
      { KnownPackage -> PackageName
pinfoName :: PackageName
      }
  deriving (Int -> KnownPackage -> ShowS
[KnownPackage] -> ShowS
KnownPackage -> String
(Int -> KnownPackage -> ShowS)
-> (KnownPackage -> String)
-> ([KnownPackage] -> ShowS)
-> Show KnownPackage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KnownPackage -> ShowS
showsPrec :: Int -> KnownPackage -> ShowS
$cshow :: KnownPackage -> String
show :: KnownPackage -> String
$cshowList :: [KnownPackage] -> ShowS
showList :: [KnownPackage] -> ShowS
Show)

data KnownComponent = KnownComponent
  { KnownComponent -> ComponentName
cinfoName :: ComponentName
  , KnownComponent -> String
cinfoStrName :: ComponentStringName
  , KnownComponent -> PackageId
cinfoPackageId :: PackageId
  , KnownComponent -> [String]
cinfoSrcDirs :: [FilePath]
  , KnownComponent -> [ModuleName]
cinfoModules :: [ModuleName]
  , KnownComponent -> [String]
cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
  , KnownComponent -> [String]
cinfoCFiles :: [FilePath]
  , KnownComponent -> [String]
cinfoJsFiles :: [FilePath]
  }
  deriving (Int -> KnownComponent -> ShowS
[KnownComponent] -> ShowS
KnownComponent -> String
(Int -> KnownComponent -> ShowS)
-> (KnownComponent -> String)
-> ([KnownComponent] -> ShowS)
-> Show KnownComponent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KnownComponent -> ShowS
showsPrec :: Int -> KnownComponent -> ShowS
$cshow :: KnownComponent -> String
show :: KnownComponent -> String
$cshowList :: [KnownComponent] -> ShowS
showList :: [KnownComponent] -> ShowS
Show)

type ComponentStringName = String

knownPackageName :: KnownPackage -> PackageName
knownPackageName :: KnownPackage -> PackageName
knownPackageName KnownPackage{PackageId
pinfoId :: KnownPackage -> PackageId
pinfoId :: PackageId
pinfoId} = PackageId -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageId
pinfoId
knownPackageName KnownPackageName{PackageName
pinfoName :: KnownPackage -> PackageName
pinfoName :: PackageName
pinfoName} = PackageName
pinfoName

emptyKnownTargets :: KnownTargets
emptyKnownTargets :: KnownTargets
emptyKnownTargets = [KnownPackage]
-> [KnownPackage]
-> [KnownPackage]
-> [KnownComponent]
-> [KnownComponent]
-> [KnownComponent]
-> KnownTargets
KnownTargets [] [] [] [] [] []

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

    selectPrimaryPackage
      :: FilePath
      -> [KnownPackage]
      -> m ([KnownPackage], [KnownPackage])
    selectPrimaryPackage :: String -> [KnownPackage] -> m ([KnownPackage], [KnownPackage])
selectPrimaryPackage String
_ [] = ([KnownPackage], [KnownPackage])
-> m ([KnownPackage], [KnownPackage])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
    selectPrimaryPackage String
cwd (KnownPackage
pkg : [KnownPackage]
packages) = do
      ([KnownPackage]
ppinfo, [KnownPackage]
opinfo) <- String -> [KnownPackage] -> m ([KnownPackage], [KnownPackage])
selectPrimaryPackage String
cwd [KnownPackage]
packages
      Bool
isPkgDirCwd <- m Bool -> (String -> m Bool) -> Maybe String -> m Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False) (DirActions m -> String -> String -> m Bool
forall (m :: * -> *).
(Applicative m, Monad m) =>
DirActions m -> String -> String -> m Bool
compareFilePath DirActions m
dirActions String
cwd) (KnownPackage -> Maybe String
mPkgDir KnownPackage
pkg)
      ([KnownPackage], [KnownPackage])
-> m ([KnownPackage], [KnownPackage])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
isPkgDirCwd then (KnownPackage
pkg KnownPackage -> [KnownPackage] -> [KnownPackage]
forall a. a -> [a] -> [a]
: [KnownPackage]
ppinfo, [KnownPackage]
opinfo) else ([KnownPackage]
ppinfo, KnownPackage
pkg KnownPackage -> [KnownPackage] -> [KnownPackage]
forall a. a -> [a] -> [a]
: [KnownPackage]
opinfo))

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

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

collectKnownComponentInfo :: PackageDescription -> [KnownComponent]
collectKnownComponentInfo :: PackageDescription -> [KnownComponent]
collectKnownComponentInfo PackageDescription
pkg =
  [ KnownComponent
    { cinfoName :: ComponentName
cinfoName = Component -> ComponentName
componentName Component
c
    , cinfoStrName :: String
cinfoStrName = PackageName -> ComponentName -> String
componentStringName (PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pkg) (Component -> ComponentName
componentName Component
c)
    , cinfoPackageId :: PackageId
cinfoPackageId = PackageDescription -> PackageId
forall pkg. Package pkg => pkg -> PackageId
packageId PackageDescription
pkg
    , cinfoSrcDirs :: [String]
cinfoSrcDirs = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ((SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bi))
    , cinfoModules :: [ModuleName]
cinfoModules = [ModuleName] -> [ModuleName]
forall a. Ord a => [a] -> [a]
ordNub (Component -> [ModuleName]
componentModules Component
c)
    , cinfoHsFiles :: [String]
cinfoHsFiles = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub (Component -> [String]
componentHsFiles Component
c)
    , cinfoCFiles :: [String]
cinfoCFiles = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub (BuildInfo -> [String]
cSources BuildInfo
bi)
    , cinfoJsFiles :: [String]
cinfoJsFiles = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub (BuildInfo -> [String]
jsSources BuildInfo
bi)
    }
  | Component
c <- PackageDescription -> [Component]
pkgComponents PackageDescription
pkg
  , let bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo Component
c
  ]

componentStringName :: PackageName -> ComponentName -> ComponentStringName
componentStringName :: PackageName -> ComponentName -> String
componentStringName PackageName
pkgname (CLibName LibraryName
LMainLibName) = PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pkgname
componentStringName PackageName
_ (CLibName (LSubLibName UnqualComponentName
name)) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName PackageName
_ (CFLibName UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName PackageName
_ (CExeName UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName PackageName
_ (CTestName UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name
componentStringName PackageName
_ (CBenchName UnqualComponentName
name) = UnqualComponentName -> String
unUnqualComponentName UnqualComponentName
name

componentModules :: Component -> [ModuleName]
-- I think it's unlikely users will ask to build a requirement
-- which is not mentioned locally.
componentModules :: Component -> [ModuleName]
componentModules (CLib Library
lib) = Library -> [ModuleName]
explicitLibModules Library
lib
componentModules (CFLib ForeignLib
flib) = ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
componentModules (CExe Executable
exe) = Executable -> [ModuleName]
exeModules Executable
exe
componentModules (CTest TestSuite
test) = TestSuite -> [ModuleName]
testModules TestSuite
test
componentModules (CBench Benchmark
bench) = Benchmark -> [ModuleName]
benchmarkModules Benchmark
bench

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

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

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

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

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

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

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

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

guardToken :: [String] -> String -> String -> Match ()
guardToken :: [String] -> String -> String -> Match ()
guardToken [String]
tokens String
msg String
s
  | ShowS
caseFold String
s String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tokens = Match ()
increaseConfidence
  | Bool
otherwise = String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
msg String
s

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

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

cinfoKind :: KnownComponent -> ComponentKind
cinfoKind :: KnownComponent -> ComponentKind
cinfoKind = ComponentName -> ComponentKind
componentKind (ComponentName -> ComponentKind)
-> (KnownComponent -> ComponentName)
-> KnownComponent
-> ComponentKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownComponent -> ComponentName
cinfoName

matchComponentKind :: String -> Match ComponentKind
matchComponentKind :: String -> Match ComponentKind
matchComponentKind String
s
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
liblabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
LibKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
fliblabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
FLibKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exelabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
ExeKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
testlabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
TestKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
benchlabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
BenchKind
  | Bool
otherwise = String -> String -> Match ComponentKind
forall a. String -> String -> Match a
matchErrorExpected String
"component kind" String
s
  where
    s' :: String
s' = ShowS
caseFold String
s
    liblabels :: [String]
liblabels = [String
"lib", String
"library"]
    fliblabels :: [String]
fliblabels = [String
"flib", String
"foreign-library"]
    exelabels :: [String]
exelabels = [String
"exe", String
"executable"]
    testlabels :: [String]
testlabels = [String
"tst", String
"test", String
"test-suite"]
    benchlabels :: [String]
benchlabels = [String
"bench", String
"benchmark"]

matchComponentKindFilter :: String -> Match ComponentKind
matchComponentKindFilter :: String -> Match ComponentKind
matchComponentKindFilter String
s
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
liblabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
LibKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
fliblabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
FLibKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
exelabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
ExeKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
testlabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
TestKind
  | String
s' String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
benchlabels = Match ()
increaseConfidence Match () -> Match ComponentKind -> Match ComponentKind
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ComponentKind -> Match ComponentKind
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ComponentKind
BenchKind
  | Bool
otherwise = String -> String -> Match ComponentKind
forall a. String -> String -> Match a
matchErrorExpected String
"component kind filter" String
s
  where
    s' :: String
s' = ShowS
caseFold String
s
    liblabels :: [String]
liblabels = [String
"libs", String
"libraries"]
    fliblabels :: [String]
fliblabels = [String
"flibs", String
"foreign-libraries"]
    exelabels :: [String]
exelabels = [String
"exes", String
"executables"]
    testlabels :: [String]
testlabels = [String
"tests", String
"test-suites"]
    benchlabels :: [String]
benchlabels = [String
"benches", String
"benchmarks"]

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

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

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

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

guardPackage :: String -> FileStatus -> Match ()
guardPackage :: String -> FileStatus -> Match ()
guardPackage String
str FileStatus
fstatus =
  String -> Match ()
guardPackageName String
str
    Match () -> Match () -> Match ()
forall a. Match a -> Match a -> Match a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> FileStatus -> Match ()
guardPackageDir String
str FileStatus
fstatus
    Match () -> Match () -> Match ()
forall a. Match a -> Match a -> Match a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> FileStatus -> Match ()
guardPackageFile String
str FileStatus
fstatus

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

validPackageName :: String -> Bool
validPackageName :: String -> Bool
validPackageName String
s =
  (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validPackageNameChar String
s
    Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s)
  where
    validPackageNameChar :: Char -> Bool
validPackageNameChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

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

guardPackageFile :: String -> FileStatus -> Match ()
guardPackageFile :: String -> FileStatus -> Match ()
guardPackageFile String
_ (FileStatusExistsFile String
file)
  | ShowS
takeExtension String
file String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".cabal" =
      Match ()
increaseConfidence
guardPackageFile String
str FileStatus
_ = String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
"package .cabal file" String
str

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

matchPackageName :: [KnownPackage] -> String -> Match KnownPackage
matchPackageName :: [KnownPackage] -> String -> Match KnownPackage
matchPackageName [KnownPackage]
ps = \String
str -> do
  Bool -> Match ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Bool
validPackageName String
str)
  String
-> String -> [String] -> Match KnownPackage -> Match KnownPackage
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing
    String
"package"
    String
str
    ((KnownPackage -> String) -> [KnownPackage] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageName -> String)
-> (KnownPackage -> PackageName) -> KnownPackage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownPackage -> PackageName
knownPackageName) [KnownPackage]
ps)
    (Match KnownPackage -> Match KnownPackage)
-> Match KnownPackage -> Match KnownPackage
forall a b. (a -> b) -> a -> b
$ Match KnownPackage -> Match KnownPackage
forall a. Match a -> Match a
increaseConfidenceFor
    (Match KnownPackage -> Match KnownPackage)
-> Match KnownPackage -> Match KnownPackage
forall a b. (a -> b) -> a -> b
$ ShowS
-> (KnownPackage -> String)
-> [KnownPackage]
-> String
-> Match KnownPackage
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly ShowS
caseFold (PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageName -> String)
-> (KnownPackage -> PackageName) -> KnownPackage -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KnownPackage -> PackageName
knownPackageName) [KnownPackage]
ps String
str

matchPackageNameUnknown :: String -> Match KnownPackage
matchPackageNameUnknown :: String -> Match KnownPackage
matchPackageNameUnknown String
str = do
  PackageName
pn <- String -> Match PackageName
forall a. Parsec a => String -> Match a
matchParse String
str
  KnownPackage -> Match KnownPackage
forall a. a -> Match a
unknownMatch (PackageName -> KnownPackage
KnownPackageName PackageName
pn)

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

matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackageFile [KnownPackage]
ps = \String
str FileStatus
fstatus -> do
  case FileStatus
fstatus of
    FileStatusExistsFile String
canonfile ->
      String
-> String -> [String] -> Match KnownPackage -> Match KnownPackage
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing String
"package .cabal file" String
str ((((String, String), KnownPackage) -> String)
-> [((String, String), KnownPackage)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String, String) -> String
forall a b. (a, b) -> b
snd ((String, String) -> String)
-> (((String, String), KnownPackage) -> (String, String))
-> ((String, String), KnownPackage)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String), KnownPackage) -> (String, String)
forall a b. (a, b) -> a
fst) [((String, String), KnownPackage)]
files) (Match KnownPackage -> Match KnownPackage)
-> Match KnownPackage -> Match KnownPackage
forall a b. (a -> b) -> a -> b
$
        Match KnownPackage -> Match KnownPackage
forall a. Match a -> Match a
increaseConfidenceFor (Match KnownPackage -> Match KnownPackage)
-> Match KnownPackage -> Match KnownPackage
forall a b. (a -> b) -> a -> b
$
          (((String, String), KnownPackage) -> KnownPackage)
-> Match ((String, String), KnownPackage) -> Match KnownPackage
forall a b. (a -> b) -> Match a -> Match b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String, String), KnownPackage) -> KnownPackage
forall a b. (a, b) -> b
snd (Match ((String, String), KnownPackage) -> Match KnownPackage)
-> Match ((String, String), KnownPackage) -> Match KnownPackage
forall a b. (a -> b) -> a -> b
$
            (((String, String), KnownPackage) -> String)
-> [((String, String), KnownPackage)]
-> String
-> Match ((String, String), KnownPackage)
forall k a. Ord k => (a -> k) -> [a] -> k -> Match a
matchExactly ((String, String) -> String
forall a b. (a, b) -> a
fst ((String, String) -> String)
-> (((String, String), KnownPackage) -> (String, String))
-> ((String, String), KnownPackage)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, String), KnownPackage) -> (String, String)
forall a b. (a, b) -> a
fst) [((String, String), KnownPackage)]
files String
canonfile
    FileStatus
_ -> Match KnownPackage
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  where
    files :: [((String, String), KnownPackage)]
files =
      [ ((String
fabs, String
frel), KnownPackage
p)
      | p :: KnownPackage
p@KnownPackage{pinfoPackageFile :: KnownPackage -> Maybe (String, String)
pinfoPackageFile = Just (String
fabs, String
frel)} <- [KnownPackage]
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 :: String -> Match ()
guardComponentName String
s
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validComponentChar String
s
      Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) =
      Match ()
increaseConfidence
  | Bool
otherwise = String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
"component name" String
s
  where
    validComponentChar :: Char -> Bool
validComponentChar Char
c =
      Char -> Bool
isAlphaNum Char
c
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'
        Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

matchComponentName :: [KnownComponent] -> String -> Match KnownComponent
matchComponentName :: [KnownComponent] -> String -> Match KnownComponent
matchComponentName [KnownComponent]
cs String
str =
  String
-> String
-> [String]
-> Match KnownComponent
-> Match KnownComponent
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing String
"component" String
str ((KnownComponent -> String) -> [KnownComponent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map KnownComponent -> String
cinfoStrName [KnownComponent]
cs) (Match KnownComponent -> Match KnownComponent)
-> Match KnownComponent -> Match KnownComponent
forall a b. (a -> b) -> a -> b
$
    Match KnownComponent -> Match KnownComponent
forall a. Match a -> Match a
increaseConfidenceFor (Match KnownComponent -> Match KnownComponent)
-> Match KnownComponent -> Match KnownComponent
forall a b. (a -> b) -> a -> b
$
      ShowS
-> (KnownComponent -> String)
-> [KnownComponent]
-> String
-> Match KnownComponent
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly ShowS
caseFold KnownComponent -> String
cinfoStrName [KnownComponent]
cs String
str

matchComponentKindAndName
  :: [KnownComponent]
  -> ComponentKind
  -> String
  -> Match KnownComponent
matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String -> Match KnownComponent
matchComponentKindAndName [KnownComponent]
cs ComponentKind
ckind String
str =
  String
-> String
-> [String]
-> Match KnownComponent
-> Match KnownComponent
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing
    (ComponentKind -> String
showComponentKind ComponentKind
ckind String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" component")
    String
str
    ((KnownComponent -> String) -> [KnownComponent] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map KnownComponent -> String
render [KnownComponent]
cs)
    (Match KnownComponent -> Match KnownComponent)
-> Match KnownComponent -> Match KnownComponent
forall a b. (a -> b) -> a -> b
$ Match KnownComponent -> Match KnownComponent
forall a. Match a -> Match a
increaseConfidenceFor
    (Match KnownComponent -> Match KnownComponent)
-> Match KnownComponent -> Match KnownComponent
forall a b. (a -> b) -> a -> b
$ ((ComponentKind, String) -> (ComponentKind, String))
-> (KnownComponent -> (ComponentKind, String))
-> [KnownComponent]
-> (ComponentKind, String)
-> Match KnownComponent
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly
      (\(ComponentKind
ck, String
cn) -> (ComponentKind
ck, ShowS
caseFold String
cn))
      (\KnownComponent
c -> (KnownComponent -> ComponentKind
cinfoKind KnownComponent
c, KnownComponent -> String
cinfoStrName KnownComponent
c))
      [KnownComponent]
cs
      (ComponentKind
ckind, String
str)
  where
    render :: KnownComponent -> String
render KnownComponent
c = ComponentKind -> String
showComponentKindShort (KnownComponent -> ComponentKind
cinfoKind KnownComponent
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":" String -> ShowS
forall a. [a] -> [a] -> [a]
++ KnownComponent -> String
cinfoStrName KnownComponent
c

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

guardModuleName :: String -> Match ()
guardModuleName :: String -> Match ()
guardModuleName String
s =
  case String -> Maybe ModuleName
forall a. Parsec a => String -> Maybe a
simpleParsec String
s :: Maybe ModuleName of
    Just ModuleName
_ -> Match ()
increaseConfidence
    Maybe ModuleName
_
      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validModuleChar String
s
          Bool -> Bool -> Bool
&& Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) ->
          () -> Match ()
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise -> String -> String -> Match ()
forall a. String -> String -> Match a
matchErrorExpected String
"module name" String
s
  where
    validModuleChar :: Char -> Bool
validModuleChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\''

matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName [ModuleName]
ms String
str =
  String
-> String -> [String] -> Match ModuleName -> Match ModuleName
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing String
"module" String
str ((ModuleName -> String) -> [ModuleName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ModuleName -> String
forall a. Pretty a => a -> String
prettyShow [ModuleName]
ms) (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
    Match ModuleName -> Match ModuleName
forall a. Match a -> Match a
increaseConfidenceFor (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
      ShowS
-> (ModuleName -> String)
-> [ModuleName]
-> String
-> Match ModuleName
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly ShowS
caseFold ModuleName -> String
forall a. Pretty a => a -> String
prettyShow [ModuleName]
ms String
str

matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd :: forall a. [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd [(ModuleName, a)]
ms String
str =
  String
-> String
-> [String]
-> Match (ModuleName, a)
-> Match (ModuleName, a)
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing String
"module" String
str (((ModuleName, a) -> String) -> [(ModuleName, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> String
forall a. Pretty a => a -> String
prettyShow (ModuleName -> String)
-> ((ModuleName, a) -> ModuleName) -> (ModuleName, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, a) -> ModuleName
forall a b. (a, b) -> a
fst) [(ModuleName, a)]
ms) (Match (ModuleName, a) -> Match (ModuleName, a))
-> Match (ModuleName, a) -> Match (ModuleName, a)
forall a b. (a -> b) -> a -> b
$
    Match (ModuleName, a) -> Match (ModuleName, a)
forall a. Match a -> Match a
increaseConfidenceFor (Match (ModuleName, a) -> Match (ModuleName, a))
-> Match (ModuleName, a) -> Match (ModuleName, a)
forall a b. (a -> b) -> a -> b
$
      ShowS
-> ((ModuleName, a) -> String)
-> [(ModuleName, a)]
-> String
-> Match (ModuleName, a)
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly ShowS
caseFold (ModuleName -> String
forall a. Pretty a => a -> String
prettyShow (ModuleName -> String)
-> ((ModuleName, a) -> ModuleName) -> (ModuleName, a) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, a) -> ModuleName
forall a b. (a, b) -> a
fst) [(ModuleName, a)]
ms String
str

matchModuleNameUnknown :: String -> Match ModuleName
matchModuleNameUnknown :: String -> Match ModuleName
matchModuleNameUnknown String
str =
  String -> String -> Match ModuleName -> Match ModuleName
forall a. String -> String -> Match a -> Match a
expecting String
"module" String
str (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
    Match ModuleName -> Match ModuleName
forall a. Match a -> Match a
increaseConfidenceFor (Match ModuleName -> Match ModuleName)
-> Match ModuleName -> Match ModuleName
forall a b. (a -> b) -> a -> b
$
      String -> Match ModuleName
forall a. Parsec a => String -> Match a
matchParse String
str

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

matchPackageDirectoryPrefix
  :: [KnownPackage]
  -> FileStatus
  -> Match (FilePath, KnownPackage)
matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus -> Match (String, KnownPackage)
matchPackageDirectoryPrefix [KnownPackage]
ps (FileStatusExistsFile String
filepath) =
  Match (String, KnownPackage) -> Match (String, KnownPackage)
forall a. Match a -> Match a
increaseConfidenceFor (Match (String, KnownPackage) -> Match (String, KnownPackage))
-> Match (String, KnownPackage) -> Match (String, KnownPackage)
forall a b. (a -> b) -> a -> b
$
    [(String, KnownPackage)] -> String -> Match (String, KnownPackage)
forall a. [(String, a)] -> String -> Match (String, a)
matchDirectoryPrefix [(String, KnownPackage)]
pkgdirs String
filepath
  where
    pkgdirs :: [(String, KnownPackage)]
pkgdirs =
      [ (String
dir, KnownPackage
p)
      | p :: KnownPackage
p@KnownPackage{pinfoDirectory :: KnownPackage -> Maybe (String, String)
pinfoDirectory = Just (String
dir, String
_)} <- [KnownPackage]
ps
      ]
matchPackageDirectoryPrefix [KnownPackage]
_ FileStatus
_ = Match (String, KnownPackage)
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

matchComponentFile
  :: [KnownComponent]
  -> String
  -> Match (FilePath, KnownComponent)
matchComponentFile :: [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentFile [KnownComponent]
cs String
str =
  String
-> String
-> [String]
-> Match (String, KnownComponent)
-> Match (String, KnownComponent)
forall a. String -> String -> [String] -> Match a -> Match a
orNoSuchThing String
"file" String
str [] (Match (String, KnownComponent) -> Match (String, KnownComponent))
-> Match (String, KnownComponent) -> Match (String, KnownComponent)
forall a b. (a -> b) -> a -> b
$
    [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentModuleFile [KnownComponent]
cs String
str
      Match (String, KnownComponent)
-> Match (String, KnownComponent) -> Match (String, KnownComponent)
forall a. Match a -> Match a -> Match a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentOtherFile [KnownComponent]
cs String
str

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

matchComponentModuleFile
  :: [KnownComponent]
  -> String
  -> Match (FilePath, KnownComponent)
matchComponentModuleFile :: [KnownComponent] -> String -> Match (String, KnownComponent)
matchComponentModuleFile [KnownComponent]
cs String
str = do
  [(String, KnownComponent)]
-> String -> Match (String, KnownComponent)
forall a. [(String, a)] -> String -> Match (String, a)
matchFile
    [ (ShowS
normalise (String
d String -> ShowS
</> ModuleName -> String
toFilePath ModuleName
m), KnownComponent
c)
    | KnownComponent
c <- [KnownComponent]
cs
    , String
d <- KnownComponent -> [String]
cinfoSrcDirs KnownComponent
c
    , ModuleName
m <- KnownComponent -> [ModuleName]
cinfoModules KnownComponent
c
    ]
    (ShowS
dropExtension (ShowS
normalise String
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 :: forall (m :: * -> *).
(Applicative m, Monad m) =>
DirActions m -> String -> String -> m Bool
compareFilePath DirActions{m String
String -> m Bool
String -> m String
doesFileExist :: forall (m :: * -> *). DirActions m -> String -> m Bool
doesDirectoryExist :: forall (m :: * -> *). DirActions m -> String -> m Bool
canonicalizePath :: forall (m :: * -> *). DirActions m -> String -> m String
getCurrentDirectory :: forall (m :: * -> *). DirActions m -> m String
doesFileExist :: String -> m Bool
doesDirectoryExist :: String -> m Bool
canonicalizePath :: String -> m String
getCurrentDirectory :: m String
..} String
fp1 String
fp2
  | String -> String -> Bool
equalFilePath String
fp1 String
fp2 = Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- avoid unnecessary IO if we can match earlier
  | Bool
otherwise = do
      String
c1 <- String -> m String
canonicalizePath String
fp1
      String
c2 <- String -> m String
canonicalizePath String
fp2
      Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ String -> String -> Bool
equalFilePath String
c1 String
c2

matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)
matchFile :: forall a. [(String, a)] -> String -> Match (String, a)
matchFile [(String, a)]
fs =
  Match (String, a) -> Match (String, a)
forall a. Match a -> Match a
increaseConfidenceFor
    (Match (String, a) -> Match (String, a))
-> (String -> Match (String, a)) -> String -> Match (String, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
-> ((String, a) -> String)
-> [(String, a)]
-> String
-> Match (String, a)
forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly ShowS
caseFold (String, a) -> String
forall a b. (a, b) -> a
fst [(String, a)]
fs

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

    filepathsplit :: [String]
filepathsplit = String -> [String]
splitDirectories String
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 (Int -> Match a -> ShowS
[Match a] -> ShowS
Match a -> String
(Int -> Match a -> ShowS)
-> (Match a -> String) -> ([Match a] -> ShowS) -> Show (Match a)
forall a. Show a => Int -> Match a -> ShowS
forall a. Show a => [Match a] -> ShowS
forall a. Show a => Match a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Match a -> ShowS
showsPrec :: Int -> Match a -> ShowS
$cshow :: forall a. Show a => Match a -> String
show :: Match a -> String
$cshowList :: forall a. Show a => [Match a] -> ShowS
showList :: [Match a] -> ShowS
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 (Int -> MatchClass -> ShowS
[MatchClass] -> ShowS
MatchClass -> String
(Int -> MatchClass -> ShowS)
-> (MatchClass -> String)
-> ([MatchClass] -> ShowS)
-> Show MatchClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchClass -> ShowS
showsPrec :: Int -> MatchClass -> ShowS
$cshow :: MatchClass -> String
show :: MatchClass -> String
$cshowList :: [MatchClass] -> ShowS
showList :: [MatchClass] -> ShowS
Show, MatchClass -> MatchClass -> Bool
(MatchClass -> MatchClass -> Bool)
-> (MatchClass -> MatchClass -> Bool) -> Eq MatchClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MatchClass -> MatchClass -> Bool
== :: MatchClass -> MatchClass -> Bool
$c/= :: MatchClass -> MatchClass -> Bool
/= :: MatchClass -> MatchClass -> Bool
Eq, Eq MatchClass
Eq MatchClass =>
(MatchClass -> MatchClass -> Ordering)
-> (MatchClass -> MatchClass -> Bool)
-> (MatchClass -> MatchClass -> Bool)
-> (MatchClass -> MatchClass -> Bool)
-> (MatchClass -> MatchClass -> Bool)
-> (MatchClass -> MatchClass -> MatchClass)
-> (MatchClass -> MatchClass -> MatchClass)
-> Ord MatchClass
MatchClass -> MatchClass -> Bool
MatchClass -> MatchClass -> Ordering
MatchClass -> MatchClass -> MatchClass
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: MatchClass -> MatchClass -> Ordering
compare :: MatchClass -> MatchClass -> Ordering
$c< :: MatchClass -> MatchClass -> Bool
< :: MatchClass -> MatchClass -> Bool
$c<= :: MatchClass -> MatchClass -> Bool
<= :: MatchClass -> MatchClass -> Bool
$c> :: MatchClass -> MatchClass -> Bool
> :: MatchClass -> MatchClass -> Bool
$c>= :: MatchClass -> MatchClass -> Bool
>= :: MatchClass -> MatchClass -> Bool
$cmax :: MatchClass -> MatchClass -> MatchClass
max :: MatchClass -> MatchClass -> MatchClass
$cmin :: MatchClass -> MatchClass -> MatchClass
min :: MatchClass -> MatchClass -> MatchClass
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 (Int -> MatchError -> ShowS
[MatchError] -> ShowS
MatchError -> String
(Int -> MatchError -> ShowS)
-> (MatchError -> String)
-> ([MatchError] -> ShowS)
-> Show MatchError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MatchError -> ShowS
showsPrec :: Int -> MatchError -> ShowS
$cshow :: MatchError -> String
show :: MatchError -> String
$cshowList :: [MatchError] -> ShowS
showList :: [MatchError] -> ShowS
Show, MatchError -> MatchError -> Bool
(MatchError -> MatchError -> Bool)
-> (MatchError -> MatchError -> Bool) -> Eq MatchError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MatchError -> MatchError -> Bool
== :: MatchError -> MatchError -> Bool
$c/= :: MatchError -> MatchError -> Bool
/= :: MatchError -> MatchError -> Bool
Eq)

instance Functor Match where
  fmap :: forall a b. (a -> b) -> Match a -> Match b
fmap a -> b
_ (NoMatch Int
d [MatchError]
ms) = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
  fmap a -> b
f (Match MatchClass
m Int
d [a]
xs) = MatchClass -> Int -> [b] -> Match b
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
m Int
d ((a -> b) -> [a] -> [b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f [a]
xs)

instance Applicative Match where
  pure :: forall a. a -> Match a
pure a
a = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Exact Int
0 [a
a]
  <*> :: forall a b. Match (a -> b) -> Match a -> Match b
(<*>) = Match (a -> b) -> Match a -> Match b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Alternative Match where
  empty :: forall a. Match a
empty = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 []
  <|> :: forall a. Match a -> Match a -> Match a
(<|>) = Match a -> Match a -> Match a
forall a. Match a -> Match a -> Match a
matchPlus

instance Monad Match where
  return :: forall a. a -> Match a
return = a -> Match a
forall a. a -> Match a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  NoMatch Int
d [MatchError]
ms >>= :: forall a b. Match a -> (a -> Match b) -> Match b
>>= a -> Match b
_ = Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
ms
  Match MatchClass
m Int
d [a]
xs >>= a -> Match b
f =
    -- To understand this, it needs to be read in context with the
    -- implementation of 'matchPlus' below
    case [Match b] -> Match b
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((a -> Match b) -> [a] -> [Match b]
forall a b. (a -> b) -> [a] -> [b]
map a -> Match b
f [a]
xs) of
      Match MatchClass
m' Int
d' [b]
xs' -> MatchClass -> Int -> [b] -> Match b
forall a. MatchClass -> Int -> [a] -> Match a
Match (MatchClass -> MatchClass -> MatchClass
forall a. Ord a => a -> a -> a
min MatchClass
m MatchClass
m') (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d') [b]
xs'
      -- The minimum match class is the one we keep. The match depth is
      -- tracked but not used in the Match case.

      NoMatch Int
d' [MatchError]
ms -> Int -> [MatchError] -> Match b
forall a. Int -> [MatchError] -> Match a
NoMatch (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d') [MatchError]
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 :: forall a. Match a
mzero = Match a
forall a. Match a
forall (f :: * -> *) a. Alternative f => f a
empty
  mplus :: forall a. Match a -> Match a -> Match a
mplus = Match a -> Match a -> Match a
forall a. Match a -> Match a -> Match a
matchPlus

(<//>) :: Match a -> Match a -> Match a
<//> :: forall a. Match a -> Match a -> Match a
(<//>) = Match a -> Match a -> Match a
forall a. 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 :: forall a. Match a -> Match a -> Match a
matchPlus a :: Match a
a@(Match MatchClass
_ Int
_ [a]
_) (NoMatch Int
_ [MatchError]
_) = Match a
a
matchPlus (NoMatch Int
_ [MatchError]
_) b :: Match a
b@(Match MatchClass
_ Int
_ [a]
_) = Match a
b
matchPlus a :: Match a
a@(NoMatch Int
d_a [MatchError]
ms_a) b :: Match a
b@(NoMatch Int
d_b [MatchError]
ms_b)
  | Int
d_a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
d_b = Match a
a -- We only really make use of the depth in the NoMatch case.
  | Int
d_a Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
d_b = Match a
b
  | Bool
otherwise = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d_a ([MatchError]
ms_a [MatchError] -> [MatchError] -> [MatchError]
forall a. [a] -> [a] -> [a]
++ [MatchError]
ms_b)
matchPlus a :: Match a
a@(Match MatchClass
m_a Int
d_a [a]
xs_a) b :: Match a
b@(Match MatchClass
m_b Int
d_b [a]
xs_b)
  | MatchClass
m_a MatchClass -> MatchClass -> Bool
forall a. Ord a => a -> a -> Bool
> MatchClass
m_b = Match a
a -- exact over inexact
  | MatchClass
m_a MatchClass -> MatchClass -> Bool
forall a. Ord a => a -> a -> Bool
< MatchClass
m_b = Match a
b -- exact over inexact
  | Bool
otherwise = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
m_a (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
d_a Int
d_b) ([a]
xs_a [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [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 :: forall a. Match a -> Match a -> Match a
matchPlusShadowing a :: Match a
a@(Match MatchClass
Exact Int
_ [a]
_) Match a
_ = Match a
a
matchPlusShadowing Match a
a Match a
b = Match a -> Match a -> Match a
forall a. Match a -> Match a -> Match a
matchPlus Match a
a Match a
b

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

matchErrorExpected :: String -> String -> Match a
matchErrorExpected :: forall a. String -> String -> Match a
matchErrorExpected String
thing String
got = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
0 [String -> String -> MatchError
MatchErrorExpected String
thing String
got]

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

expecting :: String -> String -> Match a -> Match a
expecting :: forall a. String -> String -> Match a -> Match a
expecting String
thing String
got (NoMatch Int
0 [MatchError]
_) = String -> String -> Match a
forall a. String -> String -> Match a
matchErrorExpected String
thing String
got
expecting String
_ String
_ Match a
m = Match a
m

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

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

increaseConfidence :: Match ()
increaseConfidence :: Match ()
increaseConfidence = MatchClass -> Int -> [()] -> Match ()
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Exact Int
1 [()]

increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor :: forall a. Match a -> Match a
increaseConfidenceFor Match a
m = Match a
m Match a -> (a -> Match a) -> Match a
forall a b. Match a -> (a -> Match b) -> Match b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> Match ()
increaseConfidence Match () -> Match a -> Match a
forall a b. Match a -> Match b -> Match b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Match a
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a
nubMatchesBy :: forall a. (a -> a -> Bool) -> Match a -> Match a
nubMatchesBy a -> a -> Bool
_ (NoMatch Int
d [MatchError]
msgs) = Int -> [MatchError] -> Match a
forall a. Int -> [MatchError] -> Match a
NoMatch Int
d [MatchError]
msgs
nubMatchesBy a -> a -> Bool
eq (Match MatchClass
m Int
d [a]
xs) = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
m Int
d ((a -> a -> Bool) -> [a] -> [a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy a -> a -> Bool
eq [a]
xs)

-- | Lift a list of matches to an exact match.
exactMatches, inexactMatches :: [a] -> Match a
exactMatches :: forall a. [a] -> Match a
exactMatches [] = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
exactMatches [a]
xs = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Exact Int
0 [a]
xs
inexactMatches :: forall a. [a] -> Match a
inexactMatches [] = Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
inexactMatches [a]
xs = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Inexact Int
0 [a]
xs

unknownMatch :: a -> Match a
unknownMatch :: forall a. a -> Match a
unknownMatch a
x = MatchClass -> Int -> [a] -> Match a
forall a. MatchClass -> Int -> [a] -> Match a
Match MatchClass
Unknown Int
0 [a
x]

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

data MaybeAmbiguous a
  = None [MatchError]
  | Unambiguous a
  | Ambiguous MatchClass [a]
  deriving (Int -> MaybeAmbiguous a -> ShowS
[MaybeAmbiguous a] -> ShowS
MaybeAmbiguous a -> String
(Int -> MaybeAmbiguous a -> ShowS)
-> (MaybeAmbiguous a -> String)
-> ([MaybeAmbiguous a] -> ShowS)
-> Show (MaybeAmbiguous a)
forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
forall a. Show a => [MaybeAmbiguous a] -> ShowS
forall a. Show a => MaybeAmbiguous a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> MaybeAmbiguous a -> ShowS
showsPrec :: Int -> MaybeAmbiguous a -> ShowS
$cshow :: forall a. Show a => MaybeAmbiguous a -> String
show :: MaybeAmbiguous a -> String
$cshowList :: forall a. Show a => [MaybeAmbiguous a] -> ShowS
showList :: [MaybeAmbiguous a] -> ShowS
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 :: forall k a. Ord k => (a -> k) -> [a] -> k -> Match a
matchExactly a -> k
key [a]
xs =
  \k
k -> case k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k [a]
m of
    Maybe [a]
Nothing -> Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    Just [a]
ys -> [a] -> Match a
forall a. [a] -> Match a
exactMatches [a]
ys
  where
    m :: Map k [a]
m = ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [(a -> k
key a
x, [a
x]) | a
x <- [a]
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 :: forall k k' a.
(Ord k, Ord k') =>
(k -> k') -> (a -> k) -> [a] -> k -> Match a
matchInexactly k -> k'
cannonicalise a -> k
key [a]
xs =
  \k
k -> case k -> Map k [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k [a]
m of
    Just [a]
ys -> [a] -> Match a
forall a. [a] -> Match a
exactMatches [a]
ys
    Maybe [a]
Nothing -> case k' -> Map k' [a] -> Maybe [a]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (k -> k'
cannonicalise k
k) Map k' [a]
m' of
      Just [a]
ys -> [a] -> Match a
forall a. [a] -> Match a
inexactMatches [a]
ys
      Maybe [a]
Nothing -> Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  where
    m :: Map k [a]
m = ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) [(a -> k
key a
x, [a
x]) | a
x <- [a]
xs]

    -- the map of canonicalised keys to groups of inexact matches
    m' :: Map k' [a]
m' = ([a] -> [a] -> [a]) -> (k -> k') -> Map k [a] -> Map k' [a]
forall k2 a k1.
Ord k2 =>
(a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) k -> k'
cannonicalise Map k [a]
m

matchParse :: Parsec a => String -> Match a
matchParse :: forall a. Parsec a => String -> Match a
matchParse = Match a -> (a -> Match a) -> Maybe a -> Match a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Match a
forall a. Match a
forall (m :: * -> *) a. MonadPlus m => m a
mzero a -> Match a
forall a. a -> Match a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> Match a) -> (String -> Maybe a) -> String -> Match a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe a
forall a. Parsec a => String -> Maybe a
simpleParsec

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

caseFold :: String -> String
caseFold :: ShowS
caseFold = ShowS
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 :: PackageName
-> ComponentKind -> UnqualComponentName -> ComponentName
mkComponentName PackageName
pkgname ComponentKind
ckind UnqualComponentName
ucname =
  case ComponentKind
ckind of
    ComponentKind
LibKind
      | PackageName -> UnqualComponentName
packageNameToUnqualComponentName PackageName
pkgname UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
ucname ->
          LibraryName -> ComponentName
CLibName LibraryName
LMainLibName
      | Bool
otherwise -> LibraryName -> ComponentName
CLibName (LibraryName -> ComponentName) -> LibraryName -> ComponentName
forall a b. (a -> b) -> a -> b
$ UnqualComponentName -> LibraryName
LSubLibName UnqualComponentName
ucname
    ComponentKind
FLibKind -> UnqualComponentName -> ComponentName
CFLibName UnqualComponentName
ucname
    ComponentKind
ExeKind -> UnqualComponentName -> ComponentName
CExeName UnqualComponentName
ucname
    ComponentKind
TestKind -> UnqualComponentName -> ComponentName
CTestName UnqualComponentName
ucname
    ComponentKind
BenchKind -> UnqualComponentName -> ComponentName
CBenchName UnqualComponentName
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"
-}